From 1efc0be4539d23ab800187c73551624834038e00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?An=C3=ADbal=20Olivera=20M=2E?= <156018168+aoliveram@users.noreply.github.com> Date: Fri, 6 Dec 2024 02:47:41 -0300 Subject: [PATCH] split_behaviors - function (#51) * Adding myself to the project * Some discussion about the dimensions of ans (exposure calculation) * just fixing a paragraph in Ego exposure * looking as.vector things * out object from exposure_for() * More dimensional analysis. Changes to avoid ambiguous names * stats.R fixed * out object (in exposure_for() function) now allows q diff processes * Working forms of .exposure, exposure_for, and exposure.list * updates for .exposure and exposure.list functions * correcting labels of variables * Fixing tests of diffnet * changes to exposure.list() to allow arrays of cumadopt. Add multidiff-test-discussion too. * aditional test -multidiffusion exposure calculations- * updating to Steps 1.1 (initial adopters) and 1.2 (finding seed nodes) in rdiffnet function * updating cumadopt, exposure simulation, and toa for multi-diff processes * adding a set of tests for rdiffnet_validate_args function * rdiffnet function updated to allow multi-diff. An small error in rdiffnet_check_seed_graph fixed. * generalization of rdiffnet_make_threshold function. Some others modification following the merge of the 41... branch * lot of work in new_diffnet and toa_mat functions. New tests for rdiffnet_make_threshold. Some modification in rdiffnet too. Not expecting to work yet. * changes in new_diffnet and toa_mat. Now all the original tests for those functions are pass. * updating rdiffnet_validate_args to allow objects seed.nodes different from -list-. For example: rdiffnet(100,10, seed.p.adopt = list(.1, .05)), or adding seed.nodes=c(1,2,3,4), seed.nodes=random, or seed.nodes=c(random,central). Respective tests added. * rdiffnet now allow multiple diff, showing the results. There is still work to be done to display a line saying 'number of behaviors', and to fix the summary() function. * rdiffnet now allow multiple diff, showing the results. There is still work to be done to display a line saying 'number of behaviors', and to fix the summary() function. * Now rdiffnet allow multiple diff, and shows the name -Behavior-, -Num of behaviors-, and * some minor changes in summary.diffnet * advances in summary.diffnet() for multi-diff, but this will be change to something more simple later * changes in exposure.list and exposure_for to allow personalized attrs in multi-diff * minor changes in toa_mat * now new_diffnet sets the num_of behavior internally * more changes to toa_mat to compute num_of_adoption on more classes * now toa_mat can compute adopt and cumadopt from diffnet (multiple) and matrix objects. The same tests for single behavior were adapted. * all comments were addressed, except -behavior- as a vector. * checking the status of "dynamic" and "static" graphs. * draft of split_behaviors(), with tests. * a buch of things: 1. new test for toa_diff with diffnet obj as input, 2. modifications to toa_diff, now allowing for matrix and multiple-diff diffnet obj, 3. tests for toa_diff with multi-diff inputs, 4. adding split_behavior as new function in rdiffnet, and 5. adding tests for split_behaviors in test-rdiffnet * improving readability of toa_diff * Adding disadopt * Removing weird code * Adding prototype of disadopt * Adding missing file * saving local changes * changes to toa in rdiffnet. Now the test -Disadoption works- actually works. Nevertheless, there are a couple of failures that we have to fix. * Add something to the vignet, and modifications to rdiffnet, in calculating toa * Adding missing is.na() when checking new adopters * Adding the specific q, is.na(toa[,q]). Now works. * Fixing summary.diffnet() for multi-diff * Updating documentation for exposure() * Adding split_behavior for NAMESPACE * Add -behavior- to be splitted in split_behavior * Example for split_behavior documentation * Adding documentation and examples to rdiffnet * More documentation to split_behaviors and new_diffnet * Updating documentation for toa_mat * Adding documentation for rdiffnet, with random disadoption example * Updating toa_diff documentation --------- Co-authored-by: George G. Vega Yon --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/adjmat.r | 183 ++++++++--- R/diffnet-class.r | 30 +- R/diffnet-methods.r | 104 +++--- R/rdiffnet.r | 235 ++++++++++--- R/stats.R | 45 ++- man/brfarmers.Rd | 8 +- man/brfarmersDiffNet.Rd | 8 +- man/dgr.Rd | 2 +- man/diffnet-class.Rd | 30 +- man/diffusion-data.Rd | 10 +- man/diffusionMap.Rd | 2 +- man/drawColorKey.Rd | 2 +- man/exposure.Rd | 51 ++- man/fakeDynEdgelist.Rd | 10 +- man/fakeEdgelist.Rd | 10 +- man/fakesurvey.Rd | 8 +- man/fakesurveyDyn.Rd | 8 +- man/grid_distribution.Rd | 2 +- man/hazard_rate.Rd | 2 +- man/kfamily.Rd | 8 +- man/kfamilyDiffNet.Rd | 8 +- man/medInnovations.Rd | 6 +- man/medInnovationsDiffNet.Rd | 6 +- man/plot_adopters.Rd | 2 +- man/plot_infectsuscep.Rd | 2 +- man/plot_threshold.Rd | 10 +- man/rdiffnet.Rd | 107 ++++-- man/rescale_vertex_igraph.Rd | 2 +- man/toa_diff.Rd | 42 ++- man/toa_mat.Rd | 43 ++- playground/split_behavior_discussion.R | 169 ++++++++++ tests/testthat/test-adjmat.R | 27 +- tests/testthat/test-rdiffnet-parameters.R | 10 + tests/testthat/test-rdiffnet.R | 54 ++- ...ulating-multiple-behaviors-on-networks.Rmd | 311 ++++++++++++++++++ 37 files changed, 1282 insertions(+), 278 deletions(-) create mode 100644 playground/split_behavior_discussion.R create mode 100644 vignettes/simulating-multiple-behaviors-on-networks.Rmd diff --git a/DESCRIPTION b/DESCRIPTION index d095c62e..50780a16 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -51,7 +51,7 @@ Suggests: survival VignetteBuilder: knitr LinkingTo: Rcpp, RcppArmadillo -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Encoding: UTF-8 URL: https://github.com/USCCANA/netdiffuseR, https://USCCANA.github.io/netdiffuseR/ diff --git a/NAMESPACE b/NAMESPACE index 04314db4..0e4f522d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -173,6 +173,7 @@ export(rgraph_ws) export(ring_lattice) export(round_to_seq) export(select_egoalter) +export(split_behaviors) export(struct_equiv) export(struct_test) export(struct_test_asymp) diff --git a/R/adjmat.r b/R/adjmat.r index c0b08c99..ca5bc83c 100644 --- a/R/adjmat.r +++ b/R/adjmat.r @@ -396,35 +396,19 @@ adjmat_to_edgelist.list <- function(graph, undirected, keep.isolates) { return(cbind(edgelist, times=times)) } -# # Benchmark with the previous version -# library(microbenchmark) -# library(netdiffuseR) -# -# dat <- as.data.frame(cbind(edgelist, w)) -# colnames(dat) <- c('ego','alter','tie') -# microbenchmark( -# adjmatbuild(dat,n,1:n), -# edgelist_to_adjmat(edgelist, w), times=100) -# -# old <- adjmatbuild(dat[,-3],n,1:n) -# new <- (edgelist_to_adjmat(unique(edgelist), undirected = FALSE))[,,1] -# arrayInd(which(old!=new), dim(old), dimnames(old)) -# -# ## Dynamic -# microbenchmark( -# adjByTime(cbind(year=times,dat),n,max(times)), -# edgelist_to_adjmat(edgelist, w, times), times=100) - #' Time of adoption matrix #' -#' Creates two matrices recording times of adoption of the innovation. One matrix +#' For a single behavior, creates two matrices recording times of adoption of the innovation. One matrix #' records the time period of adoption for each node with zeros elsewhere. The #' second records the cumulative time of adoption such that there are ones for -#' the time of adoption and every time period thereafter. -#' -#' @param obj Either an integer vector of size \eqn{n} containing time of adoption of the innovation, -#' or a \code{\link{diffnet}} object. -#' @param labels Character vector of size \eqn{n}. Labels (ids) of the vertices. +#' the time of adoption and every time period thereafter. For \eqn{Q} behaviors, +#' creates a list of length \eqn{Q}, where each element contains those two +#' matrices for each behavior. +#' +#' @param obj Either an integer vector of length \eqn{n} containing time of adoption +#' of the innovation, a matrix of size \eqn{n \times Q} (for multiple \eqn{Q} behaviors), or +#' a \code{\link{diffnet}} object (both for single or multiple behaviors). +#' @param labels Character vector of length \eqn{n}. Labels (ids) of the vertices. #' @param t0 Integer scalar. Sets the lower bound of the time window (e.g. 1955). #' @param t1 Integer scalar. Sets the upper bound of the time window (e.g. 2000). #' @details @@ -446,6 +430,12 @@ adjmat_to_edgelist.list <- function(graph, undirected, keep.isolates) { #' 2005 - 2000 + 1 = 6 columns instead of 2005 - 2001 + 1 = 5 columns, with the #' first column of the two matrices containing only zeros (as the first adoption #' happend after the year 2000). +#' +#' For multiple behaviors, the input can be a matrix or a \code{diffnet} object. +#' In this case, the output will be a list, with each element replicating the output +#' for a single diffusion: a matrix recording the time period of adoption for +#' each node, and a second matrix with ones from the moment the node adopts the behavior. +#' #' @examples #' # Random set of times of adoptions #' times <- sample(c(NA, 2001:2005), 10, TRUE) @@ -454,14 +444,32 @@ adjmat_to_edgelist.list <- function(graph, undirected, keep.isolates) { #' #' # Now, suppose that we observe the graph from 2000 to 2006 #' toa_mat(times, t0=2000, t1=2006) +#' +#' # For multiple behaviors, the input can be a matrix.. +#' times_1 <- c(2001L, 2004L, 2003L, 2008L) +#' times_2 <- c(2001L, 2005L, 2006L, 2008L) +#' times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) +#' +#' toa <- toa_mat(times) +#' toa[[1]]$adopt # time period of adoption for the first behavior +#' +#' #.. or a diffnet object +#' graph <- lapply(2001:2008, function(x) rgraph_er(4)) +#' diffnet <- new_diffnet(graph, times) +#' +#' toa <- toa_mat(diffnet) +#' toa[[1]]$cumadopt # cumulative adoption matrix for the first behavior + #' #' @export -#' @return A list of two \eqn{n \times T}{n x T} -#' \item{\code{cumadopt}}{has 1's for all years in which a node indicates having the innovation.} -#' \item{\code{adopt}}{has 1's only for the year of adoption and 0 for the rest.} +#' @return For a single behavior, a list of two \eqn{n \times T}{n x T}: +#' \item{\code{cumadopt}}{ has 1's for all years in which a node indicates having the innovation.} +#' \item{\code{adopt}}{ has 1's only for the year of adoption and 0 for the rest.} +#' For \eqn{Q} behaviors, a list of length \eqn{Q}, each element containing +#' \code{cumadopt} ans \code{adopt} matrices. #' @keywords manip #' @include graph_data.r -#' @author George G. Vega Yon & Thomas W. Valente +#' @author George G. Vega Yon, Thomas W. Valente, and Aníbal Olivera M. toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) { if (inherits(obj, "matrix")) { @@ -581,33 +589,132 @@ toa_mat.integer <- function(times, labels=NULL, #' Difference in Time of Adoption (TOA) between individuals #' -#' Creates \eqn{n \times n}{n * n} matrix indicating the difference in times of adoption between -#' each pair of nodes +#' Creates an \eqn{n \times n}{n * n} matrix, or for \eqn{Q}{Q} behaviors, a list +#' of length \eqn{Q}{Q} containing \eqn{n \times n}{n * n} matrices, that indicates +#' the difference in adoption times between each pair of nodes. #' @inheritParams toa_mat -#' @details Each cell ij of the resulting matrix is calculated as \eqn{toa_j - toa_i}{% +#' @details Each cell \eqn{ij}{ij} of the resulting matrix is calculated as \eqn{toa_j - toa_i}{% #' toa(j) - toa(i)}, so that whenever its positive it means that the j-th individual (alter) #' adopted the innovation sooner. -#' @return An \eqn{n \times n}{n * n} symmetric matrix indicating the difference in times of +#' @return An \eqn{n \times n}{n * n} anti-symmetric matrix (or a list of them, +#' for \eqn{Q}{Q} behaviors) indicating the difference in times of #' adoption between each pair of nodes. #' @export #' @examples +#' # For a single behavior ----------------------------------------------------- +#' #' # Generating a random vector of time #' set.seed(123) #' times <- sample(2000:2005, 10, TRUE) #' #' # Computing the TOA differences #' toa_diff(times) +#' +#' # For Q=2 behaviors --------------------------------------------------------- +#' +#' # Generating a matrix time +#' +#' times_1 <- c(2001L, 2004L, 2003L, 2008L) +#' times_2 <- c(2001L, 2005L, 2006L, 2008L) +#' times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) +#' +#' # Computing the TOA differences +#' toa_diff(times) +#' +#' # Or, from a diffnet object +#' +#' graph <- lapply(2001:2008, function(x) rgraph_er(4)) +#' diffnet <- new_diffnet(graph, times) +#' +#' # Computing the TOA differences +#' toa_diff(diffnet) +#' + +#' #' @keywords manip #' @include graph_data.r -#' @author George G. Vega Yon & Thomas W. Valente +#' @author George G. Vega Yon, Thomas W. Valente, and Aníbal Olivera M. toa_diff <- function(obj, t0=NULL, labels=NULL) { # Calculating t0 (if it was not provided) - if (!inherits(obj, "diffnet") && !length(t0)) + if (!inherits(obj, "diffnet") && !length(t0)){ t0 <- as.integer(min(obj, na.rm = TRUE)) - else - t0 <- obj$meta$pers[1] + } else { + t0 <- obj$meta$pers[1]} + + # determining num_of_behavior and prepare for multi-diffusion + num_of_behavior <- 1 + multiple <- FALSE + + if (inherits(obj, "matrix")) { # multiple + num_of_behavior <- ncol(obj) + obj <- lapply(asplit(obj, MARGIN = 2), as.integer) + multiple <- TRUE + } else if (inherits(obj, "diffnet")) { + if (inherits(obj$toa, "matrix")) { # multiple + num_of_behavior <- ncol(obj$toa) + obj <- split_behaviors(obj) + multiple <- TRUE + } + } + + if (multiple) { + out_list <- lapply(seq_len(num_of_behavior), function(q) toa_diff.unique(obj[[q]], t0)) + return(out_list) + } else { + return(toa_diff.unique(obj, t0)) + } +} + +# +# +# if (multiple) { +# for (q in 1:ncol(obj$toa)) { +# +# +# # Calculating t0 (if it was not provided) +# if (!inherits(obj, "diffnet") && !length(t0)) { +# t0 <- as.integer(min(obj[,q], na.rm = TRUE)) +# } else { +# t0 <- obj$meta$pers[1]} +# +# # Computing the difference +# if (inherits(obj, "integer")) { +# out <- toa_diff_cpp(obj - t0 + 1L) +# } else if (inherits(obj, "numeric")) { +# warning("coercing -obj- to integer.") +# out <- toa_diff_cpp(as.integer(obj) - t0 + 1L) +# } else if (inherits(obj, "diffnet")) { +# out <- toa_diff_cpp(obj$toa - t0 + 1L) +# } else stop("No method defined for class -",class(obj),"-") +# +# out +# +# } +# +# +# } else { +# # Calculating t0 (if it was not provided) +# if (!inherits(obj, "diffnet") && !length(t0)) +# t0 <- as.integer(min(obj, na.rm = TRUE)) +# else +# t0 <- obj$meta$pers[1] +# +# # Computing the difference +# if (inherits(obj, "integer")) { +# out <- toa_diff_cpp(obj - t0 + 1L) +# } else if (inherits(obj, "numeric")) { +# warning("coercing -obj- to integer.") +# out <- toa_diff_cpp(as.integer(obj) - t0 + 1L) +# } else if (inherits(obj, "diffnet")) { +# out <- toa_diff_cpp(obj$toa - t0 + 1L) +# } else stop("No method defined for class -",class(obj),"-") +# +# return(out) +# } +# } +toa_diff.unique <- function(obj, t0) { # Computing the difference if (inherits(obj, "integer")) { out <- toa_diff_cpp(obj - t0 + 1L) @@ -618,7 +725,7 @@ toa_diff <- function(obj, t0=NULL, labels=NULL) { out <- toa_diff_cpp(obj$toa - t0 + 1L) } else stop("No method defined for class -",class(obj),"-") - out + return(out) } # @rdname toa_diff diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 87163b3f..1858da85 100644 --- a/R/diffnet-class.r +++ b/R/diffnet-class.r @@ -321,16 +321,18 @@ check_as_diffnet_attrs <- function(attrs, meta, is.dynamic, id.and.per.vars=NULL #' Creates a \code{diffnet} class object #' -#' \code{diffnet} objects contain difussion networks. With adjacency -#' matrices and time of adoption (toa) vector as its main components, most of the -#' package's functions have methods for this class of objects. +#' \code{diffnet} objects contain diffusion networks. With adjacency +#' matrices and time of adoption (toa) vector (or matrix, for multiple behavior diffusion), +#' as its main components, most of the package's functions have methods for this class of objects. #' #' @templateVar dynamic TRUE #' @templateVar undirected TRUE #' @templateVar self TRUE #' @templateVar multiple TRUE #' @template graph_template -#' @param toa Numeric vector of size \eqn{n}. Times of adoption. +#' @param toa Numeric vector of size \eqn{n}. Times of adoption. For \eqn{Q}{Q} +#' multiple behavior diffusion, \code{toa} must be a matrix \eqn{n \times Q}{n * Q} +#' (see \code{\link{rdiffnet}}, examples of multiple behavior diffusion). #' @param t0 Integer scalar. Passed to \code{\link{toa_mat}}. #' @param t1 Integer scalar. Passed to \code{\link{toa_mat}}. #' @param ... Further arguments passed to the jmethod. @@ -418,6 +420,8 @@ check_as_diffnet_attrs <- function(attrs, meta, is.dynamic, id.and.per.vars=NULL #' @aliases diffnet diffnet-class #' @examples #' +#' # Creating a diffnet object from TOA (time of adoption) --------------------- +#' #' # Creating a random graph #' set.seed(123) #' graph <- rgraph_ba(t=9) @@ -435,6 +439,16 @@ check_as_diffnet_attrs <- function(attrs, meta, is.dynamic, id.and.per.vars=NULL #' # Plotting slice 4 #' plot(diffnet, t=4) #' +#' # A diffnet object from TOA of multiple behaviors --------------------------- +#' +#' # TOA for two behaviors +#' toa_matrix <- matrix(sample(c(2001L:2005L,NA), 20, TRUE), ncol = 2) +#' +#' # Creating diffnet object +#' diffnet_multi <- new_diffnet(graph, toa_matrix) +#' diffnet_multi +#' summary(diffnet_multi) +#' #' # ATTRIBUTES ---------------------------------------------------------------- #' #' # Retrieving attributes @@ -491,9 +505,11 @@ check_as_diffnet_attrs <- function(attrs, meta, is.dynamic, id.and.per.vars=NULL #' A list of class \code{diffnet} with the following elements: #' \item{graph}{A list of length \eqn{T}. Containing sparse square matrices of size \eqn{n} #' and class \code{\link[Matrix:dgCMatrix-class]{dgCMatrix}}.} -#' \item{toa}{An integer vector of size \eqn{T} with times of adoption.} +#' \item{toa}{An integer vector of length \eqn{n} with times of adoption. When \eqn{Q}{Q} multiple +#' behavior diffusion is selected, a matrix of size \eqn{n \times Q}{n * Q}}. #' \item{adopt, cumadopt}{Numeric matrices of size \eqn{n\times T}{n*T} as those returned -#' by \code{\link{toa_mat}}.} +#' by \code{\link{toa_mat}}. For \eqn{Q}{Q} multiple behavior diffusion, \code{adopt} and \code{cumadopt} +#' become a list of \eqn{n\times T}{n*T} elements, with \eqn{Q}{Q} elements.} #' \item{vertex.static.attrs}{If not NULL, a data frame with \eqn{n} rows with vertex static #' attributes.} #' \item{vertex.dyn.attrs}{A list of length \eqn{T} with data frames containing vertex attributes @@ -514,7 +530,7 @@ check_as_diffnet_attrs <- function(attrs, meta, is.dynamic, id.and.per.vars=NULL #' \item \code{behavior}: Character scalar. #' } #' } -#' @author George G. Vega Yon +#' @author George G. Vega Yon & Aníbal Olivera M. #' @name diffnet-class NULL diff --git a/R/diffnet-methods.r b/R/diffnet-methods.r index 95b420e3..239634d1 100644 --- a/R/diffnet-methods.r +++ b/R/diffnet-methods.r @@ -182,12 +182,12 @@ print.diffnet <- function(x, ...) { #' @family diffnet methods #' summary.diffnet <- function( - object, - slices = NULL, - no.print = FALSE, - skip.moran = FALSE, - valued = getOption("diffnet.valued",FALSE), - ...) { + object, + slices = NULL, + no.print = FALSE, + skip.moran = FALSE, + valued = getOption("diffnet.valued",FALSE), + ...) { # Subsetting if (!length(slices)) slices <- 1:object$meta$nper @@ -216,8 +216,8 @@ summary.diffnet <- function( # identify single-diff from multi-diff single <- !inherits(object$cumadopt, "list") - # Computing moran's I if (single) { + # Computing moran's I if (!skip.moran) { m <- matrix(NA, nrow=length(slices), ncol=4, dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval"))) @@ -230,6 +230,7 @@ summary.diffnet <- function( m[i,] <- unlist(moran(object$cumadopt[,slices[i]], g)) } + } # Computing new adopters, cumadopt and hazard rate ad <- colSums(object$adopt[,slices,drop=FALSE]) @@ -253,13 +254,16 @@ summary.diffnet <- function( } if (no.print) return(out) - } } else { - if (!skip.moran) { - out_list <- list() - data_beh_list <- list() - for (q in 1:length(object$cumadopt)) { + + out_list <- list() + data_beh_list <- list() + + for (q in 1:length(object$cumadopt)) { + + if (!skip.moran) { + #for (q in 1:length(object$cumadopt)) { m <- matrix(NA, nrow=length(slices), ncol=4, dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval"))) @@ -270,42 +274,42 @@ summary.diffnet <- function( m[i,] <- unlist(moran(object$cumadopt[[q]][,slices[i]], g)) } + #} + } - # Computing new adopters, cumadopt and hazard rate - ad <- colSums(object$adopt[[q]][,slices,drop=FALSE]) - ca <- t(cumulative_adopt_count(object$cumadopt[[q]]))[slices,-3, drop=FALSE] - hr <- t(hazard_rate(object$cumadopt[[q]], no.plot = TRUE))[slices,,drop=FALSE] - - # Left censoring - lc <- sum(object$toa[,q] == meta$pers[1], na.rm = TRUE) - rc <- sum(is.na(object$toa[,q]), na.rm=TRUE) - - #data_beh_list[[q]] <- list(ad, ca, hr, lc, rc) + # Computing new adopters, cumadopt and hazard rate + ad <- colSums(object$adopt[[q]][,slices,drop=FALSE]) + ca <- t(cumulative_adopt_count(object$cumadopt[[q]]))[slices,-3, drop=FALSE] + hr <- t(hazard_rate(object$cumadopt[[q]], no.plot = TRUE))[slices,,drop=FALSE] - out <- data.frame( - adopt = ad, - cum_adopt = ca[,1], - cum_adopt_pcent = ca[,2], - hazard = hr, - density=d - ) + # Left censoring + lc <- sum(object$toa[,q] == meta$pers[1], na.rm = TRUE) + rc <- sum(is.na(object$toa[,q]), na.rm=TRUE) - if (!skip.moran) { - out <- cbind(out, m) - } + data_beh_list[[q]] <- c(lc, rc) - if (no.print) return(out) + out <- data.frame( + adopt = ad, + cum_adopt = ca[,1], + cum_adopt_pcent = ca[,2], + hazard = hr, + density=d + ) - out_list[[q]] <- out + if (!skip.moran) { + out <- cbind(out, m) } + + out_list[[q]] <- out } + + if (no.print) return(out) } # Function to print data.frames differently header <- c(" Period "," Adopters "," Cum Adopt. (%) ", " Hazard Rate "," Density ", - if (!skip.moran) c(" Moran's I (sd) ") else NULL - ) + if (!skip.moran) c(" Moran's I (sd) ") else NULL) slen <- nchar(header) hline <- paste(sapply(sapply(slen, rep.int, x="-"), paste0, collapse=""), @@ -315,27 +319,34 @@ summary.diffnet <- function( # Quick Formatting function qf <- function(x, digits=2) sprintf(paste0("%.",digits,"f"), x) + # Start printing result cat("Diffusion network summary statistics\n", - "Name : ", meta$name, "\n", - "Behavior : ", meta$behavior, "\n", - rule,"\n",sep="") - cat(header,"\n") - cat(hline, "\n") + "Name : ", meta$name, "\n") if (single) { + cat(" Behavior : ", meta$behavior, "\n", + rule,"\n",sep="") + cat(header,"\n") + cat(hline, "\n") summary_diffnet_out_display(out, slen, meta, slices, qf, skip.moran) + cat(rule, "\n", + paste("Left censoring :", sprintf("%3.2f (%d)", lc/meta$n, lc)), "\n", + paste("Right centoring :", sprintf("%3.2f (%d)", rc/meta$n, rc)), "\n") } else { + beh_names <- strsplit(meta$behavior, ", ")[[1]] for (q in 1:length(object$cumadopt)) { + cat("\n Behavior : ", beh_names[q], "\n", + rule,"\n",sep="") + cat(header,"\n") + cat(hline, "\n") summary_diffnet_out_display(out_list[[q]], slen, meta, slices, qf, skip.moran) + cat(rule, "\n", + paste("Left censoring :", sprintf("%3.2f (%d)", lc/meta$n, data_beh_list[[q]][1])), "\n", + paste("Right centoring :", sprintf("%3.2f (%d)", rc/meta$n, data_beh_list[[q]][2])), "\n") } } - # print(out, digits=2) - cat( - rule, - paste(" Left censoring :", sprintf("%3.2f (%d)", lc/meta$n, lc)), - paste(" Right centoring :", sprintf("%3.2f (%d)", rc/meta$n, rc)), paste(" # of nodes :", sprintf("%d",meta$n)), "\n Moran's I was computed on contemporaneous autocorrelation using 1/geodesic", " values. Significane levels *** <= .01, ** <= .05, * <= .1.", @@ -345,6 +356,7 @@ summary.diffnet <- function( invisible(out) } + summary_diffnet_out_display <- function(out, slen, meta, slices, qf, skip.moran) { for (i in 1:nrow(out)) { cat(sprintf( diff --git a/R/rdiffnet.r b/R/rdiffnet.r index f007ef13..21f7bdb2 100644 --- a/R/rdiffnet.r +++ b/R/rdiffnet.r @@ -1,25 +1,32 @@ #' Random diffnet network #' #' Simulates a diffusion network by creating a random dynamic network and -#' adoption threshold levels. +#' adoption threshold levels. You can perform a simulation for a single behavior +#' (using \code{seed.p.adopt} of class \code{numeric} in \code{rdiffnet}), +#' conduct multiple simulations for a single behavior (with \code{rdiffnet_multiple}), +#' or run a simulation with multiple behaviors simultaneously (using \code{seed.p.adopt} +#' of class \code{list} in \code{rdiffnet}) #' #' @param n Integer scalar. Number of vertices. #' @param t Integer scalar. Time length. -#' @param seed.nodes Either a character scalar or a vector. Type of seed nodes (see details). -#' @param seed.p.adopt Numeric scalar. Proportion of early adopters. +#' @param seed.nodes Either a character scalar, a vector or a list (multiple behaviors only). +#' Type of seed nodes (see details). +#' @param seed.p.adopt Numeric scalar or a list (multiple behaviors only). Proportion of early adopters. #' @param seed.graph Baseline graph used for the simulation (see details). #' @param rgraph.args List. Arguments to be passed to rgraph. #' @param rewire Logical scalar. When TRUE, network slices are generated by rewiring #' (see \code{\link{rewire_graph}}). #' @param rewire.args List. Arguments to be passed to \code{\link{rewire_graph}}. -#' @param threshold.dist Either a function to be applied via \code{\link{sapply}}, -#' a numeric scalar, or a vector/matrix with \eqn{n} elements. Sets the adoption +#' @param threshold.dist For a single behavior diffusion, either a function to be applied via \code{\link{sapply}}, +#' a numeric scalar, or a vector/matrix with \eqn{n} elements. For \eqn{Q} behavior diffusion, +#' it can also be an \eqn{n \times Q} matrix or a list of \eqn{Q} single behavior inputs. Sets the adoption #' threshold for each node. #' @param exposure.args List. Arguments to be passed to \code{\link{exposure}}. #' @param name Character scalar. Passed to \code{\link{as_diffnet}}. -#' @param behavior Character scalar. Passed to \code{\link{as_diffnet}}. +#' @param behavior Character scalar or a list or character scalar (multiple behaviors only). Passed to \code{\link{as_diffnet}}. #' @param stop.no.diff Logical scalar. When \code{TRUE}, the function will return #' with error if there was no diffusion. Otherwise it throws a warning. +#' @param disadopt Function of disadoption, with current exposition, cumulative adoption, and time as possible inputs. #' @return A random \code{\link{diffnet}} class object. #' @family simulation functions #' @details @@ -33,7 +40,7 @@ #' \item Using \code{seed.graph}, a baseline graph is created. #' \item Given the baseline graph, the set of initial adopters is defined #' using \code{seed.nodes}. -#' \item Afterwards, if \code{rewire=TRUE} \eqn{t-1} slices of the network are created +#' \item Afterwards, if \code{rewire=TRUE}, \eqn{t-1} slices of the network are created #' by iteratively rewiring the baseline graph. #' \item The \code{threshold.dist} function is applied to each node in the graph. #' \item Simulation starts at \eqn{t=2} assigning adopters in each time period @@ -41,9 +48,12 @@ #' } #' #' When \code{seed.nodes} is a character scalar it can be \code{"marginal"}, \code{"central"} or \code{"random"}, -#' So each of these values sets the initial adopters using the vertices with lowest -#' degree, with highest degree or completely randomly. The number of early adoptes -#' is set as \code{seed.p.adopt * n}. Please note that when marginal nodes are +#' so each of these values sets the initial adopters using the vertices with lowest +#' degree, with highest degree or completely randomly. +#' +#' For a single behavior diffusion, the number of early adopters is set as \code{seed.p.adopt * n}. +#' To run multiple behavior diffusion, \code{seed.p.adopt} must be a \code{list} (see examples below). +#' Please note that when marginal nodes are #' set as seed it may be the case that no diffusion process is attained as the #' chosen set of first adopters can be isolated. Any other case will be considered #' as an index (via \code{\link{[<-}} methods), hence the user can manually set the set of initial adopters, for example @@ -92,22 +102,76 @@ #' } #' #' @examples -#' # A simple example ----------------------------------------------------------- +#' # (Single behavior): -------------------------------------------------------- +#' +#' # A simple example #' set.seed(123) -#' z <- rdiffnet(100,10) -#' z -#' summary(z) +#' diffnet_1 <- rdiffnet(100,10) +#' diffnet_1 +#' summary(diffnet_1) +#' +#' # Adopt if at least two neighbors have adopted ------ +#' n <- 100; t <- 5; +#' graph <- rgraph_ws(n, t, p=.3) #' -#' # A more complex example: Adopt if at least one neighbor has adopted -------- -#' y <- rdiffnet(100, 10, threshold.dist=function(x) 1, +#' diffnet_2 <- rdiffnet(seed.graph = graph, t = t, threshold.dist=function(x) 2, #' exposure.args=list(valued=FALSE, normalized=FALSE)) #' -#' # Re thinking the Adoption of Tetracycline ---------------------------------- +#' # Re thinking the Adoption of Tetracycline ---------- #' newMI <- rdiffnet(seed.graph = medInnovationsDiffNet$graph, #' threshold.dist = threshold(medInnovationsDiffNet), rewire=FALSE) #' +#' # (Multiple behavior): ------------------------------------------------------ +#' +#' # A simple example +#' set.seed(123) +#' diffnet_3 <- rdiffnet(100, 10, seed.p.adopt = list(0.1, 0.15)) +#' diffnet_3 +#' summary(diffnet_3) +#' +#' # Fully specified multi-behavior example ------------ +#' +#' threshold_matrix <- matrix(runif(n * 2), nrow = n, ncol = 2) +#' seed_nodes <- sample(1:100, 10, replace = FALSE) +#' diffnet_4 <- rdiffnet(100, 10, seed.p.adopt = list(0, 0), +#' seed.nodes = list(seed_nodes, seed_nodes), +#' threshold.dist = threshold_matrix, +#' behavior = c("tobacco", "alcohol")) +#' diffnet_4 +#' +#' # Adopt if at least one neighbor has adopted the first behavior, +#' # and at least two neighbors have adopted the second behavior. --- +#' +#' diffnet_5 <- rdiffnet(seed.graph = graph, t = t, seed.p.adopt = list(0.1, 0.1), +#' threshold.dist = list(function(x) 2, function(x) 2), +#' exposure.args=list(valued=FALSE, normalized=FALSE)) +#' diffnet_5 +#' +#' # With a disadoption function ----------------------- #' -#' @author George G. Vega Yon +#' set.seed(1231) +#' +#' random_dis <- function(expo, cumadopt, time) { +#' num_of_behaviors <- dim(cumadopt)[3] +#' +#' list_disadopt <- list() +#' +#' for (q in 1:num_of_behaviors) { +#' adopters <- which(cumadopt[, time, q, drop=FALSE] == 1) +#' if (length(adopters) == 0) { +#' # only disadopt those behaviors with adopters +#' list_disadopt[[q]] <- integer() +#' } else { +#' # selecting 10% of adopters to disadopt +#' list_disadopt[[q]] <- sample(adopters, ceiling(0.10 * length(adopters))) +#' } +#' } +#' return(list_disadopt) +#' } +#' +#' diffnet_6 <- rdiffnet(seed.graph = graph, t = 10, disadopt = random_dis, seed.p.adopt = list(0.1, 0.1)) +#' +#' @author George G. Vega Yon & Aníbal Olivera M. #' @name rdiffnet NULL @@ -254,7 +318,8 @@ rdiffnet_check_seed_graph <- function(seed.graph, rgraph.args, t, n) { #' \code{\link[parallel:parSapply]{parSapply}}). #' #' @examples -#' # Simulation study comparing the diffusion with diff sets of seed nodes ----- +#' # (Multiple simulations of single behavior): -------------------------------- +#' # Simulation study comparing the diffusion with diff sets of seed nodes #' #' # Random seed nodes #' set.seed(1) @@ -320,7 +385,8 @@ rdiffnet <- function( exposure.args = list(), name = "A diffusion network", behavior = "Random contagion", - stop.no.diff = TRUE + stop.no.diff = TRUE, + disadopt = NULL ) { # Checking options @@ -384,7 +450,6 @@ rdiffnet <- function( # Step 1.0: Setting the seed nodes ----------------------------------------- rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) - seed.p.adopt <- rdiffnet_args$seed.p.adopt seed.nodes <- rdiffnet_args$seed.nodes behavior <- rdiffnet_args$behavior @@ -407,7 +472,6 @@ rdiffnet <- function( } # Step 1.2: finding the nodes - d <- list() if (all(sapply(seed.nodes, is.character))) { # "central", "marginal", or "random" @@ -438,13 +502,13 @@ rdiffnet <- function( } # Step 1.3: Defining cumadopt and toa (time of adoption) -------------------- - cumadopt <- array(0L, dim = c(n, t, num_of_behaviors)) toa <- matrix(NA, nrow = dim(cumadopt)[1], ncol = dim(cumadopt)[3]) - for (i in 1:num_of_behaviors) { - cumadopt[d[[i]],,i] <- 1L + for (q in 1:num_of_behaviors) { + cumadopt[d[[q]],,q] <- 1L + toa[d[[q]],q] <- 1L } # Step 2.0: Thresholds ------------------------------------------------------- @@ -454,6 +518,8 @@ rdiffnet <- function( # Step 3.0: Running the simulation ------------------------------------------- for (i in 2:t) { + + # 3.1 Computing exposure if (exists("attrs_arr")){ exposure.args[c("attrs")] <- list(attrs_arr[,i, ,drop=FALSE]) } @@ -463,15 +529,44 @@ rdiffnet <- function( for (q in 1:num_of_behaviors) { - whoadopts <- which( (expo[,,q] >= thr[,q]) ) + # 3.2 Identifying who adopts based on the threshold + whoadopts <- which( (expo[,,q] >= thr[,q]) & is.na(toa[,q])) + + # 3.3 Updating the cumadopt cumadopt[whoadopts, i:t, q] <- 1L - # ADD SOMETHING TO DISADOPT - toa[, q] <- apply(cumadopt[,, q], 1, function(x) { - first_adopt <- which(x == 1) - if (length(first_adopt) > 0) first_adopt[1] else NA - }) + # 3.4 Updating the toa + if (length(whoadopts) > 0) { + toa[cbind(whoadopts, q)] <- i + } + } + + # 3.5 identifiying the disadopters + if (length(disadopt)) { + + # Run the disadoption algorithm. This will return the following: + # - A list of length q with the nodes that disadopted + disadopt_res <- disadopt(expo, cumadopt, i) + + for (q in seq_along(disadopt_res)) { + + # So only doing this if there's disadoption + if (length(disadopt_res[[q]]) == 0) + next + # Checking this makes sense (only adopters can disadopt) + q_adopters <- which(!is.na(toa[, q])) + + if (length(setdiff(disadopt_res[[q]], q_adopters)) > 0) + stop("Some nodes that disadopted were not adopters.") + + # Updating the cumadopt + cumadopt[disadopt_res[[q]], i:t, q] <- 0L + + # Updating toa + toa[cbind(disadopt_res[[q]], q)] <- NA + + } } } @@ -480,7 +575,12 @@ rdiffnet <- function( if (reachedt == 1) { if (stop.no.diff) - stop(paste("No diffusion in this network for behavior", i, "(Ups!) try changing the seed or the parameters.")) + stop( + paste( + "No diffusion in this network for behavior", i, + "(Ups!) try changing the seed or the parameters." + ) + ) else warning(paste("No diffusion for behavior", i, " in this network.")) } @@ -492,7 +592,9 @@ rdiffnet <- function( if (num_of_behaviors==1) { toa <- as.integer(toa) - } + } else { + toa <- array(as.integer(toa), dim = dim(toa)) + } new_diffnet( graph = sgraph, @@ -506,20 +608,15 @@ rdiffnet <- function( ) } - rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { # seed.p.adopt stuff - # The class of seed.p.adopt determines if is a single or multiple diff pross. if (inherits(seed.p.adopt, "list")) { - message(paste("Message: Multi-diffusion behavior simulation selected.", "Number of behaviors: ", length(seed.p.adopt))) - multi <- TRUE - } else if (inherits(seed.p.adopt, "numeric")) { if (length(seed.p.adopt)>1) { @@ -528,7 +625,6 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { } multi <- FALSE - } else { stop("The object -seed.p.adopt- must be a -numeric- (for a single behavior diff)", @@ -545,23 +641,17 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { if (length(seed.nodes) != length(seed.p.adopt)) { stop("Length of lists -seed.nodes- and -seed.p.adopt- must be the same for multi diffusion.") } - if (all(sapply(seed.nodes, is.character))) { - if (any(!seed.nodes %in% c("marginal", "central", "random"))) { stop("Some element in list -seed.nodes- is a -character- different from 'marginal', 'central', or 'random'.") } - } else if (all(sapply(seed.nodes, is.numeric))) { - if (any(sapply(seed.nodes, is.null))) { stop("There is a NULL -numeric- element") } - if (any(sapply(seed.nodes, function(x) any(x != round(x))))) { stop("Some value in the elements of the list -seed.nodes- is non-integer.") } - } else { stop("All elements of the list seed.nodes must be either -character- or -numeric-.") } @@ -576,7 +666,6 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { message("Message: Object -seed.nodes- converted to a -list-.", "For example, the first behavior has seed -", seed.nodes[[1]], "-, the second has -", seed.nodes[[2]], "-, etc.") } else { - message("Message: Object -seed.nodes- converted to a -list-.", "All behaviors will have the same -", seed.nodes, "- seed nodes.") seed.nodes <- replicate(length(seed.p.adopt), seed.nodes, simplify = FALSE) @@ -599,11 +688,9 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { message(paste("Message: Name of 1 behavior provided, but", length(seed.p.adopt), "are needed. "), "Names generalized to 'behavior'_1, 'behavior'_2, etc.") behaviors <- list() - for (i in seq_along(seed.p.adopt)) { behaviors[[i]] <- paste(behavior, i, sep = "_") } - behavior <- behaviors } @@ -612,21 +699,16 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { # For Single-diff. if (length(seed.nodes) == 1 && inherits(seed.nodes, "character")) { - if (!seed.nodes %in% c("marginal", "central", "random")) { stop("Object -seed.nodes- is a -character- different from 'marginal', 'central', or 'random'.") } - } else if (!inherits(seed.nodes, "character")) { - if (any(sapply(seed.nodes, function(x) any(x != round(x))))) { stop("Some value in the elements of the list -seed.nodes- is non-integer.") } - } else { stop("Unsupported -seed.nodes- value. See the manual for references.") } - if (length(behavior)>1) { stop("More names were provided than necessary.") } @@ -643,3 +725,50 @@ rdiffnet_validate_args <- function(seed.p.adopt, seed.nodes, behavior) { num_of_behaviors = length(seed.p.adopt) ) } + +#' Splitting behaviors +#' +#' Split each behavior within multi-diffusion diffnet object. The function gets +#' \code{toa}, \code{adopt}, \code{cumadopt}, and the \code{behavior} name from +#' each behavior, and returns a list where each element is a single behavior. +#' All the rest of the structure remains the same for each element in the list. +#' +#' @param diffnet_obj A multi-diffusion diffnet object. +#' @examples +#' # Running a multi-diffusion simulation +#' set.seed(1231) +#' diffnet_multi <- rdiffnet(50, 5, seed.p.adopt = list(0.1,0.1)) +#' +#' diffnet_multi_list <- split_behaviors(diffnet_multi) +#' diffnet_single <- diffnet_multi_list[[1]] +#' +#' # You can now run standard functions for a single behavior +#' # Plotting single behavior +#' plot_diffnet(diffnet_single, slices = c(1, 3, 5)) +#' +#' @return A list of diffnet objects. Each element represent a unique behavior. +#' @export +#' @author George G. Vega Yon & Aníbal Olivera M. +#' @name split_behaviors +split_behaviors <- function(diffnet_obj) { + + # creates a list, keeping the structure of each element + diffnets <- replicate(ncol(diffnet_obj$toa), diffnet_obj, simplify = FALSE) + + behaviors_names <- strsplit(diffnet_obj$meta$behavior, ", ")[[1]] + + # loop over the behaviors + for (q in 1:ncol(diffnet_obj$toa)) { + diffnets[[q]]$toa <- as.integer(diffnet_obj$toa[, q, drop = FALSE]) + names(diffnets[[q]]$toa) <- rownames(diffnet_obj$toa) + + diffnets[[q]]$adopt <- diffnet_obj$adopt[[q]] + + diffnets[[q]]$cumadopt <- diffnet_obj$cumadopt[[q]] + + diffnets[[q]]$meta$behavior <- behaviors_names[q] + } + + return(diffnets) +} + diff --git a/R/stats.R b/R/stats.R index 8149b2fa..dadcac6d 100644 --- a/R/stats.R +++ b/R/stats.R @@ -258,10 +258,13 @@ dgr.array <- function(graph, cmode, undirected, self, valued) { #' @templateVar dynamic TRUE #' @templateVar self TRUE #' @template graph_template -#' @param cumadopt \eqn{n\times T}{n * T} matrix. Cumulative adoption matrix obtained from -#' \code{\link{toa_mat}} +#' @param cumadopt \eqn{n\times T}{n * T} matrix for single diffusion. +#' \eqn{n\times T \times Q}{n * T * Q} array for \eqn{Q}{Q} diffusion processes. +#' Cumulative adoption matrix obtained from \code{\link{toa_mat}} #' @param attrs Either a character scalar (if \code{graph} is diffnet), -#' or a numeric matrix of size \eqn{n\times T}{n * T}. Weighting for each time, period (see details). +#' a numeric matrix of size \eqn{n\times T}{n * T}, or an array of size +#' \eqn{n\times T \times Q}{n * T * Q} (only for multi diffusion). +#' Weighting for each time period (see details). #' @param alt.graph Either a graph that should be used instead of \code{graph}, #' or \code{"se"} (see details). #' @param outgoing Logical scalar. When \code{TRUE}, computed using outgoing ties. @@ -448,12 +451,46 @@ dgr.array <- function(graph, cmode, undirected, self, valued) { #' stopifnot(all(test[!is.na(test)])) #' #' +#' # Examples for multi-diffusion --------------------------- +#' +#' # Running a multi-diffusion simulation, with q=2 behaviors +#' set.seed(999) +#' n <- 40; t <- 5; q <- 2; +#' graph <- rgraph_ws(n, t, p=.3) +#' seed_prop_adopt <- rep(list(0.1), q) +#' +#' diffnet <- rdiffnet(seed.graph = graph, t = t, seed.p.adopt = seed_prop_adopt) +#' +#' # Getting the cumulative adoption array of dims n x T x q +#' cumadopt_2 <- diffnet$cumadopt # list of matrices +#' cumadopt_2 <- array(unlist(cumadopt_2), dim = c(n, t, q)) +#' +#' expo2 <- exposure(diffnet$graph, cumadopt = cumadopt_2) +#' +#' # With an attribute -- +#' +#' X <- matrix(runif(n * t), nrow = n, ncol = t) # matrix n x T +#' ans3 <- exposure(diffnet$graph, cumadopt = cumadopt_2, attrs=X) +#' +#' X <- array(runif(n * t * q), dim = c(n, t, q)) # array n x T x q +#' ans4 <- exposure(diffnet$graph, cumadopt = cumadopt_2, attrs=X) +#' +#' # Exposure based on Structural Equivalence -- +#' +#' diffnet_1 <- split_behaviors(diffnet)[[1]] +#' se <- struct_equiv(diffnet) +#' se <- lapply(se, function(x) { +#' ans <- methods::as(x$SE, "dgCMatrix") +#' ans@x <- 1/(ans@x + 1e-20) +#' ans +#' }) +#' ans6 <- exposure(diffnet, cumadopt = cumadopt_2, alt.graph = se, valued=TRUE) #' #' @family statistics #' @keywords univar #' @return A matrix of size \eqn{n\times T}{n * T} with exposure for each node. #' @export -#' @author George G. Vega Yon & Thomas W. Valente +#' @author George G. Vega Yon, Thomas W. Valente, and Aníbal Olivera M. #' @name exposure NULL diff --git a/man/brfarmers.Rd b/man/brfarmers.Rd index 0ea296e5..eec40819 100644 --- a/man/brfarmers.Rd +++ b/man/brfarmers.Rd @@ -195,12 +195,12 @@ Other diffusion datasets: \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, -\code{\link{kfamilyDiffNet}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamily}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{kfamilyDiffNet}}, +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \concept{diffusion datasets} \keyword{datasets} diff --git a/man/brfarmersDiffNet.Rd b/man/brfarmersDiffNet.Rd index bca7ddd0..51b4e7e1 100644 --- a/man/brfarmersDiffNet.Rd +++ b/man/brfarmersDiffNet.Rd @@ -16,11 +16,11 @@ Other diffusion datasets: \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, -\code{\link{kfamilyDiffNet}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamily}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{kfamilyDiffNet}}, +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \concept{diffusion datasets} diff --git a/man/dgr.Rd b/man/dgr.Rd index 3825f669..cd9c08b9 100644 --- a/man/dgr.Rd +++ b/man/dgr.Rd @@ -119,8 +119,8 @@ Other visualizations: \code{\link{grid_distribution}()}, \code{\link{hazard_rate}()}, \code{\link{plot_adopters}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_infectsuscep}()}, \code{\link{plot_threshold}()}, \code{\link{rescale_vertex_igraph}()} diff --git a/man/diffnet-class.Rd b/man/diffnet-class.Rd index 734375c8..240ee151 100644 --- a/man/diffnet-class.Rd +++ b/man/diffnet-class.Rd @@ -121,7 +121,9 @@ is_valued(x) \item{toavar}{Character scalar. Name of the variable that holds the time of adoption.} -\item{toa}{Numeric vector of size \eqn{n}. Times of adoption.} +\item{toa}{Numeric vector of size \eqn{n}. Times of adoption. For \eqn{Q}{Q} +multiple behavior diffusion, \code{toa} must be a matrix \eqn{n \times Q}{n * Q} +(see \code{\link{rdiffnet}}, examples of multiple behavior diffusion).} \item{t0}{Integer scalar. Passed to \code{\link{toa_mat}}.} @@ -171,9 +173,11 @@ or static (\code{"static"}).} A list of class \code{diffnet} with the following elements: \item{graph}{A list of length \eqn{T}. Containing sparse square matrices of size \eqn{n} and class \code{\link[Matrix:dgCMatrix-class]{dgCMatrix}}.} -\item{toa}{An integer vector of size \eqn{T} with times of adoption.} +\item{toa}{An integer vector of length \eqn{n} with times of adoption. When \eqn{Q}{Q} multiple +behavior diffusion is selected, a matrix of size \eqn{n \times Q}{n * Q}}. \item{adopt, cumadopt}{Numeric matrices of size \eqn{n\times T}{n*T} as those returned -by \code{\link{toa_mat}}.} +by \code{\link{toa_mat}}. For \eqn{Q}{Q} multiple behavior diffusion, \code{adopt} and \code{cumadopt} +become a list of \eqn{n\times T}{n*T} elements, with \eqn{Q}{Q} elements.} \item{vertex.static.attrs}{If not NULL, a data frame with \eqn{n} rows with vertex static attributes.} \item{vertex.dyn.attrs}{A list of length \eqn{T} with data frames containing vertex attributes @@ -196,9 +200,9 @@ throught time (dynamic).} } } \description{ -\code{diffnet} objects contain difussion networks. With adjacency -matrices and time of adoption (toa) vector as its main components, most of the -package's functions have methods for this class of objects. +\code{diffnet} objects contain diffusion networks. With adjacency +matrices and time of adoption (toa) vector (or matrix, for multiple behavior diffusion), +as its main components, most of the package's functions have methods for this class of objects. } \details{ \code{diffnet} objects hold both, static and dynamic vertex attributes. When @@ -271,6 +275,8 @@ recalculates adoption and cumulative adoption matrices using \code{toa_mat}. \examples{ +# Creating a diffnet object from TOA (time of adoption) --------------------- + # Creating a random graph set.seed(123) graph <- rgraph_ba(t=9) @@ -288,6 +294,16 @@ summary(diffnet) # Plotting slice 4 plot(diffnet, t=4) +# A diffnet object from TOA of multiple behaviors --------------------------- + +# TOA for two behaviors +toa_matrix <- matrix(sample(c(2001L:2005L,NA), 20, TRUE), ncol = 2) + +# Creating diffnet object +diffnet_multi <- new_diffnet(graph, toa_matrix) +diffnet_multi +summary(diffnet_multi) + # ATTRIBUTES ---------------------------------------------------------------- # Retrieving attributes @@ -360,7 +376,7 @@ Other data management functions: \code{\link{survey_to_diffnet}()} } \author{ -George G. Vega Yon +George G. Vega Yon & Aníbal Olivera M. } \concept{data management functions} \concept{diffnet methods} diff --git a/man/diffusion-data.Rd b/man/diffusion-data.Rd index 4bfbb95e..10517b99 100644 --- a/man/diffusion-data.Rd +++ b/man/diffusion-data.Rd @@ -85,16 +85,16 @@ Analysis in the Social Sciences (pp. 98–116). New York: Cambridge University P } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, -\code{\link{kfamilyDiffNet}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamily}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{kfamilyDiffNet}}, +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \author{ Thomas W. Valente diff --git a/man/diffusionMap.Rd b/man/diffusionMap.Rd index cebfd50c..08399715 100644 --- a/man/diffusionMap.Rd +++ b/man/diffusionMap.Rd @@ -162,8 +162,8 @@ Other visualizations: \code{\link{grid_distribution}()}, \code{\link{hazard_rate}()}, \code{\link{plot_adopters}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_infectsuscep}()}, \code{\link{plot_threshold}()}, \code{\link{rescale_vertex_igraph}()} diff --git a/man/drawColorKey.Rd b/man/drawColorKey.Rd index 6804a03d..5a84d250 100644 --- a/man/drawColorKey.Rd +++ b/man/drawColorKey.Rd @@ -77,8 +77,8 @@ Other visualizations: \code{\link{grid_distribution}()}, \code{\link{hazard_rate}()}, \code{\link{plot_adopters}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_infectsuscep}()}, \code{\link{plot_threshold}()}, \code{\link{rescale_vertex_igraph}()} diff --git a/man/exposure.Rd b/man/exposure.Rd index 8f59715d..62ee4cbd 100644 --- a/man/exposure.Rd +++ b/man/exposure.Rd @@ -21,11 +21,14 @@ exposure( \arguments{ \item{graph}{A dynamic graph (see \code{\link{netdiffuseR-graphs}}).} -\item{cumadopt}{\eqn{n\times T}{n * T} matrix. Cumulative adoption matrix obtained from -\code{\link{toa_mat}}} +\item{cumadopt}{\eqn{n\times T}{n * T} matrix for single diffusion. +\eqn{n\times T \times Q}{n * T * Q} array for \eqn{Q}{Q} diffusion processes. +Cumulative adoption matrix obtained from \code{\link{toa_mat}}} \item{attrs}{Either a character scalar (if \code{graph} is diffnet), -or a numeric matrix of size \eqn{n\times T}{n * T}. Weighting for each time, period (see details).} +a numeric matrix of size \eqn{n\times T}{n * T}, or an array of size +\eqn{n\times T \times Q}{n * T * Q} (only for multi diffusion). + Weighting for each time period (see details).} \item{alt.graph}{Either a graph that should be used instead of \code{graph}, or \code{"se"} (see details).} @@ -54,9 +57,9 @@ A matrix of size \eqn{n\times T}{n * T} with exposure for each node. 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). } \details{ Exposure is calculated as follows: @@ -226,6 +229,40 @@ test <- diffnet[["expo_se", as.df=TRUE]] == diffnet[["expo_se4", as.df=TRUE]] stopifnot(all(test[!is.na(test)])) +# Examples for multi-diffusion --------------------------- + +# Running a multi-diffusion simulation, with q=2 behaviors +set.seed(999) +n <- 40; t <- 5; q <- 2; +graph <- rgraph_ws(n, t, p=.3) +seed_prop_adopt <- rep(list(0.1), q) + +diffnet <- rdiffnet(seed.graph = graph, t = t, seed.p.adopt = seed_prop_adopt) + +# Getting the cumulative adoption array of dims n x T x q +cumadopt_2 <- diffnet$cumadopt # list of matrices +cumadopt_2 <- array(unlist(cumadopt_2), dim = c(n, t, q)) + +expo2 <- exposure(diffnet$graph, cumadopt = cumadopt_2) + +# With an attribute -- + +X <- matrix(runif(n * t), nrow = n, ncol = t) # matrix n x T +ans3 <- exposure(diffnet$graph, cumadopt = cumadopt_2, attrs=X) + +X <- array(runif(n * t * q), dim = c(n, t, q)) # array n x T x q +ans4 <- exposure(diffnet$graph, cumadopt = cumadopt_2, attrs=X) + +# Exposure based on Structural Equivalence -- + +diffnet_1 <- split_behaviors(diffnet)[[1]] +se <- struct_equiv(diffnet) +se <- lapply(se, function(x) { + ans <- methods::as(x$SE, "dgCMatrix") + ans@x <- 1/(ans@x + 1e-20) + ans + }) +ans6 <- exposure(diffnet, cumadopt = cumadopt_2, alt.graph = se, valued=TRUE) } \references{ @@ -251,7 +288,7 @@ Other statistics: \code{\link{vertex_covariate_dist}()} } \author{ -George G. Vega Yon & Thomas W. Valente +George G. Vega Yon, Thomas W. Valente, and Aníbal Olivera M. } \concept{statistics} \keyword{univar} diff --git a/man/fakeDynEdgelist.Rd b/man/fakeDynEdgelist.Rd index c45af8f9..abede09f 100644 --- a/man/fakeDynEdgelist.Rd +++ b/man/fakeDynEdgelist.Rd @@ -21,16 +21,16 @@ edgelist can be merged with the dataset \code{\link{fakesurveyDyn}}. } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{diffusion-data}}, \code{\link{fakeEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, -\code{\link{kfamilyDiffNet}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamily}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{kfamilyDiffNet}}, +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \author{ George G. Vega Yon diff --git a/man/fakeEdgelist.Rd b/man/fakeEdgelist.Rd index c2fba045..68578eb8 100644 --- a/man/fakeEdgelist.Rd +++ b/man/fakeEdgelist.Rd @@ -20,16 +20,16 @@ edgelist can be merged with the dataset \code{\link{fakesurvey}}. } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, -\code{\link{kfamilyDiffNet}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamily}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{kfamilyDiffNet}}, +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \author{ George G. Vega Yon diff --git a/man/fakesurvey.Rd b/man/fakesurvey.Rd index dbcf4e14..b3e8c2c7 100644 --- a/man/fakesurvey.Rd +++ b/man/fakesurvey.Rd @@ -27,16 +27,16 @@ can be merged with the \code{\link{fakeEdgelist}}. } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, \code{\link{fakesurveyDyn}}, -\code{\link{kfamilyDiffNet}}, \code{\link{kfamily}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{kfamilyDiffNet}}, +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \author{ George G. Vega Yon diff --git a/man/fakesurveyDyn.Rd b/man/fakesurveyDyn.Rd index 34364092..90e4cfca 100644 --- a/man/fakesurveyDyn.Rd +++ b/man/fakesurveyDyn.Rd @@ -28,16 +28,16 @@ can be merged with the \code{\link{fakeDynEdgelist}}. } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, \code{\link{fakesurvey}}, -\code{\link{kfamilyDiffNet}}, \code{\link{kfamily}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{kfamilyDiffNet}}, +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \author{ George G. Vega Yon diff --git a/man/grid_distribution.Rd b/man/grid_distribution.Rd index ae993fbb..ac89058d 100644 --- a/man/grid_distribution.Rd +++ b/man/grid_distribution.Rd @@ -47,8 +47,8 @@ Other visualizations: \code{\link{drawColorKey}()}, \code{\link{hazard_rate}()}, \code{\link{plot_adopters}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_infectsuscep}()}, \code{\link{plot_threshold}()}, \code{\link{rescale_vertex_igraph}()} diff --git a/man/hazard_rate.Rd b/man/hazard_rate.Rd index a2d2f6e0..c2f8fccd 100644 --- a/man/hazard_rate.Rd +++ b/man/hazard_rate.Rd @@ -146,8 +146,8 @@ Other visualizations: \code{\link{drawColorKey}()}, \code{\link{grid_distribution}()}, \code{\link{plot_adopters}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_infectsuscep}()}, \code{\link{plot_threshold}()}, \code{\link{rescale_vertex_igraph}()} diff --git a/man/kfamily.Rd b/man/kfamily.Rd index 052c508a..95337388 100644 --- a/man/kfamily.Rd +++ b/man/kfamily.Rd @@ -469,15 +469,15 @@ Cresskill N.J.: Hampton Press. } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamilyDiffNet}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \concept{diffusion datasets} diff --git a/man/kfamilyDiffNet.Rd b/man/kfamilyDiffNet.Rd index 311899f4..da181df5 100644 --- a/man/kfamilyDiffNet.Rd +++ b/man/kfamilyDiffNet.Rd @@ -12,15 +12,15 @@ in the graph are static and described in \code{\link{kfamily}}. } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamily}}, -\code{\link{medInnovationsDiffNet}}, -\code{\link{medInnovations}} +\code{\link{medInnovations}}, +\code{\link{medInnovationsDiffNet}} } \concept{diffusion datasets} diff --git a/man/medInnovations.Rd b/man/medInnovations.Rd index 8909465d..1620fe57 100644 --- a/man/medInnovations.Rd +++ b/man/medInnovations.Rd @@ -95,15 +95,15 @@ Cresskill N.J.: Hampton Press. } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, -\code{\link{kfamilyDiffNet}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamily}}, +\code{\link{kfamilyDiffNet}}, \code{\link{medInnovationsDiffNet}} } \concept{diffusion datasets} diff --git a/man/medInnovationsDiffNet.Rd b/man/medInnovationsDiffNet.Rd index 3e8a8e57..a636a22b 100644 --- a/man/medInnovationsDiffNet.Rd +++ b/man/medInnovationsDiffNet.Rd @@ -12,15 +12,15 @@ in the graph are static and described in \code{\link{medInnovations}}. } \seealso{ Other diffusion datasets: -\code{\link{brfarmersDiffNet}}, \code{\link{brfarmers}}, +\code{\link{brfarmersDiffNet}}, \code{\link{diffusion-data}}, \code{\link{fakeDynEdgelist}}, \code{\link{fakeEdgelist}}, -\code{\link{fakesurveyDyn}}, \code{\link{fakesurvey}}, -\code{\link{kfamilyDiffNet}}, +\code{\link{fakesurveyDyn}}, \code{\link{kfamily}}, +\code{\link{kfamilyDiffNet}}, \code{\link{medInnovations}} } \concept{diffusion datasets} diff --git a/man/plot_adopters.Rd b/man/plot_adopters.Rd index 0b8dd138..c3dc9604 100644 --- a/man/plot_adopters.Rd +++ b/man/plot_adopters.Rd @@ -81,8 +81,8 @@ Other visualizations: \code{\link{drawColorKey}()}, \code{\link{grid_distribution}()}, \code{\link{hazard_rate}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_infectsuscep}()}, \code{\link{plot_threshold}()}, \code{\link{rescale_vertex_igraph}()} diff --git a/man/plot_infectsuscep.Rd b/man/plot_infectsuscep.Rd index d23d3ec0..46731280 100644 --- a/man/plot_infectsuscep.Rd +++ b/man/plot_infectsuscep.Rd @@ -119,8 +119,8 @@ Other visualizations: \code{\link{grid_distribution}()}, \code{\link{hazard_rate}()}, \code{\link{plot_adopters}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_threshold}()}, \code{\link{rescale_vertex_igraph}()} } diff --git a/man/plot_threshold.Rd b/man/plot_threshold.Rd index fcaa4c41..9900fdd9 100644 --- a/man/plot_threshold.Rd +++ b/man/plot_threshold.Rd @@ -9,9 +9,9 @@ \usage{ plot_threshold(graph, expo, vertex.label, ...) -\method{plot_threshold}{diffnet}(graph, expo, vertex.label, ...) +\method{plot_threshold}{diffnet}(graph, expo, ...) -\method{plot_threshold}{array}(graph, expo, vertex.label, ...) +\method{plot_threshold}{array}(graph, expo, ...) \method{plot_threshold}{default}( graph, @@ -56,6 +56,8 @@ plot_threshold(graph, expo, vertex.label, ...) \item{expo}{\eqn{n\times T}{n * T} matrix. Esposure to the innovation obtained from \code{\link{exposure}}} +\item{vertex.label}{Character vector of size \eqn{n}. Labels of the vertices.} + \item{...}{Additional arguments passed to \code{\link{plot}}.} \item{toa}{Integer vector of length \eqn{n} with the times of adoption.} @@ -81,8 +83,6 @@ plot_threshold(graph, expo, vertex.label, ...) \item{vertex.color}{Either a vector of size \eqn{n} or a scalar indicating colors of the vertices.} -\item{vertex.label}{Character vector of size \eqn{n}. Labels of the vertices.} - \item{vertex.label.pos}{Integer value to be passed to \code{\link{text}} via \code{pos}.} \item{vertex.label.cex}{Either a numeric scalar or vector of size \eqn{n}. Passed to \code{text}.} @@ -172,8 +172,8 @@ Other visualizations: \code{\link{grid_distribution}()}, \code{\link{hazard_rate}()}, \code{\link{plot_adopters}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_infectsuscep}()}, \code{\link{rescale_vertex_igraph}()} } diff --git a/man/rdiffnet.Rd b/man/rdiffnet.Rd index 8abb1b0e..fe4b2fab 100644 --- a/man/rdiffnet.Rd +++ b/man/rdiffnet.Rd @@ -20,7 +20,8 @@ rdiffnet( exposure.args = list(), name = "A diffusion network", behavior = "Random contagion", - stop.no.diff = TRUE + stop.no.diff = TRUE, + disadopt = NULL ) } \arguments{ @@ -39,9 +40,10 @@ rdiffnet( \item{t}{Integer scalar. Time length.} -\item{seed.nodes}{Either a character scalar or a vector. Type of seed nodes (see details).} +\item{seed.nodes}{Either a character scalar, a vector or a list (multiple behaviors only). +Type of seed nodes (see details).} -\item{seed.p.adopt}{Numeric scalar. Proportion of early adopters.} +\item{seed.p.adopt}{Numeric scalar or a list (multiple behaviors only). Proportion of early adopters.} \item{seed.graph}{Baseline graph used for the simulation (see details).} @@ -52,18 +54,21 @@ rdiffnet( \item{rewire.args}{List. Arguments to be passed to \code{\link{rewire_graph}}.} -\item{threshold.dist}{Either a function to be applied via \code{\link{sapply}}, -a numeric scalar, or a vector/matrix with \eqn{n} elements. Sets the adoption +\item{threshold.dist}{For a single behavior diffusion, either a function to be applied via \code{\link{sapply}}, +a numeric scalar, or a vector/matrix with \eqn{n} elements. For \eqn{Q} behavior diffusion, +it can also be an \eqn{n \times Q} matrix or a list of \eqn{Q} single behavior inputs. Sets the adoption threshold for each node.} \item{exposure.args}{List. Arguments to be passed to \code{\link{exposure}}.} \item{name}{Character scalar. Passed to \code{\link{as_diffnet}}.} -\item{behavior}{Character scalar. Passed to \code{\link{as_diffnet}}.} +\item{behavior}{Character scalar or a list or character scalar (multiple behaviors only). Passed to \code{\link{as_diffnet}}.} \item{stop.no.diff}{Logical scalar. When \code{TRUE}, the function will return with error if there was no diffusion. Otherwise it throws a warning.} + +\item{disadopt}{Function of disadoption, with current exposition, cumulative adoption, and time as possible inputs.} } \value{ A random \code{\link{diffnet}} class object. @@ -74,7 +79,11 @@ on what \code{statistic} is (see \code{\link{sapply}} and } \description{ Simulates a diffusion network by creating a random dynamic network and -adoption threshold levels. +adoption threshold levels. You can perform a simulation for a single behavior +(using \code{seed.p.adopt} of class \code{numeric} in \code{rdiffnet}), +conduct multiple simulations for a single behavior (with \code{rdiffnet_multiple}), +or run a simulation with multiple behaviors simultaneously (using \code{seed.p.adopt} +of class \code{list} in \code{rdiffnet}) } \details{ Instead of randomizing whether an individual adopts the innovation or not, this @@ -86,7 +95,7 @@ equal to his threshold. The simulation is done in the following steps: \item Using \code{seed.graph}, a baseline graph is created. \item Given the baseline graph, the set of initial adopters is defined using \code{seed.nodes}. - \item Afterwards, if \code{rewire=TRUE} \eqn{t-1} slices of the network are created + \item Afterwards, if \code{rewire=TRUE}, \eqn{t-1} slices of the network are created by iteratively rewiring the baseline graph. \item The \code{threshold.dist} function is applied to each node in the graph. \item Simulation starts at \eqn{t=2} assigning adopters in each time period @@ -94,9 +103,12 @@ equal to his threshold. The simulation is done in the following steps: } When \code{seed.nodes} is a character scalar it can be \code{"marginal"}, \code{"central"} or \code{"random"}, -So each of these values sets the initial adopters using the vertices with lowest -degree, with highest degree or completely randomly. The number of early adoptes -is set as \code{seed.p.adopt * n}. Please note that when marginal nodes are +so each of these values sets the initial adopters using the vertices with lowest +degree, with highest degree or completely randomly. + +For a single behavior diffusion, the number of early adopters is set as \code{seed.p.adopt * n}. +To run multiple behavior diffusion, \code{seed.p.adopt} must be a \code{list} (see examples below). +Please note that when marginal nodes are set as seed it may be the case that no diffusion process is attained as the chosen set of first adopters can be isolated. Any other case will be considered as an index (via \code{\link{[<-}} methods), hence the user can manually set the set of initial adopters, for example @@ -156,22 +168,77 @@ When \code{cl} is provided, then simulations are done via which is stopped (removed) once the process is complete. } \examples{ -# Asimple example ----------------------------------------------------------- +# (Single behavior): -------------------------------------------------------- + +# A simple example set.seed(123) -z <- rdiffnet(100,10) -z -summary(z) +diffnet_1 <- rdiffnet(100,10) +diffnet_1 +summary(diffnet_1) + +# Adopt if at least two neighbors have adopted ------ +n <- 100; t <- 5; +graph <- rgraph_ws(n, t, p=.3) -# A more complex example: Adopt if at least one neighbor has adopted -------- -y <- rdiffnet(100, 10, threshold.dist=function(x) 1, +diffnet_2 <- rdiffnet(seed.graph = graph, t = t, threshold.dist=function(x) 2, exposure.args=list(valued=FALSE, normalized=FALSE)) -# Re thinking the Adoption of Tetracycline ---------------------------------- +# Re thinking the Adoption of Tetracycline ---------- newMI <- rdiffnet(seed.graph = medInnovationsDiffNet$graph, threshold.dist = threshold(medInnovationsDiffNet), rewire=FALSE) +# (Multiple behavior): ------------------------------------------------------ + +# A simple example +set.seed(123) +diffnet_3 <- rdiffnet(100, 10, seed.p.adopt = list(0.1, 0.15)) +diffnet_3 +summary(diffnet_3) + +# Fully specified multi-behavior example ------------ + +threshold_matrix <- matrix(runif(n * 2), nrow = n, ncol = 2) +seed_nodes <- sample(1:100, 10, replace = FALSE) +diffnet_4 <- rdiffnet(100, 10, seed.p.adopt = list(0, 0), + seed.nodes = list(seed_nodes, seed_nodes), + threshold.dist = threshold_matrix, + behavior = c("tobacco", "alcohol")) +diffnet_4 + +# Adopt if at least one neighbor has adopted the first behavior, +# and at least two neighbors have adopted the second behavior. --- + +diffnet_5 <- rdiffnet(seed.graph = graph, t = t, seed.p.adopt = list(0.1, 0.1), + threshold.dist = list(function(x) 2, function(x) 2), + exposure.args=list(valued=FALSE, normalized=FALSE)) +diffnet_5 + +# With a disadoption function ----------------------- + +set.seed(1231) + +random_dis <- function(expo, cumadopt, time) { + num_of_behaviors <- dim(cumadopt)[3] + + list_disadopt <- list() + + for (q in 1:num_of_behaviors) { + adopters <- which(cumadopt[, time, q, drop=FALSE] == 1) + if (length(adopters) == 0) { + # only disadopt those behaviors with adopters + list_disadopt[[q]] <- integer() + } else { + # selecting 10\% of adopters to disadopt + list_disadopt[[q]] <- sample(adopters, ceiling(0.10 * length(adopters))) + } + } + return(list_disadopt) +} + +diffnet_6 <- rdiffnet(seed.graph = graph, t = 10, disadopt = random_dis, seed.p.adopt = list(0.1, 0.1)) -# Simulation study comparing the diffusion with diff sets of seed nodes ----- +# (Multiple simulations of single behavior): -------------------------------- +# Simulation study comparing the diffusion with diff sets of seed nodes # Random seed nodes set.seed(1) @@ -195,6 +262,6 @@ Other simulation functions: \code{\link{ring_lattice}()} } \author{ -George G. Vega Yon +George G. Vega Yon & Aníbal Olivera M. } \concept{simulation functions} diff --git a/man/rescale_vertex_igraph.Rd b/man/rescale_vertex_igraph.Rd index d2901adc..d8cf6612 100644 --- a/man/rescale_vertex_igraph.Rd +++ b/man/rescale_vertex_igraph.Rd @@ -121,8 +121,8 @@ Other visualizations: \code{\link{grid_distribution}()}, \code{\link{hazard_rate}()}, \code{\link{plot_adopters}()}, -\code{\link{plot_diffnet2}()}, \code{\link{plot_diffnet}()}, +\code{\link{plot_diffnet2}()}, \code{\link{plot_infectsuscep}()}, \code{\link{plot_threshold}()} } diff --git a/man/toa_diff.Rd b/man/toa_diff.Rd index fb604323..6c5f9091 100644 --- a/man/toa_diff.Rd +++ b/man/toa_diff.Rd @@ -7,35 +7,61 @@ toa_diff(obj, t0 = NULL, labels = NULL) } \arguments{ -\item{obj}{Either an integer vector of size \eqn{n} containing time of adoption of the innovation, -or a \code{\link{diffnet}} object.} +\item{obj}{Either an integer vector of length \eqn{n} containing time of adoption +of the innovation, a matrix of size \eqn{n \times Q} (for multiple \eqn{Q} behaviors), or +a \code{\link{diffnet}} object (both for single or multiple behaviors).} \item{t0}{Integer scalar. Sets the lower bound of the time window (e.g. 1955).} -\item{labels}{Character vector of size \eqn{n}. Labels (ids) of the vertices.} +\item{labels}{Character vector of length \eqn{n}. Labels (ids) of the vertices.} } \value{ -An \eqn{n \times n}{n * n} symmetric matrix indicating the difference in times of +An \eqn{n \times n}{n * n} anti-symmetric matrix (or a list of them, +for \eqn{Q}{Q} behaviors) indicating the difference in times of adoption between each pair of nodes. } \description{ -Creates \eqn{n \times n}{n * n} matrix indicating the difference in times of adoption between -each pair of nodes +Creates an \eqn{n \times n}{n * n} matrix, or for \eqn{Q}{Q} behaviors, a list +of length \eqn{Q}{Q} containing \eqn{n \times n}{n * n} matrices, that indicates +the difference in adoption times between each pair of nodes. } \details{ -Each cell ij of the resulting matrix is calculated as \eqn{toa_j - toa_i}{% +Each cell \eqn{ij}{ij} of the resulting matrix is calculated as \eqn{toa_j - toa_i}{% toa(j) - toa(i)}, so that whenever its positive it means that the j-th individual (alter) adopted the innovation sooner. } \examples{ +# For a single behavior ----------------------------------------------------- + # Generating a random vector of time set.seed(123) times <- sample(2000:2005, 10, TRUE) # Computing the TOA differences toa_diff(times) + +# For Q=2 behaviors --------------------------------------------------------- + +# Generating a matrix time + +times_1 <- c(2001L, 2004L, 2003L, 2008L) +times_2 <- c(2001L, 2005L, 2006L, 2008L) +times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) + +# Computing the TOA differences +toa_diff(times) + +# Or, from a diffnet object + +graph <- lapply(2001:2008, function(x) rgraph_er(4)) +diffnet <- new_diffnet(graph, times) + +# Computing the TOA differences +toa_diff(diffnet) + + } \author{ -George G. Vega Yon & Thomas W. Valente +George G. Vega Yon, Thomas W. Valente, and Aníbal Olivera M. } \keyword{manip} diff --git a/man/toa_mat.Rd b/man/toa_mat.Rd index febad39a..a1713e5f 100644 --- a/man/toa_mat.Rd +++ b/man/toa_mat.Rd @@ -7,25 +7,30 @@ toa_mat(obj, labels = NULL, t0 = NULL, t1 = NULL) } \arguments{ -\item{obj}{Either an integer vector of size \eqn{n} containing time of adoption of the innovation, -or a \code{\link{diffnet}} object.} +\item{obj}{Either an integer vector of length \eqn{n} containing time of adoption +of the innovation, a matrix of size \eqn{n \times Q} (for multiple \eqn{Q} behaviors), or +a \code{\link{diffnet}} object (both for single or multiple behaviors).} -\item{labels}{Character vector of size \eqn{n}. Labels (ids) of the vertices.} +\item{labels}{Character vector of length \eqn{n}. Labels (ids) of the vertices.} \item{t0}{Integer scalar. Sets the lower bound of the time window (e.g. 1955).} \item{t1}{Integer scalar. Sets the upper bound of the time window (e.g. 2000).} } \value{ -A list of two \eqn{n \times T}{n x T} - \item{\code{cumadopt}}{has 1's for all years in which a node indicates having the innovation.} - \item{\code{adopt}}{has 1's only for the year of adoption and 0 for the rest.} +For a single behavior, a list of two \eqn{n \times T}{n x T}: + \item{\code{cumadopt}}{ has 1's for all years in which a node indicates having the innovation.} + \item{\code{adopt}}{ has 1's only for the year of adoption and 0 for the rest.} + For \eqn{Q} behaviors, a list of length \eqn{Q}, each element containing + \code{cumadopt} ans \code{adopt} matrices. } \description{ -Creates two matrices recording times of adoption of the innovation. One matrix +For a single behavior, creates two matrices recording times of adoption of the innovation. One matrix records the time period of adoption for each node with zeros elsewhere. The second records the cumulative time of adoption such that there are ones for -the time of adoption and every time period thereafter. +the time of adoption and every time period thereafter. For \eqn{Q} behaviors, +creates a list of length \eqn{Q}, where each element contains those two +matrices for each behavior. } \details{ In order to be able to work with time ranges other than \eqn{1,\dots, T}{1,..., T} @@ -45,6 +50,11 @@ That way the resulting \code{cumadopt} and \code{adopt} matrices would have 2005 - 2000 + 1 = 6 columns instead of 2005 - 2001 + 1 = 5 columns, with the first column of the two matrices containing only zeros (as the first adoption happend after the year 2000). + +For multiple behaviors, the input can be a matrix or a \code{diffnet} object. +In this case, the output will be a list, with each element replicating the output +for a single diffusion: a matrix recording the time period of adoption for +each node, and a second matrix with ones from the moment the node adopts the behavior. } \examples{ # Random set of times of adoptions @@ -55,8 +65,23 @@ toa_mat(times) # Now, suppose that we observe the graph from 2000 to 2006 toa_mat(times, t0=2000, t1=2006) +# For multiple behaviors, the input can be a matrix.. +times_1 <- c(2001L, 2004L, 2003L, 2008L) +times_2 <- c(2001L, 2005L, 2006L, 2008L) +times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) + +toa <- toa_mat(times) +toa[[1]]$adopt # time period of adoption for the first behavior + +#.. or a diffnet object +graph <- lapply(2001:2008, function(x) rgraph_er(4)) +diffnet <- new_diffnet(graph, times) + +toa <- toa_mat(diffnet) +toa[[1]]$cumadopt # cumulative adoption matrix for the first behavior + } \author{ -George G. Vega Yon & Thomas W. Valente +George G. Vega Yon, Thomas W. Valente, and Aníbal Olivera M. } \keyword{manip} diff --git a/playground/split_behavior_discussion.R b/playground/split_behavior_discussion.R new file mode 100644 index 00000000..16613418 --- /dev/null +++ b/playground/split_behavior_discussion.R @@ -0,0 +1,169 @@ +farm <- brfarmersDiffNet +str(farm) +farm$vertex.static.attrs$liveout +class(farm$vertex.dyn.attrs) +class(farm$vertex.static.attrs) + +med_data <- medInnovationsDiffNet +str(med_data) +class(med_data$vertex.static.attrs$city) + +k_fam <- kfamilyDiffNet +str(k_fam) +class(k_fam$vertex.static.attrs$study) + +n=40; t=5 +diffnet <- rdiffnet(40, 5, seed.p.adopt = .2) +X <- matrix(diffnet[["real_threshold"]], ncol=t, nrow=n, byrow = FALSE) +#ans0 <- exposure(diffnet, attrs=X) +net_1 <- rdiffnet(n, t, seed.nodes = 'random', + exposure.args = list(attrs = matrix(runif(n), nrow=n, ncol=t, byrow = FALSE))) +summary(net_1) +str(net_1) +class(net_1$toa) +class(net_1$adopt) +class(net_1$cumadopt) +class(net_1$vertex.static.attrs) +class(net_1$graph.attrs) +class(net_1$meta) + +n=40; t=5 +net_2 <- rdiffnet(n, t, seed.p.adopt = list(0.5,0.5), + exposure.args = list(attrs = X)) +summary(net_2) +str(net_2) +class(net_2$toa) +class(net_2$adopt) +class(net_2$cumadopt) +class(net_2$vertex.static.attrs) +class(net_2$graph.attrs) +class(net_2$meta) + +split_behaviors <- function(diffnet_obj) { + + diffnets <- rep(diffnet_obj, ncol(diffnet_obj$toa)) + diffnets_list <- list() + + #ver_static_att_nams <- colnames(diffnet_obj$vertex.static.attrs) + + for (q in 1:ncol(diffnet_obj$toa)) { + + for (i in seq_along(diffnet_obj)) { + if (!is.null(diffnets[i]$toa)) { + #print(diffnets[i]$toa) + diffnets[i]$toa <- diffnet_obj$toa[, q, drop = FALSE] + } else if (!is.null(diffnets[i]$adopt)) { + diffnets[i]$adopt <- diffnet_obj$adopt[[q]] + } else if (!is.null(diffnets[i]$cumadopt)) { + diffnets[i]$cumadopt <- diffnet_obj$cumadopt[[q]] + }# else if (!is.null(diffnets[i]$vertex.dyn.attrs)) { + # diffnets[i]$vertex.dyn.attrs <- setNames(data.frame(diffnet_obj$vertex.static.attrs[, q]), ver_static_att_nams[q]) + #} + } + + # diffnets[2]$toa <- diffnet_obj$toa[, q, drop = FALSE] + # diffnets[[q]]$adopt <- diffnet_obj$adopt[[q]] + # diffnets[[q]]$cumadopt <- diffnet_obj$cumadopt[[q]] + + diffnets_list[[q]] <- diffnets[q*(1:length(diffnet_obj))] + } + + return(diffnets_list) + + # for (q in ncol(net_2$toa)) { + # + # #graph <- net_2$graph + # # + # diff_obj_2$toa <- net_2$toa[,q] + # #class(toa_slice) + # adopt_slice <- net_2$adopt[[q]] + # #class(adopt_slice) + # cumadopt_slice <- net_2$cumadopt[[q]] + # #class(cumadopt_slice) + # ver_static_att_slice <- setNames(data.frame(net_2$vertex.static.attrs[, q]), ver_static_att_nams[q]) + # #class(ver_static_att_slice) + # + # meta_slice$behavior <- strsplit(meta_slice$behavior, ", ")[[1]][q] + # #class(meta_slice) + # } +} + +############################################################################### + +split_behaviors <- function(diffnet_obj) { + + diffnets <- replicate(ncol(diffnet_obj$toa), diffnet_obj, simplify = FALSE) + + for (q in 1:ncol(diffnet_obj$toa)) { + + diffnets[[q]]$toa <- as.integer(diffnet_obj$toa[, q, drop = FALSE]) + names(diffnets[[q]]$toa) <- rownames(diffnet_obj$toa) + + diffnets[[q]]$adopt <- diffnet_obj$adopt[[q]] + + diffnets[[q]]$cumadopt <- diffnet_obj$cumadopt[[q]] + + } + return(diffnets) +} + +test_that("toa, adopt, and cumadopt should be equal! (split_behaviors)", { + set.seed(12131) + n <- 50 + t <- 5 + graph <- rgraph_ws(n, 4, p=.3) + seed.nodes <- c(1,5,7,10) + thr <- runif(n, .2,.4) + + # Generating identical networks + net_single <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = 0.1, + t = t, rewire = FALSE, threshold.dist = thr) + + net_multiple <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = list(0.1, 0.1), + t = t, rewire = FALSE, threshold.dist = thr) + + net_single_from_multiple <- split_behaviors(net_multiple) + net_single_from_multiple_1 <- net_single_from_multiple[[1]] + + expect_equal(net_single_from_multiple_1$toa, net_single$toa) + expect_equal(net_single_from_multiple_1$adopt, net_single$adopt) + expect_equal(net_single_from_multiple_1$cumadopt, net_single$cumadopt) +}) + +# Let's check the plots. + +plot_diffnet(net_single) # works +plot_diffnet(net_single$graph, net_single$adopt) # doesn't work +plot_diffnet(net_single_from_multiple_1) # works +plot_diffnet(net_single_from_multiple_1$graph, net_single_from_multiple_1$adopt) # doesn't work + +set.seed(1234) # they are almost the same +plot_threshold(net_single$graph, + exposure(net_single$graph, net_single$cumadopt), + net_single$toa) +plot_threshold(net_single_from_multiple_1$graph, + exposure(net_single_from_multiple_1$graph, net_single$cumadopt), + net_single_from_multiple_1$toa) + +################################################################################ + +set.seed(1234) +net_2 <- rdiffnet(50,5, seed.p.adopt = list(0.1, 0.1)) +#str(net_2) +net_2_splitted <- split_behaviors(net_2) +net_1_from_2 <- net_2_splitted[[1]] +expect_s3_class(net_1_from_2, "diffnet") +#str(net_1_from_2) +#str_net_1_from_2 <- capture.output(str(net_1_from_2)) + +net_1 <- rdiffnet(50,5, seed.p.adopt = 0.1, seed.nodes = c(1,2,3,4,5)) +net_1_1 <- rdiffnet(50,5, seed.p.adopt = 0.1, seed.nodes = c(1,2,3,4,5)) +expect_equivalent(net_1$toa, net_1_1$toa) + +#str(net_1) +#str_net_1 <- capture.output(str(net_1)) + +expect_equivalent(net_1_from_2$toa, net_1$toa) +expect_equal(net_1_from_2$adopt, net_1$adopt) +expect_equal(net_1_from_2$cumadopt, net_1$cumadopt) +#identical(str_net_1_from_2, str_net_1) diff --git a/tests/testthat/test-adjmat.R b/tests/testthat/test-adjmat.R index 1cf02bb1..67c0c998 100644 --- a/tests/testthat/test-adjmat.R +++ b/tests/testthat/test-adjmat.R @@ -99,7 +99,7 @@ for (g in names(EL_digraph)) { ################################################################################ # Time of adoption ################################################################################ -context("Time of Adoption (toa_mat, toa_dif)") +context("Time of Adoption (toa_mat, toa_diff)") times <- c(2001L, 2004L, 2003L, 2008L) @@ -129,6 +129,7 @@ test_that("In toa_diff, its dim should be equal to the input mat", { expect_equal(dim(toa_diff(times)), c(4,4)) expect_equal(dim(toa_diff(as.integer(times))), c(4,4)) expect_equal(toa_diff(times), toa_diff(as.integer(times))) + expect_equal(toa_diff(diffnet), toa_diff(times)) }) test_that("Checking toa_mat output", { @@ -153,17 +154,8 @@ context("Time of Adoption -multiple- (toa_mat, toa_dif)") times_1 <- c(2001L, 2004L, 2003L, 2008L) times_2 <- c(2001L, 2005L, 2006L, 2008L) times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) -graph <- lapply(2001:2008, function(x) rgraph_er(4)) -diffnet <- new_diffnet(graph, times) -#toa_mat(diffnet) toa <- toa_mat(times) -test_that("Should warn about -times- not been integer. -multiple-.", { - times_1 <- as.numeric(c(2001L, 2004L, 2003L, 2008L)) - times_2 <- as.numeric(c(2001L, 2002L, 2003L, 2005L)) - times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) - expect_warning(toa_mat(times), "will be coersed to integer") -}) test_that("Dimensions of TOA mat should be ok. -multiple-.", { for (q in 1:length(toa)) { @@ -182,12 +174,17 @@ test_that("Passing labels should work. -multiple-.", { expect_equal(rownames(toa_q$cumadopt), labs) } }) +graph <- lapply(2001:2008, function(x) rgraph_er(4)) +diffnet <- new_diffnet(graph, times) + +test_that("In toa_diff, its dim should be equal to the input mat. -multiple-.", { + expect_equal(length(toa_diff(times)), 2) + expect_equal(dim(toa_diff(times)[[1]]), c(4,4)) + expect_equal(length(toa_diff(diffnet)), 2) + expect_equal(dim(toa_diff(diffnet)[[1]]), c(4,4)) + expect_equal(toa_diff(times), toa_diff(diffnet)) +}) -# test_that("In toa_diff, its dim should be equal to the input mat. -multiple-.", { -# expect_equal(dim(toa_diff(times)), c(4,4)) -# expect_equal(dim(toa_diff(as.integer(times))), c(4,4)) -# expect_equal(toa_diff(times), toa_diff(as.integer(times))) -# }) test_that("Checking toa_mat output. -multiple-.", { diff --git a/tests/testthat/test-rdiffnet-parameters.R b/tests/testthat/test-rdiffnet-parameters.R index 7fa3e18f..89d51519 100644 --- a/tests/testthat/test-rdiffnet-parameters.R +++ b/tests/testthat/test-rdiffnet-parameters.R @@ -24,6 +24,11 @@ test_that( expect_type(rdiffnet_args$seed.nodes, "list") expect_type(rdiffnet_args$behavior, "list") + seed.nodes <- c(1,2,4,5) + expect_type(rdiffnet_args$seed.p.adopt, "list") + expect_type(rdiffnet_args$seed.nodes, "list") + expect_type(rdiffnet_args$behavior, "list") + # Must show ERROR seed.p.adopt <- c(0.4,0.82) @@ -137,10 +142,15 @@ test_that("Multi diff models rdiff args work", { rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) expect_type(rdiffnet_args$seed.nodes, "list") + seed.nodes <- list(c(1,3,5), c(1,3,5)) + rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) + expect_type(rdiffnet_args$seed.nodes, "list") + seed.nodes <- list('marginal',"central") rdiffnet_args <- rdiffnet_validate_args(seed.p.adopt, seed.nodes, behavior) expect_type(rdiffnet_args$seed.nodes, "list") + # Must show ERROR seed.p.adopt <- c(0.14,0.05) diff --git a/tests/testthat/test-rdiffnet.R b/tests/testthat/test-rdiffnet.R index 380ffeb0..b810e376 100644 --- a/tests/testthat/test-rdiffnet.R +++ b/tests/testthat/test-rdiffnet.R @@ -157,9 +157,53 @@ test_that("All should be equal! (multiple)", { }) -#rdiffnet(100, 5, seed.p.adopt = 0.9, threshold.dist = 2, exposure.args = list(normalized=FALSE)) +test_that("toa, adopt, and cumadopt should be equal! (split_behaviors tests)", { + set.seed(12131) + n <- 50 + t <- 5 + graph <- rgraph_ws(n, 4, p=.3) + seed.nodes <- c(1,5,7,10) + thr <- runif(n, .2,.4) + + # Generating identical networks + net_single <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = 0.1, + t = t, rewire = FALSE, threshold.dist = thr) + + net_multiple <- rdiffnet(seed.graph = graph, seed.nodes = seed.nodes, seed.p.adopt = list(0.1, 0.1), + t = t, rewire = FALSE, threshold.dist = thr) + + net_single_from_multiple <- split_behaviors(net_multiple) + net_single_from_multiple_1 <- net_single_from_multiple[[1]] + + expect_equal(net_single_from_multiple_1$toa, net_single$toa) + expect_equal(net_single_from_multiple_1$adopt, net_single$adopt) + expect_equal(net_single_from_multiple_1$cumadopt, net_single$cumadopt) +}) -# set.seed(1234) -# net1 <- rdiffnet(100, 5, rewire = FALSE, seed.p.adopt = list(0.1,0.08), seed.nodes = c(1,3,5)) -# net2 <- rdiffnet(100, 5, rewire = FALSE, seed.p.adopt = list(0.1,0.08), seed.nodes = list(c(1,3,5),c(1,3,5))) -# expect_equal(net1, net2) +test_that("Disadoption works", { + + + set.seed(1231) + n <- 500 + + d_adopt <- function(expo, cumadopt, time) { + + # Id double adopters + ids <- which(apply(cumadopt[, time, , drop=FALSE], 1, sum) > 1) + + if (length(ids) == 0) + return(list(integer(), integer())) + + # Otherwise, make them pick one (literally, you can only adopt + # A single behavior, in this case, we prefer the second) + return(list(ids, integer())) + + } + + ans_d_adopt <- rdiffnet(n = n, t = 10, disadopt = d_adopt, seed.p.adopt = list(0.1, 0.1)) + + tmat <- toa_mat(ans_d_adopt) + should_be_ones_or_zeros <- tmat[[1]]$cumadopt[, 10] + tmat[[2]]$cumadopt[, 10] + expect_true(all(should_be_ones_or_zeros %in% c(0,1))) + +}) diff --git a/vignettes/simulating-multiple-behaviors-on-networks.Rmd b/vignettes/simulating-multiple-behaviors-on-networks.Rmd new file mode 100644 index 00000000..ca65c5f3 --- /dev/null +++ b/vignettes/simulating-multiple-behaviors-on-networks.Rmd @@ -0,0 +1,311 @@ +--- +title: "Simulating Multiple Behaviors on Networks" +author: "Aníbal Olivera M." +date: "2024-11-21" +output: html_document +--- + +\tableofcontents + +News for **netdiffuseR** package. + +```{r loading, message=FALSE, warning=FALSE} + +#devtools::install_github("USCCANA/netdiffuseR", ref = "47-split-behaviors-rdiffnet") +library(netdiffuseR) +``` + +# Introduction + +- Social networks facilitate the spread of news, gossip, behaviors, and products. Granovetter specified a simple and intuitive mechanism that underpins much of the research on social network diffusion: individuals adopt a behavior if enough others do so. +- More specifically, in an interacting population of individuals where a behavior is spreading, each individual has a particular “threshold” and adopts the behavior if the proportion of others who have already adopted the behavior exceeds the threshold. +- However, adoption booms are commonly followed by periods of bust—riots come to an end, new fashions go out of style, and juicy gossip turns to stale news. +- So the adoption of a fashion is followed by the disadoption of that fashion by a new one. +- This dynamic requires being able to handle more than one 'propagation' at a time. +- Until now, **netdiffuseR** was not able to simulate more than one diffusion in the same setup. + +# Allowing multi-behavior diffusion simulations + +## How rdiffnet works until now + +In a (very) simplified way, `rdiffnet` has 4 steps. Before this current version, the workflow can be diagrammed as: + +```{r, echo=FALSE, out.width="55%", fig.align="center"} +knitr::include_graphics("~/anibal/netdiffuseR-original/playground/images/diagrams-single-1.png") +``` + +## How rdiffnet works from now + +In the current version, we maintain the basic structure of the workflow, but adding some functions and modifying the existing for allowing multi-behavior diffusion. + +```{r, echo=FALSE, out.width="55%", fig.align="center"} +knitr::include_graphics("~/anibal/netdiffuseR-original/playground/images/diagrams-multiple-1.png") +``` + +As you can see, now in Step 1.0, before identify the seed nodes as initial condition, the inputs `seed.p.adopt` (default 0.1 for single behavior), `seed.nodes` (default 'random'), and `behavior` (default 'random behavior') are passed to an internal function that validates they as accepted inputs and homogenized the objects for the rest of the code. + +As before, `rdiffnet` still accepts several kinds of inputs, for different classes classes and specifications, but the input that characterized the **multi-behavior** simulation is exclusively `seed.p.adopt`. If `class(seed.p.adopt)` is a `list`, then the simulation will run a total of `length(seed.p.adopt)` behaviors in the same setup. This table summarize the possible inputs for `seed.p.adopt`, `seed.nodes`, `threshold.dist`, and `behavior`, showing some examples. + +```{r, echo=FALSE, out.width="60%", fig.align="center"} +knitr::include_graphics("~/anibal/netdiffuseR-original/playground/images/table_1.png") +``` + +All functions in other steps were revised to allow now different object that can handle multi-behavior, while still can execute the already in-build functions for single diffusion within the package (as `plot()`, `plot_diffnet()`, and `plot_adopters()`, among many others). + +Additionally, now there is a new function `split_behaviors()` that returns a list where each element is a separate rdiffnet object, that correspond with each separate behavior. So in this way, you could use the same machinery constructed for single behavior, to plot or analyze now the result of the multi-behavior simulation. + +All those features are shown in more detail below. + +# `rdiffnet()` examples + +## For single diffusion: + +```{r} + +set.seed(123) + +rdiffnet(100, 5) +?rdiffnet + +rdiffnet(100, 5, seed.p.adopt = 0.1) + +rdiffnet(100, 5, seed.p.adopt = 0.1, behavior = 'tabacco') + +rdiffnet(100, 5, seed.p.adopt = 0.1, threshold.dist = 0.3) +rdiffnet(100, 5, seed.p.adopt = 0.1, threshold.dist = function(x) 0.3) +rdiffnet(100, 5, seed.p.adopt = 0.1, threshold.dist = runif(100, .2,.7)) + +rdiffnet(100, 5, seed.p.adopt = 0.1, seed.nodes = 'central') + +seed_nodes <- sample(1:100, 10, replace = FALSE) +rdiffnet(100, 5, seed.nodes = seed_nodes) + +``` + +but also, we can **specify the network**: + +```{r} +#| warning: false + +set.seed(121) +n <- 200 +t <- 10 +graph <- rgraph_ws(n, 10, p=.3) # watts-strogatz model +thr <- runif(n, .3,.5) + +rdiffnet(seed.graph = graph, t = t , seed.p.adopt = 0.1, threshold.dist = thr) +``` + +## For multi diffusion: + +```{r} + +set.seed(124) +rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), behavior = 'tabacco') +rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), behavior = c('tabacco', 'alcohol')) + +diffnet <- rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = 0.3) +diffnet$vertex.static.attrs +rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = runif(100)) +diffnet <- rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = function(x) 0.3) +diffnet$vertex.static.attrs +rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = list(0.3, 0.2)) +rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = list(runif(100), runif(100))) +rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), threshold.dist = list(function(x) 0.3, function(x) 0.2)) + +set.seed(123) +rdiffnet(100, 5, seed.p.adopt = list(0.1, 0.08), seed.nodes = c('random', 'central')) + +set.seed(123) +seed_nodes <- sample(1:100, 10, replace = FALSE) +rdiffnet(100, 5, seed.p.adopt = list(0, 0), seed.nodes = list(seed_nodes, seed_nodes)) + +``` + +Alternatively, we can **specify the network**: + +```{r} +#| warning: false + +set.seed(121) +n <- 200 +t <- 10 +graph <- rgraph_ws(n, t, p=.3) # watts-strogatz model +thr <- runif(n, .3,.5) + +diffnet <- rdiffnet(seed.graph = graph, t = t , seed.p.adopt = list(0.1, 0.15), + threshold.dist = thr) +diffnet +``` + +# `split_behaviors()` and disadoption + +If you want to use other function to analyze the results from the simulation focusing in a single behavior, you could use \`split_behaviors()\`: + +```{r} +#| warning: false + + set.seed(12131) + n <- 50 + t <- 5 + graph <- rgraph_ws(n, 4, p=.3) + seed.nodes <- c(1,5,7,10) + thr <- runif(n, .2,.4) + + # Generating identical networks + net_single <- rdiffnet(seed.graph = graph, t = t, seed.nodes = seed.nodes, + seed.p.adopt = 0.1, rewire = FALSE, threshold.dist = thr) + + net_multiple <- rdiffnet(seed.graph = graph, t = t, seed.nodes = seed.nodes, + seed.p.adopt = list(0.1, 0.1), rewire = FALSE, + threshold.dist = thr) + + net_single_from_multiple <- split_behaviors(net_multiple) + net_single_from_multiple_1 <- net_single_from_multiple[[1]] + + expect_equal(net_single_from_multiple_1$toa, net_single$toa) + expect_equal(net_single_from_multiple_1$adopt, net_single$adopt) + expect_equal(net_single_from_multiple_1$cumadopt, net_single$cumadopt) + +``` + +## Plotting each behavior + +```{r} + +plot_diffnet(net_single) +plot_diffnet(net_single_from_multiple_1) + +``` + +# Disadoption + +Until now the behaviors are independent, but we can add some disadoption function to make them dependent each other. This is achieved by introducing the function you want as an input tho rdiffnet: `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, disadopt = NULL)` + +```{r} + +set.seed(1231) +n <- 500 + +d_adopt <- function(expo, cumadopt, time) { + + # Id double adopters + ids <- which(apply(cumadopt[, time, , drop=FALSE], 1, sum) > 1) + + if (length(ids) == 0) + return(list(integer(), integer())) + + # Otherwise, make them pick one (literally, you can only adopt + # a single behavior, in this case, we prefer the second) + return(list(ids, integer())) + +} + +ans_d_adopt <- rdiffnet(n = n, t = 10, disadopt = d_adopt, + seed.p.adopt = list(0.1, 0.1)) + +tmat <- toa_mat(ans_d_adopt) +should_be_ones_or_zeros <- tmat[[1]]$cumadopt[, 10] + tmat[[2]]$cumadopt[, 10] + +expect_true(all(should_be_ones_or_zeros %in% c(0,1))) + +``` + +```{r} + +set.seed(1231) + +n <- 100; t <- 5; +graph <- rgraph_ws(n, t, p=.3) + +random_dis <- function(expo, cumadopt, time) { + num_of_behaviors <- dim(cumadopt)[3] + + list_disadopt <- list() + + for (q in 1:num_of_behaviors) { + adopters <- which(cumadopt[, time, q, drop=FALSE] == 1) + if (length(adopters) == 0) { + # only disadopt those behaviors with adopters + list_disadopt[[q]] <- integer() + } else { + # selecting 10% of adopters to disadopt + list_disadopt[[q]] <- sample(adopters, ceiling(0.10 * length(adopters))) + } + } + return(list_disadopt) +} + +diffnet_random_dis <- rdiffnet(seed.graph = graph, t = 10, disadopt = random_dis, + seed.p.adopt = list(0.1, 0.1)) + + +``` + +# `exposure()` examples + +- Exposure for multiple behaviors: + +```{r} +#| warning: false + +set.seed(12131) +g <- rgraph_ws(20, 4, p=.3) # watts-strogatz model +set0 <- c(1,5,7,10) +thr <- runif(20, .4,.7) + +diffnet <- rdiffnet(seed.graph = g, seed.nodes = set0, t = 4, rewire = FALSE, + threshold.dist = thr) + +cumadopt_2 <- diffnet$cumadopt +cumadopt_2 <- array(c(cumadopt_2,cumadopt_2[rev(1:nrow(cumadopt_2)),]), dim=c(dim(cumadopt_2), 2)) + +print(exposure(diffnet, cumadopt = cumadopt_2)) +``` + +# rdiffnet_validate_arg() + +Maybe not necessary, as this is an internal function. + +# Threshold + +## Thresholds + +- One of the cannonical concepts is the network threshold. Network thresholds (Valente, 1995; 1996), $\tau$, are defined as the required proportion or number of neighbors that leads you to adopt a particular behavior (innovation), $a=1$. In (very) general terms\pause + +$$ +a_i = \left\{\begin{array}{ll} +1 &\mbox{if } \tau_i\leq E_i \\ +0 & \mbox{Otherwise} +\end{array}\right. \qquad +E_i \equiv \frac{\sum_{j\neq i}\mathbf{X}_{ij}a_j}{\sum_{j\neq i}\mathbf{X}_{ij}} +$$ + +Where $E_i$ is i's exposure to the innovation and $\mathbf{X}$ is the adjacency matrix (the network). + +# new_diffnet() + +Same, is an internal function. + +# split_behaviors() + +Examples. + +- Importantly, while very useful, `diffnet` objects is not the only way to use **netdiffuseR**. Most of the functions can also be used with matrices and arrays. + +```{r Loading netdiffuseR, echo=FALSE} +library(netdiffuseR) +knitr::opts_chunk$set(comment = '#') +``` + +# Raw network data + +- We call raw network data to datasets that have a somewhat raw form, for example, edgelists, + +Note that the `echo = FALSE` parameter was added to the code chunk to prevent printing of the R code that generated the plot. + +- For this tutorial, we classify graph data as follows: + - Raw R network data: Datasets with edgelist, attributes, survey data, etc. + - Already R data: already read into R using igraph, statnet, etc. + - Graph files: DL, UCINET, pajek, etc. +- The includes several options to read such data.