diff --git a/DESCRIPTION b/DESCRIPTION index c0e0e0c..d095c62 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,7 +7,8 @@ Authors@R: c( ), person("Thomas", "Valente", email="tvalente@usc.edu", 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="stepharp@usc.edu", role=c("ctb"), comment="Package's first version"), person("Timothy", "Hayes", email="timothybhayes@gmail.com", role=c("ctb"), comment="Package's first version") ) diff --git a/R/diffnet-class.r b/R/diffnet-class.r index 73f5041..6704767 100644 --- 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 index 055be68..45557ef 100644 --- 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 index 4274ab0..f985660 100644 --- 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 index 8013b28..c7acb58 100644 --- 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 +# }