Updated network metrics.

.Rhistory

@@ -1,69 +1,3 @@
-levels(df_sim$node_1_id) <- c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
-levels(df_sim$node_2_id) <- c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
-fit_edge <- bison_model(
-(event | duration) ~ dyad(node_1_id, node_2_id),
-data=df_sim,
-model_type="binary_conjugate",
-priors=get_default_priors("binary_conjugate")
-)
-nets <- expect_warning(
-bison_to_igraph(fit_edge, num_draws=10),
-regexp=NA
-)
-devtools::load_all(".")
-library(dplyr)
-library(igraph)
-set.seed(123)
-# Load data in with minimal effects
-sim_data <- simulate_bison_model("binary", aggregated = TRUE, location_effect = FALSE, age_diff_effect = FALSE)
-df <- sim_data$df_sim
-df$group_id <- sample(1:4, nrow(df), replace=TRUE)
-priors = get_default_priors("binary")
-expect_warning(
-prior_check(priors, "binary"),
-regexp=NA
-)
-expect_warning(
-prior_predictive_check(
-(event | duration) ~ dyad(node_1_id, node_2_id),
-data=df,
-model_type="binary",
-priors=priors
-),
-regexp=NA
-)
-# Fit model to the data
-fit_edge <- expect_warning(
-bison_model(
-(event | duration) ~ dyad(node_1_id, node_2_id) + age_diff + (1 | group_id),
-data=df,
-model_type="binary"
-),
-regexp=NA
-)
-expect_warning(plot_network(fit_edge, lwd=10), regexp=NA)
-get_default_prior("binary")
-devtools::load_all(".")
-get_default_prior("binary")
-get_default_priors("binary")
-devtools::test_active_file()
-priors <- expect_warning(bison_brm_get_prior(
-age_diff ~ bison(edge_weight(node_1_id, node_2_id)),
-list(fit_edge, fit_edge),
-list(df_sim, df_sim)
-),
-regexp=NA
-)
-sim_data <- bisonR::simulate_bison_model("binary", aggregated = TRUE)
-df_sim <- sim_data$df_sim
-levels(df_sim$node_1_id) <- c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
-levels(df_sim$node_2_id) <- c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
-fit_edge <- bison_model(
-(event | duration) ~ dyad(node_1_id, node_2_id),
-data=df_sim,
-model_type="binary_conjugate",
-priors=get_default_priors("binary_conjugate")
-)
 priors <- expect_warning(bison_brm_get_prior(
 age_diff ~ bison(edge_weight(node_1_id, node_2_id)),
 list(fit_edge, fit_edge),
@@ -510,3 +444,69 @@ expect_warning(plot_network(fit_edge, lwd=10, threshold=0.1), regexp=NA)
 expect_warning(plot_network(fit_edge, lwd=10, threshold=0.2), regexp=NA)
 expect_warning(plot_network(fit_edge, lwd=10, threshold=0.1), regexp=NA)
 expect_warning(plot_network(fit_edge, lwd=10, threshold=0.1), regexp=NA)
+devtools::load_all(".")
+gbi <- matrix(rbinom(20 * 10, 1, 0.25), 20, 10)
+gbi <- matrix(rbinom(20 * 10, 1, 0.25), 20, 10)
+df <- convert_gbi_to_bison(gbi)
+# Correct length
+expect_true(nrow(df) == 20 * 10 * 9 * 0.5)
+df
+df[30, ]
+row <- df[30, ]
+row[4]
+gbi[row[4], c(row[1], row[2])]
+c(row[1], row[2])
+row[1]
+gbi[row[4], row[1]]
+row[1]
+row <- as.numeric(df[30, ])
+gbi[row[4], row[1]]
+gbi[row[4], row[1]] * gbi[row[4], row[2]]
+row[3]
+gbi <- matrix(rbinom(20 * 10, 1, 0.25), 20, 10)
+df <- convert_gbi_to_bison(gbi)
+# for (i in 1:nrow(df)) {
+#   row_correct <- gbi[row[4], row[1]] * gbi[row[4], row[2]] == row[3]
+#   if (row_correct == FALSE) {
+#     break
+#   }
+# }
+# expect_true(row)
+# Correct length
+# expect_true(nrow(df) == 20 * 10 * 9 * 0.5)
+# Entries are correct
+results <- rep(0, nrow(df))
+for (i in 1:nrow(df)) {
+results[i] <- gbi[ df[i, ]$group_id, df[i, ]$node_1] * gbi[ df[i, ]$group_id, df[i, ]$node_2] == df[i, ]$event
+}
+expect_true(all(results == TRUE))
+all(results == TRUE)
+gbi <- matrix(rbinom(200 * 10, 1, 0.25), 200, 10)
+df <- convert_gbi_to_bison(gbi)
+time()
+start_time <- Sys.time()
+start_time <- Sys.time()
+df <- convert_gbi_to_bison(gbi)
+Sys.time() - start_time
+start_time <- Sys.time()
+df <- convert_gbi_to_bison(gbi)
+Sys.time() - start_time
+gbi <- matrix(rbinom(200 * 10, 1, 0.25), 200, 10)
+df <- convert_gbi_to_bison(gbi)
+start_time <- Sys.time()
+df <- convert_gbi_to_bison(gbi)
+Sys.time() - start_time
+gbi <- matrix(rbinom(200 * 10, 1, 0.25), 200, 10)
+df <- convert_gbi_to_bison(gbi)
+start_time <- Sys.time()
+df <- convert_gbi_to_bison(gbi)
+Sys.time() - start_time
+gbi <- matrix(rbinom(200 * 10, 1, 0.25), 200, 10)
+df <- convert_gbi_to_bison(gbi)
+start_time <- Sys.time()
+df <- convert_gbi_to_bison(gbi)
+Sys.time() - start_time
+devtools::document()
+devtools::install()
+devtools::load_all(".")
+devtools::test_active_file()

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: bisonR
 Title: Bayesian Inference of Social Networks in R
-Version: 0.4.5
+Version: 0.4.6
 Authors@R: 
     person("Jordan", "Hart", , "jordan.da.hart@gmail.com", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-4636-0760"))

NEWS.md

@@ -1,3 +1,8 @@
+# bisonR 0.4.6
+* Added node_clustering network metric.
+* Added global_clustering network metric.
+* Added global_diameter network metric.
+
 # bisonR 0.4.5
 * Improved GBI conversion algorithm.
 

R/metrics.R

@@ -98,6 +98,17 @@ get_metric_fn <- function(metric_string) {
         return(igraph::strength(x, weights=1 * (igraph::E(x)$weight > threshold)))
       })
     }
+    if (!is.na(stringr::str_match(metric_name, "^clustering\\[.*\\]$"))) {
+      threshold <- as.numeric(str_split(metric_name, "\\[|\\]")[[1]][2])
+      return(function(x) {
+        x_binary <- x
+        edges_to_remove <- which(igraph::E(x)$weight < threshold)
+        x_binary <- igraph::delete_edges(x_binary, edges_to_remove)
+        clustering <- igraph::transitivity(x_binary, type="local")
+        clustering[is.nan(clustering)] <- 0
+        return(clustering)
+      })
+    }
   }
   if (target_name == "global") {
     if (metric_name == "density") {
@@ -109,6 +120,20 @@ get_metric_fn <- function(metric_string) {
     if (metric_name == "std") {
       return(function(net) sd(igraph::E(net)$weight))
     }
+    if (metric_name == "diameter") {
+      return(function(net) igraph::diameter(net))
+    }
+    if (!is.na(stringr::str_match(metric_name, "^clustering\\[.*\\]$"))) {
+      threshold <- as.numeric(str_split(metric_name, "\\[|\\]")[[1]][2])
+      return(function(x) {
+        x_binary <- x
+        edges_to_remove <- which(igraph::E(x)$weight < threshold)
+        x_binary <- igraph::delete_edges(x_binary, edges_to_remove)
+        clustering <- igraph::transitivity(x_binary, type="global")
+        # clustering[is.nan(clustering)] <- 0
+        return(clustering)
+      })
+    }
   }
   stop(paste0("Network metric ", metric_string, " does not exist."))
 }

tests/testthat/test-metrics.R

@@ -48,6 +48,11 @@ test_that("network metrics work", {
     regexp=NA
   )
 
+  x <- expect_warning(
+    extract_metric(fit_edge, "node_clustering[0.2]"),
+    regexp=NA
+  )
+
   x <- expect_warning(
     extract_metric(fit_edge, "global_cv"),
     regexp=NA
@@ -63,6 +68,16 @@ test_that("network metrics work", {
     regexp=NA
   )
 
+  x <- expect_warning(
+    extract_metric(fit_edge, "global_diameter"),
+    regexp=NA
+  )
+
+  x <- expect_warning(
+    extract_metric(fit_edge, "global_clustering[0.2]"),
+    regexp=NA
+  )
+
   expect_warning (
     plot_metric(x),
     regexp=NA

vignettes/network_metrics.Rmd

@@ -23,13 +23,126 @@ The following feature/metric pairs are currently supported in bisonR:
 * `edge` - Edge-level properties
   * `weight` - Edge weight
 * `node` - Node-level properties
+  * `degree[t]` - Node degree (where t is the binary threshold for an edge)
   * `strength` - Node strength
   * `eigen` - Node eigenvector centrality
   * `betweenness` - Node betweenness
   * `closeness` - Node closeness
+  * `clustering` - Node-level clustering coefficient
 * `global` - Network-level properties
   * `density` - Weighted density
-  * `cv` - Coefficient of variation of edge weights - often called social differentiation
+  * `cv` - Coefficient of variation of edge weights - also known as social differentiation
   * `std` - Standard deviation of edge weights
+  * `diameter` - Diameter of the network
+  * `clustering` - Clustering coefficient of the network - also known as transitivity
+
+# Examples
 
+See below for examples of how to generate the network metrics listed above.
+
+```{r}
+library(bisonR)
+library(dplyr)
+```
+
+```{r}
+sim_data <- simulate_bison_model("binary", aggregated = TRUE)
+df <- sim_data$df_sim
+
+fit_edge <- bison_model(
+  (event | duration) ~ dyad(node_1_id, node_2_id),
+  data=df,
+  model_type="binary_conjugate",
+  priors=get_default_priors("binary_conjugate")
+)
+```
+
+## Edge
+
+### Edge weight
+
+```{r}
+metrics <- extract_metric(fit_edge, "edge_weight", num_draws=10)
+metrics[1:6, 1:5] # Preview first few samples and edges
+```
+
+## Node
+
+### Node degree
+
+```{r}
+metrics <- extract_metric(fit_edge, "node_degree[0.2]")
+metrics[1:6, 1:5] # Preview first few samples and nodes
+```
+
+### Node strength
+
+```{r}
+metrics <- extract_metric(fit_edge, "node_strength", num_draws=10)
+metrics[1:6, 1:5] # Preview first few samples and nodes
+```
+
+### Node eigenvector centrality
+
+```{r}
+metrics <- extract_metric(fit_edge, "node_eigen")
+metrics[1:6, 1:5] # Preview first few samples and nodes
+```
+
+### Node betweenness
+
+```{r}
+metrics <- extract_metric(fit_edge, "node_betweenness")
+metrics[1:6, 1:5] # Preview first few samples and nodes
+```
 
+### Node closeness
+
+```{r}
+metrics <- extract_metric(fit_edge, "node_closeness")
+metrics[1:6, 1:5] # Preview first few samples and nodes
+```
+
+### Node-level clustering coefficient
+
+```{r}
+metrics <- extract_metric(fit_edge, "node_clustering[0.2]")
+metrics[1:6, 1:5] # Preview first few samples and nodes
+```
+
+## Global
+
+### Global coefficient of variation
+
+```{r}
+metrics <- extract_metric(fit_edge, "global_cv")
+metrics[1:6] # Preview first few samples
+```
+
+### Global density
+
+```{r}
+metrics <- extract_metric(fit_edge, "global_density")
+metrics[1:6] # Preview first few samples
+```
+
+### Global standard deviation of edge weights
+
+```{r}
+metrics <- extract_metric(fit_edge, "global_std")
+metrics[1:6] # Preview first few samples
+```
+
+### Global diameter
+
+```{r}
+metrics <- extract_metric(fit_edge, "global_diameter")
+metrics[1:6] # Preview first few samples
+```
+
+### Global clustering coefficient
+
+```{r}
+metrics <- extract_metric(fit_edge, "global_clustering[0.2]")
+metrics[1:6] # Preview first few samples
+```