From 7f3defd1b263de3a5f1228395f0d315f2e6a8133 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Tue, 29 Oct 2024 17:05:57 -0600 Subject: [PATCH 01/34] Adding myself to the project --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 11576da..c0e0e0c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,6 +7,7 @@ Authors@R: c( ), person("Thomas", "Valente", email="tvalente@usc.edu", role=c("aut", "cph"), comment=c(ORCID="0000-0002-8824-5816", what="R original code")), + person("Anibal", "Olivera Morales", role = c("aut", "ctb")), person("Stephanie", "Dyal", email="stepharp@usc.edu", role=c("ctb"), comment="Package's first version"), person("Timothy", "Hayes", email="timothybhayes@gmail.com", role=c("ctb"), comment="Package's first version") ) From 18cd21f808c61eb22fda3ee9c2cf5d46c27c9fce Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Wed, 30 Oct 2024 17:46:47 -0600 Subject: [PATCH 02/34] Some discussion about the dimensions of ans (exposure calculation) --- playground/ans-discussion.R | 87 +++++++++++++++++++++++++++++++++++++ 1 file changed, 87 insertions(+) create mode 100644 playground/ans-discussion.R diff --git a/playground/ans-discussion.R b/playground/ans-discussion.R new file mode 100644 index 0000000..ea05b7e --- /dev/null +++ b/playground/ans-discussion.R @@ -0,0 +1,87 @@ +# Set dimensions +n <- 4 # Number of nodes +t <- 3 # Number of time steps +q <- 2 # Number of contagions + +# Define graph (n x n matrix) +graph <- matrix(c(0, 1, 0, 0, + 1, 0, 1, 0, + 0, 1, 0, 1, + 0, 0, 1, 0), nrow = n, byrow = TRUE) + +# Define attrs (n x t matrix) +attrs <- matrix(c(1, 2, 3, + 4, 5, 6, + 7, 8, 9, + 10,11,12), nrow = n) +#attrs <- array(c(1,2,3, +# 4,5,6, +# 7,8,9, +# 10,11,12, +# Second contagion +# 2,4,6, +# 8,10,12, +# 14,16,18, +# 20,22,24), dim = c(n,t,q)) + +# Define cumadopt (n x t x q array) +cumadopt <- array(c(1,2,3, + 4,5,6, + 7,8,9, + 10,11,12, + # Second contagion + 2,4,6, + 8,10,12, + 14,16,18, + 20,22,24), dim = c(n,t,q)) + +# ORIGINAL: Graph -> n x n +# attrs -> n x T +# cumadopt-> n x T +# +# so (attrs * cumadopt) -> n x T +# (graph %*% (attrs * cumadopt)) -> n x T +# +# normalization: as.vector(ans/( graph %*% attrs + 1e-20 )) +# so (graph %*% attrs) -> n x T + +# NEW: Graph -> n x n +# attrs -> n x T +# cumadopt-> n x T x q +# +# so (graph %*% (attrs * cumadopt)) -> n x T x q +# +# normalization +# so (graph %*% attrs) -> n x T + +# ANS + +ans <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca)) +ans <- array(ans, dim = c(n,t,q)) +dim(ans) + +# NORMALIZATION + +den <- graph %*% attrs +dim(den) + +ans/( graph %*% attrs + 1e-20 ) # Error + +# TRY THIS + +ans_norm <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca) / ( graph %*% attrs + 1e-20 )) +ans <- array(ans, dim = c(n,t,q)) +dim(ans) + +### Another option + +#initializing array +ans <- array(0, dim = c(n,t,q)) +norm <- graph %*% attrs + 1e-20 + +#loop for q contagions +for (k in seq_len(q)) { + ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) / norm +} + +dim(ans) From 34f2e730d2a17a5e213991abb87ea509074b4ca8 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Thu, 31 Oct 2024 11:49:39 -0600 Subject: [PATCH 03/34] just fixing a paragraph in Ego exposure --- R/stats.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/stats.R b/R/stats.R index 115c6f0..af68f02 100644 --- a/R/stats.R +++ b/R/stats.R @@ -250,9 +250,9 @@ dgr.array <- function(graph, cmode, undirected, self, valued) { #' Calculates exposure to adoption over time via multiple different types of weight #' matrices. The basic model is exposure to adoption by immediate neighbors #' (outdegree) at the time period prior to ego’s adoption. This exposure can also be -#' based on (1) incoming ties, (2) structural equivalence, (3) indirect ties, (4) -#' attribute weighted (5) network-metric weighted (e.g., central nodes have more -#' influence), and attribute-weighted (e.g., based on homophily or tie strength). +#' based on (1) incoming ties, (2) structural equivalence, (3) indirect ties, +#' (4) network-metric weighted (e.g., central nodes have more +#' influence), and (5) attribute-weighted (e.g., based on homophily or tie strength). #' #' @templateVar valued TRUE #' @templateVar dynamic TRUE From f27f17403f60f0054274f15ffe4570fdc1e2bb34 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Thu, 31 Oct 2024 12:10:20 -0600 Subject: [PATCH 04/34] looking as.vector things --- playground/ans-discussion.R | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/playground/ans-discussion.R b/playground/ans-discussion.R index ea05b7e..3bb9a0d 100644 --- a/playground/ans-discussion.R +++ b/playground/ans-discussion.R @@ -25,6 +25,11 @@ attrs <- matrix(c(1, 2, 3, # 20,22,24), dim = c(n,t,q)) # Define cumadopt (n x t x q array) +cumadopt <- array(c(1,2,3, + 4,5,6, + 7,8,9, + 10,11,12), dim = c(n,t)) + cumadopt <- array(c(1,2,3, 4,5,6, 7,8,9, @@ -38,6 +43,7 @@ cumadopt <- array(c(1,2,3, # ORIGINAL: Graph -> n x n # attrs -> n x T # cumadopt-> n x T +# ans -> 1 x n # # so (attrs * cumadopt) -> n x T # (graph %*% (attrs * cumadopt)) -> n x T @@ -48,6 +54,7 @@ cumadopt <- array(c(1,2,3, # NEW: Graph -> n x n # attrs -> n x T # cumadopt-> n x T x q +# ans -> q x n # # so (graph %*% (attrs * cumadopt)) -> n x T x q # @@ -73,15 +80,34 @@ ans_norm <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca) / ( gr ans <- array(ans, dim = c(n,t,q)) dim(ans) -### Another option +# OR THIS #initializing array ans <- array(0, dim = c(n,t,q)) norm <- graph %*% attrs + 1e-20 +normalized <- TRUE + #loop for q contagions for (k in seq_len(q)) { - ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) / norm + if (normalized) ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) / norm + else ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) } +as.vector(ans, dim = c(n,t,q)) + dim(ans) + + +## + +ans <- ( graph %*% (attrs * cumadopt) ) +dim(ans) # n x t + +ans_norm <- ans/( graph %*% attrs + 1e-20 ) +class(ans_norm) # "matrix" "array" +dim(ans_norm) # n x t + +ans_norm_vec <- as.vector(ans/( graph %*% attrs + 1e-20 )) +class(ans_norm_vec) # "numeric" +dim(ans_norm_vec) # NULL, only a vector o length 4x3=12 From 8977e4f41db2b6f3c929010c945246912b8b3e98 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Thu, 31 Oct 2024 14:03:07 -0600 Subject: [PATCH 05/34] out object from exposure_for() --- playground/ans-discussion.R | 82 +++++++++++++++---------------------- playground/out-discussion.R | 65 +++++++++++++++++++++++++++++ 2 files changed, 99 insertions(+), 48 deletions(-) create mode 100644 playground/out-discussion.R diff --git a/playground/ans-discussion.R b/playground/ans-discussion.R index 3bb9a0d..010be56 100644 --- a/playground/ans-discussion.R +++ b/playground/ans-discussion.R @@ -3,64 +3,65 @@ n <- 4 # Number of nodes t <- 3 # Number of time steps q <- 2 # Number of contagions -# Define graph (n x n matrix) + +# ORIGINAL: Graph -> n x n +# attrs -> n x T +# cumadopt-> n x T +# ans -> n x T +# +# so (attrs * cumadopt) -> n x T +# (graph %*% (attrs * cumadopt)) -> n x T +# +# normalization: as.vector(ans/( graph %*% attrs + 1e-20 )) +# so (graph %*% attrs) -> n x T + graph <- matrix(c(0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0), nrow = n, byrow = TRUE) -# Define attrs (n x t matrix) attrs <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12), nrow = n) -#attrs <- array(c(1,2,3, -# 4,5,6, -# 7,8,9, -# 10,11,12, -# Second contagion -# 2,4,6, -# 8,10,12, -# 14,16,18, -# 20,22,24), dim = c(n,t,q)) - -# Define cumadopt (n x t x q array) + cumadopt <- array(c(1,2,3, 4,5,6, 7,8,9, 10,11,12), dim = c(n,t)) -cumadopt <- array(c(1,2,3, - 4,5,6, - 7,8,9, - 10,11,12, - # Second contagion - 2,4,6, - 8,10,12, - 14,16,18, - 20,22,24), dim = c(n,t,q)) +ans <- ( graph %*% (attrs * cumadopt) ) +dim(ans) # n x t -# ORIGINAL: Graph -> n x n -# attrs -> n x T -# cumadopt-> n x T -# ans -> 1 x n -# -# so (attrs * cumadopt) -> n x T -# (graph %*% (attrs * cumadopt)) -> n x T -# -# normalization: as.vector(ans/( graph %*% attrs + 1e-20 )) -# so (graph %*% attrs) -> n x T +ans_norm <- ans/( graph %*% attrs + 1e-20 ) +class(ans_norm) # "matrix" "array" +dim(ans_norm) # n x t + +ans_norm_vec <- as.vector(ans/( graph %*% attrs + 1e-20 )) +class(ans_norm_vec) # "numeric" +dim(ans_norm_vec) # NULL, only a vector o length 4x3=12 # NEW: Graph -> n x n # attrs -> n x T # cumadopt-> n x T x q -# ans -> q x n +# ans -> n x T x q # # so (graph %*% (attrs * cumadopt)) -> n x T x q # # normalization # so (graph %*% attrs) -> n x T + +cumadopt <- array(c(1,2,3, + 4,5,6, + 7,8,9, + 10,11,12, + # Second contagion + 2,4,6, + 8,10,12, + 14,16,18, + 20,22,24), dim = c(n,t,q)) + # ANS ans <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca)) @@ -82,7 +83,6 @@ dim(ans) # OR THIS -#initializing array ans <- array(0, dim = c(n,t,q)) norm <- graph %*% attrs + 1e-20 @@ -97,17 +97,3 @@ for (k in seq_len(q)) { as.vector(ans, dim = c(n,t,q)) dim(ans) - - -## - -ans <- ( graph %*% (attrs * cumadopt) ) -dim(ans) # n x t - -ans_norm <- ans/( graph %*% attrs + 1e-20 ) -class(ans_norm) # "matrix" "array" -dim(ans_norm) # n x t - -ans_norm_vec <- as.vector(ans/( graph %*% attrs + 1e-20 )) -class(ans_norm_vec) # "numeric" -dim(ans_norm_vec) # NULL, only a vector o length 4x3=12 diff --git a/playground/out-discussion.R b/playground/out-discussion.R new file mode 100644 index 0000000..30958d1 --- /dev/null +++ b/playground/out-discussion.R @@ -0,0 +1,65 @@ +n <- 4 # Number of nodes +t <- 3 # Number of time steps + +# static graph +graph <- matrix(c(0, 1, 0, 0, + 1, 0, 1, 0, + 0, 1, 0, 1, + 0, 0, 1 ,0), nrow = n) + +cumadopt <- matrix(c(1, 0, 0, + 1, 1, 0, + 0, 1, 1, + 0, 0, 1), nrow = n) + +attrs <- matrix(c(10, 20, 30, + 40, 50, 60, + 70, 80, 90, + 100,110,120), nrow = n) + +# Toy model of .exposure +.exposure <- function(graph, cumadopt, attrs, + outgoing = TRUE, valued = TRUE, normalized = FALSE, self = FALSE) { + + ans <- ( graph %*% (attrs * cumadopt) ) + ans_norm <- ans/( graph %*% attrs + 1e-20 ) + return(as.vector(ans/ans_norm)) +} + +# for static graphs it returns `1L` +nslices <- function(graph) { + if ("matrix" %in% class(graph)) { + return(1L) + } else if ("list" %in% class(graph)) { + return(length(graph)) + } +} + +out <- matrix(nrow = nrow(cumadopt), ncol = ncol(cumadopt)) + +lags <- 0 + +if (lags >= 0L) { + for (i in 1:(nslices(graph) - lags)) { + out[, i + lags] <- .exposure(graph, + cumadopt[, i, drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } +} else { + for (i in (1 - lags):nslices(graph)) { + out[, i + lags] <- .exposure(graph[[i]], + cumadopt[, i], + attrs[, i], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } +} + +# View the result of 'out' +print(out) From ef83eb26b51b2e00e1e9cafc0d655b95699e6c41 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Fri, 1 Nov 2024 16:25:33 -0600 Subject: [PATCH 06/34] More dimensional analysis. Changes to avoid ambiguous names --- R/stats.R | 25 +++++++++++-- playground/ans-discussion.R | 16 ++++++--- playground/out-discussion.R | 71 +++++++++++++++++++++++++------------ 3 files changed, 82 insertions(+), 30 deletions(-) diff --git a/R/stats.R b/R/stats.R index af68f02..0d4d2b6 100644 --- a/R/stats.R +++ b/R/stats.R @@ -479,7 +479,28 @@ NULL ans <- ( graph %*% (attrs * cumadopt) ) if (normalized) as.vector(ans/( graph %*% attrs + 1e-20 )) - else as.vector(ans) + + #if (normalized) { + # norm <- graph %*% attrs + 1e-20 + # ans <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca) / norm ) + # as.vector(ans) + #} else { + # ans <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca)) + # as.vector(ans) + #} + + #ans <- array(0, dim = c(ncol(graph),dim(cumadopt)[2],dim(cumadopt)[3])) + #norm <- graph %*% attrs + 1e-20 + + #for (k in seq_len(dim(cumadopt)[3])) { + # if (normalized) { + # ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) / norm + # } else { + # ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) + # } + #} + + as.vector(ans) } # library(microbenchmark) @@ -637,7 +658,7 @@ exposure_for <- function( lags ) { - out <- matrix(nrow = nrow(cumadopt), ncol = ncol(cumadopt)) + out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) if (lags >= 0L) { for (i in 1:(nslices(graph) - lags)) diff --git a/playground/ans-discussion.R b/playground/ans-discussion.R index 010be56..4aa581d 100644 --- a/playground/ans-discussion.R +++ b/playground/ans-discussion.R @@ -83,17 +83,23 @@ dim(ans) # OR THIS -ans <- array(0, dim = c(n,t,q)) + + +ans <- array(0, dim = c(ncol(graph),dim(cumadopt)[2],dim(cumadopt)[3])) norm <- graph %*% attrs + 1e-20 normalized <- TRUE -#loop for q contagions for (k in seq_len(q)) { - if (normalized) ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) / norm - else ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) + if (normalized) { + ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) / norm + } else { + ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) + } } -as.vector(ans, dim = c(n,t,q)) +as.vector(ans) + +ans dim(ans) diff --git a/playground/out-discussion.R b/playground/out-discussion.R index 30958d1..75869fc 100644 --- a/playground/out-discussion.R +++ b/playground/out-discussion.R @@ -1,16 +1,36 @@ n <- 4 # Number of nodes t <- 3 # Number of time steps +q <- 2 # pathogens # static graph -graph <- matrix(c(0, 1, 0, 0, - 1, 0, 1, 0, - 0, 1, 0, 1, - 0, 0, 1 ,0), nrow = n) +# Define a collection of graphs as a single array (n x n x nslices) +graph_slice_test <- array(c( + # First time slice (graph1) + c(0, 1, 0, 0, + 1, 0, 1, 0, + 0, 1, 0, 1, + 0, 0, 1, 0), + # Second time slice (graph2) + c(0, 1, 1, 0, + 1, 0, 0, 1, + 1, 0, 0 ,1, + 0 ,1 ,1 ,0), + # Third time slice (graph3) + c(0 ,0 ,1 ,1, + 0 ,0 ,1 ,1, + 1 ,1 ,0 ,0, + 1 ,1 ,0 ,0)), + dim = c(n,n ,t)) -cumadopt <- matrix(c(1, 0, 0, - 1, 1, 0, - 0, 1, 1, - 0, 0, 1), nrow = n) +cumadopt <- array(c(1,2,3, + 4,5,6, + 7,8,9, + 10,11,12, + # Second contagion + 2,4,6, + 8,10,12, + 14,16,18, + 20,22,24), dim = c(n,t,q)) attrs <- matrix(c(10, 20, 30, 40, 50, 60, @@ -18,31 +38,35 @@ attrs <- matrix(c(10, 20, 30, 100,110,120), nrow = n) # Toy model of .exposure -.exposure <- function(graph, cumadopt, attrs, +.exposure <- function(graph_slice, cumadopt_slice, attrs_slice, outgoing = TRUE, valued = TRUE, normalized = FALSE, self = FALSE) { - ans <- ( graph %*% (attrs * cumadopt) ) - ans_norm <- ans/( graph %*% attrs + 1e-20 ) - return(as.vector(ans/ans_norm)) -} + ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[2],dim(cumadopt)[3])) + norm <- graph_slice %*% attrs_slice + 1e-20 -# for static graphs it returns `1L` -nslices <- function(graph) { - if ("matrix" %in% class(graph)) { - return(1L) - } else if ("list" %in% class(graph)) { - return(length(graph)) + for (k in seq_len(q)) { + if (normalized) { + ans[,,k] <- graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) / norm + } else { + ans[,,k] <- graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) + } } + + as.vector(ans) } -out <- matrix(nrow = nrow(cumadopt), ncol = ncol(cumadopt)) +# for static graphs it returns `1L` +# nslices --> from diffnet-methods + +out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) lags <- 0 if (lags >= 0L) { for (i in 1:(nslices(graph) - lags)) { - out[, i + lags] <- .exposure(graph, - cumadopt[, i, drop = FALSE], + out[, i + lags] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + #cumadopt[, i, ], attrs[, i, drop = FALSE], outgoing = TRUE, valued = TRUE, @@ -52,7 +76,8 @@ if (lags >= 0L) { } else { for (i in (1 - lags):nslices(graph)) { out[, i + lags] <- .exposure(graph[[i]], - cumadopt[, i], + cumadopt[, i, , drop = FALSE], + #cumadopt[, i, ], attrs[, i], outgoing = TRUE, valued = TRUE, From 8a8282c3ef61b0c08668c26db746c890ac568e95 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Fri, 1 Nov 2024 16:36:42 -0600 Subject: [PATCH 07/34] stats.R fixed --- R/stats.R | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/R/stats.R b/R/stats.R index 0d4d2b6..11941a1 100644 --- a/R/stats.R +++ b/R/stats.R @@ -476,10 +476,6 @@ NULL # Checking self if (!self) graph <- sp_diag(graph, rep(0, nnodes(graph))) - ans <- ( graph %*% (attrs * cumadopt) ) - - if (normalized) as.vector(ans/( graph %*% attrs + 1e-20 )) - #if (normalized) { # norm <- graph %*% attrs + 1e-20 # ans <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca) / norm ) @@ -500,7 +496,13 @@ NULL # } #} - as.vector(ans) + ans <- ( graph %*% (attrs * cumadopt) ) + + if (normalized) { + as.vector(ans/( graph %*% attrs + 1e-20 )) + } else { + as.vector(ans) + } } # library(microbenchmark) @@ -658,7 +660,7 @@ exposure_for <- function( lags ) { - out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) + out <- matrix(nrow = nrow(cumadopt), ncol = ncol(cumadopt)) if (lags >= 0L) { for (i in 1:(nslices(graph) - lags)) From bd5c92f67a007c198d623aaaeae053d641c665d1 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Fri, 1 Nov 2024 17:02:48 -0600 Subject: [PATCH 08/34] out object (in exposure_for() function) now allows q diff processes --- playground/out-discussion.R | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/playground/out-discussion.R b/playground/out-discussion.R index 75869fc..61eea43 100644 --- a/playground/out-discussion.R +++ b/playground/out-discussion.R @@ -2,9 +2,13 @@ n <- 4 # Number of nodes t <- 3 # Number of time steps q <- 2 # pathogens -# static graph -# Define a collection of graphs as a single array (n x n x nslices) -graph_slice_test <- array(c( +# NEW: Graph -> n x n +# attrs -> n x T +# cumadopt-> n x T x q +# ans -> n x T +# out -> n x q x T + +graph <- array(c( # First time slice (graph1) c(0, 1, 0, 0, 1, 0, 1, 0, @@ -41,30 +45,32 @@ attrs <- matrix(c(10, 20, 30, .exposure <- function(graph_slice, cumadopt_slice, attrs_slice, outgoing = TRUE, valued = TRUE, normalized = FALSE, self = FALSE) { - ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[2],dim(cumadopt)[3])) + #ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[2],dim(cumadopt)[3])) + ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[3])) norm <- graph_slice %*% attrs_slice + 1e-20 - for (k in seq_len(q)) { + for (k in 1:dim(cumadopt)[3]) { if (normalized) { - ans[,,k] <- graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) / norm + ans[,k] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) / norm) } else { - ans[,,k] <- graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) + ans[,k] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k])) } } - as.vector(ans) + #as.vector(ans) + return(ans) } # for static graphs it returns `1L` # nslices --> from diffnet-methods -out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) +out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[3], dim(cumadopt)[2])) lags <- 0 if (lags >= 0L) { for (i in 1:(nslices(graph) - lags)) { - out[, i + lags] <- .exposure(graph[[i]], + out[, , i + lags] <- .exposure(graph[[i]], cumadopt[, i, , drop = FALSE], #cumadopt[, i, ], attrs[, i, drop = FALSE], @@ -75,10 +81,10 @@ if (lags >= 0L) { } } else { for (i in (1 - lags):nslices(graph)) { - out[, i + lags] <- .exposure(graph[[i]], + out[, , i + lags] <- .exposure(graph[[i]], cumadopt[, i, , drop = FALSE], #cumadopt[, i, ], - attrs[, i], + attrs[, i, drop = FALSE], outgoing = TRUE, valued = TRUE, normalized = FALSE, @@ -86,5 +92,5 @@ if (lags >= 0L) { } } -# View the result of 'out' -print(out) + +# out it's working perfectly !! From 8f3314ec4e867d9e6e15cb215149b85359fc8a74 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Fri, 1 Nov 2024 18:31:42 -0600 Subject: [PATCH 09/34] Working forms of .exposure, exposure_for, and exposure.list --- R/stats.R | 76 ++++--- ...discussion.R => exposure-ans-discussion.R} | 0 playground/exposure-out-discussion.R | 201 ++++++++++++++++++ playground/out-discussion.R | 96 --------- 4 files changed, 249 insertions(+), 124 deletions(-) rename playground/{ans-discussion.R => exposure-ans-discussion.R} (100%) create mode 100644 playground/exposure-out-discussion.R delete mode 100644 playground/out-discussion.R diff --git a/R/stats.R b/R/stats.R index 11941a1..eef4155 100644 --- a/R/stats.R +++ b/R/stats.R @@ -476,33 +476,26 @@ NULL # Checking self if (!self) graph <- sp_diag(graph, rep(0, nnodes(graph))) + #ans <- ( graph %*% (attrs * cumadopt) ) + # #if (normalized) { - # norm <- graph %*% attrs + 1e-20 - # ans <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca) / norm ) - # as.vector(ans) + # as.vector(ans/( graph %*% attrs + 1e-20 )) #} else { - # ans <- apply(cumadopt, MARGIN=3, function(ca) graph %*% (attrs * ca)) # as.vector(ans) #} + # + ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[3])) + norm <- graph_slice %*% attrs_slice + 1e-20 - #ans <- array(0, dim = c(ncol(graph),dim(cumadopt)[2],dim(cumadopt)[3])) - #norm <- graph %*% attrs + 1e-20 - - #for (k in seq_len(dim(cumadopt)[3])) { - # if (normalized) { - # ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) / norm - # } else { - # ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) - # } - #} - - ans <- ( graph %*% (attrs * cumadopt) ) - - if (normalized) { - as.vector(ans/( graph %*% attrs + 1e-20 )) - } else { - as.vector(ans) + for (k in 1:dim(cumadopt)[3]) { + if (normalized) { + ans[,k] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) / norm) + } else { + ans[,k] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k])) + } } + + return(ans) } # library(microbenchmark) @@ -660,17 +653,44 @@ exposure_for <- function( lags ) { - out <- matrix(nrow = nrow(cumadopt), ncol = ncol(cumadopt)) + #out <- matrix(nrow = nrow(cumadopt), ncol = ncol(cumadopt)) + + #if (lags >= 0L) { + # for (i in 1:(nslices(graph) - lags)) + # out[,i+lags]<- .exposure(graph[[i]], cumadopt[,i,drop=FALSE], attrs[,i,drop=FALSE], + # outgoing, valued, normalized, self) + #} else { + # for (i in (1-lags):nslices(graph)) + # out[,i+lags]<- .exposure(graph[[i]], cumadopt[,i,drop=FALSE], attrs[,i,drop=FALSE], + # outgoing, valued, normalized, self) + #} + + out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) if (lags >= 0L) { - for (i in 1:(nslices(graph) - lags)) - out[,i+lags]<- .exposure(graph[[i]], cumadopt[,i,drop=FALSE], attrs[,i,drop=FALSE], - outgoing, valued, normalized, self) + for (i in 1:(nslices(graph) - lags)) { + out[, i + lags, ] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + #cumadopt[, i, ], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } } else { - for (i in (1-lags):nslices(graph)) - out[,i+lags]<- .exposure(graph[[i]], cumadopt[,i,drop=FALSE], attrs[,i,drop=FALSE], - outgoing, valued, normalized, self) + for (i in (1 - lags):nslices(graph)) { + out[, i + lags, ] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + #cumadopt[, i, ], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } } + return(out) } diff --git a/playground/ans-discussion.R b/playground/exposure-ans-discussion.R similarity index 100% rename from playground/ans-discussion.R rename to playground/exposure-ans-discussion.R diff --git a/playground/exposure-out-discussion.R b/playground/exposure-out-discussion.R new file mode 100644 index 0000000..d9d558f --- /dev/null +++ b/playground/exposure-out-discussion.R @@ -0,0 +1,201 @@ +n <- 4 # Number of nodes +t <- 3 # Number of time steps +q <- 2 # pathogens + +# NEW: Graph -> n x n +# attrs -> n x T +# cumadopt-> n x T x q +# ans -> n x T +# out -> n x q x T + +graph_array <- array(c( + # First time slice (graph1) + c(0, 1, 0, 0, + 1, 0, 1, 0, + 0, 1, 0, 1, + 0, 0, 1, 0), + # Second time slice (graph2) + c(0, 1, 1, 0, + 1, 0, 0, 1, + 1, 0, 0 ,1, + 0 ,1 ,1 ,0), + # Third time slice (graph3) + c(0 ,0 ,1 ,1, + 0 ,0 ,1 ,1, + 1 ,1 ,0 ,0, + 1 ,1 ,0 ,0)), + dim = c(n,n ,t)) + +graph <- as_spmat(graph_array) + +cumadopt <- array(c(1,2,3, + 4,5,6, + 7,8,9, + 10,11,12, + # Second contagion + 2,4,6, + 8,10,12, + 14,16,18, + 20,22,24), dim = c(n,t,q)) + +attrs <- matrix(c(10, 20, 30, + 40, 50, 60, + 70, 80, 90, + 100,110,120), nrow = n) + +# Toy model of .exposure + +.exposure <- function(graph_slice, cumadopt_slice, attrs_slice, + outgoing = TRUE, valued = TRUE, normalized = FALSE, self = FALSE) { + + norm <- graph_slice %*% attrs_slice + 1e-20 + + if (!is.na(dim(cumadopt)[3])) { + ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[3])) + + for (q in 1:dim(cumadopt)[3]) { + if (normalized) { + ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) / norm) + } else { + ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k])) + } + } + } else { + ans <- graph_slice %*% (attrs_slice * cumadopt_slice) + + if (normalized) { + ans <- ans/ norm + } + } + + #as.vector(ans) + return(as.vector(ans)) +} + +# for static graphs it returns `1L` +# nslices --> from diffnet-methods + +lags = 0 + +if (!is.na(dim(cumadopt)[3])) { + out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) + + if (lags >= 0L) { + for (i in 1:(nslices(graph) - lags)) { + out[, i + lags, ] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } else { + for (i in (1 - lags):nslices(graph)) { + out[, i + lags, ] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } +} else { + out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2])) + + if (lags >= 0L) { + for (i in 1:(nslices(graph) - lags)) { + out[, i + lags] <- .exposure(graph[[i]], + cumadopt[, i, drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } else { + for (i in (1 - lags):nslices(graph)) { + out[, i + lags] <- .exposure(graph[[i]], + cumadopt[, i, drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } +} + +# out it's working perfectly for multiple diff processes!! +# +# -- +# +# -- +# +# Now what if there's only one diff process: + +# 1 pathogen ONLY + +cumadopt <- array(c(1,2,3, + 4,5,6, + 7,8,9, + 10,11,12 + ), dim = c(n,t)) + +attrs <- matrix(c(10, 20, 30, + 40, 50, 60, + 70, 80, 90, + 100,110,120), nrow = n) + +if (!is.na(dim(cumadopt)[3])) { + out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) + + if (lags >= 0L) { + for (i in 1:(nslices(graph) - lags)) { + out[, i + lags, ] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } else { + for (i in (1 - lags):nslices(graph)) { + out[, i + lags, ] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } +} else { + out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2])) + + if (lags >= 0L) { + for (i in 1:(nslices(graph) - lags)) { + out[, i + lags] <- .exposure(graph[[i]], + cumadopt[, i, drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } else { + for (i in (1 - lags):nslices(graph)) { + out[, i + lags] <- .exposure(graph[[i]], + cumadopt[, i, drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } +} + +# Works well.. diff --git a/playground/out-discussion.R b/playground/out-discussion.R deleted file mode 100644 index 61eea43..0000000 --- a/playground/out-discussion.R +++ /dev/null @@ -1,96 +0,0 @@ -n <- 4 # Number of nodes -t <- 3 # Number of time steps -q <- 2 # pathogens - -# NEW: Graph -> n x n -# attrs -> n x T -# cumadopt-> n x T x q -# ans -> n x T -# out -> n x q x T - -graph <- array(c( - # First time slice (graph1) - c(0, 1, 0, 0, - 1, 0, 1, 0, - 0, 1, 0, 1, - 0, 0, 1, 0), - # Second time slice (graph2) - c(0, 1, 1, 0, - 1, 0, 0, 1, - 1, 0, 0 ,1, - 0 ,1 ,1 ,0), - # Third time slice (graph3) - c(0 ,0 ,1 ,1, - 0 ,0 ,1 ,1, - 1 ,1 ,0 ,0, - 1 ,1 ,0 ,0)), - dim = c(n,n ,t)) - -cumadopt <- array(c(1,2,3, - 4,5,6, - 7,8,9, - 10,11,12, - # Second contagion - 2,4,6, - 8,10,12, - 14,16,18, - 20,22,24), dim = c(n,t,q)) - -attrs <- matrix(c(10, 20, 30, - 40, 50, 60, - 70, 80, 90, - 100,110,120), nrow = n) - -# Toy model of .exposure -.exposure <- function(graph_slice, cumadopt_slice, attrs_slice, - outgoing = TRUE, valued = TRUE, normalized = FALSE, self = FALSE) { - - #ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[2],dim(cumadopt)[3])) - ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[3])) - norm <- graph_slice %*% attrs_slice + 1e-20 - - for (k in 1:dim(cumadopt)[3]) { - if (normalized) { - ans[,k] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) / norm) - } else { - ans[,k] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k])) - } - } - - #as.vector(ans) - return(ans) -} - -# for static graphs it returns `1L` -# nslices --> from diffnet-methods - -out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[3], dim(cumadopt)[2])) - -lags <- 0 - -if (lags >= 0L) { - for (i in 1:(nslices(graph) - lags)) { - out[, , i + lags] <- .exposure(graph[[i]], - cumadopt[, i, , drop = FALSE], - #cumadopt[, i, ], - attrs[, i, drop = FALSE], - outgoing = TRUE, - valued = TRUE, - normalized = FALSE, - self = FALSE) - } -} else { - for (i in (1 - lags):nslices(graph)) { - out[, , i + lags] <- .exposure(graph[[i]], - cumadopt[, i, , drop = FALSE], - #cumadopt[, i, ], - attrs[, i, drop = FALSE], - outgoing = TRUE, - valued = TRUE, - normalized = FALSE, - self = FALSE) - } -} - - -# out it's working perfectly !! From b7f689aeb68935967c4feecf6cdb6a123b9d997d Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 4 Nov 2024 10:11:30 -0700 Subject: [PATCH 10/34] updates for .exposure and exposure.list functions --- R/stats.R | 71 +++++++++++++++++++++------- playground/exposure-out-discussion.R | 60 ++++++++++++----------- 2 files changed, 86 insertions(+), 45 deletions(-) diff --git a/R/stats.R b/R/stats.R index eef4155..89731ab 100644 --- a/R/stats.R +++ b/R/stats.R @@ -484,18 +484,29 @@ NULL # as.vector(ans) #} # - ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[3])) + norm <- graph_slice %*% attrs_slice + 1e-20 - for (k in 1:dim(cumadopt)[3]) { + if (!is.na(dim(cumadopt)[3])) { + ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[3])) + + for (q in 1:dim(cumadopt)[3]) { + if (normalized) { + ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,q]) / norm) + } else { + ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,q])) + } + } + } else { + ans <- graph_slice %*% (attrs_slice * cumadopt_slice) + if (normalized) { - ans[,k] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) / norm) - } else { - ans[,k] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k])) + ans <- ans/ norm } } - return(ans) + #as.vector(ans) + return(as.vector(ans)) } # library(microbenchmark) @@ -665,29 +676,53 @@ exposure_for <- function( # outgoing, valued, normalized, self) #} - out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) + if (!is.na(dim(cumadopt)[3])) { + out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) + + if (lags >= 0L) { + for (i in 1:(nslices(graph) - lags)) { + out[, i + lags, ] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } else { + for (i in (1 - lags):nslices(graph)) { + out[, i + lags, ] <- .exposure(graph[[i]], + cumadopt[, i, , drop = FALSE], + attrs[, i, drop = FALSE], + outgoing = TRUE, + valued = TRUE, + normalized = FALSE, + self = FALSE) + } + } + } else { + out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2])) - if (lags >= 0L) { - for (i in 1:(nslices(graph) - lags)) { - out[, i + lags, ] <- .exposure(graph[[i]], - cumadopt[, i, , drop = FALSE], - #cumadopt[, i, ], + if (lags >= 0L) { + for (i in 1:(nslices(graph) - lags)) { + out[, i + lags] <- .exposure(graph[[i]], + cumadopt[, i, drop = FALSE], attrs[, i, drop = FALSE], outgoing = TRUE, valued = TRUE, normalized = FALSE, self = FALSE) - } - } else { - for (i in (1 - lags):nslices(graph)) { - out[, i + lags, ] <- .exposure(graph[[i]], - cumadopt[, i, , drop = FALSE], - #cumadopt[, i, ], + } + } else { + for (i in (1 - lags):nslices(graph)) { + out[, i + lags] <- .exposure(graph[[i]], + cumadopt[, i, drop = FALSE], attrs[, i, drop = FALSE], outgoing = TRUE, valued = TRUE, normalized = FALSE, self = FALSE) + } } } diff --git a/playground/exposure-out-discussion.R b/playground/exposure-out-discussion.R index d9d558f..eeb658e 100644 --- a/playground/exposure-out-discussion.R +++ b/playground/exposure-out-discussion.R @@ -28,23 +28,36 @@ graph_array <- array(c( graph <- as_spmat(graph_array) -cumadopt <- array(c(1,2,3, - 4,5,6, - 7,8,9, - 10,11,12, - # Second contagion - 2,4,6, - 8,10,12, - 14,16,18, - 20,22,24), dim = c(n,t,q)) - -attrs <- matrix(c(10, 20, 30, - 40, 50, 60, - 70, 80, 90, - 100,110,120), nrow = n) +# one +cumadopt_one <- matrix(c( + 0, 1, 1, + 1, 1, 1, + 0, 0, 1, + 0, 0, 0 +), nrow = n, byrow = TRUE) + +#two +cumadopt_two <- array(0, dim = c(n, t, q)) + +cumadopt_two[,,1] <- matrix(c( + 0, 1, 1, + 1, 1, 1, + 0, 0, 1, + 0, 0, 0 +), nrow = n, byrow = TRUE) + +cumadopt_two[,,2] <- matrix(c( + 0, 1, 1, + 0, 1, 1, + 0, 0, 1, + 0, 0, 1 +), nrow = n, byrow = TRUE) + +# attributes between [0-1] +attrs <- matrix(runif(n * t), nrow = n) -# Toy model of .exposure +# Toy model of .exposure .exposure <- function(graph_slice, cumadopt_slice, attrs_slice, outgoing = TRUE, valued = TRUE, normalized = FALSE, self = FALSE) { @@ -55,9 +68,9 @@ attrs <- matrix(c(10, 20, 30, for (q in 1:dim(cumadopt)[3]) { if (normalized) { - ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k]) / norm) + ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,q]) / norm) } else { - ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,k])) + ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,q])) } } } else { @@ -77,6 +90,8 @@ attrs <- matrix(c(10, 20, 30, lags = 0 +cumadopt <- cumadopt_two + if (!is.na(dim(cumadopt)[3])) { out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) @@ -137,16 +152,7 @@ if (!is.na(dim(cumadopt)[3])) { # 1 pathogen ONLY -cumadopt <- array(c(1,2,3, - 4,5,6, - 7,8,9, - 10,11,12 - ), dim = c(n,t)) - -attrs <- matrix(c(10, 20, 30, - 40, 50, 60, - 70, 80, 90, - 100,110,120), nrow = n) +cumadopt <- cumadopt_one if (!is.na(dim(cumadopt)[3])) { out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) From 6ffdba5459ffaf10530bba38db50c38839401bd7 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 4 Nov 2024 10:29:54 -0700 Subject: [PATCH 11/34] correcting labels of variables --- R/stats.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/stats.R b/R/stats.R index 89731ab..ab1a481 100644 --- a/R/stats.R +++ b/R/stats.R @@ -485,20 +485,20 @@ NULL #} # - norm <- graph_slice %*% attrs_slice + 1e-20 + norm <- graph %*% attrs + 1e-20 if (!is.na(dim(cumadopt)[3])) { ans <- array(0, dim = c(dim(cumadopt)[1],dim(cumadopt)[3])) for (q in 1:dim(cumadopt)[3]) { if (normalized) { - ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,q]) / norm) + ans[,q] <- as.vector(graph %*% (attrs * cumadopt[,,q]) / norm) } else { - ans[,q] <- as.vector(graph_slice %*% (attrs_slice * cumadopt_slice[,,q])) + ans[,q] <- as.vector(graph_slice %*% (attrs * cumadopt[,,q])) } } } else { - ans <- graph_slice %*% (attrs_slice * cumadopt_slice) + ans <- graph %*% (attrs * cumadopt) if (normalized) { ans <- ans/ norm From d4720e0bb0678db044c472c82fc01136b38a6a40 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 4 Nov 2024 11:58:40 -0700 Subject: [PATCH 12/34] Fixing tests of diffnet --- R/diffnet-class.r | 1 + R/stats.R | 32 ++++++++++++++-------------- playground/exposure-out-discussion.R | 2 +- tests/testthat/test-stats.R | 2 +- 4 files changed, 19 insertions(+), 18 deletions(-) diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 740ccdc..73f5041 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -631,6 +631,7 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm as.character(name))) meta$behavior <- ifelse(!length(behavior), "", ifelse(is.na(behavior), "", as.character(behavior))) + meta$version <- 5 # Removing dimnames graph <- Map(function(x) Matrix::unname(x), x=graph) diff --git a/R/stats.R b/R/stats.R index ab1a481..c53e314 100644 --- a/R/stats.R +++ b/R/stats.R @@ -684,20 +684,20 @@ exposure_for <- function( out[, i + lags, ] <- .exposure(graph[[i]], cumadopt[, i, , drop = FALSE], attrs[, i, drop = FALSE], - outgoing = TRUE, - valued = TRUE, - normalized = FALSE, - self = FALSE) + outgoing = outgoing, + valued = valued, + normalized = normalized, + self = self) } } else { for (i in (1 - lags):nslices(graph)) { out[, i + lags, ] <- .exposure(graph[[i]], cumadopt[, i, , drop = FALSE], attrs[, i, drop = FALSE], - outgoing = TRUE, - valued = TRUE, - normalized = FALSE, - self = FALSE) + outgoing = outgoing, + valued = valued, + normalized = normalized, + self = self) } } } else { @@ -708,20 +708,20 @@ exposure_for <- function( out[, i + lags] <- .exposure(graph[[i]], cumadopt[, i, drop = FALSE], attrs[, i, drop = FALSE], - outgoing = TRUE, - valued = TRUE, - normalized = FALSE, - self = FALSE) + outgoing = outgoing, + valued = valued, + normalized = normalized, + self = self) } } else { for (i in (1 - lags):nslices(graph)) { out[, i + lags] <- .exposure(graph[[i]], cumadopt[, i, drop = FALSE], attrs[, i, drop = FALSE], - outgoing = TRUE, - valued = TRUE, - normalized = FALSE, - self = FALSE) + outgoing = outgoing, + valued = valued, + normalized = normalized, + self = self) } } } diff --git a/playground/exposure-out-discussion.R b/playground/exposure-out-discussion.R index eeb658e..9dbc851 100644 --- a/playground/exposure-out-discussion.R +++ b/playground/exposure-out-discussion.R @@ -6,7 +6,7 @@ q <- 2 # pathogens # attrs -> n x T # cumadopt-> n x T x q # ans -> n x T -# out -> n x q x T +# out -> n x T x q graph_array <- array(c( # First time slice (graph1) diff --git a/tests/testthat/test-stats.R b/tests/testthat/test-stats.R index 939836d..27676f6 100644 --- a/tests/testthat/test-stats.R +++ b/tests/testthat/test-stats.R @@ -3,7 +3,7 @@ context("Stats functions (including exposure)") test_that("exposure calculations", { # Generating data set.seed(999) - diffnet <- rdiffnet(40,5, seed.p.adopt = .1) + diffnet <- rdiffnet(40, 5, seed.p.adopt = .1) # Default ans0 <- exposure(diffnet) From bcabadbfb71957e079b63058a74dc5a0e19e0cc6 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Tue, 5 Nov 2024 14:09:24 -0700 Subject: [PATCH 13/34] changes to exposure.list() to allow arrays of cumadopt. Add multidiff-test-discussion too. --- R/stats.R | 17 +++- playground/multidiff-test-discussion.R | 131 +++++++++++++++++++++++++ 2 files changed, 144 insertions(+), 4 deletions(-) create mode 100644 playground/multidiff-test-discussion.R diff --git a/R/stats.R b/R/stats.R index c53e314..4aa2d98 100644 --- a/R/stats.R +++ b/R/stats.R @@ -638,10 +638,19 @@ exposure.list <- function( # attrs can be either # degree, indegree, outdegree, or a user defined vector. # by default is user equal to 1 - da <- dim(attrs) - if (!length(da)) stop("-attrs- must be a matrix of size n by T.") - if (any(da != dim(cumadopt))) stop("Incorrect size for -attrs-. ", - "It must be of size that -cumadopt-.") + + dim_attrs <- dim(attrs) # default n x T matrix of 1's + if (!length(dim_attrs)) stop("-attrs- must be a matrix of size n by T.") + + if (!is.na(dim(cumadopt)[3])) { + attrs <- array(rep(attrs, q), dim = c(dim_attrs, dim(cumadopt)[3])) + dim_attrs <- dim(attrs) # now n x T x q array of 1's, q behaviors + if (any(dim_attrs != dim(cumadopt))) stop("Incorrect size for -attrs-. ", + "Does not match n dim or t dim.") + } else { + if (any(dim_attrs != dim(cumadopt))) stop("Incorrect size for -attrs-. ", + "It must be of size that -cumadopt-.") + } add_dimnames.mat(cumadopt) diff --git a/playground/multidiff-test-discussion.R b/playground/multidiff-test-discussion.R new file mode 100644 index 0000000..ba38830 --- /dev/null +++ b/playground/multidiff-test-discussion.R @@ -0,0 +1,131 @@ + +test_that("multidiffusion exposure calculations", { + # Generating data + diffnet <- rdiffnet(40,5, seed.p.adopt = .1) + + #data(medInnovationsDiffNet) + #exposure(medInnovationsDiffNet) + + # two spreads + cumadopt_2 <- medInnovationsDiffNet$cumadopt + cumadopt_2 <- array(c(cumadopt_2,cumadopt_2[rev(1:nrow(cumadopt_2)),]), dim=c(dim(cumadopt_2), 2)) + + # Default + #ans0 <- exposure(medInnovationsDiffNet)#exposure(diffnet) + ans1 <- as.matrix(do.call(cbind,lapply(medInnovationsDiffNet$meta$pers, function(x) { + s <- medInnovationsDiffNet$graph[[x]] + for (q in 1:dim(cumadopt)[3]) { + ( s %*% cumadopt_2[,x,q,drop=FALSE])/(1e-15+Matrix::rowSums(s)) + } + }))) + + exposure(medInnovationsDiffNet$graph, medInnovationsDiffNet$cumadopt) + + ans2 <- exposure(medInnovationsDiffNet$graph, cumadopt = cumadopt_2) + #ans3 <- exposure(as.array(medInnovationsDiffNet), cumadopt = cumadopt_2) + + expect_equivalent(ans0, ans1) + expect_equivalent(ans0, ans2) + expect_equivalent(ans0, ans3) + + # With an attribute + X <- matrix(diffnet[["real_threshold"]], ncol=5, nrow=40, byrow = FALSE) + ans0 <- exposure(diffnet, attrs=X) + ans1 <- exposure(diffnet, attrs="real_threshold") + expect_equivalent(ans0, ans1) + + expect_error(exposure(diffnet$graph, attrs="real_threshold"),"is only valid for") + + # Struct Equiv + se <- struct_equiv(diffnet) + se <- lapply(se, function(x) { + ans <- methods::as(x$SE, "dgCMatrix") + ans@x <- 1/(ans@x + 1e-20) + ans + }) + exp_1_diffnet <- exposure(diffnet, alt.graph = se, valued=TRUE) + se2 <- vector("list", length(se)) + exp_1_manual <- as.matrix(do.call(cbind,lapply(diffnet$meta$pers, function(x) { + s <- methods::as(struct_equiv(diffnet$graph[[x]])$SE, "dgCMatrix") + s@x <- 1/(s@x + 1e-20) + se2[[x]] <<- s + ( s %*% diffnet$cumadopt[,x,drop=FALSE])/(Matrix::rowSums(s) +1e-20) + }))) + + expect_equivalent(unname(exp_1_diffnet), unname(exp_1_manual)) + + # Lagged exposure + ans0 <- exposure(diffnet) + ans1 <- exposure(diffnet, lags = 1) + ans2 <- exposure(diffnet, lags = 2) + ans3 <- exposure(diffnet, lags = -1) + + expect_equivalent(ans0[,-5], ans1[,-1]) + expect_equivalent(ans0[,-(4:5)], ans2[,-(1:2)]) + expect_equivalent(ans0[,-1], ans3[,-5]) + + expect_error(exposure(diffnet, lags=5), "cannot be greater") + expect_error(exposure(diffnet, lags=NA)) + expect_error(exposure(diffnet, lags=c(1:2))) + +}) + +test_that("multidiffusion exposure calculations", { + # Generating data + set.seed(999) + diffnet <- rdiffnet(40,5, seed.p.adopt = .1) + + # Default + ans0 <- exposure(diffnet) + ans1 <- as.matrix(do.call(cbind,lapply(diffnet$meta$pers, function(x) { + s <- diffnet$graph[[x]] + ( s %*% diffnet$cumadopt[,x,drop=FALSE])/(1e-15+Matrix::rowSums(s)) + }))) + ans2 <- exposure(diffnet$graph, cumadopt = diffnet$cumadopt) + ans3 <- exposure(as.array(diffnet), cumadopt = diffnet$cumadopt) + + expect_equivalent(ans0, ans1) + expect_equivalent(ans0, ans2) + expect_equivalent(ans0, ans3) + + # With an attribute + X <- matrix(diffnet[["real_threshold"]], ncol=5, nrow=40, byrow = FALSE) + ans0 <- exposure(diffnet, attrs=X) + ans1 <- exposure(diffnet, attrs="real_threshold") + expect_equivalent(ans0, ans1) + + expect_error(exposure(diffnet$graph, attrs="real_threshold"),"is only valid for") + + # Struct Equiv + se <- struct_equiv(diffnet) + se <- lapply(se, function(x) { + ans <- methods::as(x$SE, "dgCMatrix") + ans@x <- 1/(ans@x + 1e-20) + ans + }) + exp_1_diffnet <- exposure(diffnet, alt.graph = se, valued=TRUE) + se2 <- vector("list", length(se)) + exp_1_manual <- as.matrix(do.call(cbind,lapply(diffnet$meta$pers, function(x) { + s <- methods::as(struct_equiv(diffnet$graph[[x]])$SE, "dgCMatrix") + s@x <- 1/(s@x + 1e-20) + se2[[x]] <<- s + ( s %*% diffnet$cumadopt[,x,drop=FALSE])/(Matrix::rowSums(s) +1e-20) + }))) + + expect_equivalent(unname(exp_1_diffnet), unname(exp_1_manual)) + + # Lagged exposure + ans0 <- exposure(diffnet) + ans1 <- exposure(diffnet, lags = 1) + ans2 <- exposure(diffnet, lags = 2) + ans3 <- exposure(diffnet, lags = -1) + + expect_equivalent(ans0[,-5], ans1[,-1]) + expect_equivalent(ans0[,-(4:5)], ans2[,-(1:2)]) + expect_equivalent(ans0[,-1], ans3[,-5]) + + expect_error(exposure(diffnet, lags=5), "cannot be greater") + expect_error(exposure(diffnet, lags=NA)) + expect_error(exposure(diffnet, lags=c(1:2))) + +}) From 587babb74f045eb0f63245b21ab64965b2e41dd8 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Tue, 5 Nov 2024 21:10:18 -0700 Subject: [PATCH 14/34] aditional test -multidiffusion exposure calculations- --- R/stats.R | 4 +- playground/multidiff-test-discussion.R | 148 ++++++++----------------- tests/testthat/test-stats.R | 82 ++++++++++++++ 3 files changed, 132 insertions(+), 102 deletions(-) diff --git a/R/stats.R b/R/stats.R index 4aa2d98..f547e51 100644 --- a/R/stats.R +++ b/R/stats.R @@ -643,8 +643,8 @@ exposure.list <- function( if (!length(dim_attrs)) stop("-attrs- must be a matrix of size n by T.") if (!is.na(dim(cumadopt)[3])) { - attrs <- array(rep(attrs, q), dim = c(dim_attrs, dim(cumadopt)[3])) - dim_attrs <- dim(attrs) # now n x T x q array of 1's, q behaviors + attrs_mul <- array(rep(attrs, dim(cumadopt)[3]), dim = c(dim_attrs, dim(cumadopt)[3])) + dim_attrs <- dim(attrs_mul) # now n x T x q array of 1's, q behaviors if (any(dim_attrs != dim(cumadopt))) stop("Incorrect size for -attrs-. ", "Does not match n dim or t dim.") } else { diff --git a/playground/multidiff-test-discussion.R b/playground/multidiff-test-discussion.R index ba38830..53a567b 100644 --- a/playground/multidiff-test-discussion.R +++ b/playground/multidiff-test-discussion.R @@ -1,128 +1,76 @@ - test_that("multidiffusion exposure calculations", { # Generating data diffnet <- rdiffnet(40,5, seed.p.adopt = .1) - #data(medInnovationsDiffNet) - #exposure(medInnovationsDiffNet) - - # two spreads - cumadopt_2 <- medInnovationsDiffNet$cumadopt + # Creating two spreads + cumadopt_2 <- diffnet$cumadopt cumadopt_2 <- array(c(cumadopt_2,cumadopt_2[rev(1:nrow(cumadopt_2)),]), dim=c(dim(cumadopt_2), 2)) - # Default - #ans0 <- exposure(medInnovationsDiffNet)#exposure(diffnet) - ans1 <- as.matrix(do.call(cbind,lapply(medInnovationsDiffNet$meta$pers, function(x) { - s <- medInnovationsDiffNet$graph[[x]] - for (q in 1:dim(cumadopt)[3]) { - ( s %*% cumadopt_2[,x,q,drop=FALSE])/(1e-15+Matrix::rowSums(s)) - } - }))) - - exposure(medInnovationsDiffNet$graph, medInnovationsDiffNet$cumadopt) + # Default -- + ans0 <- exposure(diffnet, cumadopt = cumadopt_2) + ans1 <- array(unlist(lapply(1:dim(cumadopt_2)[3], function(q) { + lapply(diffnet$meta$pers, function(x) { + graph_slice <- diffnet$graph[[x]] + as.numeric((graph_slice %*% cumadopt_2[, x, q, drop = FALSE]) / + (1e-20 + Matrix::rowSums(graph_slice))) + }) + })), dim = dim(cumadopt_2)) - ans2 <- exposure(medInnovationsDiffNet$graph, cumadopt = cumadopt_2) - #ans3 <- exposure(as.array(medInnovationsDiffNet), cumadopt = cumadopt_2) + ans2 <- exposure(diffnet$graph, cumadopt = cumadopt_2) + ans3 <- exposure(as.array(diffnet), cumadopt = cumadopt_2) + #ans0 - ans1 expect_equivalent(ans0, ans1) expect_equivalent(ans0, ans2) expect_equivalent(ans0, ans3) - # With an attribute - X <- matrix(diffnet[["real_threshold"]], ncol=5, nrow=40, byrow = FALSE) - ans0 <- exposure(diffnet, attrs=X) - ans1 <- exposure(diffnet, attrs="real_threshold") - expect_equivalent(ans0, ans1) - - expect_error(exposure(diffnet$graph, attrs="real_threshold"),"is only valid for") - - # Struct Equiv - se <- struct_equiv(diffnet) - se <- lapply(se, function(x) { - ans <- methods::as(x$SE, "dgCMatrix") - ans@x <- 1/(ans@x + 1e-20) - ans - }) - exp_1_diffnet <- exposure(diffnet, alt.graph = se, valued=TRUE) - se2 <- vector("list", length(se)) - exp_1_manual <- as.matrix(do.call(cbind,lapply(diffnet$meta$pers, function(x) { - s <- methods::as(struct_equiv(diffnet$graph[[x]])$SE, "dgCMatrix") - s@x <- 1/(s@x + 1e-20) - se2[[x]] <<- s - ( s %*% diffnet$cumadopt[,x,drop=FALSE])/(Matrix::rowSums(s) +1e-20) - }))) - - expect_equivalent(unname(exp_1_diffnet), unname(exp_1_manual)) - - # Lagged exposure - ans0 <- exposure(diffnet) - ans1 <- exposure(diffnet, lags = 1) - ans2 <- exposure(diffnet, lags = 2) - ans3 <- exposure(diffnet, lags = -1) - - expect_equivalent(ans0[,-5], ans1[,-1]) - expect_equivalent(ans0[,-(4:5)], ans2[,-(1:2)]) - expect_equivalent(ans0[,-1], ans3[,-5]) + # By each behavior -- + ans4 <- exposure(diffnet) + ans5 <- exposure(diffnet$graph, cumadopt = diffnet$cumadopt) + cumadopt_rev <- diffnet$cumadopt[rev(1:nrow(diffnet$cumadopt)),] + ans6 <- exposure(diffnet$graph, cumadopt = cumadopt_rev) - expect_error(exposure(diffnet, lags=5), "cannot be greater") - expect_error(exposure(diffnet, lags=NA)) - expect_error(exposure(diffnet, lags=c(1:2))) - -}) - -test_that("multidiffusion exposure calculations", { - # Generating data - set.seed(999) - diffnet <- rdiffnet(40,5, seed.p.adopt = .1) + expect_equivalent(ans0[,,1], ans4) + expect_equivalent(ans0[,,1], ans5) + expect_equivalent(ans0[,,2], ans6) - # Default - ans0 <- exposure(diffnet) - ans1 <- as.matrix(do.call(cbind,lapply(diffnet$meta$pers, function(x) { - s <- diffnet$graph[[x]] - ( s %*% diffnet$cumadopt[,x,drop=FALSE])/(1e-15+Matrix::rowSums(s)) - }))) - ans2 <- exposure(diffnet$graph, cumadopt = diffnet$cumadopt) - ans3 <- exposure(as.array(diffnet), cumadopt = diffnet$cumadopt) - - expect_equivalent(ans0, ans1) - expect_equivalent(ans0, ans2) - expect_equivalent(ans0, ans3) - - # With an attribute + # With an attribute -- X <- matrix(diffnet[["real_threshold"]], ncol=5, nrow=40, byrow = FALSE) - ans0 <- exposure(diffnet, attrs=X) - ans1 <- exposure(diffnet, attrs="real_threshold") + ans0 <- exposure(diffnet$graph, cumadopt = cumadopt_2, attrs=X) + ans1 <- exposure(as.array(diffnet), cumadopt = cumadopt_2, attrs=X) expect_equivalent(ans0, ans1) expect_error(exposure(diffnet$graph, attrs="real_threshold"),"is only valid for") - # Struct Equiv + # Struct Equiv -- se <- struct_equiv(diffnet) se <- lapply(se, function(x) { ans <- methods::as(x$SE, "dgCMatrix") ans@x <- 1/(ans@x + 1e-20) ans }) - exp_1_diffnet <- exposure(diffnet, alt.graph = se, valued=TRUE) - se2 <- vector("list", length(se)) - exp_1_manual <- as.matrix(do.call(cbind,lapply(diffnet$meta$pers, function(x) { - s <- methods::as(struct_equiv(diffnet$graph[[x]])$SE, "dgCMatrix") - s@x <- 1/(s@x + 1e-20) - se2[[x]] <<- s - ( s %*% diffnet$cumadopt[,x,drop=FALSE])/(Matrix::rowSums(s) +1e-20) - }))) - - expect_equivalent(unname(exp_1_diffnet), unname(exp_1_manual)) - - # Lagged exposure - ans0 <- exposure(diffnet) - ans1 <- exposure(diffnet, lags = 1) - ans2 <- exposure(diffnet, lags = 2) - ans3 <- exposure(diffnet, lags = -1) - - expect_equivalent(ans0[,-5], ans1[,-1]) - expect_equivalent(ans0[,-(4:5)], ans2[,-(1:2)]) - expect_equivalent(ans0[,-1], ans3[,-5]) + ans0 <- exposure(diffnet, cumadopt = cumadopt_2, alt.graph = se, valued=TRUE) + ans1 <- array(unlist(lapply(1:dim(cumadopt_2)[3], function(q) { + lapply(diffnet$meta$pers, function(x) { + graph_slice <- methods::as(struct_equiv(diffnet$graph[[x]])$SE, "dgCMatrix") + graph_slice@x <- 1/(graph_slice@x + 1e-20) + as.numeric((graph_slice %*% cumadopt_2[, x, q, drop = FALSE]) / + (1e-20 + Matrix::rowSums(graph_slice))) + }) + })), dim = dim(cumadopt_2)) + + #ans0 - ans1 + expect_equivalent(unname(ans0), unname(ans1)) + + # Lagged exposure -- + ans0 <- exposure(diffnet, cumadopt = cumadopt_2) + ans1 <- exposure(diffnet, cumadopt = cumadopt_2, lags = 1) + ans2 <- exposure(diffnet, cumadopt = cumadopt_2, lags = 2) + ans3 <- exposure(diffnet, cumadopt = cumadopt_2, lags = -1) + + expect_equivalent(ans0[,-5,], ans1[,-1,]) + expect_equivalent(ans0[,-(4:5),], ans2[,-(1:2),]) + expect_equivalent(ans0[,-1,], ans3[,-5,]) expect_error(exposure(diffnet, lags=5), "cannot be greater") expect_error(exposure(diffnet, lags=NA)) diff --git a/tests/testthat/test-stats.R b/tests/testthat/test-stats.R index 27676f6..ad929e6 100644 --- a/tests/testthat/test-stats.R +++ b/tests/testthat/test-stats.R @@ -1,5 +1,87 @@ context("Stats functions (including exposure)") +test_that("multidiffusion exposure calculations", { + # Generating data + set.seed(999) + diffnet <- rdiffnet(40,5, seed.p.adopt = .1) + + # Creating two spreads + cumadopt_2 <- diffnet$cumadopt + cumadopt_2 <- array(c(cumadopt_2,cumadopt_2[rev(1:nrow(cumadopt_2)),]), dim=c(dim(cumadopt_2), 2)) + + # Default -- + ans0 <- exposure(diffnet, cumadopt = cumadopt_2) + ans1 <- array(unlist(lapply(1:dim(cumadopt_2)[3], function(q) { + lapply(diffnet$meta$pers, function(x) { + graph_slice <- diffnet$graph[[x]] + as.numeric((graph_slice %*% cumadopt_2[, x, q, drop = FALSE]) / + (1e-21 + Matrix::rowSums(graph_slice))) + }) + })), dim = dim(cumadopt_2)) + + ans2 <- exposure(diffnet$graph, cumadopt = cumadopt_2) + ans3 <- exposure(as.array(diffnet), cumadopt = cumadopt_2) + + #round(ans0 - ans1) + expect_equivalent(ans0, ans1) + expect_equivalent(ans0, ans2) + expect_equivalent(ans0, ans3) + + # By each behavior -- + ans4 <- exposure(diffnet) + ans5 <- exposure(diffnet$graph, cumadopt = diffnet$cumadopt) + cumadopt_rev <- diffnet$cumadopt[rev(1:nrow(diffnet$cumadopt)),] + ans6 <- exposure(diffnet$graph, cumadopt = cumadopt_rev) + + expect_equivalent(ans0[,,1], ans4) + expect_equivalent(ans0[,,1], ans5) + expect_equivalent(ans0[,,2], ans6) + + # With an attribute -- + X <- matrix(diffnet[["real_threshold"]], ncol=5, nrow=40, byrow = FALSE) + ans0 <- exposure(diffnet$graph, cumadopt = cumadopt_2, attrs=X) + ans1 <- exposure(as.array(diffnet), cumadopt = cumadopt_2, attrs=X) + expect_equivalent(ans0, ans1) + + expect_error(exposure(diffnet$graph, attrs="real_threshold"),"is only valid for") + + # Struct Equiv -- + se <- struct_equiv(diffnet) + se <- lapply(se, function(x) { + ans <- methods::as(x$SE, "dgCMatrix") + ans@x <- 1/(ans@x + 1e-20) + ans + }) + ans0 <- exposure(diffnet, cumadopt = cumadopt_2, alt.graph = se, valued=TRUE) + ans1 <- array(unlist(lapply(1:dim(cumadopt_2)[3], function(q) { + lapply(diffnet$meta$pers, function(x) { + graph_slice <- methods::as(struct_equiv(diffnet$graph[[x]])$SE, "dgCMatrix") + graph_slice@x <- 1/(graph_slice@x + 1e-20) + as.numeric((graph_slice %*% cumadopt_2[, x, q, drop = FALSE]) / + (1e-20 + Matrix::rowSums(graph_slice))) + }) + })), dim = dim(cumadopt_2)) + + #ans0 - ans1 + expect_equivalent(unname(ans0), unname(ans1)) + + # Lagged exposure -- + ans0 <- exposure(diffnet, cumadopt = cumadopt_2) + ans1 <- exposure(diffnet, cumadopt = cumadopt_2, lags = 1) + ans2 <- exposure(diffnet, cumadopt = cumadopt_2, lags = 2) + ans3 <- exposure(diffnet, cumadopt = cumadopt_2, lags = -1) + + expect_equivalent(ans0[,-5,], ans1[,-1,]) + expect_equivalent(ans0[,-(4:5),], ans2[,-(1:2),]) + expect_equivalent(ans0[,-1,], ans3[,-5,]) + + expect_error(exposure(diffnet, lags=5), "cannot be greater") + expect_error(exposure(diffnet, lags=NA)) + expect_error(exposure(diffnet, lags=c(1:2))) + +}) + + test_that("exposure calculations", { # Generating data set.seed(999) From 9f9a25ef1f39f868fcf2d4bf2d0c06ba75966aef Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Wed, 6 Nov 2024 00:51:07 -0700 Subject: [PATCH 15/34] updating to Steps 1.1 (initial adopters) and 1.2 (finding seed nodes) in rdiffnet function --- R/rdiffnet.r | 115 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 85 insertions(+), 30 deletions(-) diff --git a/R/rdiffnet.r b/R/rdiffnet.r index 3a479b2..c9ed872 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -310,19 +310,20 @@ rdiffnet_multiple <- function( #' @rdname rdiffnet #' @export rdiffnet <- function( - n, - t, - seed.nodes = "random", - seed.p.adopt = 0.05, - seed.graph = "scale-free", - rgraph.args = list(), - rewire = TRUE, - rewire.args = list(), - threshold.dist = runif(n), - exposure.args = list(), - name = "A diffusion network", - behavior = "Random contagion", - stop.no.diff = TRUE + n, + t, + seed.nodes = "random", + seed.p.adopt = 0.05, + seed.graph = "scale-free", + rgraph.args = list(), + rewire = TRUE, + rewire.args = list(), + threshold.dist = runif(n), + exposure.args = list(), + name = "A diffusion network", + behavior = "Random contagion", + stop.no.diff = TRUE, + behavior.num = 1 ) { # Checking options @@ -373,20 +374,61 @@ rdiffnet <- function( sgraph <- lapply(sgraph, `attr<-`, which="undirected", value=NULL) - # Number of initial adopters - if ((seed.p.adopt > 1) | (seed.p.adopt < 0)) { - stop("The proportion of initial adopters should be a number in [0,1]") + # Step 1.0: Setting the seed nodes ----------------------------------------- + + # Step 1.1: Number of initial adopters + + if (length(seed.p.adopt)>1 && length(seed.p.adopt) == behavior.num) { + + n0 <- list() + + for (i in seq_along(seed.p.adopt)) { + + if ((seed.p.adopt[i] > 1) | (seed.p.adopt[i] < 0)) { + stop(paste("The proportion of initial adopters for behavior", i, "should be a number in [0,1]")) + } + if (n*seed.p.adopt[i] < 1) { + warning(paste("Set of initial adopters for behavior", i, "set to 1.")) + } + + n0[[i]] <- max(1, n * seed.p.adopt[i]) + } + + } else if (length(seed.p.adopt)==1 && length(seed.p.adopt) == behavior.num) { + + if ((seed.p.adopt > 1) | (seed.p.adopt < 0)) { + stop("The proportion of initial adopters should be a number in [0,1]") + } + if (n*seed.p.adopt < 1) { + warning("Set of initial adopters set to 1.") + } + + n0 <- max(1, n*seed.p.adopt) + } else { + stop("Number of initial adopters. Mismatch between length(seed.p.adopt) and behavior.num") } - if (n*seed.p.adopt < 1) - warning("Set of initial adopters set to 1.") - n0 <- max(1, n*seed.p.adopt) - # Step 0.1: Setting the seed nodes ------------------------------------------- - cumadopt <- matrix(0L, ncol=t, nrow=n) - toa <- matrix(NA, ncol=1, nrow= n) + # Step 1.2: Finding seed nodes + if (length(seed.nodes) > 1 && length(seed.nodes) == behavior.num) { + dlist <- list() + + if (any(seed.nodes %in% c("central", "marginal"))) { + d <- dgr(sgraph)[, 1, drop = FALSE] + central_d <- rownames(d[order(d, decreasing = TRUE), , drop = FALSE]) + marginal_d <- rownames(d[order(d, decreasing = FALSE), , drop = FALSE]) + } - if (length(seed.nodes) == 1) { + # assign nodes characters values in seed.nodes + for (i in seq_along(seed.p.adopt)) { + dlist[[i]] <- switch(seed.nodes[i], + "central" = as.numeric(central_d[1:floor(n0[[i]])]), + "marginal" = as.numeric(marginal_d[1:floor(n0[[i]])]), + "random" = sample.int(n, floor(n0[[i]])), + stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"") + ) + } + } else if (length(seed.nodes) == 1 && length(seed.nodes) == behavior.num) { if (seed.nodes %in% c("central","marginal")) { @@ -401,24 +443,37 @@ rdiffnet <- function( d <- sample.int(n, floor(n0)) - } else + } else { stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"") + } + } else if (class(seed.nodes)=="list" && length(seed.nodes) != behavior.num) { + + stop("Finding seed nodes. Mismatch between length(seed.nodes) and behavior.num") } else if (!inherits(seed.nodes, "character")) { - d <- seed.nodes + if (length(seed.nodes) >= 1 && length(seed.nodes) == behavior.num) { + d <- seed.nodes + } else if (class(seed.nodes)=="list" && length(seed.nodes) != behavior.num) { + stop("Particular seed nodes provided. Mismatch between length(seed.nodes) and behavior.num") + } else { + d <- seed.nodes + } - } else - stop("Unsupported -seed.nodes- value. See the manual for references.") + } else {stop("Unsupported -seed.nodes- value. See the manual for references.") } + + # Step 1.3: Defining cumadopt and toa (time of adoption) -------------------- + cumadopt <- matrix(0L, ncol=t, nrow=n) + toa <- matrix(NA, ncol=1, nrow= n) # Setting seed nodes via vector toa[d] <- 1L cumadopt[d,] <- 1L - # Step 3.0: Thresholds ------------------------------------------------------- + # Step 2.0: Thresholds ------------------------------------------------------- thr <- rdiffnet_make_threshold(threshold.dist, n) - # Running the simulation + # Step 3.0: Running the simulation ------------------------------------------- for (i in 2:t) { # Computing exposure @@ -439,10 +494,10 @@ rdiffnet <- function( warning("No diffusion in this network.") } + # Step 4.0: Creating diffnet object ------------------------------------------ # Checking attributes isself <- any(sapply(sgraph, function(x) any(Matrix::diag(x) != 0) )) - # Creating diffnet object new_diffnet( graph = sgraph, toa = as.integer(toa), From a54800bbd14860fe2fb2deba6566ae4eff17e78f Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Wed, 6 Nov 2024 11:01:31 -0700 Subject: [PATCH 16/34] updating cumadopt, exposure simulation, and toa for multi-diff processes --- R/rdiffnet.r | 151 +++++++++++++++++++++++++++++++++++---------------- 1 file changed, 104 insertions(+), 47 deletions(-) diff --git a/R/rdiffnet.r b/R/rdiffnet.r index c9ed872..659075c 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -316,7 +316,7 @@ rdiffnet <- function( seed.p.adopt = 0.05, seed.graph = "scale-free", rgraph.args = list(), - rewire = TRUE, + rewire = TRUE, #set TRUE originally rewire.args = list(), threshold.dist = runif(n), exposure.args = list(), @@ -369,9 +369,9 @@ rdiffnet <- function( # Step 0.1: Rewiring or not ------------------------------------------------ # Rewiring - if (rewire) + if (rewire) { sgraph <- do.call(rewire_graph, c(list(graph=sgraph), rewire.args)) - + } sgraph <- lapply(sgraph, `attr<-`, which="undirected", value=NULL) # Step 1.0: Setting the seed nodes ----------------------------------------- @@ -394,7 +394,7 @@ rdiffnet <- function( n0[[i]] <- max(1, n * seed.p.adopt[i]) } - } else if (length(seed.p.adopt)==1 && length(seed.p.adopt) == behavior.num) { + } else if (length(seed.p.adopt)== 1 && behavior.num == 1) { if ((seed.p.adopt > 1) | (seed.p.adopt < 0)) { stop("The proportion of initial adopters should be a number in [0,1]") @@ -405,30 +405,31 @@ rdiffnet <- function( n0 <- max(1, n*seed.p.adopt) } else { - stop("Number of initial adopters. Mismatch between length(seed.p.adopt) and behavior.num") + stop("Error in setting number of initial adopters. Mismatch between length(seed.p.adopt) and behavior.num") } # Step 1.2: Finding seed nodes - if (length(seed.nodes) > 1 && length(seed.nodes) == behavior.num) { - dlist <- list() + if (length(seed.nodes) > 1 && length(seed.nodes) == behavior.num && class(seed.nodes)!="list") { + # multi-diff. Something like seed.nodes <- c("marginal", "central"), and behavior.num <- 2 + d <- list() if (any(seed.nodes %in% c("central", "marginal"))) { - d <- dgr(sgraph)[, 1, drop = FALSE] - central_d <- rownames(d[order(d, decreasing = TRUE), , drop = FALSE]) - marginal_d <- rownames(d[order(d, decreasing = FALSE), , drop = FALSE]) + dg <- dgr(sgraph)[, 1, drop = FALSE] + central_d <- rownames(dg[order(dg, decreasing = TRUE), , drop = FALSE]) + marginal_d <- rownames(dg[order(dg, decreasing = FALSE), , drop = FALSE]) } - # assign nodes characters values in seed.nodes - for (i in seq_along(seed.p.adopt)) { - dlist[[i]] <- switch(seed.nodes[i], - "central" = as.numeric(central_d[1:floor(n0[[i]])]), - "marginal" = as.numeric(marginal_d[1:floor(n0[[i]])]), - "random" = sample.int(n, floor(n0[[i]])), - stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"") + for (i in seq_along(seed.nodes)) { # assign nodes characters values in seed.nodes + d[[i]] <- switch(seed.nodes[i], + "central" = as.numeric(central_d[1:floor(n0[[i]])]), + "marginal" = as.numeric(marginal_d[1:floor(n0[[i]])]), + "random" = sample.int(n, floor(n0[[i]])), + stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"") ) } - } else if (length(seed.nodes) == 1 && length(seed.nodes) == behavior.num) { + } else if (length(seed.nodes) == 1 && behavior.num == 1) { + # Single-diff. Something like seed.nodes <- "central" if (seed.nodes %in% c("central","marginal")) { @@ -447,43 +448,86 @@ rdiffnet <- function( stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"") } } else if (class(seed.nodes)=="list" && length(seed.nodes) != behavior.num) { - - stop("Finding seed nodes. Mismatch between length(seed.nodes) and behavior.num") + # Something like seed.nodes <- c("marginal", "central"), BUT behavior.num <- 3 + stop("Error in finding seed nodes. Mismatch between length(seed.nodes) and behavior.num") } else if (!inherits(seed.nodes, "character")) { - if (length(seed.nodes) >= 1 && length(seed.nodes) == behavior.num) { - d <- seed.nodes - } else if (class(seed.nodes)=="list" && length(seed.nodes) != behavior.num) { + if (class(seed.nodes)=="list" && length(seed.nodes) != behavior.num) { + # Something like seed.nodes <- list(c(1,4), c(3,6,8)), BUT behavior.num <- 3 stop("Particular seed nodes provided. Mismatch between length(seed.nodes) and behavior.num") - } else { + } else { + # single-diff and multi-diff. # Something like seed.nodes <- c(3,6,8)), AND behavior.num <- 1, + # or seed.nodes <- list(c(1,4), c(3,6,8)), AND behavior.num <- 2 d <- seed.nodes } - } else {stop("Unsupported -seed.nodes- value. See the manual for references.") } # Step 1.3: Defining cumadopt and toa (time of adoption) -------------------- - cumadopt <- matrix(0L, ncol=t, nrow=n) - toa <- matrix(NA, ncol=1, nrow= n) - # Setting seed nodes via vector - toa[d] <- 1L - cumadopt[d,] <- 1L + if (class(d) == "list") { + # multi-diff + + if (length(d) != behavior.num) { + stop("Error: length(d) must be the same as behavior.num") + } + + cumadopt <- array(0L, dim = c(n, t, behavior.num)) + + # Setting seed nodes via array + for (i in seq_along(d)) { + cumadopt[d[[i]],,i] <- 1L + } + } else { + # single-diff + cumadopt <- matrix(0L, ncol=t, nrow=n) + toa <- matrix(NA, ncol=1, nrow= n) + + # Setting seed nodes via vector + toa[d] <- 1L # REMINDER TO DELETE THIS OBJECT !!! + cumadopt[d,] <- 1L + } # Step 2.0: Thresholds ------------------------------------------------------- - thr <- rdiffnet_make_threshold(threshold.dist, n) + thr <- rdiffnet_make_threshold(threshold.dist, n) # REMINDER TO CHANGE rdiffnet_make_threshold # Step 3.0: Running the simulation ------------------------------------------- for (i in 2:t) { + if (!is.na(dim(cumadopt)[3])) { + # multi-diff. Computing exposure + # ONLY MEANWHILE + thr <- array(c(thr,rev(thr)), dim=c(length(thr), dim(cumadopt)[3])) + + exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i, ,drop=FALSE]) + expo <- do.call(exposure, exposure.args) + #for (q in 1:dim(cumadopt)[3]) { + # exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i,q,drop=FALSE]) + #} + + toa <- matrix(NA, nrow = dim(cumadopt)[1], ncol = dim(cumadopt)[3]) + + for (q in 1:dim(cumadopt)[3]) { + whoadopts <- which( (expo[,,q] >= thr[,q]) )# & is.na(toa)) + cumadopt[whoadopts, i:t, q] <- 1L + # ADD SOMETHING TO DISADOPT + # Initialize 'toa' with NA values + toa[, q] <- apply(cumadopt[,, q], 1, function(x) { + first_adopt <- which(x == 1) + if (length(first_adopt) > 0) first_adopt[1] else NA + }) + } - # Computing exposure - exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i,drop=FALSE]) - expo <- do.call(exposure, exposure.args) + } else { + # single-diff. Computing exposure + exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i,drop=FALSE]) + expo <- do.call(exposure, exposure.args) - whoadopts <- which( (expo >= thr) & is.na(toa)) - toa[whoadopts] <- i - cumadopt[whoadopts, i:t] <- 1L + whoadopts <- which( (expo >= thr) & is.na(toa)) + toa[whoadopts] <- i + cumadopt[whoadopts, i:t] <- 1L + } } + # GENERALIZE TO MULTI-DIFF reachedt <- max(toa, na.rm=TRUE) # Checking the result @@ -498,15 +542,28 @@ rdiffnet <- function( # Checking attributes isself <- any(sapply(sgraph, function(x) any(Matrix::diag(x) != 0) )) - new_diffnet( - graph = sgraph, - toa = as.integer(toa), - self = isself, - t0 = 1, - t1 = t, - vertex.static.attrs = data.frame(real_threshold=thr), - name = name, - behavior = behavior - ) + if (!is.na(dim(cumadopt)[3])) { + new_diffnet( + graph = sgraph, + toa = toa, + self = isself, + t0 = 1, + t1 = t, + vertex.static.attrs = data.frame(real_threshold=thr), + name = name, + behavior = behavior + ) + } else { + new_diffnet( + graph = sgraph, + toa = as.integer(toa), + self = isself, + t0 = 1, + t1 = t, + vertex.static.attrs = data.frame(real_threshold=thr), + name = name, + behavior = behavior + ) + } } From 1d34b5ddf38a56e0f841e66be7e95bf3d1c6cfd9 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Fri, 8 Nov 2024 15:07:28 -0700 Subject: [PATCH 17/34] adding a set of tests for rdiffnet_validate_args function --- tests/testthat/test-rdiffnet-parameters.R | 117 ++++++++++++++++++++++ 1 file changed, 117 insertions(+) create mode 100644 tests/testthat/test-rdiffnet-parameters.R diff --git a/tests/testthat/test-rdiffnet-parameters.R b/tests/testthat/test-rdiffnet-parameters.R new file mode 100644 index 0000000..b6e0255 --- /dev/null +++ b/tests/testthat/test-rdiffnet-parameters.R @@ -0,0 +1,117 @@ +# Single -------------------------------------------------------------------- + +# Must work +test_that( + "Checking single diffusion rdiffnet args", { + seed.p.adopt <- c(0.14) + seed.nodes <- c('random') + behavior <- c("random behavior") + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + + class(rdiffnet_args$seed.p.adopt) == "list" + class(rdiffnet_args$seed.nodes) == "list" + class(rdiffnet_args$behavior) == "list" + + seed.p.adopt <- 0.14 + seed.nodes <- 'random' + behavior <- "random behavior" + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + rdiffnet_args$seed.p.adopt; class(rdiffnet_args$seed.p.adopt) + rdiffnet_args$seed.nodes; class(rdiffnet_args$seed.nodes) + rdiffnet_args$behavior; class(rdiffnet_args$behavior) + + class(rdiffnet_args$seed.p.adopt) == "list" + class(rdiffnet_args$seed.nodes) == "list" + class(rdiffnet_args$behavior) == "list" + + # Must show ERROR + + seed.p.adopt <- c(0.4,0.82) + seed.nodes <- c('random') + behavior <- "random behavior" + expect_error( + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + ) + + seed.p.adopt <- c(0.14) + seed.nodes <- c('random', 'central') + behavior <- "random behavior" + expect_error( + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + ) + + seed.p.adopt <- c(0.14) + seed.nodes <- "central" + behavior <- c("random behavior_1", "random behavior_2") + expect_error( + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + ) + behavior <- list("random behavior_1", "random behavior_2") + expect_error( + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + ) +}) + + +# Multiple -------------------------------------------------------------------- + +# Must work +test_that("Multi diff models rdiff args work", { + seed.p.adopt <- list(0.14,0.05) + seed.nodes <- list('random', "central") + behavior <- list("random behavior_1", "random behavior_2") + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + class(rdiffnet_args$seed.p.adopt) == "list" + class(rdiffnet_args$seed.nodes) == "list" + class(rdiffnet_args$behavior) == "list" + + behavior <- c("random behavior_1", "random behavior_2") + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + class(rdiffnet_args$behavior) == "list" + + behavior <- "random behavior" #Default + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + class(rdiffnet_args$behavior) == "list" + + seed.nodes <- c(1,3,5) + behavior <- list("random behavior_1", "random behavior_2") + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + class(rdiffnet_args$seed.nodes) == 'list' + + seed.nodes <- list('marginal',"central") + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + class(rdiffnet_args$seed.nodes) == 'list' + + seed.nodes <- list('marginal',"central") ###### + behavior <- c("random behavior_1") + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + + # Must show ERROR + + seed.p.adopt <- c(0.14,0.05) + seed.nodes <- list('random', "central") + behavior <- list("random behavior_1", "random behavior_2") + expect_error( + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + ) + + seed.p.adopt <- list(0.14,0.05) + seed.nodes <- c('marginal',"central") + expect_error( + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + ) + + + + behavior <- list("random behavior_1") + expect_error( + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + ) + + seed.nodes <- list('random') + behavior <- list("random behavior_1", "random behavior_2") + expect_error( + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + ) +}) + From 83d1d665187b93d7e27dca6baf895f7a6a29834d Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Fri, 8 Nov 2024 15:56:40 -0700 Subject: [PATCH 18/34] rdiffnet function updated to allow multi-diff. An small error in rdiffnet_check_seed_graph fixed. --- R/rdiffnet.r | 350 +++++++++++++--------- R/rewire.r | 4 +- R/stats.R | 2 +- playground/multidiff-test-discussion.R | 79 ----- tests/testthat/test-rdiffnet-parameters.R | 5 - 5 files changed, 209 insertions(+), 231 deletions(-) delete mode 100644 playground/multidiff-test-discussion.R diff --git a/R/rdiffnet.r b/R/rdiffnet.r index 659075c..055be68 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -92,7 +92,7 @@ #' } #' #' @examples -#' # Asimple example ----------------------------------------------------------- +#' # A simple example ----------------------------------------------------------- #' set.seed(123) #' z <- rdiffnet(100,10) #' z @@ -322,8 +322,7 @@ rdiffnet <- function( exposure.args = list(), name = "A diffusion network", behavior = "Random contagion", - stop.no.diff = TRUE, - behavior.num = 1 + stop.no.diff = TRUE ) { # Checking options @@ -376,44 +375,35 @@ rdiffnet <- function( # Step 1.0: Setting the seed nodes ----------------------------------------- - # Step 1.1: Number of initial adopters - - if (length(seed.p.adopt)>1 && length(seed.p.adopt) == behavior.num) { - - n0 <- list() + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - for (i in seq_along(seed.p.adopt)) { + seed.p.adopt <- rdiffnet_args$seed.p.adopt + seed.nodes <- rdiffnet_args$seed.nodes + behavior <- rdiffnet_args$behavior + num_of_behaviors <- rdiffnet_args$num_of_behaviors - if ((seed.p.adopt[i] > 1) | (seed.p.adopt[i] < 0)) { - stop(paste("The proportion of initial adopters for behavior", i, "should be a number in [0,1]")) - } - if (n*seed.p.adopt[i] < 1) { - warning(paste("Set of initial adopters for behavior", i, "set to 1.")) - } + # Step 1.1: Number of initial adopters - n0[[i]] <- max(1, n * seed.p.adopt[i]) - } + n0 <- list() - } else if (length(seed.p.adopt)== 1 && behavior.num == 1) { + for (i in 1:num_of_behaviors) { - if ((seed.p.adopt > 1) | (seed.p.adopt < 0)) { - stop("The proportion of initial adopters should be a number in [0,1]") + if ((seed.p.adopt[[i]] > 1) | (seed.p.adopt[[i]] < 0)) { + stop(paste("The proportion of initial adopters for behavior", i, "should be a number in [0,1]")) } - if (n*seed.p.adopt < 1) { - warning("Set of initial adopters set to 1.") + if (n*seed.p.adopt[[i]] < 1) { + warning(paste("Set of initial adopters for behavior", i, "set to 1.")) } - n0 <- max(1, n*seed.p.adopt) - } else { - stop("Error in setting number of initial adopters. Mismatch between length(seed.p.adopt) and behavior.num") + n0[[i]] <- max(1, n * seed.p.adopt[[i]]) } + # Step 1.2 + + d <- list() - # Step 1.2: Finding seed nodes - if (length(seed.nodes) > 1 && length(seed.nodes) == behavior.num && class(seed.nodes)!="list") { - # multi-diff. Something like seed.nodes <- c("marginal", "central"), and behavior.num <- 2 + if (all(sapply(seed.nodes, is.character))) { # "central", "marginal", or "random" - d <- list() if (any(seed.nodes %in% c("central", "marginal"))) { dg <- dgr(sgraph)[, 1, drop = FALSE] central_d <- rownames(dg[order(dg, decreasing = TRUE), , drop = FALSE]) @@ -421,149 +411,221 @@ rdiffnet <- function( } for (i in seq_along(seed.nodes)) { # assign nodes characters values in seed.nodes - d[[i]] <- switch(seed.nodes[i], - "central" = as.numeric(central_d[1:floor(n0[[i]])]), - "marginal" = as.numeric(marginal_d[1:floor(n0[[i]])]), - "random" = sample.int(n, floor(n0[[i]])), - stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"") - ) + d[[i]] <- switch(seed.nodes[[i]], + "central" = as.numeric(central_d[1:floor(n0[[i]])]), + "marginal" = as.numeric(marginal_d[1:floor(n0[[i]])]), + "random" = sample.int(n, floor(n0[[i]])), + stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"") + ) } - } else if (length(seed.nodes) == 1 && behavior.num == 1) { - # Single-diff. Something like seed.nodes <- "central" - - if (seed.nodes %in% c("central","marginal")) { - - # Creating a degree ranking - d <- dgr(sgraph)[,1,drop=FALSE] - decre <- ifelse(seed.nodes == "central", TRUE, FALSE) - d <- rownames(d[order(d, decreasing = decre),,drop=FALSE]) - d <- d[1:floor(n0)] - d <- as.numeric(d) - - } else if (seed.nodes == "random") { - d <- sample.int(n, floor(n0)) + } else if (all(sapply(seed.nodes, is.numeric))) { # specific nodes - } else { - stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"") + for (i in 1:num_of_behaviors) { + d[[i]] <- seed.nodes[[i]] } - } else if (class(seed.nodes)=="list" && length(seed.nodes) != behavior.num) { - # Something like seed.nodes <- c("marginal", "central"), BUT behavior.num <- 3 - stop("Error in finding seed nodes. Mismatch between length(seed.nodes) and behavior.num") - - } else if (!inherits(seed.nodes, "character")) { - if (class(seed.nodes)=="list" && length(seed.nodes) != behavior.num) { - # Something like seed.nodes <- list(c(1,4), c(3,6,8)), BUT behavior.num <- 3 - stop("Particular seed nodes provided. Mismatch between length(seed.nodes) and behavior.num") - } else { - # single-diff and multi-diff. # Something like seed.nodes <- c(3,6,8)), AND behavior.num <- 1, - # or seed.nodes <- list(c(1,4), c(3,6,8)), AND behavior.num <- 2 - d <- seed.nodes - } - } else {stop("Unsupported -seed.nodes- value. See the manual for references.") } + } else { + stop("Unsupported -seed.nodes- value. See the manual for references.") + } # Step 1.3: Defining cumadopt and toa (time of adoption) -------------------- - if (class(d) == "list") { - # multi-diff - - if (length(d) != behavior.num) { - stop("Error: length(d) must be the same as behavior.num") - } - - cumadopt <- array(0L, dim = c(n, t, behavior.num)) - - # Setting seed nodes via array - for (i in seq_along(d)) { - cumadopt[d[[i]],,i] <- 1L - } - } else { - # single-diff - cumadopt <- matrix(0L, ncol=t, nrow=n) - toa <- matrix(NA, ncol=1, nrow= n) + cumadopt <- array(0L, dim = c(n, t, num_of_behaviors)) - # Setting seed nodes via vector - toa[d] <- 1L # REMINDER TO DELETE THIS OBJECT !!! - cumadopt[d,] <- 1L + for (i in 1:num_of_behaviors) { + cumadopt[d[[i]],,i] <- 1L } + toa <- matrix(NA, nrow = dim(cumadopt)[1], ncol = dim(cumadopt)[3]) + # Step 2.0: Thresholds ------------------------------------------------------- thr <- rdiffnet_make_threshold(threshold.dist, n) # REMINDER TO CHANGE rdiffnet_make_threshold + # ONLY MEANWHILE + thr <- array(c(thr,rev(thr)), dim=c(length(thr), dim(cumadopt)[3])) + # Step 3.0: Running the simulation ------------------------------------------- + for (i in 2:t) { - if (!is.na(dim(cumadopt)[3])) { - # multi-diff. Computing exposure - # ONLY MEANWHILE - thr <- array(c(thr,rev(thr)), dim=c(length(thr), dim(cumadopt)[3])) - - exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i, ,drop=FALSE]) - expo <- do.call(exposure, exposure.args) - #for (q in 1:dim(cumadopt)[3]) { - # exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i,q,drop=FALSE]) - #} - - toa <- matrix(NA, nrow = dim(cumadopt)[1], ncol = dim(cumadopt)[3]) - - for (q in 1:dim(cumadopt)[3]) { - whoadopts <- which( (expo[,,q] >= thr[,q]) )# & is.na(toa)) - cumadopt[whoadopts, i:t, q] <- 1L - # ADD SOMETHING TO DISADOPT - # Initialize 'toa' with NA values - toa[, q] <- apply(cumadopt[,, q], 1, function(x) { - first_adopt <- which(x == 1) - if (length(first_adopt) > 0) first_adopt[1] else NA - }) - } - } else { - # single-diff. Computing exposure - exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i,drop=FALSE]) - expo <- do.call(exposure, exposure.args) + exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i, ,drop=FALSE]) + expo <- do.call(exposure, exposure.args) + + for (q in 1:num_of_behaviors) { + + whoadopts <- which( (expo[,,q] >= thr[,q]) )# & is.na(toa)) + cumadopt[whoadopts, i:t, q] <- 1L + # ADD SOMETHING TO DISADOPT + + toa[, q] <- apply(cumadopt[,, q], 1, function(x) { + first_adopt <- which(x == 1) + if (length(first_adopt) > 0) first_adopt[1] else NA + }) - whoadopts <- which( (expo >= thr) & is.na(toa)) - toa[whoadopts] <- i - cumadopt[whoadopts, i:t] <- 1L } } + # GENERALIZE TO MULTI-DIFF - reachedt <- max(toa, na.rm=TRUE) - # Checking the result - if (reachedt == 1) { - if (stop.no.diff) - stop("No diffusion in this network (Ups!) try changing the seed or the parameters.") - else - warning("No diffusion in this network.") + for (i in 1:num_of_behaviors) { + reachedt <- max(toa[,i], na.rm=TRUE) + + if (reachedt == 1) { + if (stop.no.diff) + stop(paste("No diffusion in this network for behavior", i, "(Ups!) try changing the seed or the parameters.")) + else + warning(paste("No diffusion for behavior", i, " in this network.")) + } } # Step 4.0: Creating diffnet object ------------------------------------------ # Checking attributes isself <- any(sapply(sgraph, function(x) any(Matrix::diag(x) != 0) )) - if (!is.na(dim(cumadopt)[3])) { - new_diffnet( - graph = sgraph, - toa = toa, - self = isself, - t0 = 1, - t1 = t, - vertex.static.attrs = data.frame(real_threshold=thr), - name = name, - behavior = behavior - ) + if (num_of_behaviors==1) {toa <- as.integer(toa)} + + new_diffnet( + graph = sgraph, + toa = toa, + self = isself, + t0 = 1, + t1 = t, + vertex.static.attrs = data.frame(real_threshold=thr), + name = name, + behavior = behavior + ) +} + + +rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { + + # seed.p.adopt stuff + + # The class of seed.p.adopt determines if is a single or multiple diff pross. + + if (class(seed.p.adopt) == "list") { + + message(paste("Message: Multi-diffusion behavior simulation selected.", + "Number of behaviors: ", length(seed.p.adopt))) + + multi <- TRUE + + } else if (class(seed.p.adopt) == "numeric") { + + if (length(seed.p.adopt)>1) { + stop(paste("length(seed.p.adopt) =", length(seed.p.adopt), + ", but for multi-diffusion -seed.p.adopt- must be a -list-.")) + } + + multi <- FALSE + } else { - new_diffnet( - graph = sgraph, - toa = as.integer(toa), - self = isself, - t0 = 1, - t1 = t, - vertex.static.attrs = data.frame(real_threshold=thr), - name = name, - behavior = behavior - ) + + stop("The object -seed.p.adopt- must be a -numeric- (for a single behavior diff)", + "or a -list- (multiple behavior diff).") } -} + # seed.nodes stuff + + if (multi) { + + # For multi-diff. + + if (class(seed.nodes) == "list") { + if (length(seed.nodes) != length(seed.p.adopt)) { + stop("Length of lists -seed.nodes- and -seed.p.adopt- must be the same for multi diffusion.") + } + + if (all(sapply(seed.nodes, is.character))) { + + if (any(!seed.nodes %in% c("marginal", "central", "random"))) { + stop("Some element in list -seed.nodes- is a -character- different from 'marginal', 'central', or 'random'.") + } + + } else if (all(sapply(seed.nodes, is.numeric))) { + + if (any(sapply(seed.nodes, is.null))) { + stop("There is a NULL -numeric- element") + } + + if (any(sapply(seed.nodes, function(x) any(x != round(x))))) { + stop("Some value in the elements of the list -seed.nodes- is non-integer.") + } + + } else { + stop("All elements of the list seed.nodes must be either -character- or -numeric-.") + } + } else if (class(seed.nodes) == "numeric") { + + message("Message: Object -seed.nodes- converted to a -list-.", + "All behaviors will have the same seed nodes.") + + seed.nodes <- replicate(length(behavior), seed.nodes, simplify = FALSE) + } else if (class(seed.nodes) == "character") { + + stop("-character- class not supported for multi-diffusion. It must be a -list-.") + } + + else { + stop("Unsupported -seed.nodes- value. See the manual for references.") + } + + if (class(behavior) == "list") { + if (length(seed.p.adopt)!=length(behavior)) { + stop("If -behavior- is a list, it must be of the same length as -seed.p.adopt-.") + } + } else if (class(behavior) == "character" && length(behavior) > 1) { + if (length(behavior) != length(seed.p.adopt)) { + stop("Mismatch between length(behavior) and length(seed.p.adopt)") + } else { + behavior <- as.list(behavior) + } + } else if (class(behavior) == "character" && length(behavior) == 1) { + message(paste("Message: Name of 1 behavior provided, but", length(seed.p.adopt), "are needed. "), + "Names generalized to 'behavior'_1, 'behavior'_2, etc.") + behaviors <- list() + + for (i in seq_along(seed.p.adopt)) { + behaviors[[i]] <- paste(behavior, i, sep = "_") + } + + behavior <- behaviors + } + + } else { + + # For Single-diff. + + if (length(seed.nodes) == 1 && class(seed.nodes)=="character") { + + if (!seed.nodes %in% c("marginal", "central", "random")) { + stop("Object -seed.nodes- is a -character- different from 'marginal', 'central', or 'random'.") + } + + } else if (!inherits(seed.nodes, "character")) { + + if (any(sapply(seed.nodes, function(x) any(x != round(x))))) { + stop("Some value in the elements of the list -seed.nodes- is non-integer.") + } + + } else { + stop("Unsupported -seed.nodes- value. See the manual for references.") + } + + if (length(behavior)>1) { + stop("More names were provided than necessary.") + } + + seed.p.adopt <- list(seed.p.adopt) + seed.nodes <- list(seed.nodes) + behavior <- list(behavior) + } + + list( + seed.p.adopt = seed.p.adopt, + seed.nodes = seed.nodes, + behavior = behavior, + num_of_behaviors = length(seed.p.adopt) + ) +} diff --git a/R/rewire.r b/R/rewire.r index d46479d..2cecbd3 100644 --- a/R/rewire.r +++ b/R/rewire.r @@ -234,7 +234,7 @@ rewire_graph <- function( if (copy.first) { - warning( + message( "The option -copy.first- is set to TRUE. In this case, the first graph will be ", "treated as a baseline, and thus, networks after T=1 will be replaced with T-1.", immediate. = TRUE @@ -407,7 +407,7 @@ rewire_graph.array <-function( #' #' Mantel, N. (1967). The detection of disease clustering and a generalized #' regression approach. Cancer Research, 27(2), 209–20. -#' +#' #' @seealso This function can be used as null distribution in \code{struct_test} #' @family simulation functions #' @export diff --git a/R/stats.R b/R/stats.R index f547e51..4274ab0 100644 --- a/R/stats.R +++ b/R/stats.R @@ -494,7 +494,7 @@ NULL if (normalized) { ans[,q] <- as.vector(graph %*% (attrs * cumadopt[,,q]) / norm) } else { - ans[,q] <- as.vector(graph_slice %*% (attrs * cumadopt[,,q])) + ans[,q] <- as.vector(graph %*% (attrs * cumadopt[,,q])) } } } else { diff --git a/playground/multidiff-test-discussion.R b/playground/multidiff-test-discussion.R deleted file mode 100644 index 53a567b..0000000 --- a/playground/multidiff-test-discussion.R +++ /dev/null @@ -1,79 +0,0 @@ -test_that("multidiffusion exposure calculations", { - # Generating data - diffnet <- rdiffnet(40,5, seed.p.adopt = .1) - - # Creating two spreads - cumadopt_2 <- diffnet$cumadopt - cumadopt_2 <- array(c(cumadopt_2,cumadopt_2[rev(1:nrow(cumadopt_2)),]), dim=c(dim(cumadopt_2), 2)) - - # Default -- - ans0 <- exposure(diffnet, cumadopt = cumadopt_2) - ans1 <- array(unlist(lapply(1:dim(cumadopt_2)[3], function(q) { - lapply(diffnet$meta$pers, function(x) { - graph_slice <- diffnet$graph[[x]] - as.numeric((graph_slice %*% cumadopt_2[, x, q, drop = FALSE]) / - (1e-20 + Matrix::rowSums(graph_slice))) - }) - })), dim = dim(cumadopt_2)) - - ans2 <- exposure(diffnet$graph, cumadopt = cumadopt_2) - ans3 <- exposure(as.array(diffnet), cumadopt = cumadopt_2) - - #ans0 - ans1 - expect_equivalent(ans0, ans1) - expect_equivalent(ans0, ans2) - expect_equivalent(ans0, ans3) - - # By each behavior -- - ans4 <- exposure(diffnet) - ans5 <- exposure(diffnet$graph, cumadopt = diffnet$cumadopt) - cumadopt_rev <- diffnet$cumadopt[rev(1:nrow(diffnet$cumadopt)),] - ans6 <- exposure(diffnet$graph, cumadopt = cumadopt_rev) - - expect_equivalent(ans0[,,1], ans4) - expect_equivalent(ans0[,,1], ans5) - expect_equivalent(ans0[,,2], ans6) - - # With an attribute -- - X <- matrix(diffnet[["real_threshold"]], ncol=5, nrow=40, byrow = FALSE) - ans0 <- exposure(diffnet$graph, cumadopt = cumadopt_2, attrs=X) - ans1 <- exposure(as.array(diffnet), cumadopt = cumadopt_2, attrs=X) - expect_equivalent(ans0, ans1) - - expect_error(exposure(diffnet$graph, attrs="real_threshold"),"is only valid for") - - # Struct Equiv -- - se <- struct_equiv(diffnet) - se <- lapply(se, function(x) { - ans <- methods::as(x$SE, "dgCMatrix") - ans@x <- 1/(ans@x + 1e-20) - ans - }) - ans0 <- exposure(diffnet, cumadopt = cumadopt_2, alt.graph = se, valued=TRUE) - ans1 <- array(unlist(lapply(1:dim(cumadopt_2)[3], function(q) { - lapply(diffnet$meta$pers, function(x) { - graph_slice <- methods::as(struct_equiv(diffnet$graph[[x]])$SE, "dgCMatrix") - graph_slice@x <- 1/(graph_slice@x + 1e-20) - as.numeric((graph_slice %*% cumadopt_2[, x, q, drop = FALSE]) / - (1e-20 + Matrix::rowSums(graph_slice))) - }) - })), dim = dim(cumadopt_2)) - - #ans0 - ans1 - expect_equivalent(unname(ans0), unname(ans1)) - - # Lagged exposure -- - ans0 <- exposure(diffnet, cumadopt = cumadopt_2) - ans1 <- exposure(diffnet, cumadopt = cumadopt_2, lags = 1) - ans2 <- exposure(diffnet, cumadopt = cumadopt_2, lags = 2) - ans3 <- exposure(diffnet, cumadopt = cumadopt_2, lags = -1) - - expect_equivalent(ans0[,-5,], ans1[,-1,]) - expect_equivalent(ans0[,-(4:5),], ans2[,-(1:2),]) - expect_equivalent(ans0[,-1,], ans3[,-5,]) - - expect_error(exposure(diffnet, lags=5), "cannot be greater") - expect_error(exposure(diffnet, lags=NA)) - expect_error(exposure(diffnet, lags=c(1:2))) - -}) diff --git a/tests/testthat/test-rdiffnet-parameters.R b/tests/testthat/test-rdiffnet-parameters.R index b6e0255..8013b28 100644 --- a/tests/testthat/test-rdiffnet-parameters.R +++ b/tests/testthat/test-rdiffnet-parameters.R @@ -16,9 +16,6 @@ test_that( seed.nodes <- 'random' behavior <- "random behavior" rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - rdiffnet_args$seed.p.adopt; class(rdiffnet_args$seed.p.adopt) - rdiffnet_args$seed.nodes; class(rdiffnet_args$seed.nodes) - rdiffnet_args$behavior; class(rdiffnet_args$behavior) class(rdiffnet_args$seed.p.adopt) == "list" class(rdiffnet_args$seed.nodes) == "list" @@ -101,8 +98,6 @@ test_that("Multi diff models rdiff args work", { rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) ) - - behavior <- list("random behavior_1") expect_error( rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) From c5990c49db0c65fae2967b0d8c55f58ae7316775 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 11 Nov 2024 16:29:46 -0700 Subject: [PATCH 19/34] generalization of rdiffnet_make_threshold function. Some others modification following the merge of the 41... branch --- DESCRIPTION | 3 +- R/diffnet-class.r | 2 +- R/rdiffnet.r | 48 ++++++--------- R/stats.R | 25 -------- tests/testthat/test-rdiffnet-parameters.R | 73 ++++++++++++++++++++++- 5 files changed, 93 insertions(+), 58 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c0e0e0c..d095c62 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,7 +7,8 @@ Authors@R: c( ), person("Thomas", "Valente", email="tvalente@usc.edu", role=c("aut", "cph"), comment=c(ORCID="0000-0002-8824-5816", what="R original code")), - person("Anibal", "Olivera Morales", role = c("aut", "ctb")), + person("Anibal", "Olivera Morales", role = c("aut", "ctb"), + comment=c(ORCID="0009-0000-3736-7939", what="Multi-diffusion version")), person("Stephanie", "Dyal", email="stepharp@usc.edu", role=c("ctb"), comment="Package's first version"), person("Timothy", "Hayes", email="timothybhayes@gmail.com", role=c("ctb"), comment="Package's first version") ) diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 73f5041..6704767 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -631,7 +631,7 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm as.character(name))) meta$behavior <- ifelse(!length(behavior), "", ifelse(is.na(behavior), "", as.character(behavior))) - meta$version <- 5 + meta$version <- utils::packageVersion("netdiffuseR") # Removing dimnames graph <- Map(function(x) Matrix::unname(x), x=graph) diff --git a/R/rdiffnet.r b/R/rdiffnet.r index 055be68..45557ef 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -111,42 +111,30 @@ #' @name rdiffnet NULL -rdiffnet_make_threshold <- function(x, n) { +rdiffnet_make_threshold <- function(x, n, q) { - # Using sapply to compute the threshold if (inherits(x, "function")) { - thr <- sapply(1:n, x) + thr <- matrix(sapply(1:(n*q), function(i) x()), nrow = n, ncol = q) - } else if ((length(x)==1) && is.numeric(x)) { + } else if (is.numeric(x) && length(x) == 1) { - thr <- rep(x, n) + thr <- matrix(rep(x, n * q), nrow = n, ncol = q) } else { - # Setting depending on class - if (any(class(x) %in% c("data.frame", "matrix"))) { - - thr <- as.vector(as.matrix(x)) - - # Must match the length of n - if (length(thr) != n) - stop("Incorrect length for -threshold.dist- (",length(x),")", - ". It should be a vector of length ",n,".") + if (any(class(x) %in% c("data.frame", "matrix"))) { + thr <- as.matrix(x) + if (!all(dim(thr) == c(n, q))) stop("Incorrect dimensions for threshold.dist.", + "It should be a matrix of size ", n, "x", q, ".") } else if (is.vector(x)) { - - thr <- x - - # Must match the length of n - if (length(thr) != n) - stop("Incorrect length for -threshold.dist- (",length(x),")", - ". It should be a vector of length ",n,".") - - } else { - - stop("-threshold.dist- must be either a numeric vector of length -n-, a numeric scalar, or a function.") - - } + if (length(x) == n * q && q>1) { + stop("Incorrect input: A vector of length ", n*q, " is not allowed.", + "Please provide a vector of length ", n, ".") + } else if (length(x) == n) { + thr <- matrix(rep(x, q), nrow = n, ncol = q) + } else stop("Incorrect length for threshold.dist.") + } else stop("threshold.dist must be a numeric vector or matrix of appropriate size or a function.") } thr @@ -316,7 +304,7 @@ rdiffnet <- function( seed.p.adopt = 0.05, seed.graph = "scale-free", rgraph.args = list(), - rewire = TRUE, #set TRUE originally + rewire = TRUE, rewire.args = list(), threshold.dist = runif(n), exposure.args = list(), @@ -440,10 +428,10 @@ rdiffnet <- function( toa <- matrix(NA, nrow = dim(cumadopt)[1], ncol = dim(cumadopt)[3]) # Step 2.0: Thresholds ------------------------------------------------------- - thr <- rdiffnet_make_threshold(threshold.dist, n) # REMINDER TO CHANGE rdiffnet_make_threshold + thr <- rdiffnet_make_threshold(threshold.dist, n, num_of_behaviors) # REMINDER TO CHANGE rdiffnet_make_threshold # ONLY MEANWHILE - thr <- array(c(thr,rev(thr)), dim=c(length(thr), dim(cumadopt)[3])) + #thr <- array(c(thr,rev(thr)), dim=c(length(thr), dim(cumadopt)[3])) # Step 3.0: Running the simulation ------------------------------------------- diff --git a/R/stats.R b/R/stats.R index 4274ab0..f985660 100644 --- a/R/stats.R +++ b/R/stats.R @@ -476,15 +476,6 @@ NULL # Checking self if (!self) graph <- sp_diag(graph, rep(0, nnodes(graph))) - #ans <- ( graph %*% (attrs * cumadopt) ) - # - #if (normalized) { - # as.vector(ans/( graph %*% attrs + 1e-20 )) - #} else { - # as.vector(ans) - #} - # - norm <- graph %*% attrs + 1e-20 if (!is.na(dim(cumadopt)[3])) { @@ -505,13 +496,9 @@ NULL } } - #as.vector(ans) return(as.vector(ans)) } -# library(microbenchmark) -# microbenchmark(.exposure, netdiffuseR:::exposure_cpp) - check_lags <- function(npers, lags) { # Checking length @@ -673,18 +660,6 @@ exposure_for <- function( lags ) { - #out <- matrix(nrow = nrow(cumadopt), ncol = ncol(cumadopt)) - - #if (lags >= 0L) { - # for (i in 1:(nslices(graph) - lags)) - # out[,i+lags]<- .exposure(graph[[i]], cumadopt[,i,drop=FALSE], attrs[,i,drop=FALSE], - # outgoing, valued, normalized, self) - #} else { - # for (i in (1-lags):nslices(graph)) - # out[,i+lags]<- .exposure(graph[[i]], cumadopt[,i,drop=FALSE], attrs[,i,drop=FALSE], - # outgoing, valued, normalized, self) - #} - if (!is.na(dim(cumadopt)[3])) { out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3])) diff --git a/tests/testthat/test-rdiffnet-parameters.R b/tests/testthat/test-rdiffnet-parameters.R index 8013b28..c7acb58 100644 --- a/tests/testthat/test-rdiffnet-parameters.R +++ b/tests/testthat/test-rdiffnet-parameters.R @@ -3,6 +3,9 @@ # Must work test_that( "Checking single diffusion rdiffnet args", { + + # Must work + seed.p.adopt <- c(0.14) seed.nodes <- c('random') behavior <- c("random behavior") @@ -49,11 +52,38 @@ test_that( ) }) +test_that("Checking threshold for single diffusion", { + + # Must work + + thr <- rdiffnet_make_threshold(1.5, n = 50, q = 1) + expect_equal(dim(thr), c(50, 1)) + + x <- runif(50) + thr <- rdiffnet_make_threshold(x, n = 50, q = 1) + expect_equal(dim(thr), c(50, 1)) + + thr <- rdiffnet_make_threshold(function() 0.5, n = 50, q = 1) + expect_equal(dim(thr), c(50, 1)) + + thr <- rdiffnet_make_threshold(function() rexp(1), n = 50, q = 1) + expect_equal(dim(thr), c(50, 1)) + + # Must show ERROR + + x <- runif(100) # Length n*q + expect_error( + rdiffnet_make_threshold(x, n = 50, q = 1) + ) + +}) # Multiple -------------------------------------------------------------------- -# Must work test_that("Multi diff models rdiff args work", { + + # Must work + seed.p.adopt <- list(0.14,0.05) seed.nodes <- list('random', "central") behavior <- list("random behavior_1", "random behavior_2") @@ -110,3 +140,44 @@ test_that("Multi diff models rdiff args work", { ) }) + +# NOT working now !!! + +# test_that("Checking threshold for multiple diffusion", { +# +# # Must work +# +# x <- matrix(runif(100), nrow = 50, ncol = 2) +# thr <- rdiffnet_make_threshold(x, n = 50, q = 2) +# expect_equal(dim(thr), c(50, 2)) +# +# x <- runif(100) # Length n*q +# expect_error( +# rdiffnet_make_threshold(x, n = 50, q = 2) +# ) +# +# seed.p.adopt <- list(function() runif(1), function() rexp(1)) +# thr <- rdiffnet_make_threshold(seed.p.adopt, n = 50, q = 2) +# expect_equal(dim(thr), c(50,1)) +# +# +# seed.p.adopt <- list(0.14,0.05) +# thr <- rdiffnet_make_threshold(seed.p.adopt[[1]], n = 50, q = 2) +# expect_equal(dim(thr), c(50,2)) +# +# +# seed.p.adopt <- list(runif(50), runif(50)) +# +# # Test first element of list +# thr <- rdiffnet_make_threshold(seed.p.adopt[[1]], n = 50, q =1 ) +# +# expect_equal(dim(thr), c(50,1)) +# +# +# # Must show ERROR +# +# x <- runif(100) # Length n*q +# expect_error( +# rdiffnet_make_threshold(x, n=100,q=3), +# "incorrect input +# } From 3ef1d72b64fadf312c2ac8a44f665616258a61ef Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Tue, 12 Nov 2024 09:16:56 -0700 Subject: [PATCH 20/34] lot of work in new_diffnet and toa_mat functions. New tests for rdiffnet_make_threshold. Some modification in rdiffnet too. Not expecting to work yet. --- R/adjmat.r | 41 +++++-- R/diffnet-class.r | 73 ++++++++---- R/rdiffnet.r | 74 +++++++----- tests/testthat/test-rdiffnet-parameters.R | 133 +++++++++++++--------- tests/testthat/test-rdiffnet.R | 27 ++++- 5 files changed, 233 insertions(+), 115 deletions(-) diff --git a/R/adjmat.r b/R/adjmat.r index 06c4d31..ac6d671 100644 --- a/R/adjmat.r +++ b/R/adjmat.r @@ -462,30 +462,47 @@ adjmat_to_edgelist.list <- function(graph, undirected, keep.isolates) { #' @keywords manip #' @include graph_data.r #' @author George G. Vega Yon & Thomas W. Valente -toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) { +toa_mat <- function(obj, num_of_behaviors=1, labels=NULL, t0=NULL, t1=NULL) { if (!inherits(obj, "diffnet")) { if (!length(t0)) t0 <- min(obj, na.rm = TRUE) if (!length(t1)) t1 <- max(obj, na.rm = TRUE) } - cls <- class(obj) - ans <- if ("numeric" %in% cls) { - toa_mat.numeric(obj, labels, t0, t1) - } else if ("integer" %in% cls) { - toa_mat.integer(obj, labels, t0, t1) - } else if ("diffnet" %in% cls) { - with(obj, list(adopt=adopt,cumadopt=cumadopt)) - } else - stopifnot_graph(obj) - + ans <- list() + if (num_of_behaviors == 1) { + cls <- class(obj) + ans[[1]] <- if ("numeric" %in% cls) { + toa_mat.numeric(obj, labels, t0, t1) + } else if ("integer" %in% cls) { + toa_mat.integer(obj, labels, t0, t1) + } else if ("diffnet" %in% cls) { + with(obj, list(adopt=adopt,cumadopt=cumadopt)) + } else { + stopifnot_graph(obj) + } + } else { + #ans <- list() + + for (q in 1:num_of_behaviors) { + cls <- class(obj[,q]) + ans[[q]] <- if ("numeric" %in% cls) { # Why included? + toa_mat.numeric(obj[,q], labels, t0, t1) + } else if ("integer" %in% cls) { + toa_mat.integer(obj[,q], labels, t0, t1) + } else if ("diffnet" %in% cls) { # Why included? + with(obj[,q], list(adopt=adopt,cumadopt=cumadopt)) + } else { + stopifnot_graph(obj[,q]) + } + } + } if (inherits(obj, "diffnet")) { dimnames(ans$adopt) <- with(obj$meta, list(ids,pers)) dimnames(ans$cumadopt) <- with(obj$meta, list(ids,pers)) } - return(ans) } diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 6704767..cc482bb 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -547,7 +547,8 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm self = getOption("diffnet.self"), multiple = getOption("diffnet.multiple"), name = "Diffusion Network", - behavior = "Unspecified" + behavior = "Unspecified", + num_of_behaviors = 1 ) { # Step 0.0: Check if its diffnet! -------------------------------------------- @@ -563,42 +564,64 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm # Step 1.2: Checking that lengths fit - if (length(toa)!=meta$n) stop("-graph- and -toa- have different lengths (", - meta$n, " and ", length(toa), " respectively). ", - "-toa- should be of length n (number of vertices).") + if (num_of_behaviors == 1) { + if (length(toa)!=meta$n){ stop("-graph- and -toa- have different lengths (", meta$n, " and ", length(toa), + " respectively). ", "-toa- should be of length n (number of vertices).") } + } else { + if (length(toa[,1])!=meta$n) {stop("-graph- and -toa[,1]- have different lengths (", meta$n, " and ", length(toa[,1]), + " respectively). ", "-toa- should be of length n (number of vertices).") } + } # Step 2.1: Checking class of TOA and coercing if necesary ------------------- - if (!inherits(toa, "integer")) { - warning("Coercing -toa- into integer.") - toa <- as.integer(toa) + if (num_of_behaviors==1) { + if (!inherits(toa, "integer")) { + warning("Coercing -toa- into integer.") + toa <- as.integer(toa) + } + } else { + for (q in 1:num_of_behaviors) { + if (!inherits(toa[,q], "integer")) { + warning("Coercing -toa- into integer.") + toa[,q] <- as.integer(toa[,q]) + } + } } # Step 2.2: Checking names of toa - if (!length(names(toa))) - names(toa) <- meta$ids + if (num_of_behaviors==1) { + if (!length(names(toa))) {names(toa) <- meta$ids} + } else { + if (!length(rownames(toa))) { # Not necessary? toa_mat(toa, labels = meta$ids, t0=t0, t1=t1) already has labels + rownames(toa) <- meta$ids + } + } # Step 3.1: Creating Time of adoption matrix --------------------------------- - mat <- toa_mat(toa, labels = meta$ids, t0=t0, t1=t1) + mat <- toa_mat(toa, num_of_behaviors, labels = meta$ids, t0=t0, t1=t1) # Step 3.2: Verifying dimensions and fixing meta$pers if (meta$type != "static") { - tdiff <- meta$nper - ncol(mat[[1]]) + tdiff <- meta$nper - ncol(mat[[1]]$adopt) if (tdiff < 0) stop("Range of -toa- is bigger than the number of slices in -graph- (", - ncol(mat[[1]]), " and ", length(graph) ," respectively). ", + ncol(mat[[1]]$adopt), " and ", length(graph) ," respectively). ", "There must be at least as many slices as range of toa.") else if (tdiff > 0) stop("Range of -toa- is smaller than the number of slices in -graph- (", - ncol(mat[[1]]), " and ", length(graph) ," respectively). ", + ncol(mat[[1]]$adopt), " and ", length(graph) ," respectively). ", "Please provide lower and upper boundaries for the values in -toa- ", "using -t0- and -t- (see ?toa_mat).") } else { - graph <- lapply(1:ncol(mat[[1]]), function(x) methods::as(graph, "dgCMatrix")) + + # This should be reviewed !! (here the graph becomes 'dynamic') + + graph <- lapply(1:ncol(mat[[1]]$adopt), function(x) methods::as(graph, "dgCMatrix")) meta <- classify_graph(graph) } - meta$pers <- as.integer(colnames(mat$adopt)) + # labels of the time periods + meta$pers <- as.integer(colnames(mat[[1]]$adopt)) # same all behaviors # Step 4.0: Checking the attributes ------------------------------------------ @@ -636,14 +659,26 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm # Removing dimnames graph <- Map(function(x) Matrix::unname(x), x=graph) dimnames(toa) <- NULL - dimnames(mat$adopt) <- NULL - dimnames(mat$cumadopt) <- NULL + for (q in 1:num_of_behaviors) { + dimnames(mat[[q]]$adopt) <- NULL + dimnames(mat[[q]]$cumadopt) <- NULL + } + + adopt <- list() + cumadopt <- list() + if (num_of_behaviors>1) {for (q in 1:num_of_behaviors) { + adopt[[q]] <- mat[[q]]$adopt + cumadopt[[q]] <- mat[[q]]$cumadopt + }} else { + adopt <- mat[[1]]$adopt + cumadopt <- mat[[1]]$cumadopt + } return(structure(list( graph = graph, toa = toa, - adopt = mat$adopt, - cumadopt = mat$cumadopt, + adopt = adopt, + cumadopt = cumadopt, # Attributes vertex.static.attrs = vertex.static.attrs, vertex.dyn.attrs = vertex.dyn.attrs, diff --git a/R/rdiffnet.r b/R/rdiffnet.r index 45557ef..ff80c6e 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -111,33 +111,48 @@ #' @name rdiffnet NULL -rdiffnet_make_threshold <- function(x, n, q) { +rdiffnet_make_threshold <- function(x, n, num_of_behaviors) { - if (inherits(x, "function")) { + # Check if x is a matrix or array with correct dimensions + if (is.matrix(x) || is.array(x)) { + if (!all(dim(x) == c(n, num_of_behaviors))) { + stop("Incorrect threshold input in function -rdiffnet_make_threshold-. The matrix/array must have dimensions ", n, "x", num_of_behaviors, ".") + } + return(as.matrix(x)) # Return the matrix as-is + } else if (!is.list(x) && num_of_behaviors > 1) { + # Ensure x is a list when num_of_behaviors > 1 + stop("For multiple behaviors (num_of_behaviors > 1), threshold.dist must be a list.") + } - thr <- matrix(sapply(1:(n*q), function(i) x()), nrow = n, ncol = q) + # Make a list, for single diffusion + if (!is.list(x)) { + x <- list(x) + } - } else if (is.numeric(x) && length(x) == 1) { + if (length(x) != num_of_behaviors) { + stop("The length of the list must match the number of behaviors (num_of_behaviors).") + } - thr <- matrix(rep(x, n * q), nrow = n, ncol = q) + thr <- matrix(NA, nrow = n, ncol = num_of_behaviors) - } else { + for (q in seq_len(num_of_behaviors)) { + if (inherits(x[[q]], "function")) { - if (any(class(x) %in% c("data.frame", "matrix"))) { - thr <- as.matrix(x) - if (!all(dim(thr) == c(n, q))) stop("Incorrect dimensions for threshold.dist.", - "It should be a matrix of size ", n, "x", q, ".") - } else if (is.vector(x)) { - if (length(x) == n * q && q>1) { - stop("Incorrect input: A vector of length ", n*q, " is not allowed.", - "Please provide a vector of length ", n, ".") - } else if (length(x) == n) { - thr <- matrix(rep(x, q), nrow = n, ncol = q) - } else stop("Incorrect length for threshold.dist.") - } else stop("threshold.dist must be a numeric vector or matrix of appropriate size or a function.") - } + thr[, q] <- sapply(1:n, function(j) x[[q]]()) + + } else if (is.numeric(x[[q]]) && length(x[[q]]) == 1) { + + thr[, q] <- rep(x[[q]], n) + + } else if (is.vector(x[[q]]) && length(x[[q]]) == n) { - thr + thr[, q] <- x[[q]] + + } else if (is.vector(x[[q]]) && length(x[[q]]) != n) { + stop("Incorrect threshold input in function -rdiffnet_make_threshold-.") + } + } + return(thr) } rdiffnet_check_seed_graph <- function(seed.graph, rgraph.args, t, n) { @@ -386,7 +401,7 @@ rdiffnet <- function( n0[[i]] <- max(1, n * seed.p.adopt[[i]]) } - # Step 1.2 + # Step 1.2: finding the nodes d <- list() @@ -421,17 +436,15 @@ rdiffnet <- function( cumadopt <- array(0L, dim = c(n, t, num_of_behaviors)) + toa <- matrix(NA, nrow = dim(cumadopt)[1], ncol = dim(cumadopt)[3]) + for (i in 1:num_of_behaviors) { cumadopt[d[[i]],,i] <- 1L } - toa <- matrix(NA, nrow = dim(cumadopt)[1], ncol = dim(cumadopt)[3]) - # Step 2.0: Thresholds ------------------------------------------------------- - thr <- rdiffnet_make_threshold(threshold.dist, n, num_of_behaviors) # REMINDER TO CHANGE rdiffnet_make_threshold - # ONLY MEANWHILE - #thr <- array(c(thr,rev(thr)), dim=c(length(thr), dim(cumadopt)[3])) + thr <- rdiffnet_make_threshold(threshold.dist, n, num_of_behaviors) # Step 3.0: Running the simulation ------------------------------------------- @@ -442,7 +455,7 @@ rdiffnet <- function( for (q in 1:num_of_behaviors) { - whoadopts <- which( (expo[,,q] >= thr[,q]) )# & is.na(toa)) + whoadopts <- which( (expo[,,q] >= thr[,q]) ) cumadopt[whoadopts, i:t, q] <- 1L # ADD SOMETHING TO DISADOPT @@ -454,8 +467,6 @@ rdiffnet <- function( } } - # GENERALIZE TO MULTI-DIFF - for (i in 1:num_of_behaviors) { reachedt <- max(toa[,i], na.rm=TRUE) @@ -481,7 +492,8 @@ rdiffnet <- function( t1 = t, vertex.static.attrs = data.frame(real_threshold=thr), name = name, - behavior = behavior + behavior = behavior, + num_of_behaviors = num_of_behaviors ) } @@ -549,7 +561,7 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { message("Message: Object -seed.nodes- converted to a -list-.", "All behaviors will have the same seed nodes.") - seed.nodes <- replicate(length(behavior), seed.nodes, simplify = FALSE) + seed.nodes <- replicate(length(seed.p.adopt), seed.nodes, simplify = FALSE) } else if (class(seed.nodes) == "character") { stop("-character- class not supported for multi-diffusion. It must be a -list-.") diff --git a/tests/testthat/test-rdiffnet-parameters.R b/tests/testthat/test-rdiffnet-parameters.R index c7acb58..c44dba2 100644 --- a/tests/testthat/test-rdiffnet-parameters.R +++ b/tests/testthat/test-rdiffnet-parameters.R @@ -54,33 +54,49 @@ test_that( test_that("Checking threshold for single diffusion", { + n <- 50 + num_of_behaviors <- 1 + # Must work - thr <- rdiffnet_make_threshold(1.5, n = 50, q = 1) - expect_equal(dim(thr), c(50, 1)) + x <- 0.35 # numeric scalar + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + expect_equal(dim(thr), c(n, 1)) - x <- runif(50) - thr <- rdiffnet_make_threshold(x, n = 50, q = 1) - expect_equal(dim(thr), c(50, 1)) + x <- runif(n) # vector of length n + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + expect_equal(dim(thr), c(n, 1)) - thr <- rdiffnet_make_threshold(function() 0.5, n = 50, q = 1) - expect_equal(dim(thr), c(50, 1)) + x <- function() runif(1) # function + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + expect_equal(dim(thr), c(n, 1)) - thr <- rdiffnet_make_threshold(function() rexp(1), n = 50, q = 1) - expect_equal(dim(thr), c(50, 1)) # Must show ERROR - x <- runif(100) # Length n*q + x <- runif(100)# Length greater than n + expect_error( + rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors), + "Incorrect threshold input in function -rdiffnet_make_threshold-." + ) + + x <- runif(25)# Length less than n expect_error( - rdiffnet_make_threshold(x, n = 50, q = 1) + rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors), + "Incorrect threshold input in function -rdiffnet_make_threshold-." + ) + + x <- "invalid_input"# Non-numeric input + expect_error( + rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors), + "Incorrect threshold input in function -rdiffnet_make_threshold-." ) }) # Multiple -------------------------------------------------------------------- -test_that("Multi diff models rdiff args work", { +test_that("Multi diff models rdiff args work", { # Must work @@ -140,44 +156,57 @@ test_that("Multi diff models rdiff args work", { ) }) +test_that("Checking threshold for multiple diffusion", { + + n <- 50 + num_of_behaviors <- 2 + + # Must work + + x <- matrix(runif(100), nrow = n, ncol = num_of_behaviors) # matrix input + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + expect_equal(dim(thr), c(n, num_of_behaviors)) + + x <- list(function() runif(1), function() rexp(1)) # list of functions + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + expect_equal(dim(thr), c(n, num_of_behaviors)) + + x <- list(0.14,0.05) # list of scalars + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + expect_equal(dim(thr), c(n,num_of_behaviors)) + + x <- list(runif(n), runif(n)) # list of vectors + thr <- rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors) + expect_equal(dim(thr),c(n,num_of_behaviors)) + + + # Must show ERROR + + x <- list(runif(2*n),runif(n)) # incorrect vector length (too long for one behavior) + expect_error( + rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors), + "Incorrect threshold input in function -rdiffnet_make_threshold-." + ) + + x <- list(runif(n/2),runif(n)) # incorrect vector length (too short for one behavior) + expect_error( + rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors), + "Incorrect threshold input in function -rdiffnet_make_threshold-." + ) + + x <- c(runif(n),runif(n)) # the input should be a list + expect_error( + rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors) + ) + + x <- list(0.14) # Only one behavior provided in the list + expect_error( + rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors), + "The length of the list must match the number of behaviors" + ) -# NOT working now !!! - -# test_that("Checking threshold for multiple diffusion", { -# -# # Must work -# -# x <- matrix(runif(100), nrow = 50, ncol = 2) -# thr <- rdiffnet_make_threshold(x, n = 50, q = 2) -# expect_equal(dim(thr), c(50, 2)) -# -# x <- runif(100) # Length n*q -# expect_error( -# rdiffnet_make_threshold(x, n = 50, q = 2) -# ) -# -# seed.p.adopt <- list(function() runif(1), function() rexp(1)) -# thr <- rdiffnet_make_threshold(seed.p.adopt, n = 50, q = 2) -# expect_equal(dim(thr), c(50,1)) -# -# -# seed.p.adopt <- list(0.14,0.05) -# thr <- rdiffnet_make_threshold(seed.p.adopt[[1]], n = 50, q = 2) -# expect_equal(dim(thr), c(50,2)) -# -# -# seed.p.adopt <- list(runif(50), runif(50)) -# -# # Test first element of list -# thr <- rdiffnet_make_threshold(seed.p.adopt[[1]], n = 50, q =1 ) -# -# expect_equal(dim(thr), c(50,1)) -# -# -# # Must show ERROR -# -# x <- runif(100) # Length n*q -# expect_error( -# rdiffnet_make_threshold(x, n=100,q=3), -# "incorrect input -# } + x <- runif(n) # Only one behavior provided in the vector + expect_error( + rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors) + ) +}) diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index fb703e0..8c8ec50 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -88,7 +88,7 @@ test_that("Error and warning on rdiffnet", { set.seed(111) - expect_error(rdiffnet(100, 5, threshold.dist = rep(10,10)), "Incorrect length") + expect_error(rdiffnet(100, 5, threshold.dist = rep(10,10))) expect_error(rdiffnet(100, 5, threshold.dist = rep(10,100)), "No diffusion") expect_warning(rdiffnet(100, 5, threshold.dist = rep(10,100), stop.no.diff = FALSE), "No diffusion") @@ -106,3 +106,28 @@ test_that("Simulation study", { expect_equal(ans0, ans1) }) + +# Test for multi diffusion + +# Seed of first adopters +test_that("All should be equal!", { + set.seed(12131) + n <- 50 + t <- 5 + graph <- rgraph_ws(n, 4, p=.3) + seed.p.adopt <- list(0.1, 0.1) + seed.nodes <- c(1,5,7,10) + thr <- runif(n, .2,.4) + thr_list <- list(thr,thr) + + # Generating identical networks + net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, + t = t, threshold.dist = thr_list) + + + + net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, + t = 5, rewire = FALSE, threshold.dist = thr) + + expect_equal(net1, net2) +}) From 39a3840f7936d6593a70e611ca3753e47a37e484 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Tue, 12 Nov 2024 12:25:06 -0700 Subject: [PATCH 21/34] changes in new_diffnet and toa_mat. Now all the original tests for those functions are pass. --- R/adjmat.r | 16 ++++--- R/diffnet-class.r | 83 ++++++++++++++++++++++------------ tests/testthat/test-rdiffnet.R | 25 ---------- 3 files changed, 64 insertions(+), 60 deletions(-) diff --git a/R/adjmat.r b/R/adjmat.r index ac6d671..f7d2435 100644 --- a/R/adjmat.r +++ b/R/adjmat.r @@ -482,8 +482,6 @@ toa_mat <- function(obj, num_of_behaviors=1, labels=NULL, t0=NULL, t1=NULL) { stopifnot_graph(obj) } } else { - #ans <- list() - for (q in 1:num_of_behaviors) { cls <- class(obj[,q]) ans[[q]] <- if ("numeric" %in% cls) { # Why included? @@ -498,12 +496,18 @@ toa_mat <- function(obj, num_of_behaviors=1, labels=NULL, t0=NULL, t1=NULL) { } } - if (inherits(obj, "diffnet")) { - dimnames(ans$adopt) <- with(obj$meta, list(ids,pers)) - dimnames(ans$cumadopt) <- with(obj$meta, list(ids,pers)) + for (q in 1:num_of_behaviors) { + if (inherits(obj, "diffnet")) { + dimnames(ans[[q]]$adopt) <- with(obj$meta, list(ids,pers)) + dimnames(ans[[q]]$cumadopt) <- with(obj$meta, list(ids,pers)) + } } - return(ans) + if (num_of_behaviors==1) { + return(ans[[1]]) + } else { + return(ans) + } } toa_mat.default <- function(per, t0, t1) { diff --git a/R/diffnet-class.r b/R/diffnet-class.r index cc482bb..7b8675a 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -601,27 +601,47 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm # Step 3.2: Verifying dimensions and fixing meta$pers - if (meta$type != "static") { - tdiff <- meta$nper - ncol(mat[[1]]$adopt) - if (tdiff < 0) - stop("Range of -toa- is bigger than the number of slices in -graph- (", - ncol(mat[[1]]$adopt), " and ", length(graph) ," respectively). ", - "There must be at least as many slices as range of toa.") - else if (tdiff > 0) - stop("Range of -toa- is smaller than the number of slices in -graph- (", - ncol(mat[[1]]$adopt), " and ", length(graph) ," respectively). ", - "Please provide lower and upper boundaries for the values in -toa- ", - "using -t0- and -t- (see ?toa_mat).") + if (num_of_behaviors==1) { + if (meta$type != "static") { + tdiff <- meta$nper - ncol(mat$adopt) + if (tdiff < 0) + stop("Range of -toa- is bigger than the number of slices in -graph- (", + ncol(mat$adopt), " and ", length(graph) ," respectively). ", + "There must be at least as many slices as range of toa.") + else if (tdiff > 0) + stop("Range of -toa- is smaller than the number of slices in -graph- (", + ncol(mat$adopt), " and ", length(graph) ," respectively). ", + "Please provide lower and upper boundaries for the values in -toa- ", + "using -t0- and -t- (see ?toa_mat).") + } else { + graph <- lapply(1:ncol(mat$adopt), function(x) methods::as(graph, "dgCMatrix")) + meta <- classify_graph(graph) + } } else { - - # This should be reviewed !! (here the graph becomes 'dynamic') - - graph <- lapply(1:ncol(mat[[1]]$adopt), function(x) methods::as(graph, "dgCMatrix")) - meta <- classify_graph(graph) + if (meta$type != "static") { + tdiff <- meta$nper - ncol(mat[[1]]$adopt) + if (tdiff < 0) + stop("Range of -toa- is bigger than the number of slices in -graph- (", + ncol(mat[[1]]$adopt), " and ", length(graph) ," respectively). ", + "There must be at least as many slices as range of toa.") + else if (tdiff > 0) + stop("Range of -toa- is smaller than the number of slices in -graph- (", + ncol(mat[[1]]$adopt), " and ", length(graph) ," respectively). ", + "Please provide lower and upper boundaries for the values in -toa- ", + "using -t0- and -t- (see ?toa_mat).") + } else { + + # This should be reviewed !! (here the graph becomes 'dynamic') + + graph <- lapply(1:ncol(mat[[1]]$adopt), function(x) methods::as(graph, "dgCMatrix")) + meta <- classify_graph(graph) + } } # labels of the time periods - meta$pers <- as.integer(colnames(mat[[1]]$adopt)) # same all behaviors + if (num_of_behaviors==1) { + meta$pers <- as.integer(colnames(mat$adopt)) + } else {meta$pers <- as.integer(colnames(mat[[1]]$adopt))} # same for all behaviors # Step 4.0: Checking the attributes ------------------------------------------ @@ -659,19 +679,24 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm # Removing dimnames graph <- Map(function(x) Matrix::unname(x), x=graph) dimnames(toa) <- NULL - for (q in 1:num_of_behaviors) { - dimnames(mat[[q]]$adopt) <- NULL - dimnames(mat[[q]]$cumadopt) <- NULL - } - adopt <- list() - cumadopt <- list() - if (num_of_behaviors>1) {for (q in 1:num_of_behaviors) { - adopt[[q]] <- mat[[q]]$adopt - cumadopt[[q]] <- mat[[q]]$cumadopt - }} else { - adopt <- mat[[1]]$adopt - cumadopt <- mat[[1]]$cumadopt + if (num_of_behaviors==1) { + dimnames(mat$adopt) <- NULL + dimnames(mat$cumadopt) <- NULL + + adopt <- mat$adopt + cumadopt <- mat$cumadopt + } else { + for (q in 1:num_of_behaviors) { + dimnames(mat[[q]]$adopt) <- NULL + dimnames(mat[[q]]$cumadopt) <- NULL + } + adopt <- list() + cumadopt <- list() + for (q in 1:num_of_behaviors) { + adopt[[q]] <- mat[[q]]$adopt + cumadopt[[q]] <- mat[[q]]$cumadopt + } } return(structure(list( diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index 8c8ec50..f293fb7 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -106,28 +106,3 @@ test_that("Simulation study", { expect_equal(ans0, ans1) }) - -# Test for multi diffusion - -# Seed of first adopters -test_that("All should be equal!", { - set.seed(12131) - n <- 50 - t <- 5 - graph <- rgraph_ws(n, 4, p=.3) - seed.p.adopt <- list(0.1, 0.1) - seed.nodes <- c(1,5,7,10) - thr <- runif(n, .2,.4) - thr_list <- list(thr,thr) - - # Generating identical networks - net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, - t = t, threshold.dist = thr_list) - - - - net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, - t = 5, rewire = FALSE, threshold.dist = thr) - - expect_equal(net1, net2) -}) From 3b360b3bf4df9ac401051dca3d8806ded8eaa06f Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Tue, 12 Nov 2024 19:06:35 -0700 Subject: [PATCH 22/34] updating rdiffnet_validate_args to allow objects seed.nodes different from -list-. For example: rdiffnet(100,10, seed.p.adopt = list(.1, .05)), or adding seed.nodes=c(1,2,3,4), seed.nodes=random, or seed.nodes=c(random,central). Respective tests added. --- R/rdiffnet.r | 28 +++++++------- tests/testthat/test-rdiffnet-parameters.R | 46 ++++++++++++++--------- tests/testthat/test-rdiffnet.R | 29 ++++++++++++++ 3 files changed, 71 insertions(+), 32 deletions(-) diff --git a/R/rdiffnet.r b/R/rdiffnet.r index ff80c6e..022d1de 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -120,24 +120,19 @@ rdiffnet_make_threshold <- function(x, n, num_of_behaviors) { } return(as.matrix(x)) # Return the matrix as-is } else if (!is.list(x) && num_of_behaviors > 1) { - # Ensure x is a list when num_of_behaviors > 1 - stop("For multiple behaviors (num_of_behaviors > 1), threshold.dist must be a list.") + x <- rep(list(x), num_of_behaviors) } # Make a list, for single diffusion - if (!is.list(x)) { + if (!is.list(x) && num_of_behaviors==1) { x <- list(x) } - if (length(x) != num_of_behaviors) { - stop("The length of the list must match the number of behaviors (num_of_behaviors).") - } - thr <- matrix(NA, nrow = n, ncol = num_of_behaviors) for (q in seq_len(num_of_behaviors)) { if (inherits(x[[q]], "function")) { - + set.seed(123) thr[, q] <- sapply(1:n, function(j) x[[q]]()) } else if (is.numeric(x[[q]]) && length(x[[q]]) == 1) { @@ -557,17 +552,22 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { stop("All elements of the list seed.nodes must be either -character- or -numeric-.") } } else if (class(seed.nodes) == "numeric") { - message("Message: Object -seed.nodes- converted to a -list-.", - "All behaviors will have the same seed nodes.") + "All behaviors will have the same -", seed.nodes, "- seed nodes.") seed.nodes <- replicate(length(seed.p.adopt), seed.nodes, simplify = FALSE) } else if (class(seed.nodes) == "character") { + if (length(seed.nodes)==length(seed.p.adopt)) { + seed.nodes <- as.list(seed.nodes) + message("Message: Object -seed.nodes- converted to a -list-.", + "For example, the first behavior has seed -", seed.nodes[[1]], "-, the second has -", seed.nodes[[2]], "-, etc.") + } else { - stop("-character- class not supported for multi-diffusion. It must be a -list-.") - } - - else { + message("Message: Object -seed.nodes- converted to a -list-.", + "All behaviors will have the same -", seed.nodes, "- seed nodes.") + seed.nodes <- replicate(length(seed.p.adopt), seed.nodes, simplify = FALSE) + } + } else { stop("Unsupported -seed.nodes- value. See the manual for references.") } diff --git a/tests/testthat/test-rdiffnet-parameters.R b/tests/testthat/test-rdiffnet-parameters.R index c44dba2..88b2cc0 100644 --- a/tests/testthat/test-rdiffnet-parameters.R +++ b/tests/testthat/test-rdiffnet-parameters.R @@ -100,6 +100,17 @@ test_that("Multi diff models rdiff args work", { # Must work + seed.p.adopt <- list(0.14,0.05) + seed.nodes <- "random" + behavior <- "random behavior" + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + + seed.nodes <- c(1,3,5) + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + + seed.nodes <- c('marginal',"central") + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + seed.p.adopt <- list(0.14,0.05) seed.nodes <- list('random', "central") behavior <- list("random behavior_1", "random behavior_2") @@ -125,7 +136,6 @@ test_that("Multi diff models rdiff args work", { rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) class(rdiffnet_args$seed.nodes) == 'list' - seed.nodes <- list('marginal',"central") ###### behavior <- c("random behavior_1") rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) @@ -138,12 +148,6 @@ test_that("Multi diff models rdiff args work", { rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) ) - seed.p.adopt <- list(0.14,0.05) - seed.nodes <- c('marginal',"central") - expect_error( - rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - ) - behavior <- list("random behavior_1") expect_error( rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) @@ -163,6 +167,23 @@ test_that("Checking threshold for multiple diffusion", { # Must work + # not list entries + + x <- 0.35 # numeric scalar + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + expect_equivalent(thr, matrix(x, nrow=n, ncol=num_of_behaviors)) + + x <- runif(n) # vector of length n + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + expect_equivalent(thr, matrix(rep(x, num_of_behaviors), nrow = n, ncol = num_of_behaviors)) + + x <- function() runif(1) # function + thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) + set.seed(123) + expect_equal(thr, t(sapply(1:n, function(i) rep(x(), num_of_behaviors)))) + + # list entries + x <- matrix(runif(100), nrow = n, ncol = num_of_behaviors) # matrix input thr <- rdiffnet_make_threshold(x, n = n, num_of_behaviors = num_of_behaviors) expect_equal(dim(thr), c(n, num_of_behaviors)) @@ -198,15 +219,4 @@ test_that("Checking threshold for multiple diffusion", { expect_error( rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors) ) - - x <- list(0.14) # Only one behavior provided in the list - expect_error( - rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors), - "The length of the list must match the number of behaviors" - ) - - x <- runif(n) # Only one behavior provided in the vector - expect_error( - rdiffnet_make_threshold(x,n=n,num_of_behaviors=num_of_behaviors) - ) }) diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index f293fb7..5bf556a 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -106,3 +106,32 @@ test_that("Simulation study", { expect_equal(ans0, ans1) }) + +# Test for multi diffusion --- + + + + +# Seed of first adopters +# test_that("All should be equal!", { +# set.seed(12131) +# n <- 50 +# t <- 5 +# graph <- rgraph_ws(n, 4, p=.3) +# seed.p.adopt <- list(0.1, 0.1) +# seed.nodes <- c(1,5,7,10) +# thr <- runif(n, .2,.4) +# thr_list <- list(thr,thr) +# +# # Generating identical networks +# net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, +# t = t, threshold.dist = thr_list) +# +# net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, +# t = t, threshold.dist = thr_list) +# +# expect_equal(net1, net2) +# # net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, +# # t = 5, rewire = FALSE, threshold.dist = thr) +# # +# }) From 271047be89d9f29009579293b0721d2ce46f32b2 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Wed, 13 Nov 2024 11:59:49 -0700 Subject: [PATCH 23/34] rdiffnet now allow multiple diff, showing the results. There is still work to be done to display a line saying 'number of behaviors', and to fix the summary() function. --- R/diffnet-methods.r | 33 ++++++++++++++++++++++++++++--- tests/testthat/test-rdiffnet.R | 36 ++++++++++++++++++++++------------ 2 files changed, 53 insertions(+), 16 deletions(-) diff --git a/R/diffnet-methods.r b/R/diffnet-methods.r index 109a0f9..2ac474b 100644 --- a/R/diffnet-methods.r +++ b/R/diffnet-methods.r @@ -75,6 +75,10 @@ plot.diffnet <- function( #' @export #' @rdname diffnet-class print.diffnet <- function(x, ...) { + #print(str(x)) + #x$cumadopt + #meta + #class(cumadopt) with(x, { # Getting attrs vsa <- paste0(colnames(vertex.static.attrs), collapse=", ") @@ -94,6 +98,26 @@ print.diffnet <- function(x, ...) { paste(head(meta$ids, 8), collapse=", "), ifelse(meta$n>8, ", ...", "") ,")") + single <- class(cumadopt)[1]!='list' + # if (!single) { + # prevalence <- list() + # for (q in 1:length(cumadopt)) {prevalence[[1]] <- formatC(sum(cumadopt[[q]][,meta$nper])/meta$n, digits = 2, format="f")} + # prevalence <- as.character(prevalence) + # } + # + # Initialize an empty character vector + if (!single) { + prevalence_all <- character(length(cumadopt)) + + for (q in 1:length(cumadopt)) { + prevalence <- formatC(sum(cumadopt[[q]][,meta$nper]) / meta$n, digits = 2, format="f") + prevalence_all[q] <- prevalence + } + prevalence_all <- paste(prevalence_all, collapse = ", ") + + #print(prevalence_all) # Output the combined result + } + cat( "Dynamic network of class -diffnet-", paste(" Name :", meta$name), @@ -101,9 +125,12 @@ print.diffnet <- function(x, ...) { paste(" # of nodes :", nodesl ), paste(" # of time periods :", meta$nper, sprintf("(%d - %d)", meta$pers[1], meta$pers[meta$nper])), paste(" Type :", ifelse(meta$undirected, "undirected", "directed")), - paste(" Final prevalence :", - formatC(sum(cumadopt[,meta$nper])/meta$n, digits = 2, format="f") - ), + paste(" Type of diff :", ifelse(single, "Single", "Multiple")), + if (single) { + paste(" Final prevalence :", formatC(sum(cumadopt[,meta$nper])/meta$n, digits = 2, format="f")) + } else { + paste(" Prevalence :", prevalence_all) + }, paste(" Static attributes :", vsa), paste(" Dynamic attributes :", vda), sep="\n" diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index 5bf556a..75f33fd 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -114,19 +114,29 @@ test_that("Simulation study", { # Seed of first adopters # test_that("All should be equal!", { -# set.seed(12131) -# n <- 50 -# t <- 5 -# graph <- rgraph_ws(n, 4, p=.3) -# seed.p.adopt <- list(0.1, 0.1) -# seed.nodes <- c(1,5,7,10) -# thr <- runif(n, .2,.4) -# thr_list <- list(thr,thr) -# -# # Generating identical networks -# net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, -# t = t, threshold.dist = thr_list) -# + # set.seed(12131) + # n <- 50 + # t <- 5 + # graph <- rgraph_ws(n, 4, p=.3) + # seed.p.adopt <- list(0.1, 0.1) + # seed.nodes <- c(1,5,7,10) + # thr <- runif(n, .2,.4) + # thr_list <- list(thr,thr) + # + # # Generating identical networks + # net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, + # t = t, threshold.dist = thr_list) + # + # rdiffnet(100,10, seed.p.adopt = list(.1, .05)) + # + # rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes=c(1,2,3,4)) + # + # rdiffnet(100,10, seed.p.adopt = .05, seed.nodes='random') + # rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes='random') + # + # rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes=c('random','central')) + + # net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, # t = t, threshold.dist = thr_list) # From 06156852240b014f7b878e9633c034226da9ea10 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Wed, 13 Nov 2024 12:05:33 -0700 Subject: [PATCH 24/34] rdiffnet now allow multiple diff, showing the results. There is still work to be done to display a line saying 'number of behaviors', and to fix the summary() function. --- R/diffnet-methods.r | 14 +------------- tests/testthat/test-rdiffnet.R | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 25 deletions(-) diff --git a/R/diffnet-methods.r b/R/diffnet-methods.r index 2ac474b..ca89829 100644 --- a/R/diffnet-methods.r +++ b/R/diffnet-methods.r @@ -75,10 +75,6 @@ plot.diffnet <- function( #' @export #' @rdname diffnet-class print.diffnet <- function(x, ...) { - #print(str(x)) - #x$cumadopt - #meta - #class(cumadopt) with(x, { # Getting attrs vsa <- paste0(colnames(vertex.static.attrs), collapse=", ") @@ -98,14 +94,8 @@ print.diffnet <- function(x, ...) { paste(head(meta$ids, 8), collapse=", "), ifelse(meta$n>8, ", ...", "") ,")") + # Computing prevalence for multi-diff single <- class(cumadopt)[1]!='list' - # if (!single) { - # prevalence <- list() - # for (q in 1:length(cumadopt)) {prevalence[[1]] <- formatC(sum(cumadopt[[q]][,meta$nper])/meta$n, digits = 2, format="f")} - # prevalence <- as.character(prevalence) - # } - # - # Initialize an empty character vector if (!single) { prevalence_all <- character(length(cumadopt)) @@ -114,8 +104,6 @@ print.diffnet <- function(x, ...) { prevalence_all[q] <- prevalence } prevalence_all <- paste(prevalence_all, collapse = ", ") - - #print(prevalence_all) # Output the combined result } cat( diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index 75f33fd..8a226b7 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -114,18 +114,18 @@ test_that("Simulation study", { # Seed of first adopters # test_that("All should be equal!", { - # set.seed(12131) - # n <- 50 - # t <- 5 - # graph <- rgraph_ws(n, 4, p=.3) - # seed.p.adopt <- list(0.1, 0.1) - # seed.nodes <- c(1,5,7,10) - # thr <- runif(n, .2,.4) - # thr_list <- list(thr,thr) - # - # # Generating identical networks - # net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, - # t = t, threshold.dist = thr_list) + set.seed(12131) + n <- 50 + t <- 5 + graph <- rgraph_ws(n, 4, p=.3) + seed.p.adopt <- list(0.1, 0.1) + seed.nodes <- c(1,5,7,10) + thr <- runif(n, .2,.4) + thr_list <- list(thr,thr) + + # Generating identical networks + net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, + t = t, threshold.dist = thr_list) # # rdiffnet(100,10, seed.p.adopt = list(.1, .05)) # From e871f3303a7c5f31103b7ed3a083f728281b7e92 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Wed, 13 Nov 2024 13:24:51 -0700 Subject: [PATCH 25/34] Now rdiffnet allow multiple diff, and shows the name -Behavior-, -Num of behaviors-, and --- R/diffnet-class.r | 6 ++++-- R/diffnet-methods.r | 10 +++++++--- tests/testthat/test-rdiffnet.R | 36 +++++++++++++++++----------------- 3 files changed, 29 insertions(+), 23 deletions(-) diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 7b8675a..596db8d 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -672,8 +672,6 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm meta$multiple <- multiple meta$name <- ifelse(!length(name), "", ifelse(is.na(name), "", as.character(name))) - meta$behavior <- ifelse(!length(behavior), "", ifelse(is.na(behavior), "", - as.character(behavior))) meta$version <- utils::packageVersion("netdiffuseR") # Removing dimnames @@ -681,12 +679,16 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm dimnames(toa) <- NULL if (num_of_behaviors==1) { + meta$behavior <- ifelse(!length(behavior), "", ifelse(is.na(behavior), "", + as.character(behavior))) dimnames(mat$adopt) <- NULL dimnames(mat$cumadopt) <- NULL adopt <- mat$adopt cumadopt <- mat$cumadopt } else { + meta$behavior <- paste(unlist(behavior), collapse = ", ") + for (q in 1:num_of_behaviors) { dimnames(mat[[q]]$adopt) <- NULL dimnames(mat[[q]]$cumadopt) <- NULL diff --git a/R/diffnet-methods.r b/R/diffnet-methods.r index ca89829..85faa0d 100644 --- a/R/diffnet-methods.r +++ b/R/diffnet-methods.r @@ -98,12 +98,16 @@ print.diffnet <- function(x, ...) { single <- class(cumadopt)[1]!='list' if (!single) { prevalence_all <- character(length(cumadopt)) - for (q in 1:length(cumadopt)) { prevalence <- formatC(sum(cumadopt[[q]][,meta$nper]) / meta$n, digits = 2, format="f") prevalence_all[q] <- prevalence } prevalence_all <- paste(prevalence_all, collapse = ", ") + + num_of_behavior <- as.character(length(cumadopt)) + } else { + prevalence <- formatC(sum(cumadopt[,meta$nper])/meta$n, digits = 2, format="f") + num_of_behavior <- "1" } cat( @@ -113,9 +117,9 @@ print.diffnet <- function(x, ...) { paste(" # of nodes :", nodesl ), paste(" # of time periods :", meta$nper, sprintf("(%d - %d)", meta$pers[1], meta$pers[meta$nper])), paste(" Type :", ifelse(meta$undirected, "undirected", "directed")), - paste(" Type of diff :", ifelse(single, "Single", "Multiple")), + paste(" Num of behaviors :", num_of_behavior), if (single) { - paste(" Final prevalence :", formatC(sum(cumadopt[,meta$nper])/meta$n, digits = 2, format="f")) + paste(" Final prevalence :", prevalence) } else { paste(" Prevalence :", prevalence_all) }, diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index 8a226b7..1a40327 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -113,7 +113,7 @@ test_that("Simulation study", { # Seed of first adopters -# test_that("All should be equal!", { +test_that("All should be equal!", { set.seed(12131) n <- 50 t <- 5 @@ -126,22 +126,22 @@ test_that("Simulation study", { # Generating identical networks net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, t = t, threshold.dist = thr_list) - # - # rdiffnet(100,10, seed.p.adopt = list(.1, .05)) - # - # rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes=c(1,2,3,4)) - # - # rdiffnet(100,10, seed.p.adopt = .05, seed.nodes='random') - # rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes='random') - # - # rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes=c('random','central')) + rdiffnet(100,10, seed.p.adopt = list(.1, .05)) + + rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes=c(1,2,3,4)) + + rdiffnet(100,10, seed.p.adopt = .05, seed.nodes='random') + rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes='random') -# net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, -# t = t, threshold.dist = thr_list) -# -# expect_equal(net1, net2) -# # net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, -# # t = 5, rewire = FALSE, threshold.dist = thr) -# # -# }) + rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes=c('random','central')) + + + net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, + t = t, threshold.dist = thr_list) + + #expect_equal(net1, net2) + # net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, + # t = 5, rewire = FALSE, threshold.dist = thr) + # +}) From 375595972469b27508ebee09c09801ed80ef6ee7 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Wed, 13 Nov 2024 17:48:16 -0700 Subject: [PATCH 26/34] some minor changes in summary.diffnet --- R/diffnet-methods.r | 71 ++++++++++++++++++++-------------- tests/testthat/test-rdiffnet.R | 24 ++---------- 2 files changed, 45 insertions(+), 50 deletions(-) diff --git a/R/diffnet-methods.r b/R/diffnet-methods.r index 85faa0d..1c4539e 100644 --- a/R/diffnet-methods.r +++ b/R/diffnet-methods.r @@ -213,44 +213,55 @@ summary.diffnet <- function( # x <-nelements/(meta$n * (meta$n-1)) })) + # identify single-diff from multi-diff + single <- class(object$cumadopt)[1]!='list' + # Computing moran's I - if (!skip.moran) { + if (single) { + + if (!skip.moran) { + m <- matrix(NA, nrow=length(slices), ncol=4, + dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval"))) - m <- matrix(NA, nrow=length(slices), ncol=4, - dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval"))) + for (i in 1:length(slices)) { + # Computing distances + g <- approx_geodesic(object$graph[[slices[i]]], ...) + # Inverting it (only the diagonal may have 0) + g@x <- 1/g@x - for (i in 1:length(slices)) { - # Computing distances - g <- approx_geodesic(object$graph[[slices[i]]], ...) + m[i,] <- unlist(moran(object$cumadopt[,slices[i]], g)) + } - # Inverting it (only the diagonal may have 0) - g@x <- 1/g@x + # Computing new adopters, cumadopt and hazard rate + ad <- colSums(object$adopt[,slices,drop=FALSE]) + ca <- t(cumulative_adopt_count(object$cumadopt))[slices,-3, drop=FALSE] + hr <- t(hazard_rate(object$cumadopt, no.plot = TRUE))[slices,,drop=FALSE] + + # Left censoring + lc <- sum(object$toa == meta$pers[1], na.rm = TRUE) + rc <- sum(is.na(object$toa), na.rm=TRUE) + + out <- data.frame( + adopt = ad, + cum_adopt = ca[,1], + cum_adopt_pcent = ca[,2], + hazard = hr, + density=d + ) - m[i,] <- unlist(moran(object$cumadopt[,slices[i]], g)) + if (!skip.moran) { + out <- cbind(out, m) } - } - # Computing adopters, cumadopt and hazard rate - ad <- colSums(object$adopt[,slices,drop=FALSE]) - ca <- t(cumulative_adopt_count(object$cumadopt))[slices,-3, drop=FALSE] - hr <- t(hazard_rate(object$cumadopt, no.plot = TRUE))[slices,,drop=FALSE] - - # Left censoring - lc <- sum(object$toa == meta$pers[1], na.rm = TRUE) - rc <- sum(is.na(object$toa), na.rm=TRUE) - - out <- data.frame( - adopt = ad, - cum_adopt = ca[,1], - cum_adopt_pcent = ca[,2], - hazard = hr, - density=d - ) - if (!skip.moran) { - out <- cbind(out, m) - } + if (no.print) return(out) + } + + } else { - if (no.print) return(out) + message("Multiple in summary.diffnet -borrar-") + + + } # Function to print data.frames differently header <- c(" Period "," Adopters "," Cum Adopt. (%) ", diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index 1a40327..15770e5 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -109,11 +109,8 @@ test_that("Simulation study", { # Test for multi diffusion --- - - - # Seed of first adopters -test_that("All should be equal!", { +test_that("All should be equal! (multiple)", { set.seed(12131) n <- 50 t <- 5 @@ -125,23 +122,10 @@ test_that("All should be equal!", { # Generating identical networks net1 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, - t = t, threshold.dist = thr_list) - - rdiffnet(100,10, seed.p.adopt = list(.1, .05)) - - rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes=c(1,2,3,4)) - - rdiffnet(100,10, seed.p.adopt = .05, seed.nodes='random') - rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes='random') - - rdiffnet(100,10, seed.p.adopt = list(.1, .05), seed.nodes=c('random','central')) - + t = t, rewire = FALSE, threshold.dist = thr_list) net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, - t = t, threshold.dist = thr_list) + t = t, rewire = FALSE, threshold.dist = thr_list) - #expect_equal(net1, net2) - # net2 <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = seed.p.adopt, - # t = 5, rewire = FALSE, threshold.dist = thr) - # + expect_equal(net1, net2) }) From 875b22f26b898fcd2b7dd4bbc5560136c1101411 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Fri, 15 Nov 2024 14:00:39 -0700 Subject: [PATCH 27/34] advances in summary.diffnet() for multi-diff, but this will be change to something more simple later --- R/diffnet-methods.r | 99 +++++++++++++++++++++++++--------- tests/testthat/test-rdiffnet.R | 33 ++++++++++++ 2 files changed, 106 insertions(+), 26 deletions(-) diff --git a/R/diffnet-methods.r b/R/diffnet-methods.r index 1c4539e..b74e33f 100644 --- a/R/diffnet-methods.r +++ b/R/diffnet-methods.r @@ -218,7 +218,6 @@ summary.diffnet <- function( # Computing moran's I if (single) { - if (!skip.moran) { m <- matrix(NA, nrow=length(slices), ncol=4, dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval"))) @@ -257,10 +256,49 @@ summary.diffnet <- function( } } else { + if (!skip.moran) { + out_list <- list() + data_beh_list <- list() + for (q in 1:length(object$cumadopt)) { + m <- matrix(NA, nrow=length(slices), ncol=4, + dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval"))) + + for (i in 1:length(slices)) { + + g <- approx_geodesic(object$graph[[slices[i]]], ...) + g@x <- 1/g@x + + m[i,] <- unlist(moran(object$cumadopt[[q]][,slices[i]], g)) + } - message("Multiple in summary.diffnet -borrar-") + # Computing new adopters, cumadopt and hazard rate + ad <- colSums(object$adopt[[q]][,slices,drop=FALSE]) + ca <- t(cumulative_adopt_count(object$cumadopt[[q]]))[slices,-3, drop=FALSE] + hr <- t(hazard_rate(object$cumadopt[[q]], no.plot = TRUE))[slices,,drop=FALSE] + # Left censoring + lc <- sum(object$toa[,q] == meta$pers[1], na.rm = TRUE) + rc <- sum(is.na(object$toa[,q]), na.rm=TRUE) + #data_beh_list[[q]] <- list(ad, ca, hr, lc, rc) + + out <- data.frame( + adopt = ad, + cum_adopt = ca[,1], + cum_adopt_pcent = ca[,2], + hazard = hr, + density=d + ) + + if (!skip.moran) { + out <- cbind(out, m) + } + + if (no.print) return(out) + + out_list[[q]] <- out + } + } } # Function to print data.frames differently @@ -283,31 +321,14 @@ summary.diffnet <- function( rule,"\n",sep="") cat(header,"\n") cat(hline, "\n") - for (i in 1:nrow(out)) { - cat(sprintf( - paste0("%",slen,"s", collapse=" "), - qf(meta$pers[slices[i]],0), qf(out[i,1],0), - sprintf("%s (%s)", - qf(out$cum_adopt[i],0), - qf(out$cum_adopt_pcent[i]) - ), - ifelse(i==1, "-",qf(out$hazard[i])), qf(out$density[i]), - if (!skip.moran) { - if (is.nan(out$moran_sd[i])) - " - " - else - sprintf("%s (%s) %-3s", - qf(out$moran_obs[i]), - qf(out$moran_sd[i]), - ifelse(out$moran_pval[i] <= .01, "***", - ifelse(out$moran_pval[i] <= .05, "**", - ifelse(out$moran_pval[i] <= .10, "*", "" - ))) - ) - } else "" - ), "\n") - } + if (single) { + summary_diffnet_out_display(out, slen, meta, slices, qf, skip.moran) + } else { + for (q in 1:length(object$cumadopt)) { + summary_diffnet_out_display(out_list[[q]], slen, meta, slices, qf, skip.moran) + } + } # print(out, digits=2) @@ -324,6 +345,32 @@ summary.diffnet <- function( invisible(out) } +summary_diffnet_out_display <- function(out, slen, meta, slices, qf, skip.moran) { + for (i in 1:nrow(out)) { + cat(sprintf( + paste0("%",slen,"s", collapse=" "), + qf(meta$pers[slices[i]],0), qf(out[i,1],0), + sprintf("%s (%s)", + qf(out$cum_adopt[i],0), + qf(out$cum_adopt_pcent[i]) + ), + ifelse(i==1, "-",qf(out$hazard[i])), qf(out$density[i]), + + if (!skip.moran) { + if (is.nan(out$moran_sd[i])) {" - "} + else {sprintf("%s (%s) %-3s", + qf(out$moran_obs[i]), + qf(out$moran_sd[i]), + ifelse(out$moran_pval[i] <= .01, "***", + ifelse(out$moran_pval[i] <= .05, "**", + ifelse(out$moran_pval[i] <= .10, "*", "" + ))) + )} + } else {""} + ), "\n") + } +} + #' Plot the diffusion process #' #' Creates a colored network plot showing the structure of the graph through time diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index 15770e5..57f81eb 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -129,3 +129,36 @@ test_that("All should be equal! (multiple)", { expect_equal(net1, net2) }) + + +#single +rdiffnet(100, 5) +rdiffnet(100, 5, seed.p.adopt = 0.1) +rdiffnet(100, 5, seed.p.adopt = 0.1, seed.nodes = 'random') +rdiffnet(100, 5, seed.nodes = c(1,3,5)) +net_1 <- rdiffnet(100, 5, seed.nodes = c(1,3,5)) +summary(net_1) + +#multi +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08)) +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), behavior = c('tabacco', 'alcohol')) +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), seed.nodes = 'random') +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), seed.nodes = c('random', 'central')) +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = 0.3) +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(0.1,0.2)) +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = rexp(100)) +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(rexp(100),runif(100))) +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = function(x) 0.3) +rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(function(x) 0.3, function(x) 0.2)) + +net_1 <- rdiffnet(100, 5, seed.nodes = c(1,3,5)) +summary(net_1) +net_2 <- rdiffnet(100, 5, seed.p.adopt = list(0.05,0.05), seed.nodes = c(1,3,5)) +summary(net_2) + +#rdiffnet(100, 5, seed.p.adopt = 0.9, threshold.dist = 2, exposure.args = list(normalized=FALSE)) + +# set.seed(1234) +# net1 <- rdiffnet(100, 5, rewire = FALSE, seed.p.adopt = list(0.1,0.08), seed.nodes = c(1,3,5)) +# net2 <- rdiffnet(100, 5, rewire = FALSE, seed.p.adopt = list(0.1,0.08), seed.nodes = list(c(1,3,5),c(1,3,5))) +# expect_equal(net1, net2) From e9a34cd774055935a4bf43c2969e3e134b19ab31 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 18 Nov 2024 10:56:16 -0700 Subject: [PATCH 28/34] changes in exposure.list and exposure_for to allow personalized attrs in multi-diff --- R/rdiffnet.r | 13 +++++++++++++ R/stats.R | 22 ++++++++++++---------- 2 files changed, 25 insertions(+), 10 deletions(-) diff --git a/R/rdiffnet.r b/R/rdiffnet.r index 022d1de..1c8d571 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -332,6 +332,16 @@ rdiffnet <- function( if (!length(exposure.args[["valued"]])) exposure.args[["valued"]] <- getOption("diffnet.valued", FALSE) if (!length(exposure.args[["normalized"]])) exposure.args[["normalized"]] <- TRUE + if (class(exposure.args[["attrs"]])[1] == "matrix") { + # Checking if the attrs matrix is has dims n x t + if (any(dim(exposure.args[["attrs"]]) != dim(matrix(NA, nrow = n, ncol = t)))) { + stop("Incorrect size for -attrs- in rdiffnet. Does not match n dim or t dim.")} + attrs_arr <- exposure.args[["attrs"]] + if (class(seed.p.adopt) == 'list'){ + attrs_arr <- array(attrs_arr, dim = c(n, t, length(seed.p.adopt))) + } else {attrs_arr <- array(attrs_arr, dim = c(n, t, 1))} + } + # Step 0.0: Creating the network seed ---------------------------------------- # Checking the class of the seed.graph sgraph <- rdiffnet_check_seed_graph(seed.graph, rgraph.args, t, n) @@ -444,6 +454,9 @@ rdiffnet <- function( # Step 3.0: Running the simulation ------------------------------------------- for (i in 2:t) { + if (exists("attrs_arr")){ + exposure.args[c("attrs")] <- list(attrs_arr[,i, ,drop=FALSE]) + } exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i, ,drop=FALSE]) expo <- do.call(exposure, exposure.args) diff --git a/R/stats.R b/R/stats.R index f985660..8149b2f 100644 --- a/R/stats.R +++ b/R/stats.R @@ -566,7 +566,11 @@ exposure <- function( # Checking attrs if (!length(attrs)) { - attrs <- matrix(1, ncol=ncol(cumadopt), nrow=nrow(cumadopt)) + if (!is.na(dim(cumadopt)[3])) { + attrs <- array(1, dim = c(nrow(cumadopt), ncol(cumadopt), 1))} + else {attrs <- matrix(1, ncol=ncol(cumadopt), nrow=nrow(cumadopt))} + } else if (!is.na(dim(cumadopt)[3])) { + attrs <- array(attrs, dim = c(nrow(attrs), ncol(attrs), 1)) } # Checking alt graph @@ -626,20 +630,18 @@ exposure.list <- function( # degree, indegree, outdegree, or a user defined vector. # by default is user equal to 1 - dim_attrs <- dim(attrs) # default n x T matrix of 1's - if (!length(dim_attrs)) stop("-attrs- must be a matrix of size n by T.") + # dim(attrs) default n x T matrix of 1's + if (!length(dim(attrs))) stop("-attrs- must be a matrix of size n by T.") if (!is.na(dim(cumadopt)[3])) { - attrs_mul <- array(rep(attrs, dim(cumadopt)[3]), dim = c(dim_attrs, dim(cumadopt)[3])) - dim_attrs <- dim(attrs_mul) # now n x T x q array of 1's, q behaviors - if (any(dim_attrs != dim(cumadopt))) stop("Incorrect size for -attrs-. ", + if (dim(cumadopt)[3]>1 && any(dim(attrs)[-3] != dim(cumadopt)[-3])) stop("Incorrect size for -attrs-. ", "Does not match n dim or t dim.") } else { - if (any(dim_attrs != dim(cumadopt))) stop("Incorrect size for -attrs-. ", + if (any(dim(attrs) != dim(cumadopt))) stop("Incorrect size for -attrs-. ", "It must be of size that -cumadopt-.") } - add_dimnames.mat(cumadopt) + add_dimnames.mat(attrs) output <- exposure_for(graph, cumadopt, attrs, outgoing, valued, normalized, self, lags) @@ -667,7 +669,7 @@ exposure_for <- function( for (i in 1:(nslices(graph) - lags)) { out[, i + lags, ] <- .exposure(graph[[i]], cumadopt[, i, , drop = FALSE], - attrs[, i, drop = FALSE], + attrs[, i, , drop = FALSE], outgoing = outgoing, valued = valued, normalized = normalized, @@ -677,7 +679,7 @@ exposure_for <- function( for (i in (1 - lags):nslices(graph)) { out[, i + lags, ] <- .exposure(graph[[i]], cumadopt[, i, , drop = FALSE], - attrs[, i, drop = FALSE], + attrs[, i, , drop = FALSE], outgoing = outgoing, valued = valued, normalized = normalized, From 345df65ceff2f059ec1eab1083b5e93317df073c Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 18 Nov 2024 16:46:28 -0700 Subject: [PATCH 29/34] minor changes in toa_mat --- R/adjmat.r | 6 +++++- R/diffnet-class.r | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/R/adjmat.r b/R/adjmat.r index f7d2435..fc69100 100644 --- a/R/adjmat.r +++ b/R/adjmat.r @@ -462,7 +462,11 @@ adjmat_to_edgelist.list <- function(graph, undirected, keep.isolates) { #' @keywords manip #' @include graph_data.r #' @author George G. Vega Yon & Thomas W. Valente -toa_mat <- function(obj, num_of_behaviors=1, labels=NULL, t0=NULL, t1=NULL) { +toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) { + + if (inherits(obj, "matrix")) { + num_of_behaviors <- dim(obj)[2] + } else {num_of_behaviors <- 1} if (!inherits(obj, "diffnet")) { if (!length(t0)) t0 <- min(obj, na.rm = TRUE) diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 596db8d..42b6ae5 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -597,7 +597,7 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm } # Step 3.1: Creating Time of adoption matrix --------------------------------- - mat <- toa_mat(toa, num_of_behaviors, labels = meta$ids, t0=t0, t1=t1) + mat <- toa_mat(toa, labels = meta$ids, t0=t0, t1=t1) # Step 3.2: Verifying dimensions and fixing meta$pers From e01535e53803217f3d0d7da36cadf55c04e5370a Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 18 Nov 2024 17:26:05 -0700 Subject: [PATCH 30/34] now new_diffnet sets the num_of behavior internally --- R/diffnet-class.r | 9 +++++++-- R/rdiffnet.r | 3 +-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 42b6ae5..1c77397 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -547,8 +547,7 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm self = getOption("diffnet.self"), multiple = getOption("diffnet.multiple"), name = "Diffusion Network", - behavior = "Unspecified", - num_of_behaviors = 1 + behavior = "Unspecified" ) { # Step 0.0: Check if its diffnet! -------------------------------------------- @@ -557,6 +556,12 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm return(graph) } + # Step 0.1: Setting num_of_behavior ------------------------------------------ + + if (inherits(toa, "matrix")) { + num_of_behaviors <- dim(toa)[2] + } else {num_of_behaviors <- 1} + # Step 1.1: Check graph ------------------------------------------------------ meta <- classify_graph(graph) if (meta$type=="static") diff --git a/R/rdiffnet.r b/R/rdiffnet.r index 1c8d571..58dbbbc 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -500,8 +500,7 @@ rdiffnet <- function( t1 = t, vertex.static.attrs = data.frame(real_threshold=thr), name = name, - behavior = behavior, - num_of_behaviors = num_of_behaviors + behavior = behavior ) } From b6e63ca1a6c758a7c3808d98a66db2b300fe6d9f Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 18 Nov 2024 18:04:44 -0700 Subject: [PATCH 31/34] more changes to toa_mat to compute num_of_adoption on more classes --- R/adjmat.r | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/R/adjmat.r b/R/adjmat.r index fc69100..884785f 100644 --- a/R/adjmat.r +++ b/R/adjmat.r @@ -466,6 +466,10 @@ toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) { if (inherits(obj, "matrix")) { num_of_behaviors <- dim(obj)[2] + } else if (inherits(obj, "diffnet")){ + if (inherits(obj$toa, "matrix")) { + num_of_behaviors <- dim(obj$toa)[2]} + else {num_of_behaviors <- 1} } else {num_of_behaviors <- 1} if (!inherits(obj, "diffnet")) { @@ -487,13 +491,13 @@ toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) { } } else { for (q in 1:num_of_behaviors) { - cls <- class(obj[,q]) - ans[[q]] <- if ("numeric" %in% cls) { # Why included? + #cls <- class(obj[,q]) + ans[[q]] <- if ("numeric" %in% class(obj[,q])) { # Why included? toa_mat.numeric(obj[,q], labels, t0, t1) - } else if ("integer" %in% cls) { + } else if ("integer" %in% class(obj[,q])) { toa_mat.integer(obj[,q], labels, t0, t1) - } else if ("diffnet" %in% cls) { # Why included? - with(obj[,q], list(adopt=adopt,cumadopt=cumadopt)) + } else if ("diffnet" %in% class(obj)) { # Why included? + with(obj, list(adopt=adopt[[q]],cumadopt=cumadopt[[q]])) } else { stopifnot_graph(obj[,q]) } From 516cf33b8211575be6672b57e1a164222401c56e Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 18 Nov 2024 19:10:19 -0700 Subject: [PATCH 32/34] now toa_mat can compute adopt and cumadopt from diffnet (multiple) and matrix objects. The same tests for single behavior were adapted. --- R/adjmat.r | 10 +++--- tests/testthat/test-adjmat.R | 63 ++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+), 4 deletions(-) diff --git a/R/adjmat.r b/R/adjmat.r index 884785f..abc6217 100644 --- a/R/adjmat.r +++ b/R/adjmat.r @@ -492,10 +492,12 @@ toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) { } else { for (q in 1:num_of_behaviors) { #cls <- class(obj[,q]) - ans[[q]] <- if ("numeric" %in% class(obj[,q])) { # Why included? - toa_mat.numeric(obj[,q], labels, t0, t1) - } else if ("integer" %in% class(obj[,q])) { - toa_mat.integer(obj[,q], labels, t0, t1) + ans[[q]] <- if ("matrix" %in% class(obj)) { + if ("integer" %in% class(obj[,q])){ + toa_mat.integer(obj[,q], labels, t0, t1) + } else if ("numeric" %in% class(obj[,q])) { # Why included? + toa_mat.numeric(obj[,q], labels, t0, t1) + } } else if ("diffnet" %in% class(obj)) { # Why included? with(obj, list(adopt=adopt[[q]],cumadopt=cumadopt[[q]])) } else { diff --git a/tests/testthat/test-adjmat.R b/tests/testthat/test-adjmat.R index a037278..1cf02bb 100644 --- a/tests/testthat/test-adjmat.R +++ b/tests/testthat/test-adjmat.R @@ -145,6 +145,69 @@ test_that("Checking toa_mat output", { expect_equal(amat, toa_mat(diffnet)) }) +################################################################################ +# Time of adoption (multiple) +################################################################################ +context("Time of Adoption -multiple- (toa_mat, toa_dif)") + +times_1 <- c(2001L, 2004L, 2003L, 2008L) +times_2 <- c(2001L, 2005L, 2006L, 2008L) +times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) +graph <- lapply(2001:2008, function(x) rgraph_er(4)) +diffnet <- new_diffnet(graph, times) +#toa_mat(diffnet) +toa <- toa_mat(times) + +test_that("Should warn about -times- not been integer. -multiple-.", { + times_1 <- as.numeric(c(2001L, 2004L, 2003L, 2008L)) + times_2 <- as.numeric(c(2001L, 2002L, 2003L, 2005L)) + times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) + expect_warning(toa_mat(times), "will be coersed to integer") +}) + +test_that("Dimensions of TOA mat should be ok. -multiple-.", { + for (q in 1:length(toa)) { + cumadopt <- t(apply(toa[[q]]$adopt, 1, cumsum)) + expect_equal(dim(toa[[q]]$adopt), c(4, length(min(times[,q]):max(times[,q])))) + expect_equal(dim(toa[[q]]$adopt), dim(toa[[q]]$cumadopt), info = "adopt and cumadopt are equal dim") + expect_equal(t(apply(toa[[q]]$adopt, 1, cumsum)), toa[[q]]$cumadopt, info = "cumadopt is the cumsum") + } +}) + +test_that("Passing labels should work. -multiple-.", { + for (q in 1:length(toa)) { + labs <- letters[1:length(times[,q])] + toa_q <- toa_mat(times[,q], labels=labs) + expect_equal(rownames(toa_q$adopt), labs) + expect_equal(rownames(toa_q$cumadopt), labs) + } +}) + +# test_that("In toa_diff, its dim should be equal to the input mat. -multiple-.", { +# expect_equal(dim(toa_diff(times)), c(4,4)) +# expect_equal(dim(toa_diff(as.integer(times))), c(4,4)) +# expect_equal(toa_diff(times), toa_diff(as.integer(times))) +# }) + +test_that("Checking toa_mat output. -multiple-.", { + + # Manual calc + mat <- matrix(0, nrow=4, ncol=8) + mat <- array(rep(mat,2), dim = c(nrow(mat), ncol(mat), 2)) + dimnames(mat) <- list(1:4, 2001:2008) + amat_tot <- list() + for (q in 1:dim(mat)[3]) { + amat <- list(adopt=mat[,,q], cumadopt=mat[,,q]) + for (i in 1:4) { + amat$adopt[i,times[i,q] - 2000] <- 1 + amat$cumadopt[i,] <- cumsum(amat$adopt[i,]) + } + amat_tot[[q]] <- amat + } + + expect_equal(amat_tot, toa_mat(diffnet)) +}) + ################################################################################ # Isolated ################################################################################ From 90f4af52b46d06dcd21970b017c772e5819cb6cc Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Tue, 19 Nov 2024 10:56:34 -0700 Subject: [PATCH 33/34] all comments were addressed, except -behavior- as a vector. --- R/adjmat.r | 1 - R/diffnet-class.r | 2 + R/diffnet-methods.r | 4 +- R/rdiffnet.r | 22 ++++----- tests/testthat/test-rdiffnet-parameters.R | 38 ++++++++-------- tests/testthat/test-rdiffnet.R | 55 ++++++++++++----------- 6 files changed, 63 insertions(+), 59 deletions(-) diff --git a/R/adjmat.r b/R/adjmat.r index abc6217..c0b08c9 100644 --- a/R/adjmat.r +++ b/R/adjmat.r @@ -491,7 +491,6 @@ toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) { } } else { for (q in 1:num_of_behaviors) { - #cls <- class(obj[,q]) ans[[q]] <- if ("matrix" %in% class(obj)) { if ("integer" %in% class(obj[,q])){ toa_mat.integer(obj[,q], labels, t0, t1) diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 1c77397..d968576 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -638,6 +638,8 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm # This should be reviewed !! (here the graph becomes 'dynamic') + warning("here the graph becomes 'dynamic' for multiple") + graph <- lapply(1:ncol(mat[[1]]$adopt), function(x) methods::as(graph, "dgCMatrix")) meta <- classify_graph(graph) } diff --git a/R/diffnet-methods.r b/R/diffnet-methods.r index b74e33f..95b420e 100644 --- a/R/diffnet-methods.r +++ b/R/diffnet-methods.r @@ -95,7 +95,7 @@ print.diffnet <- function(x, ...) { ifelse(meta$n>8, ", ...", "") ,")") # Computing prevalence for multi-diff - single <- class(cumadopt)[1]!='list' + single <- !inherits(cumadopt, "list") if (!single) { prevalence_all <- character(length(cumadopt)) for (q in 1:length(cumadopt)) { @@ -214,7 +214,7 @@ summary.diffnet <- function( })) # identify single-diff from multi-diff - single <- class(object$cumadopt)[1]!='list' + single <- !inherits(object$cumadopt, "list") # Computing moran's I if (single) { diff --git a/R/rdiffnet.r b/R/rdiffnet.r index 58dbbbc..025c3ba 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -332,12 +332,12 @@ rdiffnet <- function( if (!length(exposure.args[["valued"]])) exposure.args[["valued"]] <- getOption("diffnet.valued", FALSE) if (!length(exposure.args[["normalized"]])) exposure.args[["normalized"]] <- TRUE - if (class(exposure.args[["attrs"]])[1] == "matrix") { + if (inherits(exposure.args[["attrs"]], "matrix")) { # Checking if the attrs matrix is has dims n x t if (any(dim(exposure.args[["attrs"]]) != dim(matrix(NA, nrow = n, ncol = t)))) { stop("Incorrect size for -attrs- in rdiffnet. Does not match n dim or t dim.")} attrs_arr <- exposure.args[["attrs"]] - if (class(seed.p.adopt) == 'list'){ + if (inherits(seed.p.adopt, "list")){ attrs_arr <- array(attrs_arr, dim = c(n, t, length(seed.p.adopt))) } else {attrs_arr <- array(attrs_arr, dim = c(n, t, 1))} } @@ -511,14 +511,14 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { # The class of seed.p.adopt determines if is a single or multiple diff pross. - if (class(seed.p.adopt) == "list") { + if (inherits(seed.p.adopt, "list")) { message(paste("Message: Multi-diffusion behavior simulation selected.", "Number of behaviors: ", length(seed.p.adopt))) multi <- TRUE - } else if (class(seed.p.adopt) == "numeric") { + } else if (inherits(seed.p.adopt, "numeric")) { if (length(seed.p.adopt)>1) { stop(paste("length(seed.p.adopt) =", length(seed.p.adopt), @@ -539,7 +539,7 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { # For multi-diff. - if (class(seed.nodes) == "list") { + if (inherits(seed.nodes, "list")) { if (length(seed.nodes) != length(seed.p.adopt)) { stop("Length of lists -seed.nodes- and -seed.p.adopt- must be the same for multi diffusion.") } @@ -563,12 +563,12 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { } else { stop("All elements of the list seed.nodes must be either -character- or -numeric-.") } - } else if (class(seed.nodes) == "numeric") { + } else if (inherits(seed.nodes, "numeric")) { message("Message: Object -seed.nodes- converted to a -list-.", "All behaviors will have the same -", seed.nodes, "- seed nodes.") seed.nodes <- replicate(length(seed.p.adopt), seed.nodes, simplify = FALSE) - } else if (class(seed.nodes) == "character") { + } else if (inherits(seed.nodes, "character")) { if (length(seed.nodes)==length(seed.p.adopt)) { seed.nodes <- as.list(seed.nodes) message("Message: Object -seed.nodes- converted to a -list-.", @@ -583,17 +583,17 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { stop("Unsupported -seed.nodes- value. See the manual for references.") } - if (class(behavior) == "list") { + if (inherits(behavior, "list")) { if (length(seed.p.adopt)!=length(behavior)) { stop("If -behavior- is a list, it must be of the same length as -seed.p.adopt-.") } - } else if (class(behavior) == "character" && length(behavior) > 1) { + } else if (inherits(behavior, "character") && length(behavior) > 1) { if (length(behavior) != length(seed.p.adopt)) { stop("Mismatch between length(behavior) and length(seed.p.adopt)") } else { behavior <- as.list(behavior) } - } else if (class(behavior) == "character" && length(behavior) == 1) { + } else if (inherits(behavior, "character") && length(behavior) == 1) { message(paste("Message: Name of 1 behavior provided, but", length(seed.p.adopt), "are needed. "), "Names generalized to 'behavior'_1, 'behavior'_2, etc.") behaviors <- list() @@ -609,7 +609,7 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { # For Single-diff. - if (length(seed.nodes) == 1 && class(seed.nodes)=="character") { + if (length(seed.nodes) == 1 && inherits(seed.nodes, "character")) { if (!seed.nodes %in% c("marginal", "central", "random")) { stop("Object -seed.nodes- is a -character- different from 'marginal', 'central', or 'random'.") diff --git a/tests/testthat/test-rdiffnet-parameters.R b/tests/testthat/test-rdiffnet-parameters.R index 88b2cc0..7fa3e18 100644 --- a/tests/testthat/test-rdiffnet-parameters.R +++ b/tests/testthat/test-rdiffnet-parameters.R @@ -11,18 +11,18 @@ test_that( behavior <- c("random behavior") rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - class(rdiffnet_args$seed.p.adopt) == "list" - class(rdiffnet_args$seed.nodes) == "list" - class(rdiffnet_args$behavior) == "list" + expect_type(rdiffnet_args$seed.p.adopt, "list") + expect_type(rdiffnet_args$seed.nodes, "list") + expect_type(rdiffnet_args$behavior, "list") seed.p.adopt <- 0.14 seed.nodes <- 'random' behavior <- "random behavior" rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - class(rdiffnet_args$seed.p.adopt) == "list" - class(rdiffnet_args$seed.nodes) == "list" - class(rdiffnet_args$behavior) == "list" + expect_type(rdiffnet_args$seed.p.adopt, "list") + expect_type(rdiffnet_args$seed.nodes, "list") + expect_type(rdiffnet_args$behavior, "list") # Must show ERROR @@ -104,40 +104,42 @@ test_that("Multi diff models rdiff args work", { seed.nodes <- "random" behavior <- "random behavior" rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + expect_type(rdiffnet_args$seed.p.adopt, "list") + expect_type(rdiffnet_args$seed.nodes, "list") + expect_type(rdiffnet_args$behavior, "list") seed.nodes <- c(1,3,5) rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + expect_type(rdiffnet_args$seed.nodes, "list") seed.nodes <- c('marginal',"central") rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + expect_type(rdiffnet_args$seed.nodes, "list") - seed.p.adopt <- list(0.14,0.05) - seed.nodes <- list('random', "central") behavior <- list("random behavior_1", "random behavior_2") rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - class(rdiffnet_args$seed.p.adopt) == "list" - class(rdiffnet_args$seed.nodes) == "list" - class(rdiffnet_args$behavior) == "list" + expect_type(rdiffnet_args$behavior, "list") behavior <- c("random behavior_1", "random behavior_2") rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - class(rdiffnet_args$behavior) == "list" + expect_type(rdiffnet_args$behavior, "list") behavior <- "random behavior" #Default rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - class(rdiffnet_args$behavior) == "list" + expect_type(rdiffnet_args$behavior, "list") + + behavior <- c("random behavior_1") + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + expect_type(rdiffnet_args$behavior, "list") seed.nodes <- c(1,3,5) behavior <- list("random behavior_1", "random behavior_2") rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - class(rdiffnet_args$seed.nodes) == 'list' + expect_type(rdiffnet_args$seed.nodes, "list") seed.nodes <- list('marginal',"central") rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - class(rdiffnet_args$seed.nodes) == 'list' - - behavior <- c("random behavior_1") - rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + expect_type(rdiffnet_args$seed.nodes, "list") # Must show ERROR diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index 57f81eb..380ffeb 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -107,9 +107,35 @@ test_that("Simulation study", { }) -# Test for multi diffusion --- +# Testing diffnet class across several inputs (single) +test_that("rdiffnet must run across several inputs (single)", { + expect_s3_class(rdiffnet(100, 5), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = 0.1), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = 0.1, seed.nodes = 'random'), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.nodes = c(1, 3, 5)), "diffnet") + + # summary + net_1 <- rdiffnet(100, 5, seed.nodes = c(1,3,5)) + expect_s3_class(summary(net_1), "data.frame") +}) + +# Testing diffnet class across several inputs (multiple) +test_that("rdiffnet must run across several inputs (multiple)", { + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08)), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), behavior = c('tabacco', 'alcohol')), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), seed.nodes = 'random'), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), seed.nodes = c('random', 'central')), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = 0.3), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = list(0.1, 0.2)), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = rexp(100)), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = list(rexp(100), runif(100))), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = function(x) 0.3), "diffnet") + expect_s3_class(rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = list(function(x) 0.3, function(x) 0.2)), "diffnet") + + net_2 <- rdiffnet(100, 5, seed.p.adopt = list(0.05,0.05), seed.nodes = c(1,3,5)) + expect_s3_class(summary(net_2), "data.frame") +}) -# Seed of first adopters test_that("All should be equal! (multiple)", { set.seed(12131) n <- 50 @@ -131,31 +157,6 @@ test_that("All should be equal! (multiple)", { }) -#single -rdiffnet(100, 5) -rdiffnet(100, 5, seed.p.adopt = 0.1) -rdiffnet(100, 5, seed.p.adopt = 0.1, seed.nodes = 'random') -rdiffnet(100, 5, seed.nodes = c(1,3,5)) -net_1 <- rdiffnet(100, 5, seed.nodes = c(1,3,5)) -summary(net_1) - -#multi -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08)) -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), behavior = c('tabacco', 'alcohol')) -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), seed.nodes = 'random') -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), seed.nodes = c('random', 'central')) -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = 0.3) -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(0.1,0.2)) -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = rexp(100)) -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(rexp(100),runif(100))) -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = function(x) 0.3) -rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(function(x) 0.3, function(x) 0.2)) - -net_1 <- rdiffnet(100, 5, seed.nodes = c(1,3,5)) -summary(net_1) -net_2 <- rdiffnet(100, 5, seed.p.adopt = list(0.05,0.05), seed.nodes = c(1,3,5)) -summary(net_2) - #rdiffnet(100, 5, seed.p.adopt = 0.9, threshold.dist = 2, exposure.args = list(normalized=FALSE)) # set.seed(1234) From 93dc056d5e063fad9aa7cc2e1fc8358f93c4c454 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Wed, 20 Nov 2024 16:39:31 -0700 Subject: [PATCH 34/34] checking the status of "dynamic" and "static" graphs. --- R/diffnet-class.r | 9 ++------- R/rdiffnet.r | 4 +++- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/R/diffnet-class.r b/R/diffnet-class.r index d968576..87163b3 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -577,7 +577,7 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm " respectively). ", "-toa- should be of length n (number of vertices).") } } - # Step 2.1: Checking class of TOA and coercing if necesary ------------------- + # Step 2.1: Checking class of TOA and coercing if necessary ------------------- if (num_of_behaviors==1) { if (!inherits(toa, "integer")) { warning("Coercing -toa- into integer.") @@ -635,11 +635,6 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm "Please provide lower and upper boundaries for the values in -toa- ", "using -t0- and -t- (see ?toa_mat).") } else { - - # This should be reviewed !! (here the graph becomes 'dynamic') - - warning("here the graph becomes 'dynamic' for multiple") - graph <- lapply(1:ncol(mat[[1]]$adopt), function(x) methods::as(graph, "dgCMatrix")) meta <- classify_graph(graph) } @@ -683,7 +678,7 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm # Removing dimnames graph <- Map(function(x) Matrix::unname(x), x=graph) - dimnames(toa) <- NULL + #dimnames(toa) <- NULL if (num_of_behaviors==1) { meta$behavior <- ifelse(!length(behavior), "", ifelse(is.na(behavior), "", diff --git a/R/rdiffnet.r b/R/rdiffnet.r index 025c3ba..f007ef1 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -490,7 +490,9 @@ rdiffnet <- function( # Checking attributes isself <- any(sapply(sgraph, function(x) any(Matrix::diag(x) != 0) )) - if (num_of_behaviors==1) {toa <- as.integer(toa)} + if (num_of_behaviors==1) { + toa <- as.integer(toa) + } new_diffnet( graph = sgraph,