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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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/17] 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 f8679000ba9b63d4cdacd904ae7a0bcd61c51c80 Mon Sep 17 00:00:00 2001 From: Anibal Olivera Morales Date: Mon, 11 Nov 2024 13:43:43 -0700 Subject: [PATCH 17/17] final commit to merge --- DESCRIPTION | 3 +- R/diffnet-class.r | 2 +- R/stats.R | 25 -------- playground/multidiff-test-discussion.R | 79 -------------------------- 4 files changed, 3 insertions(+), 106 deletions(-) delete mode 100644 playground/multidiff-test-discussion.R 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/stats.R b/R/stats.R index f547e51..501f10a 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/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))) - -})