v1.7.0

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: manynet
 Title: Many Ways to Make, Modify, Mark, and Measure Myriad Networks
-Version: 1.6.7
-Date: 2025-11-05
+Version: 1.7.0
+Date: 2025-11-19
 Description: Many tools for making, modifying, 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

@@ -353,6 +353,7 @@ export(create_star)
 export(create_tree)
 export(create_wheel)
 export(create_windmill)
+export(delete_changes)
 export(delete_nodes)
 export(delete_ties)
 export(describe_changes)
@@ -446,6 +447,7 @@ export(net_factions)
 export(net_harmonic)
 export(net_hazard)
 export(net_heterophily)
+export(net_homophily)
 export(net_immunity)
 export(net_indegree)
 export(net_independence)
@@ -571,6 +573,7 @@ export(node_fluid)
 export(node_harmonic)
 export(node_heterophily)
 export(node_hierarchy)
+export(node_homophily)
 export(node_hub)
 export(node_in_adopter)
 export(node_in_automorphic)

NEWS.md

@@ -1,3 +1,39 @@
+# manynet 1.7.0
+
+## Making
+
+- Improved vector printing to be more succinct and suggest `print_all()`
+- Improved printing methods for changing mnet objects
+
+## Modifying
+
+- Added `delete_changes()` for deleting all changes from a changing network
+- Improved `to_waves()` to work with networks that are changing, longitudinal, or both
+- Fixed `as_diffusion()` to not trim off final wave in the report
+- Fixed `as_diffusion()` to return correct E and R compartments for waning diffusion models
+
+## Marking
+
+- Improved `is_longitudinal()` to only check for tie waves and not nodal changes
+
+## Measuring
+
+- Improved `net_diversity()` and `node_diversity()`
+  - No longer offers a cluster option, which can be obtained using `over_membership()`
+  - Added more methods for calculating diversity, including Teachman's, coefficient of variation, and the Gini coefficient
+  - Improved `net_diversity()` and `node_diversity()` to use and declare methods appropriate for the vector of attributes
+- Added `net_homophily()` and `node_homophily()` for measuring homophily according to different methods including
+  - Krackhardt's EI index of heterophily as well as its inverse as a measure of homophily
+  - Yule's Q as a further measure of homophily
+  - Geary's C as a measure of homophily for numeric attributes
+- Updated documentation for richness, diversity, and homophily measures
+- Fixed `node_is_latent()`, `node_is_infected()`, `node_is_recoverd()` to work with changing networks
+- Improved `node_is_exposed()` to work with changing networks and now accepts a time argument
+
+## Tutorials
+
+- Fixed description of `to_directed()` and `to_redirected()` in the data tutorial
+
 # manynet 1.6.7
 
 ## Making

R/class_marks.R

@@ -55,9 +55,9 @@ print_tblvec <- function(y, names, n){
   body <- pillar::tbl_format_body(tibs, setup)[c(TRUE, FALSE, TRUE)]
   if(setup$extra_cols_total > 0){
     print(body)
-    cat(pillar::style_subtle(paste("# ... with",
+    cat(pillar::style_subtle(paste("# ... and",
                                    setup$extra_cols_total,
-                                   "more values from this nodeset unprinted.",
-                                   "Use `print(..., n = Inf)` to print all values.")))
+                                   "more values from this nodeset.",
+                                   "Use `print_all(...)` to print all values.")))
   } else print(body)
 }

R/class_models.R

