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 <[email protected]>

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/

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)

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

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