diff --git a/DESCRIPTION b/DESCRIPTION index 11576da4..d095c62e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,6 +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"), + 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 740ccdc7..67047677 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 <- 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 3a479b20..659075cc 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, #set TRUE originally + 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 @@ -368,25 +369,67 @@ 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) - # 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 && 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]") + } + if (n*seed.p.adopt < 1) { + warning("Set of initial adopters 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") } - 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 && class(seed.nodes)!="list") { + # multi-diff. Something like seed.nodes <- c("marginal", "central"), and behavior.num <- 2 - if (length(seed.nodes) == 1) { + 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]) + marginal_d <- rownames(dg[order(dg, decreasing = FALSE), , drop = FALSE]) + } + + 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 && behavior.num == 1) { + # Single-diff. Something like seed.nodes <- "central" if (seed.nodes %in% c("central","marginal")) { @@ -401,34 +444,90 @@ 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) { + # 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")) { - d <- seed.nodes + 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") + } - # Setting seed nodes via vector - toa[d] <- 1L - cumadopt[d,] <- 1L + cumadopt <- array(0L, dim = c(n, t, behavior.num)) - # Step 3.0: Thresholds ------------------------------------------------------- - thr <- rdiffnet_make_threshold(threshold.dist, n) + # 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) # REMINDER TO CHANGE rdiffnet_make_threshold - # Running the simulation + # 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 @@ -439,19 +538,32 @@ 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), - 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 + ) + } } diff --git a/R/stats.R b/R/stats.R index 115c6f03..501f10ad 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 @@ -476,14 +476,28 @@ NULL # Checking self if (!self) graph <- sp_diag(graph, rep(0, nnodes(graph))) - ans <- ( graph %*% (attrs * cumadopt) ) + norm <- graph %*% attrs + 1e-20 - if (normalized) as.vector(ans/( graph %*% attrs + 1e-20 )) - else as.vector(ans) -} + 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 %*% (attrs * cumadopt[,,q]) / norm) + } else { + ans[,q] <- as.vector(graph_slice %*% (attrs * cumadopt[,,q])) + } + } + } else { + ans <- graph %*% (attrs * cumadopt) + + if (normalized) { + ans <- ans/ norm + } + } -# library(microbenchmark) -# microbenchmark(.exposure, netdiffuseR:::exposure_cpp) + return(as.vector(ans)) +} check_lags <- function(npers, lags) { @@ -611,10 +625,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_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 { + if (any(dim_attrs != dim(cumadopt))) stop("Incorrect size for -attrs-. ", + "It must be of size that -cumadopt-.") + } add_dimnames.mat(cumadopt) @@ -637,17 +660,56 @@ 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) + 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 = 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 = 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, valued, normalized, self) + 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 = 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 = outgoing, + valued = valued, + normalized = normalized, + self = self) + } + } } + return(out) } diff --git a/playground/exposure-ans-discussion.R b/playground/exposure-ans-discussion.R new file mode 100644 index 00000000..4aa581dd --- /dev/null +++ b/playground/exposure-ans-discussion.R @@ -0,0 +1,105 @@ +# Set dimensions +n <- 4 # Number of nodes +t <- 3 # Number of time steps +q <- 2 # Number of contagions + + +# 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) + +attrs <- matrix(c(1, 2, 3, + 4, 5, 6, + 7, 8, 9, + 10,11,12), nrow = n) + +cumadopt <- array(c(1,2,3, + 4,5,6, + 7,8,9, + 10,11,12), dim = c(n,t)) + +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 + +# NEW: Graph -> n x n +# attrs -> n x T +# cumadopt-> n x T x q +# 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)) +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) + +# OR THIS + + + +ans <- array(0, dim = c(ncol(graph),dim(cumadopt)[2],dim(cumadopt)[3])) +norm <- graph %*% attrs + 1e-20 + +normalized <- TRUE + +for (k in seq_len(q)) { + if (normalized) { + ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) / norm + } else { + ans[,,k] <- graph %*% (attrs * cumadopt[,,k]) + } +} + +as.vector(ans) + + +ans +dim(ans) diff --git a/playground/exposure-out-discussion.R b/playground/exposure-out-discussion.R new file mode 100644 index 00000000..9dbc8510 --- /dev/null +++ b/playground/exposure-out-discussion.R @@ -0,0 +1,207 @@ +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 T x q + +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) + +# 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 +.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[,,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 <- ans/ norm + } + } + + #as.vector(ans) + return(as.vector(ans)) +} + +# for static graphs it returns `1L` +# nslices --> from diffnet-methods + +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])) + + 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 <- cumadopt_one + +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/tests/testthat/test-stats.R b/tests/testthat/test-stats.R index 939836dd..ad929e6c 100644 --- a/tests/testthat/test-stats.R +++ b/tests/testthat/test-stats.R @@ -1,10 +1,92 @@ context("Stats functions (including exposure)") -test_that("exposure calculations", { +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) + diffnet <- rdiffnet(40, 5, seed.p.adopt = .1) + # Default ans0 <- exposure(diffnet) ans1 <- as.matrix(do.call(cbind,lapply(diffnet$meta$pers, function(x) {