Merge fb953d3 into 14f331d

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: migraph
 Title: Multimodal Network Analysis and More
-Version: 1.1.5
-Date: 2023-11-02
+Version: 1.1.6
+Date: 2023-11-08
 Description: A set of tools for analysing multimodal networks.
    It includes functions for measuring 
    centrality, centralization, cohesion, closure, constraint and diversity,

NEWS.md

@@ -1,3 +1,20 @@
+# migraph 1.1.6
+
+2023-11-08
+
+## Measures
+
+- Added first drafts of various diffusion measures: `network_transmissability()`, `node_infection_length()`, `network_infection_length()`, `network_reproduction()`, `node_adoption_time()`, `node_adopter()`, `node_thresholds()`.
+
+## Models
+
+- Fixed documentation for `play_diffusion()`.
+- Fixed bug in labelling in plot results for SIR models.
+
+## Tutorials
+
+- Added plots using `autographs()` and elaboration for tutorial 7.
+
 # migraph 1.1.5
 
 2023-11-02

R/class_models.R

@@ -220,20 +220,27 @@ plot.diff_model <- function(x, ...){
     S <- E <- I <- I_new <- R <- NULL # initialize variables to avoid CMD check notes
     data <- x
     p <- ggplot2::ggplot(data) + 
-      ggplot2::geom_line(ggplot2::aes(x = t, y = S/n, color = "A"),size = 1.25) +
-      ggplot2::geom_line(ggplot2::aes(x = t, y = I/n, color = "C"),size = 1.25) +
+      ggplot2::geom_line(ggplot2::aes(x = t, y = S/n, color = "A"), linewidth = 1.25) +
+      ggplot2::geom_line(ggplot2::aes(x = t, y = I/n, color = "C"), linewidth = 1.25) +
       ggplot2::geom_col(ggplot2::aes(x = t, y = I_new/n), 
                         alpha = 0.4) +
-      ggplot2::theme_minimal() + ggplot2::ylim(0,1) +
+      ggplot2::theme_minimal() + 
+      ggplot2::coord_cartesian(ylim = c(0,1)) + # using coord_cartesion to avoid printing warnings
       ggplot2::ylab("Proportion") + ggplot2::xlab("Steps")
-    if(any(data$E>0))
+    labs <- c("Susceptible", "Infected")
+    if(any(data$E>0)){
       p <- p +
-      ggplot2::geom_line(ggplot2::aes(x = t, y = E/n, color = "B"),size = 1.25)
-    if(any(data$R>0))
+        ggplot2::geom_line(ggplot2::aes(x = t, y = E/n, color = "B"),size = 1.25)
+      labs <- c("Susceptible", "Exposed", "Infected")
+    }
+    if(any(data$R>0)){
       p <- p +
-      ggplot2::geom_line(ggplot2::aes(x = t, y = R/n, color = "D"),size = 1.25)
+        ggplot2::geom_line(ggplot2::aes(x = t, y = R/n, color = "D"),size = 1.25)
+      labs <- c(labs, "Recovered")
+    }
+
     p + ggplot2::scale_color_manual("Legend", 
-                            labels = c("Susceptible", "Exposed", "Infected", "Recovered"),
+                            labels = labs,
                             values = c(A = "blue", B = "orange", 
                                        C = "red", D = "darkgreen"),
                             guide = "legend")
@@ -252,18 +259,25 @@ plot.diffs_model <- function(x, ...){
                            method = "loess", se=TRUE, level = .95, formula = 'y~x') +
       ggplot2::geom_smooth(ggplot2::aes(x = t, y = I/n, color = "C"), 
                            method = "loess", se=TRUE, level = .95, formula = 'y~x') +
-      ggplot2::theme_minimal() + ggplot2::ylim(0,1) +
+      ggplot2::theme_minimal() + 
+      ggplot2::coord_cartesian(ylim = c(0,1)) + # using coord_cartesion to avoid printing warnings
       ggplot2::ylab("Proportion") + ggplot2::xlab("Steps")
-    if(any(data$E>0))
+    labs <- c("Susceptible", "Infected")
+    if(any(data$E>0)){
       p <- p +
-      ggplot2::geom_smooth(ggplot2::aes(x = t, y = E/n, color = "B"), 
-                           method = "loess", se=TRUE, level = .95, formula = 'y~x')
-    if(any(data$R>0))
+        ggplot2::geom_smooth(ggplot2::aes(x = t, y = E/n, color = "B"), 
+                             method = "loess", se=TRUE, level = .95, formula = 'y~x')
+      labs <- c("Susceptible", "Exposed", "Infected")
+    }
+    if(any(data$R>0)){
       p <- p +
-      ggplot2::geom_smooth(ggplot2::aes(x = t, y = R/n, color = "D"), 
-                           method = "loess", se=TRUE, level = .95, formula = 'y~x')
+        ggplot2::geom_smooth(ggplot2::aes(x = t, y = R/n, color = "D"), 
+                             method = "loess", se=TRUE, level = .95, formula = 'y~x')
+      labs <- c(labs, "Recovered")
+    }
+
     p + ggplot2::scale_color_manual("Legend", 
-                                    labels = c("Susceptible", "Exposed", "Infected", "Recovered"),
+                                    labels = labs,
                                     values = c(A = "blue", B = "orange", 
                                                C = "red", D = "darkgreen"),
                                     guide = "legend")

R/measure_diffusion.R

@@ -0,0 +1,77 @@
+#' Functions to play games on networks
+#' @param diff_model A valid network diffusion model.
+#' @family measures
+#' @name diffusion
+#' @references
+#'   Valente, Tom W. (1995). _Network models of the diffusion of innovations_
+#'   (2nd ed.). Cresskill N.J.: Hampton Press.
+NULL
+
+#' @describeIn diffusion Calculates the average transmissibility observed
+#'   in a diffusion simulation, or the number of new infections over
+#'   the number of susceptible, over the number of infected 
+#' @export
+network_transmissibility <- function(diff_model){
+  out <- diff_model |> 
+    mutate(transmissibility = (I - dplyr::lag(I)/dplyr::lag(S))/
+             dplyr::lag(I))
+  out <- out$transmissibility
+  out <- out[!is.infinite(out)]
+  mean(out, na.rm = TRUE)
+}
+
+#' @describeIn diffusion Calculates the average length nodes remain
+#'   infected in a compartmental model with recovery
+#' @export
+node_infection_length <- function(diff_model){
+  events <- attr(diff_model, "events")
+  if(!"R" %in% events$event) stop("Infection length only calculable if there is recovery or removal.")
+  vapply(seq_len(diff_model$n[1]), 
+         function(x) mean(diff(dplyr::filter(events, nodes == x)$t)),
+         FUN.VALUE = numeric(1))
+}
+
+#' @describeIn diffusion Calculates the average length nodes remain
+#'   infected in a compartmental model with recovery for the network as a whole
+#' @export
+network_infection_length <- function(diff_model){
+  mean(node_infection_length(diff_model))
+}
+
+#' @describeIn diffusion Calculates the observed reproductive number
+#'   in a diffusion simulation as the network's transmissibility over
+#'   the network's average infection length
+#' @export
+network_reproduction <- function(diff_model){
+  network_transmissibility(diff_model)/
+    network_infection_length(diff_model)
+}
+
+#' @describeIn diffusion Returns nodes' time of adoption/infection
+#' @export
+node_adoption_time <- function(diff_model){
+  summary(diff_model) |> dplyr::filter(event == "I") |> 
+    dplyr::distinct(nodes, .keep_all = TRUE) |> 
+    dplyr::select(t) |> c() |> unname() |> unlist()
+}
+
+#' @describeIn diffusion Returns nodes' time of adoption/infection
+#' @export
+node_adopter <- function(diff_model){
+  toa <- node_adoption_time(diff_model)
+  avg <- mean(toa)
+  sdv <- sd(toa)
+  ifelse(toa < (avg - sdv), "Early Adopter", 
+         ifelse(toa > (avg + sdv), "Laggard",
+                ifelse((avg - sdv) < toa & toa <= avg, "Early Majority", 
+                       ifelse(avg < toa & toa <= avg + sdv, "Late Majority", "Non-Adopter"))))
+}
+
+#' @describeIn diffusion Infers nodes' thresholds from the amount
+#'   of exposure they had when they became infected
+#' @export
+node_thresholds <- function(diff_model){
+  summary(diff_model) |> dplyr::filter(event == "I") |> 
+    dplyr::distinct(nodes, .keep_all = TRUE) |> 
+    dplyr::select(exposure) |> c() |> unname() |> unlist()
+}

R/model_play.R

@@ -11,26 +11,26 @@
 #'   of the number of contacts/exposures sufficient for infection.
 #'   If less than 1, the threshold is interpreted as complex,
 #'   where the threshold concerns the proportion of contacts.
-#' @param transmissibility A proportion indicating the transmission rate,
+#' @param transmissibility The transmission rate probability,
 #'   \eqn{\beta}.
 #'   By default 1, which means any node for which the threshold is met
 #'   or exceeded will become infected.
 #'   Anything lower means a correspondingly lower probability of adoption,
 #'   even when the threshold is met or exceeded.
-#' @param recovery A proportion indicating the rate of recovery, 
-#'   \eqn{\gamma}.
+#' @param recovery The probability those who are infected
+#'   recover, \eqn{\gamma}.
 #'   For example, if infected individuals take, on average, 
 #'   four days to recover, then \eqn{\gamma = 0.25}.
 #'   By default 0, which means there is no recovery (i.e. an SI model).
 #'   Anything higher results in an SIR model.
-#' @param latency A proportion indicating the rate at which those exposed 
+#' @param latency The inverse probability those who have been exposed
 #'   become infectious (infected), \eqn{\sigma}.
 #'   For example, if exposed individuals take, on average, 
-#'   four days to become infectious, then \eqn{\sigma = 0.25}.
+#'   four days to become infectious, then \eqn{\sigma = 0.75} (1/1-0.75 = 1/0.25 = 4).
 #'   By default 0, which means those exposed become immediately infectious (i.e. an SI model).
 #'   Anything higher results in e.g. a SEI model.
-#' @param waning A proportion indicating the rate at which those who are
-#'   recovered become susceptible again, \eqn{\xi}.
+#' @param waning The probability those who are recovered 
+#'   become susceptible again, \eqn{\xi}.
 #'   For example, if recovered individuals take, on average,
 #'   four days to lose their immunity, then \eqn{\xi = 0.25}.
 #'   By default 0, which means any recovered individuals retain lifelong immunity (i.e. an SIR model).
@@ -107,14 +107,14 @@ play_diffusion <- function(.data,
     # count exposures for each node:
     tabcontact <- table(contacts)
     # identify those nodes who are exposed at or above their threshold
-    new <- as.numeric(names(which(tabcontact >= thresholds[as.numeric(names(tabcontact))])))
-    new <- new[stats::rbinom(length(new), 1, transmissibility)==1]
+    newinf <- as.numeric(names(which(tabcontact >= thresholds[as.numeric(names(tabcontact))])))
+    newinf <- newinf[stats::rbinom(length(newinf), 1, transmissibility)==1]
     if(!is.null(recovery) & length(recovered)>0) 
-      new <- setdiff(new, recovered) # recovered can't be reinfected
+      newinf <- setdiff(newinf, recovered) # recovered can't be reinfected
     if(!is.null(exposed) & length(exposed)>0) 
-      new <- setdiff(new, exposed) # exposed already infected
-    if(is.infinite(steps) & length(new)==0 & length(exposed)==0) break # if no new infections we can stop
-    exposed <- c(exposed, new)
+      newinf <- setdiff(newinf, exposed) # exposed already infected
+    if(is.infinite(steps) & length(newinf)==0 & length(exposed)==0) break # if no new infections we can stop
+    exposed <- c(exposed, newinf)
 
     # new list of infected 
     infectious <- exposed[stats::rbinom(length(exposed), 1, latency)==0]
@@ -123,9 +123,9 @@ play_diffusion <- function(.data,
     # tick time
     t <- t+1
     # record new infections
-    if(!is.null(new) & length(new)>0)
+    if(!is.null(newinf) & length(newinf)>0)
       events <- rbind(events, 
-                    data.frame(t = t, nodes = new, event = "I"))
+                    data.frame(t = t, nodes = newinf, event = "I"))
     # record recoveries
     if(!is.null(exposed) & length(exposed)>0)
       events <- rbind(events,
@@ -143,7 +143,7 @@ play_diffusion <- function(.data,
                                n = n,
                          S = n - (length(exposed) + length(infected) + length(recovered)),
                          E = length(exposed),
-                         I_new = length(new),
+                         I_new = length(newinf),
                          I = length(infected),
                          R = length(recovered)))
     if(is.infinite(steps) & length(infected)==n) break