Merge branch '47-split-behaviors-patch' into 47-split-behaviors-rdiffnet

Author: gvegayon

R/rdiffnet.r

@@ -320,7 +320,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
@@ -451,6 +452,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])
     }
@@ -460,24 +463,62 @@ rdiffnet <- function(
 
     for (q in 1:num_of_behaviors) {
 
+      # 3.2 Identifying who adopts based on the threshold
       whoadopts <- which( (expo[,,q] >= thr[,q]) )
+
+      # 3.3 Updating the cumadopt
       cumadopt[whoadopts, i:t, q] <- 1L
-                                                        # ADD SOMETHING TO DISADOPT
 
+      # 3.4` Updating the toa
+      # toa[cbind(whoadopts, q)] <- i
       toa[, q] <- apply(cumadopt[,, q], 1, function(x) {
         first_adopt <- which(x == 1)
         if (length(first_adopt) > 0) first_adopt[1] else NA
       })
 
     }
+
+    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 is 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
+
+      }
+
+
+    }
   }
 
   for (i in 1:num_of_behaviors) {
     reachedt <- max(toa[,i], na.rm=TRUE)
 
     if (reachedt == 1) {
       if (stop.no.diff)
-        stop(paste("No diffusion in this network for behavior", i, "(Ups!) try changing the seed or the parameters."))
+        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."))
     }

tests/testthat/test-rdiffnet.R

@@ -180,6 +180,33 @@ test_that("toa, adopt, and cumadopt should be equal! (split_behaviors tests)", {
   expect_equal(net_single_from_multiple_1$cumadopt, net_single$cumadopt)
 })
 
+test_that("Disadoption works", {
+
+
+  set.seed(1231)
+  n <- 500
+
+  d_adopt <- function(expo, cumadopt, time) {
+
+    # Id double adopters
+    ids <- which(apply(cumadopt[, 3, , 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, will drop the second)
+    return(list(ids, integer()))
+
+  }
+
+  ans <- rdiffnet(n = n, t = 10, disadopt = d_adopt, seed.p.adopt = list(0.1, 0.1))
+
+  tmat <- toa_mat(ans)
+  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)))
+
+})
 
 #rdiffnet(100, 5, seed.p.adopt = 0.9, threshold.dist = 2, exposure.args = list(normalized=FALSE))