Skip to content

Commit

Permalink
updates for dqrng 0.4.0 + cleanup
Browse files Browse the repository at this point in the history
- `dqrng` updates (see #96);
- be more careful setting seeds in tests;
- restored some previously failing tests;
- misc formatting/cleanup.
  • Loading branch information
achubaty committed May 13, 2024
1 parent 51d72db commit 44a71e3
Show file tree
Hide file tree
Showing 9 changed files with 183 additions and 213 deletions.
4 changes: 2 additions & 2 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -12,8 +12,8 @@ Description: Provides GIS and map utilities, plus additional modeling tools for
URL:
https://spades-tools.predictiveecology.org,
https://github.com/PredictiveEcology/SpaDES.tools
Date: 2024-04-25
Version: 2.0.6.9000
Date: 2024-05-13
Version: 2.0.6.9001
Authors@R: c(
person("Eliot J B", "McIntire", , "[email protected]", role = c("aut"),
comment = c(ORCID = "0000-0002-6914-8316")),
Expand Down
3 changes: 2 additions & 1 deletion NEWS.md
Original file line number Diff line number Diff line change
@@ -1,7 +1,8 @@
# SpaDES.tools (development version)

## bug fixes
* fixed issue with `rasterizeReduced()`
* fixed issue with `rasterizeReduced()`;
* updates to deal with changes to RNG in `dqrng` (#96; @rstub). if backwards compatibility is needed, set `dqrng::dqRNGkind("Xoroshiro128+")` before running `spread` to ensure numerical reproducibility with previous versions;

# SpaDES.tools 2.0.6

Expand Down
10 changes: 5 additions & 5 deletions R/initialize.R
Original file line number Diff line number Diff line change
Expand Up @@ -126,17 +126,17 @@ randomPolygons <- function(ras = rast(ext(0, 15, 0, 15), res = 1, vals = 0),
#' Produces a `SpatVector` polygons object with 1 feature that will have approximately an area
#' equal to `area` (expecting area in hectares), #' and a centre at approximately `x`.
#'
#' @param x Either a `SpatVector`, or `SpatialPoints` (deprecated), `SpatialPolygons`
#' (deprecated), or `matrix` with two
#' dimensions, 1 row, with the approximate centre of the new random polygon to create.
#' If `matrix`, then longitude and latitude are assumed (epsg:4326)
#' @param x Either a `SpatVector`, or `SpatialPoints` (deprecated), `SpatialPolygons` (deprecated),
#' or `matrix` with two dimensions, 1 row, with the approximate centre of the new random
#' polygon to create.
#' If `matrix`, then longitude and latitude are assumed (`epsg:4326`).
#'
#' @param area A numeric, the approximate area in `meters squared` of the random polygon.
#'
#' @param hectares Deprecated. Use `area` in meters squared.
#'
#' @return A `SpatVector` polygons object, with approximately the area request,
#' centred approximately at the coordinates requested, in the projection of `x`
#' centred approximately at the coordinates requested, in the projection of `x`.
#'
#' @importFrom terra crs crs<-
#' @importFrom stats rbeta runif
Expand Down
49 changes: 27 additions & 22 deletions R/spread.R
Original file line number Diff line number Diff line change
Expand Up @@ -275,10 +275,10 @@ utils::globalVariables(c(
#' between 0 and 1, which will force `relativeSpreadProb`
#' to be `TRUE`.
#'
#' @param ... Additional named vectors or named list of named vectors
#' required for `stopRule`. These
#' vectors should be as long as required e.g., length
#' `loci` if there is one value per event.
#' @param ... Additional named vectors or named list of named vectors required for `stopRule`.
#' These vectors should be as long as required e.g., length `loci` if there is
#' one value per event.
#'
#' @param plot.it If `TRUE`, then plot the raster at every iteration,
#' so one can watch the spread event grow.
#'
Expand Down Expand Up @@ -319,6 +319,10 @@ utils::globalVariables(c(
#'
#' This will generally be more useful when `allowOverlap` is `TRUE`.
#'
#' @note `dqrng` v0.4.0 changed the default RNG. If backwards compatibility is needed,
#' set `dqrng::dqRNGkind("Xoroshiro128+")` before running `spread` to ensure numerical
#' reproducibility with previous versions.
#'
#' @example inst/examples/example_spread.R
#'
#' @author Eliot McIntire and Steve Cumming
Expand Down Expand Up @@ -346,9 +350,9 @@ spread <- function(landscape, loci = NA_real_, spreadProb = 0.23, persistence =
stop("Can't use neighProbs and allowOverlap = TRUE together")
}
if (requireNamespace("dqrng", quietly = TRUE)) {

dqrng::dqset.seed(sample.int(1e9, 2)) ## set dqrng seed from base state
samInt <- dqrng::dqsample.int
# set dqrng seed from base state
dqrng::dqset.seed(sample.int(1e9, 2))
} else {
samInt <- sample.int
}
Expand Down Expand Up @@ -456,21 +460,22 @@ spread <- function(landscape, loci = NA_real_, spreadProb = 0.23, persistence =
if (!is.null(lowMemory)) {
message("lowMemory argument is now deprecated; using standard spread.")
}
# The experimental new spread function has some changes for speed. 1) The
# bottleneck amazingly, was the creation of a new empty vector of length
# ncell(landscape) ... it took >50% of the time of the spread function
# when called 100,000s of times on a variety of spreadProb situations. 2) I
# found that the only way to stop instantiating this was to have a
# data.table object that uses reference semantics. 3) Put a simple, 1 column
# data.table object into the SpaDES.tools namespace. It will contain the
# former spreads object which was 0 everywhere the events hadn't spread
# to, and a non-zero integer otherwise. 4) The function has to make sure that
# it is "correct" on leaving the function. Two different cases: A) it
# exits improperly --> action is delete this object; B) it exits correctly
# --> action is to change all the values that were non-zero back to zero,
# rather than delete the object. The whole point is to keep the object
# intact after it has exited spread, so that it is available again
# immediately for reuse.
## The experimental new spread function has some changes for speed.
## 1) The bottleneck, amazingly, was the creation of a new empty vector of length
## ncell(landscape) ... it took >50% of the time of the spread function
## when called 100,000s of times on a variety of spreadProb situations.
## 2) I found that the only way to stop instantiating this was to have a
## data.table object that uses reference semantics.
## 3) Put a simple, 1 column data.table object into the SpaDES.tools namespace.
## It will contain the former spreads object which was 0 everywhere the events
## hadn't spread to, and a non-zero integer otherwise.
## 4) The function has to make sure that it is "correct" on leaving the function.
## Two different cases:
## A) it exits improperly --> action is delete this object;
## B) it exits correctly --> action is to change all the values that were non-zero
## back to zero, rather than delete the object.
## The whole point is to keep the object intact after it has exited spread,
## so that it is available again immediately for reuse.
needEmptySpreads <- TRUE
stNamespace <- asNamespace("SpaDES.tools")
if (exists("spreadsDTInNamespace", envir = stNamespace)) {
Expand Down Expand Up @@ -802,7 +807,7 @@ spread <- function(landscape, loci = NA_real_, spreadProb = 0.23, persistence =
# random ordering so not always same:
lenPot <- NROW(potentials)
if (lenPot) {
reorderVals <- samInt(lenPot) ## TODO: uses sample.int(..., replace = FALSE)
reorderVals <- samInt(lenPot)
potentials <- potentials[reorderVals, , drop = FALSE]
}
if (!allowOverlap) {
Expand Down
10 changes: 5 additions & 5 deletions man/randomPolygons.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

12 changes: 8 additions & 4 deletions man/spread.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

86 changes: 31 additions & 55 deletions tests/testthat/helper-testInit.R
Original file line number Diff line number Diff line change
@@ -1,11 +1,13 @@
rastDF <- data.frame(pkg = c("raster", "terra"),
class = c("Raster", "SpatRaster"),
read = c("raster::raster", "terra::rast"),
stack = c("raster::stack", "terra::rast"),
stackClass = c("RasterStack", "SpatRaster"),
extent = c("raster::extent", "terra::ext"))

needTerraAndRaster <- function(envir = parent.frame()) {
rastDF <- data.frame(
pkg = c("raster", "terra"),
class = c("Raster", "SpatRaster"),
read = c("raster::raster", "terra::rast"),
stack = c("raster::stack", "terra::rast"),
stackClass = c("RasterStack", "SpatRaster"),
extent = c("raster::extent", "terra::ext")
)

if (!requireNamespace("raster", quietly = TRUE)) {
rastDF <- rastDF[rastDF$pkg == "terra", ]
}
Expand All @@ -18,17 +20,12 @@ needTerraAndRaster <- function(envir = parent.frame()) {
# optsAsk in this environment,
# loads and libraries indicated plus testthat,
# sets options("reproducible.ask" = FALSE) if ask = FALSE
testInit <- function(libraries = character(), ask = FALSE, verbose,
tmpFileExt = "",
opts = NULL, needGoogleDriveAuth = FALSE
) {
testInit <- function(libraries = character(), ask = FALSE, verbose, tmpFileExt = "", opts = NULL) {
data.table::setDTthreads(2)
reproducible::set.randomseed()

pf <- parent.frame()

if (isTRUE(needGoogleDriveAuth))
libraries <- c(libraries)
if (length(libraries)) {
libraries <- unique(libraries)
loadedAlready <- vapply(libraries, function(pkg)
Expand All @@ -44,56 +41,35 @@ testInit <- function(libraries = character(), ask = FALSE, verbose,
}
}

# skip_gauth <- identical(Sys.getenv("SKIP_GAUTH"), "true") # only set in setup.R for covr
# if (isTRUE(needGoogleDriveAuth) ) {
# if (!skip_gauth) {
# if (interactive()) {
# if (!googledrive::drive_has_token()) {
# getAuth <- FALSE
# if (is.null(getOption("gargle_oauth_email"))) {
# possLocalCache <- "c:/Eliot/.secret"
# cache <- if (file.exists(possLocalCache))
# possLocalCache else TRUE
# switch(Sys.info()["user"],
# emcintir = {options(gargle_oauth_email = "[email protected]",
# gargle_oauth_cache = cache)},
# NULL)
# }
# if (is.null(getOption("gargle_oauth_email"))) {
# if (.isRstudioServer()) {
# .requireNamespace("httr", stopOnFALSE = TRUE)
# options(httr_oob_default = TRUE)
# }
# }
# getAuth <- TRUE
# if (isTRUE(getAuth))
# googledrive::drive_auth()
# }
# }
# }
# skip_if_no_token()
# }

out <- list()
withr::local_options("reproducible.ask" = ask, .local_envir = pf)
# withr::local_options("spades.debug" = debug, .local_envir = pf)
# withr::local_options("spades.moduleCodeChecks" = smcc, .local_envir = pf)
withr::local_options("spades.recoveryMode" = FALSE, .local_envir = pf)
withr::local_options("reproducible.verbose" = FALSE, .local_envir = pf)
withr::local_options("spades.useRequire" = FALSE, .local_envir = pf)
withr::local_options("spades.sessionInfo" = FALSE, .local_envir = pf)

if (!missing(verbose))
## set default options for tests
withr::local_options(list(
reproducible.ask = ask,
reproducible.verbose = FALSE,
# spades.debug = debug,
# spades.moduleCodeChecks = smcc,
spades.sessionInfo = FALSE,
spades.recoveryMode = FALSE,
spades.useRequire = FALSE
), .local_envir = pf)

if (!missing(verbose)) {
withr::local_options("reproducible.verbose" = verbose, .local_envir = pf)
if (!is.null(opts))
}
if (!is.null(opts)) {
withr::local_options(opts, .local_envir = pf)
tmpdir <- reproducible::normPath(withr::local_tempdir(tmpdir = reproducible::tempdir2(), .local_envir = pf))
tmpCache <- reproducible::normPath(withr::local_tempdir(tmpdir = tmpdir, .local_envir = pf))
}
tmpdir <- withr::local_tempdir(tmpdir = reproducible::tempdir2(), .local_envir = pf) |>
reproducible::normPath()
tmpCache <- withr::local_tempdir(tmpdir = tmpdir, .local_envir = pf) |>
reproducible::normPath()
if (isTRUE(any(nzchar(tmpFileExt)))) {
dotStart <- startsWith(tmpFileExt, ".")
if (any(!dotStart))
tmpFileExt[!dotStart] <- paste0(".", tmpFileExt)
out$tmpfile <- reproducible::normPath(withr::local_tempfile(tmpdir = tmpdir, fileext = tmpFileExt))
out$tmpfile <- withr::local_tempfile(tmpdir = tmpdir, fileext = tmpFileExt) |>
reproducible::normPath()
}
withr::local_dir(tmpdir, .local_envir = pf)

Expand Down
Loading

0 comments on commit 44a71e3

Please sign in to comment.