Merge pull request #103 from stocnet/develop

v1.3.2

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: manynet
 Title: Many Ways to Make, Modify, Map, Mark, and Measure Myriad Networks
-Version: 1.3.1
-Date: 2024-10-29
+Version: 1.3.2
+Date: 2024-11-05
 Description: Many tools for making, modifying, mapping, marking, measuring, 
    and motifs and memberships of many different types of networks.
    All functions operate with matrices, edge lists, and 'igraph', 'network', and 'tidygraph' objects,

NAMESPACE

@@ -442,6 +442,7 @@ export(net_components)
 export(net_congruency)
 export(net_connectedness)
 export(net_core)
+export(net_correlation)
 export(net_degree)
 export(net_density)
 export(net_diameter)

NEWS.md

@@ -1,3 +1,10 @@
+# manynet 1.3.2
+
+## Measuring
+
+- Added `net_correlation()` for calculating the product-moment correlation between networks
+- Improved speed of make_network_measure by retrieving single call at parent level
+
 # manynet 1.3.1
 
 ## Package

R/class_measures.R

@@ -21,10 +21,10 @@ make_tie_measure <- function(out, .data) {
   out
 }
 
-make_network_measure <- function(out, .data) {
+make_network_measure <- function(out, .data, call) {
   class(out) <- c("network_measure", class(out))
   attr(out, "mode") <- net_dims(.data)
-  attr(out, "call") <- deparse(sys.calls())
+  attr(out, "call") <- call
   out
 }
 
@@ -107,13 +107,18 @@ summary.network_measure <- function(object, ...,
                                   null = c("random","configuration"), 
                                   times = 500) {
   null <- paste0("generate_", match.arg(null))
-  callItems <- trimws(strsplit(unlist(attr(object, "call")), 
+  callItems <- trimws(strsplit(attr(object, "call"), 
                                split = "\\(|\\)|,")[[1]])
   idFun <- which(grepl("^net_", callItems))[1]
   fun <- callItems[idFun]
   dat <- callItems[idFun+1]
+  if(length(callItems)>2) oth <- callItems[3:length(callItems)] else
+    oth <- NULL
   nulls <- vapply(mnet_progress_seq(times), function(r){
-    suppressMessages(get(fun)(get(null)(get(dat))))
+    if(is.null(oth))
+      suppressMessages(get(fun)(get(null)(get(dat)))) else
+        suppressMessages(get(fun)(get(null)(get(dat)), 
+                                  gsub("\"", "", oth)))
   }, FUN.VALUE = numeric(1))
   out <- (object - mean(nulls))/stats::sd(nulls)
   out[is.nan(out)] <- 0

R/measure_centrality.R

@@ -254,7 +254,7 @@ net_degree <- function(.data, normalized = TRUE,
     out <- igraph::centr_degree(graph = .data, mode = direction, 
                                 normalized = normalized)$centralization
   }
-  out <- make_network_measure(out, .data)
+  out <- make_network_measure(out, .data, call = deparse(sys.call()))
   out
 }
 
@@ -501,7 +501,7 @@ net_betweenness <- function(.data, normalized = TRUE,
   } else {
     out <- igraph::centr_betw(graph = graph)$centralization
   }
-  out <- make_network_measure(out, .data)
+  out <- make_network_measure(out, .data, call = deparse(sys.call()))
   out
 }
 
@@ -846,7 +846,7 @@ net_closeness <- function(.data, normalized = TRUE,
                              mode = direction,
                              normalized = normalized)$centralization
   }
-  out <- make_network_measure(out, .data)
+  out <- make_network_measure(out, .data, call = deparse(sys.call()))
   out
 }
 
@@ -1125,7 +1125,7 @@ net_eigenvector <- function(.data, normalized = TRUE){
     out <- igraph::centr_eigen(manynet::as_igraph(.data), 
                                normalized = normalized)$centralization
   }
