Move pbapply to suggests and fix some of the CI test problems

7 files changed, 52 insertions, 6 deletions

diff --git a/DESCRIPTION b/DESCRIPTION
index b36057d..d59b985 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -27,12 +27,12 @@ Imports:
     Matrix,
     methods,
     parallel,
-    pbapply,
     Rcpp (>= 0.8.0),
     stats,
     TMB (>= 1.7.18),
     utils
 Suggests:
+    pbapply,
     knitr,
     rmarkdown,
     raster,
diff --git a/NAMESPACE b/NAMESPACE
index 3234918..a91651a 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -17,7 +17,6 @@ importFrom(methods, is, as, new, show, slot, .hasSlot, callGeneric,
            callNextMethod, setMethod)
 importFrom(lattice, xyplot, levelplot)
 importFrom(Rcpp, evalCpp)
-importFrom(pbapply, pbsapply, pblapply)
 
 
 # Fitting functions
diff --git a/R/boot.R b/R/boot.R
index 2f8cffc..8f854c8 100644
--- a/R/boot.R
+++ b/R/boot.R
@@ -77,7 +77,8 @@ setMethod("parboot", "unmarkedFit",  function(object, statistic=SSE, nsim=10,
     })
   }
 
-  t.star <- t(pbapply::pbsapply(simList, run_sim, object=object,
+  # Uses pbapply if available, or parSapply if not (see utils.R)
+  t.star <- t(sapply2(simList, run_sim, object=object,
                               statistic=statistic, starts=starts, t0=t0,
                               cl=cl, ...))
   if(length(t0) == 1) t.star <- matrix(t.star, ncol=1)
diff --git a/R/power.R b/R/power.R
index da2072c..3240e8e 100644
--- a/R/power.R
+++ b/R/power.R
@@ -84,6 +84,9 @@ powerAnalysis <- function(object, coefs=NULL, design=NULL, alpha=0.05, nulls=lis
     ses <- shiny::getDefaultReactiveDomain()
     pb <- shiny::Progress$new(ses, min=0, max=1)
     pb$set(message="Running simulations")
+    if(!requireNamespace("pbapply", quietly=TRUE)){
+      stop("You need to install the pbapply package", call.=FALSE)
+    }
     fits <- pbapply::pblapply(1:nsim, function(i, sims, fit, bdata=NULL){
       if(!is.null(design)) fit@data <- bdata[[i]]
       if(inherits(fit, "unmarkedFitOccuMulti")){
@@ -99,7 +102,7 @@ powerAnalysis <- function(object, coefs=NULL, design=NULL, alpha=0.05, nulls=lis
 
   } else {
 
-    fits <- pbapply::pblapply(1:nsim, function(i, sims, fit, bdata=NULL){
+    fits <- lapply2(1:nsim, function(i, sims, fit, bdata=NULL){
       if(!is.null(design)) fit@data <- bdata[[i]]
       if(inherits(fit, "unmarkedFitOccuMulti")){
         fit@data@ylist <- sims[[i]]
@@ -429,6 +432,9 @@ shinyPower <- function(object, ...){
   if(!requireNamespace("shiny")){
     stop("Install the shiny library to use this function", call.=FALSE)
   }
+  if(!requireNamespace("pbapply")){
+    stop("Install the pbapply library to use this function", call.=FALSE)
+  }
   options(unmarked_shiny=TRUE)
   on.exit(options(unmarked_shiny=FALSE))
   .shiny_env$.SHINY_MODEL <- object
diff --git a/R/utils.R b/R/utils.R
index 6bfb5ac..8b977eb 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -909,3 +909,21 @@ E_loglam <- function(log_lam, object, name){
   ll <- log_lam + v/2
   ll
 }
+
+sapply2 <- function(X, FUN, ..., cl = NULL){
+  if(requireNamespace("pbapply", quietly=TRUE)){
+    return(pbapply::pbsapply(X=X, FUN=FUN, ..., cl = cl))
+  } else if(!is.null(cl)){
+    return(parallel::parSapply(cl=cl, X=X, FUN=FUN, ...))
+  }
+  sapply(X=X, FUN=FUN, ...)
+}
+
+lapply2 <- function(X, FUN, ..., cl = NULL){
+  if(requireNamespace("pbapply", quietly=TRUE)){
+    return(pbapply::pblapply(X=X, FUN=FUN, ..., cl = cl))
+  } else if(!is.null(cl)){
+    return(parallel::parLapply(cl=cl, X=X, fun=FUN, ...))
+  }
+  lapply(X=X, FUN=FUN, ...)
+}
diff --git a/tests/testthat/test_parboot.R b/tests/testthat/test_parboot.R
index ca7e5e5..33a620b 100644
--- a/tests/testthat/test_parboot.R
+++ b/tests/testthat/test_parboot.R
@@ -68,7 +68,20 @@ test_that("parboot handles failing model fits", {
   set.seed(123)
   expect_warning(pb <- parboot(fm, nsim=20, statistic=fail_func))
   expect_equal(nrow(pb@t.star), 13)
+})
+
+test_that("parboot handles failing model fits in parallel", {
+  skip_on_cran()
+  skip_on_ci()
+  fail_func <- function(x){
+    rand <- rnorm(1)
+    if(rand > 0.5){
+      stop("fail")
+    }
+    return(rand)
+  }
 
+  set.seed(123)
   expect_warning(pb <- parboot(fm, nsim=20, statistic=fail_func, parallel=TRUE))
   expect_true(nrow(pb@t.star) < 20)
 
@@ -84,6 +97,15 @@ test_that("parboot handles statistic functions with additional arguments", {
   pb <- parboot(fm, nsim=10, statistic=opt_func, y=0.1)
   expect_equal(colnames(pb@t.star), c("res", "y"))
   expect_true(all(pb@t.star[,"y"]==0.1))
+})
+
+test_that("parboot handles statistic functions with additional arguments in parallel", {
+  skip_on_cran()
+  skip_on_ci()
+  opt_func <- function(x, y){
+    res <- mean(residuals(x), na.rm=TRUE)
+    c(res=res, y=y)
+  }
 
   pb <- parboot(fm, nsim=10, statistic=opt_func, y=0.1, parallel=TRUE)
   expect_equal(colnames(pb@t.star), c("res", "y"))
diff --git a/tests/testthat/test_predict.R b/tests/testthat/test_predict.R
index 3582470..440d87e 100644
--- a/tests/testthat/test_predict.R
+++ b/tests/testthat/test_predict.R
@@ -128,7 +128,7 @@ test_that("predicting from raster works",{
   expect_is(pr, 'RasterStack')
   expect_equal(names(pr), c("Predicted","SE","lower","upper"))
   expect_equal(pr[1,1][1], 0.3675313, tol=1e-5)
-  expect_equal(crs(pr), crs(nd_raster))
+  expect_equal(raster::crs(pr), raster::crs(nd_raster))
 
   #append data
   pr <- predict(mod, 'state', newdata=nd_raster, appendData=TRUE)
@@ -167,7 +167,7 @@ test_that("predicting from terra::rast works",{
   expect_is(pr, 'SpatRaster')
   expect_equal(names(pr), c("Predicted","SE","lower","upper"))
   expect_equivalent(pr[1,1][1], 0.3675313, tol=1e-5)
-  expect_equal(crs(pr), crs(nd_raster))
+  expect_equal(terra::crs(pr), terra::crs(nd_raster))
 
   #append data
   pr <- predict(mod, 'state', newdata=nd_raster, appendData=TRUE)