generalization of rdiffnet_make_threshold function. Some others modif…

…ication following the merge of the 41... branch

DESCRIPTION

@@ -7,7 +7,8 @@ Authors@R: c(
     ),
   person("Thomas", "Valente", email="[email protected]", role=c("aut", "cph"),
     comment=c(ORCID="0000-0002-8824-5816", what="R original code")),
-  person("Anibal", "Olivera Morales", role = c("aut", "ctb")),
+  person("Anibal", "Olivera Morales", role = c("aut", "ctb"), 
+    comment=c(ORCID="0009-0000-3736-7939", what="Multi-diffusion version")),
   person("Stephanie", "Dyal", email="[email protected]", role=c("ctb"), comment="Package's first version"),
   person("Timothy", "Hayes", email="[email protected]", role=c("ctb"), comment="Package's first version")
   )

R/diffnet-class.r

@@ -631,7 +631,7 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm
                                                       as.character(name)))
   meta$behavior   <- ifelse(!length(behavior), "", ifelse(is.na(behavior), "",
                                                           as.character(behavior)))
-  meta$version    <- 5
+  meta$version    <- utils::packageVersion("netdiffuseR")
 
   # Removing dimnames
   graph                  <- Map(function(x) Matrix::unname(x), x=graph)

R/rdiffnet.r

@@ -111,42 +111,30 @@
 #' @name rdiffnet
 NULL
 