@@ -17,6 +17,7 @@ print.diff_model <- function(x, ..., verbose = FALSE){
   if(!verbose){
     x$n <- NULL
     x$s <- NULL
+    x$S_new <- NULL
     x$I_new <- NULL
     x$E_new <- NULL
     x$R_new <- NULL

R/class_networks.R

@@ -180,9 +180,10 @@ describe_ties <- function(x){
 #' @export
 describe_changes <- function(x){
   if(is_longitudinal(x)){
-    paste(" over", max(tie_attribute(x, "wave")), "waves")
+    waves <- tie_attribute(x, "wave")
+    if(is.null(waves)) waves <- as_changelist(x)$time
+    paste(" over", max(waves), "waves")
   } else if (is_dynamic(x)){
-
     if("time" %in% net_tie_attributes(x)){
       paste(" from", min(tie_attribute(x, "time"), na.rm = TRUE), 
             "to", max(tie_attribute(x, "time"), na.rm = TRUE))

R/manip_as.R

@@ -1001,24 +1001,26 @@ as_diffusion.diff_model <- function(.data, twomode = FALSE, events) {
 #' @export
 as_diffusion.mnet <- function(.data, twomode = FALSE, events) {
   events <- as_changelist(.data)
-  nodes <- net_nodes(.data)
+  nodes <- c(net_nodes(.data))
   sumchanges <- events %>% dplyr::group_by(time) %>% 
-    dplyr::reframe(I_new = sum(value == "I"),
+    dplyr::reframe(S_new = sum(value == "S"),
                    E_new = sum(value == "E"),
+                   I_new = sum(value == "I"),
                    R_new = sum(value == "R"))
-  report <- dplyr::tibble(time = seq_len(max(events$time)) - 1,
+  report <- dplyr::tibble(time = 0:max(events$time),
                           n = nodes) %>% 
     dplyr::left_join(sumchanges, by = dplyr::join_by(time))
   report[is.na(report)] <- 0
-  report$R <- cumsum(report$R_new)
-  report$I <- cumsum(report$I_new) - report$R
-  report$E <- ifelse(report$E_new == 0 & 
-                       cumsum(report$E_new) == max(cumsum(report$E_new)),
-                     report$E_new, cumsum(report$E_new))
-  report$E <- ifelse(report$R + report$I + report$E > report$n,
-                     report$n - (report$R + report$I),
-                     report$E)
-  report$S <- report$n - report$R - report$I - report$E
+
+  if(all(report$E_new == 0)){
+    report$S = report$n + cumsum(report$S_new - report$I_new)
+    report$E = rep(0, nrow(report))
+  } else {
+    report$S = report$n + cumsum(report$S_new - report$E_new) # susceptible decreases as they become exposed
+    report$E = cumsum(report$E_new) - cumsum(report$I_new) # exposed become infectious
+  }
+  report$I = cumsum(report$I_new) - cumsum(report$R_new) # infectious recover
+  report$R = cumsum(report$R_new) - cumsum(report$S_new) # recovered accumulate
   report$s <- vapply(report$time, function(t){
     twin <- dplyr::filter(events, events$time <= t)
     infected <- dplyr::filter(twin, twin$value == "I")$node
@@ -1028,11 +1030,11 @@ as_diffusion.mnet <- function(.data, twomode = FALSE, events) {
     expos[recovered] <- F
     sum(expos)
   }, numeric(1) )
-  if (any(report$R + report$I + report$E + report$S != report$n)) {
+  if (any((report$R + report$I + report$E + report$S) != report$n)) {
     snet_abort("Oops, something is wrong")
   }
   report <- dplyr::select(report, 
-                          dplyr::any_of(c("time", "n", "S", "s", "E", "E_new", 
+                          dplyr::any_of(c("time", "n", "S", "s", "S_new", "E", "E_new", 
                                           "I", "I_new", "R", "R_new")))
   # make_diff_model(events, report, .data)
   class(report) <- c("diff_model", class(report))

R/manip_nodes.R

@@ -327,6 +327,12 @@ add_changes <- function(.data, changes){
     .data %>% mutate_nodes(diffusion = "S")
 }
 
+#' @rdname manip_changes
+#' @export
+delete_changes <- function(.data){
+  igraph::delete_graph_attr(.data, "changes")
+}
+
 #' @rdname manip_changes
 #' @export
 mutate_changes <- function(.data, ...) UseMethod("mutate_changes")

R/manip_split.R

@@ -182,21 +182,86 @@ to_waves <- function(.data, attribute = "wave", panels = NULL,
 #' @export
 to_waves.tbl_graph <- function(.data, attribute = "wave", panels = NULL,
                                cumulative = FALSE) {
-  wp <- unique(tie_attribute(.data, attribute))
-  if(!is.null(panels))
-    wp <- intersect(panels, wp)
-  if(length(wp) > 1) {
-    out <- lapply(wp, function(l){
-      filter_ties(.data, !!as.name(attribute) == l)
+  out <- NULL
+  if(is_changing(.data) && is_longitudinal(.data)){
+    cl <- as_changelist(.data)
+    el <- as_edgelist(.data)
+
+    # Get all unique times in order
+    times <- sort(unique(cl$time))
+    if(!is.null(panels))
+      times <- intersect(panels, times)
+
+    waves <- lapply(times, function(t) {
+      # Latest changes by time t
+      changes <- cl %>% 
+        dplyr::filter(time <= t) %>% 
+        dplyr::group_by(node) %>% 
+        dplyr::reframe(var = var,
+                         latest_value = value[which.max(time)],
+                         .groups = "drop")
+      for(v in unique(changes$var)){
+        upd <- rep(NA, net_nodes(.data))
+        upd[changes[var = v,]$node] <- changes[var = v,]$latest_value
+        old <- node_attribute(.data, v)
+        if(inherits(old, "logi")) old <- as.logical(old)
+        out <- add_node_attribute(.data, v, dplyr::coalesce(upd, old))
+      }
+      out <- delete_changes(out)
+      out <- filter_ties(out, wave == t)
+      out
     })
-    names(out) <- wp
-  } else {
-    out <- filter_ties(.data, !!as.name(attribute) == wp)
-  }
-  if (isTRUE(cumulative)) {
-    out <- cumulative_ties(out, attribute)
+    names(waves) <- paste("Wave", times)
+    out <- waves
+  } else if(is_changing(.data)){
+    cl <- as_changelist(.data)
+    if(!attribute %in% names(cl) && "time" %in% names(cl)){
+      attribute <- "time"
+    }
+    # Get all unique times in order
+    times <- sort(unique(cl$time))
+    if(!is.null(panels))
+      times <- intersect(panels, times)
+
+    # Iterate over times
+    waves <- lapply(times, function(t) {
+      # Latest changes by time t
+      changes <- cl %>% 
+        dplyr::filter(time <= t) %>% 
+        dplyr::group_by(node) %>% 
+        dplyr::reframe(var = var,
+                         latest_value = value[which.max(time)],
+                         .groups = "drop")
+      for(v in unique(changes$var)){
+        upd <- rep(NA, net_nodes(.data))
+        upd[changes[var = v,]$node] <- changes[var = v,]$latest_value
+        old <- node_attribute(.data, v)
+        if(inherits(old, "logi")) old <- as.logical(old)
+        out <- add_node_attribute(.data, v, dplyr::coalesce(upd, old))
+      }
+      out <- delete_changes(out)
+      out
+    })
+    names(waves) <- paste("Wave", times)
+    out <- waves
+  } else if(is_longitudinal(.data)){
+    wp <- unique(tie_attribute(.data, attribute))
+    if(!is.null(panels))
+      wp <- intersect(panels, wp)
+    if(length(wp) > 1) {
+      out <- lapply(wp, function(l){
+        filter_ties(.data, !!as.name(attribute) == l)
+      })
+      names(out) <- wp
+    } else {
+      out <- filter_ties(.data, !!as.name(attribute) == wp)
+    }
+    if (isTRUE(cumulative)) {
+      out <- .cumulative_ties(out, attribute)
+    }
+    out <- out[order(names(out))]
   }
-  out[order(names(out))]
+  if(is.null(out)) .data else out
 }
 
 #' @export
@@ -218,7 +283,7 @@ to_waves.data.frame <- function(.data, attribute = "wave", panels = NULL,
     out <- .data[,attribute == wp]
   }
   if (isTRUE(cumulative)) {
-    out <- cumulative_ties(out, attribute)
+    out <- .cumulative_ties(out, attribute)
   }
   out
 }
@@ -240,12 +305,12 @@ to_waves.diff_model <- function(.data, attribute = "t", panels = NULL,
                         Recovered = node_is_recovered(diff, time = k))
   }
   if (isTRUE(cumulative)) {
-    out <- cumulative_ties(out, attribute)
+    out <- .cumulative_ties(out, attribute)
   }
   out
 }
 
-cumulative_ties <- function(x, attribute) {
+.cumulative_ties <- function(x, attribute) {
   edges <- to <- from <- NULL
   thisRequires("zoo")
   thisRequires("purrr")

R/manynet-utils.R

@@ -6,7 +6,8 @@ utils::globalVariables(c(".data", "obs",
                          "nodes","event","exposure",
                          "student","students","colleges",
                          "node","value","var","active","time",
-                         "A","B","C","D"))
+                         "A","B","C","D",
+                         "n"))
 
 # Helper function for declaring available methods
 available_methods <- function(fun_vctr) {

R/mark_net.R

@@ -105,9 +105,10 @@ is_list <- function(.data) {
 is_longitudinal <- function(.data) {
   if(is_manynet(.data)) {
     ig <- as_igraph(.data)
-    catts <- names(igraph::graph_attr(ig, "changes"))
+    # catts <- names(igraph::graph_attr(ig, "changes"))
     tatts <- igraph::edge_attr_names(ig)
-    return("time" %in% catts | "wave" %in% tatts | "panel" %in% tatts)
+    return(#"time" %in% catts | 
+             "wave" %in% tatts | "panel" %in% tatts)
   } else if(is_list(.data)){
     all(lapply(.data, net_nodes)==net_nodes(.data[[1]]))
   }