generalization of rdiffnet_make_threshold function. Some others modif…

…ication following the merge of the 41... branch
USCCANA · gvegayon · Nov 22, 2024 · Oct 29, 2024 · Oct 30, 2024 · Oct 31, 2024
commit c5990c49db0c65fae2967b0d8c55f58ae7316775
diff --git a/DESCRIPTION b/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")
   )

diff --git a/R/diffnet-class.r b/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)

diff --git a/R/rdiffnet.r b/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 -------------------------------------------
 

diff --git a/R/stats.R b/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]))
 

diff --git a/tests/testthat/test-rdiffnet-parameters.R b/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
 # }