-  out <- make_network_measure(out, .data)
+  out <- make_network_measure(out, .data, call = deparse(sys.call()))
   out
 }
 

R/measure_closure.R

@@ -38,7 +38,7 @@ NULL
 net_reciprocity <- function(.data, method = "default") {
   if(missing(.data)) {expect_nodes(); .data <- .G()}
   make_network_measure(igraph::reciprocity(manynet::as_igraph(.data), mode = method), 
-                       .data)
+                       .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_closure 
@@ -60,7 +60,7 @@ node_reciprocity <- function(.data) {
 net_transitivity <- function(.data) {
   if(missing(.data)) {expect_nodes(); .data <- .G()}
   make_network_measure(igraph::transitivity(manynet::as_igraph(.data)), 
-                       .data)
+                       .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_closure 
@@ -103,7 +103,7 @@ net_equivalency <- function(.data) {
     if (is.nan(out)) out <- 1
     if(manynet::is_weighted(.data)) out <- out / mean(mat[mat>0])
   } else {
-    out <- rowSums(vapply(cli::cli_progress_along(1:net_nodes(.data)), function(i){
+    out <- rowSums(vapply(mnet_progress_nodes(.data), function(i){
       threepaths <- igraph::all_simple_paths(.data, i, cutoff = 3,
                                              mode = "all")
       onepaths <- threepaths[vapply(threepaths, length,
@@ -115,7 +115,7 @@ net_equivalency <- function(.data) {
     }, FUN.VALUE = numeric(2)))
     out <- out[1]/out[2]
   }
-  make_network_measure(out, .data)
+  make_network_measure(out, .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_closure
@@ -171,5 +171,5 @@ net_congruency <- function(.data, object2){
        sum(twopaths *
              (matrix(degrees, connects, connects) - twopaths)))
   if (is.nan(output)) output <- 1
-  make_network_measure(output, .data)
+  make_network_measure(output, .data, call = deparse(sys.call()))
 }

R/measure_cohesion.R

@@ -36,7 +36,7 @@ net_density <- function(.data) {
   } else {
     out <- igraph::edge_density(manynet::as_igraph(.data))
   }
-  make_network_measure(out, .data)
+  make_network_measure(out, .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_cohesion
@@ -52,7 +52,7 @@ net_components <- function(.data){
   if(missing(.data)) {expect_nodes(); .data <- .G()}
   object <- manynet::as_igraph(.data)
   make_network_measure(igraph::components(object, mode = "strong")$no,
-                       object)
+                       object, call = deparse(sys.call()))
 }
 
 #' @rdname measure_cohesion 
@@ -69,7 +69,8 @@ net_components <- function(.data){
 #' @export
 net_cohesion <- function(.data){
   if(missing(.data)) {expect_nodes(); .data <- .G()}
-  make_network_measure(igraph::cohesion(manynet::as_igraph(.data)), .data)
+  make_network_measure(igraph::cohesion(manynet::as_igraph(.data)), 
+                       .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_cohesion 
@@ -80,7 +81,8 @@ net_cohesion <- function(.data){
 #' @export
 net_adhesion <- function(.data){
   if(missing(.data)) {expect_nodes(); .data <- .G()}
-  make_network_measure(igraph::adhesion(manynet::as_igraph(.data)), .data)
+  make_network_measure(igraph::adhesion(manynet::as_igraph(.data)), 
+                       .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_cohesion 
@@ -94,7 +96,7 @@ net_diameter <- function(.data){
   object <- manynet::as_igraph(.data)
   make_network_measure(igraph::diameter(object, 
                                         directed = manynet::is_directed(object)),
-                       object)
+                       object, call = deparse(sys.call()))
 }
 
 #' @rdname measure_cohesion 
@@ -108,7 +110,7 @@ net_length <- function(.data){
   object <- manynet::as_igraph(.data)
   make_network_measure(igraph::mean_distance(object,
                                              directed = manynet::is_directed(object)),
-                       object)
+                       object, call = deparse(sys.call()))
 }
 
 #' @rdname measure_cohesion 
@@ -123,5 +125,5 @@ net_independence <- function(.data){
   } else {
     out <- igraph::ivs_size(manynet::to_undirected(manynet::as_igraph(.data)))
   }
-  make_network_measure(out, .data)
+  make_network_measure(out, .data, call = deparse(sys.call()))
 }

R/measure_diffusion.R

@@ -59,7 +59,8 @@ net_transmissibility <- function(diff_model){
   out <- out[!is.infinite(out)]
   out <- out[!is.nan(out)]
   make_network_measure(mean(out, na.rm = TRUE),
-                       attr(diff_model, "network"))
+                       attr(diff_model, "network"),
+                       call = deparse(sys.call()))
 }
 
 #' @rdname measure_diffusion_net 
@@ -84,7 +85,8 @@ net_recovery <- function(diff_model, censor = TRUE){
   if(censor && any(!is.infinite(recovs) & !is.na(recovs)))
     recovs[is.infinite(recovs)] <- nrow(diff_model)
   make_network_measure(mean(recovs, na.rm = TRUE),
-                       attr(diff_model, "network"))
+                       attr(diff_model, "network"),
+                       call = deparse(sys.call()))
 }
 
 #' @rdname measure_diffusion_net 
@@ -129,7 +131,8 @@ net_reproduction <- function(diff_model){
   out <- net_transmissibility(diff_model)/
     (1/net_recovery(diff_model))
   out <- min(out, mean(node_deg(net)))
-  make_network_measure(out, net)
+  make_network_measure(out, net,
+                       call = deparse(sys.call()))
 }
 
 #' @rdname measure_diffusion_net 
@@ -171,7 +174,8 @@ net_immunity <- function(diff_model, normalized = TRUE){
   net <- attr(diff_model, "network")
   out <- 1 - 1/net_reproduction(diff_model)
   if(!normalized) out <- ceiling(out * net_nodes(net))
-  make_network_measure(out, net)
+  make_network_measure(out, net,
+                       call = deparse(sys.call()))
 }
 
 #' @rdname measure_diffusion_net
@@ -233,7 +237,8 @@ net_hazard <- function(diff_model){
   diff_model <- as_diffusion(diff_model)
   out <- (diff_model$I - dplyr::lag(diff_model$I)) / 
     (diff_model$n - dplyr::lag(diff_model$I))
-  make_network_measure(out, attr(diff_model, "network"))
+  make_network_measure(out, attr(diff_model, "network"),
+                       call = deparse(sys.call()))
 }
 
 # net_infection ####
@@ -270,7 +275,8 @@ net_infection_complete <- function(diff_model){
   diff_model <- as_diffusion(diff_model)
   out <- which(diff_model$I == diff_model$n)[1]
   if(is.na(out)) out <- Inf
-  make_network_measure(out, attr(diff_model, "network"))
+  make_network_measure(out, attr(diff_model, "network"),
+                       call = deparse(sys.call()))
 }
 
 #' @rdname measure_diffusion_infection 
@@ -281,7 +287,8 @@ net_infection_total <- function(diff_model, normalized = TRUE){
   diff_model <- as_diffusion(diff_model)
   out <- sum(diff_model$I_new)
   if(normalized) out <- out / diff_model$n[length(diff_model$n)]
-  make_network_measure(out, attr(diff_model, "network"))
+  make_network_measure(out, attr(diff_model, "network"),
+                       call = deparse(sys.call()))
 }
 
 #' @rdname measure_diffusion_infection 
@@ -291,7 +298,8 @@ net_infection_total <- function(diff_model, normalized = TRUE){
 net_infection_peak <- function(diff_model){
   diff_model <- as_diffusion(diff_model)
   out <- which(diff_model$I_new == max(diff_model$I_new))[1]
-  make_network_measure(out, attr(diff_model, "network"))
+  make_network_measure(out, attr(diff_model, "network"),
+                       call = deparse(sys.call()))
 }
 
 # node_diffusion ####

R/measure_features.R

@@ -49,7 +49,7 @@ net_core <- function(.data,
   if(is.null(mark)) mark <- node_is_core(.data)
   out <- stats::cor(c(as_matrix(.data)), 
                     c(as_matrix(create_core(.data, mark = mark))))
-  make_network_measure(out, .data)
+  make_network_measure(out, .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_features
@@ -100,7 +100,7 @@ net_richclub <- function(.data){
   coefs[is.nan(coefs)] <- 1
   out <- coefs[elbow_finder(seq_along(coefs), coefs)]
     # max(coefs, na.rm = TRUE)
-  make_network_measure(out, .data)
+  make_network_measure(out, .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_features 
@@ -118,7 +118,7 @@ net_factions <- function(.data,
   out <- stats::cor(c(manynet::as_matrix(.data)), 
                     c(manynet::as_matrix(manynet::create_components(.data,
                                                   membership = membership))))
-  make_network_measure(out, .data)
+  make_network_measure(out, .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_features
@@ -174,11 +174,12 @@ net_modularity <- function(.data,
   if(is_twomode(.data)){
     make_network_measure(igraph::modularity(to_multilevel(.data), 
                                           membership = membership,
-                                          resolution = resolution), .data)
+                                          resolution = resolution), 
+                         .data, call = deparse(sys.call()))
   } else make_network_measure(igraph::modularity(.data, 
                                                membership = membership,
                                                resolution = resolution),
-                              .data)
+                              .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_features 
@@ -264,7 +265,7 @@ net_smallworld <- function(.data,
                 "sigma" = (co/cr)/(lo/lr),
                 "SWI" = ((lo - ll)/(lr - ll))*((co - cr)/(cl - cr)))
   make_network_measure(out,
-                       .data)
+                       .data, call = deparse(sys.call()))
 }
 
 #' @rdname measure_features 
@@ -304,7 +305,8 @@ net_scalefree <- function(.data){
                 "could have been drawn from a power-law", 
                 "distribution rejected.\n"))
   }
-  make_network_measure(out$alpha, .data)
+  make_network_measure(out$alpha, .data, 
+                       call = deparse(sys.call()))
 }
 
 #' @rdname measure_features 
@@ -380,7 +382,8 @@ net_balance <- function(.data) {
   }
   tria_count <- count_signed_triangles(g)
   make_network_measure(unname((tria_count["+++"] + tria_count["+--"])/sum(tria_count)),
-                       .data)
+                       .data, 
+                       call = deparse(sys.call()))
 }
 
 
@@ -392,6 +395,7 @@ net_balance <- function(.data) {
 #'   
 #'   - `net_change()` measures the Hamming distance between two or more networks.
 #'   - `net_stability()` measures the Jaccard index of stability between two or more networks.
+#'   - `net_correlation()` measures the product-moment correlation between two networks.
 #' 
 #'   These `net_*()` functions return a numeric vector the length of the number
 #'   of networks minus one. E.g., the periods between waves.
@@ -436,4 +440,20 @@ net_stability <- function(.data, object2){
     n10 <- sum(net1 * net2==0)
     n11 / (n01 + n10 + n11)
   }, FUN.VALUE = numeric(1))
+}
+
+#' @rdname measure_periods 
+#' @export
+net_correlation <- function(.data, object2){
+  if(missing(.data)) {expect_nodes(); .data <- .G()}
+  comp1 <- as_matrix(.data)
+  comp2 <- as_matrix(object2)
+  if(!is_complex(.data)){
+    diag(comp1) <- NA
+  }
+  if(!is_directed(.data)){
+    comp1[upper.tri(comp1)] <- NA
+  }
+  out <- cor(c(comp1), c(comp2), use = "complete.obs")
+  make_network_measure(out, .data, call = deparse(sys.call()))
 }