-rdiffnet_make_threshold <- function(x, n) {
+rdiffnet_make_threshold <- function(x, n, q) {
 
-  # Using sapply to compute the threshold
   if (inherits(x, "function")) {
 
-    thr <- sapply(1:n, x)
+    thr <- matrix(sapply(1:(n*q), function(i) x()), nrow = n, ncol = q)
 
-  } else if ((length(x)==1) && is.numeric(x)) {
+  } else if (is.numeric(x) && length(x) == 1) {
 
-    thr <- rep(x, n)
+    thr <- matrix(rep(x, n * q), nrow = n, ncol = q)
 
   } else {
-    # Setting depending on class
-    if (any(class(x) %in% c("data.frame", "matrix"))) {
-
-      thr <- as.vector(as.matrix(x))
-
-      # Must match the length of n
-      if (length(thr) != n)
-        stop("Incorrect length for -threshold.dist- (",length(x),")",
-             ". It should be a vector of length ",n,".")
 
+    if (any(class(x) %in% c("data.frame", "matrix"))) {
+      thr <- as.matrix(x)
+      if (!all(dim(thr) == c(n, q))) stop("Incorrect dimensions for threshold.dist.",
+                                      "It should be a matrix of size ", n, "x", q, ".")
     } else if (is.vector(x)) {
-
-      thr <- x
-
-      # Must match the length of n
-      if (length(thr) != n)
-        stop("Incorrect length for -threshold.dist- (",length(x),")",
-             ". It should be a vector of length ",n,".")
-
-    } else {
-
-      stop("-threshold.dist- must be either a numeric vector of length -n-, a numeric scalar, or a function.")
-
-    }
+      if (length(x) == n * q && q>1) {
+        stop("Incorrect input: A vector of length ", n*q, " is not allowed.",
+             "Please provide a vector of length ", n, ".")
+      } else if (length(x) == n) {
+        thr <- matrix(rep(x, q), nrow = n, ncol = q)
+      } else stop("Incorrect length for threshold.dist.")
+    } else stop("threshold.dist must be a numeric vector or matrix of appropriate size or a function.")
   }
 
   thr
@@ -316,7 +304,7 @@ rdiffnet <- function(
     seed.p.adopt   = 0.05,
     seed.graph     = "scale-free",
     rgraph.args    = list(),
-    rewire         = TRUE, #set TRUE originally
+    rewire         = TRUE,
     rewire.args    = list(),
     threshold.dist = runif(n),
     exposure.args  = list(),
@@ -440,10 +428,10 @@ rdiffnet <- function(
   toa <- matrix(NA, nrow = dim(cumadopt)[1], ncol = dim(cumadopt)[3])
 
   # Step 2.0: Thresholds -------------------------------------------------------
-  thr <- rdiffnet_make_threshold(threshold.dist, n) # REMINDER TO CHANGE rdiffnet_make_threshold
+  thr <- rdiffnet_make_threshold(threshold.dist, n, num_of_behaviors) # REMINDER TO CHANGE rdiffnet_make_threshold
 
                                                                 # ONLY MEANWHILE
-  thr <- array(c(thr,rev(thr)), dim=c(length(thr), dim(cumadopt)[3]))
+  #thr <- array(c(thr,rev(thr)), dim=c(length(thr), dim(cumadopt)[3]))
 
   # Step 3.0: Running the simulation -------------------------------------------
 

R/stats.R

@@ -476,15 +476,6 @@ NULL
   # Checking self
   if (!self) graph <- sp_diag(graph, rep(0, nnodes(graph)))
 
-  #ans <- ( graph %*% (attrs * cumadopt) )
-  #
-  #if (normalized) {
-  #  as.vector(ans/( graph %*% attrs + 1e-20 ))
-  #} else {
-  #  as.vector(ans)
-  #}
-  #
-
   norm <- graph %*% attrs + 1e-20
 
   if (!is.na(dim(cumadopt)[3])) {
@@ -505,13 +496,9 @@ NULL
     }
   }
 
-  #as.vector(ans)
   return(as.vector(ans))
 }
 
-# library(microbenchmark)
-# microbenchmark(.exposure, netdiffuseR:::exposure_cpp)
-
 check_lags <- function(npers, lags) {
 
   # Checking length
@@ -673,18 +660,6 @@ exposure_for <- function(
   lags
   ) {
 
-  #out <- matrix(nrow = nrow(cumadopt), ncol = ncol(cumadopt))
-
-  #if (lags >= 0L) {
-  #  for (i in 1:(nslices(graph) - lags))
-  #    out[,i+lags]<- .exposure(graph[[i]], cumadopt[,i,drop=FALSE], attrs[,i,drop=FALSE],
-  #                             outgoing, valued, normalized, self)
-  #} else {
-  #  for (i in (1-lags):nslices(graph))
-  #    out[,i+lags]<- .exposure(graph[[i]], cumadopt[,i,drop=FALSE], attrs[,i,drop=FALSE],
-  #                             outgoing, valued, normalized, self)
-  #}
-
   if (!is.na(dim(cumadopt)[3])) {
     out <- array(NA, dim = c(dim(cumadopt)[1], dim(cumadopt)[2], dim(cumadopt)[3]))
 

tests/testthat/test-rdiffnet-parameters.R

@@ -3,6 +3,9 @@
 # Must work
 test_that(
   "Checking single diffusion rdiffnet args", {
+
+  # Must work
+
   seed.p.adopt <- c(0.14)
   seed.nodes <- c('random')
   behavior <- c("random behavior")
@@ -49,11 +52,38 @@ test_that(
   )
 })
 
+test_that("Checking threshold for single diffusion", {
+
+  # Must work
+
+  thr <- rdiffnet_make_threshold(1.5, n = 50, q = 1)
+  expect_equal(dim(thr), c(50, 1))
+
+  x <- runif(50)
+  thr <- rdiffnet_make_threshold(x, n = 50, q = 1)
+  expect_equal(dim(thr), c(50, 1))
+
+  thr <- rdiffnet_make_threshold(function() 0.5, n = 50, q = 1)
+  expect_equal(dim(thr), c(50, 1))
+
+  thr <- rdiffnet_make_threshold(function() rexp(1), n = 50, q = 1)
+  expect_equal(dim(thr), c(50, 1))
+
+  # Must show ERROR
+
+  x <- runif(100) # Length n*q
+  expect_error(
+    rdiffnet_make_threshold(x, n = 50, q = 1)
+  )
+
+})
 
 # Multiple --------------------------------------------------------------------
 
-# Must work
 test_that("Multi diff  models rdiff args work", {
+
+  # Must work
+
   seed.p.adopt <- list(0.14,0.05)
   seed.nodes <- list('random', "central")
   behavior <- list("random behavior_1", "random behavior_2")
@@ -110,3 +140,44 @@ test_that("Multi diff  models rdiff args work", {
   )
 })
 
+
+# NOT working now !!!
+
+# test_that("Checking threshold for multiple diffusion", {
+#
+#   # Must work
+#
+# x <- matrix(runif(100), nrow = 50, ncol = 2)
+# thr <- rdiffnet_make_threshold(x, n = 50, q = 2)
+# expect_equal(dim(thr), c(50, 2))
+#
+# x <- runif(100) # Length n*q
+# expect_error(
+#   rdiffnet_make_threshold(x, n = 50, q = 2)
+# )
+#
+#   seed.p.adopt <- list(function() runif(1), function() rexp(1))
+#   thr <- rdiffnet_make_threshold(seed.p.adopt, n = 50, q = 2)
+#   expect_equal(dim(thr), c(50,1))
+#
+#
+#   seed.p.adopt <- list(0.14,0.05)
+#   thr <- rdiffnet_make_threshold(seed.p.adopt[[1]], n = 50, q = 2)
+#   expect_equal(dim(thr), c(50,2))
+#
+#
+#   seed.p.adopt <- list(runif(50), runif(50))
+#
+#   # Test first element of list
+#   thr <- rdiffnet_make_threshold(seed.p.adopt[[1]], n = 50, q =1 )
+#
+#   expect_equal(dim(thr), c(50,1))
+#
+#
+#   # Must show ERROR
+#
+#   x <- runif(100) # Length n*q
+#   expect_error(
+#     rdiffnet_make_threshold(x, n=100,q=3),
+#     "incorrect input
+# }