test_that("test miscellaneous unit tests cache-helpers", {
skip_if_not_installed("sf")
skip_if_not_installed("terra")
testInit(libraries = c("sf", "terra"), opts = list(reproducible.useMemoise = TRUE))
a <- 1
mess <- capture_message(.cacheMessage(a, "test", TRUE))
expect_true(any(grepl(.message$LoadedCacheResult("Memoised"), mess)))
mess <- capture_message(.cacheMessage(a, "test", FALSE))
## TODO: what was the old expected behaviour here? message now includes "added memoised copy"
# expect_false(any(grepl(paste0(.message$LoadedCacheResult(), ".*added"), mess)))
mess <- capture_message(.cacheMessage(a, "test", NA))
expect_true(any(grepl(.message$LoadedCacheResult(), mess)))
expect_false(all(grepl("adding", mess)))
# studyAreaName with sf and sfc
if (require("sf")) {
pol <- st_sfc(st_polygon(list(cbind(c(0, 3, 3, 0, 0), c(0, 0, 3, 3, 0)))))
h <- st_sf(r = 5, pol)
expect_true(is(studyAreaName(pol), "character"))
expect_true(is(studyAreaName(h), "character"))
}
# studyAreaName with SpatVector
if (requireNamespace("terra", quietly = TRUE)) {
v <- terra::vect(system.file("ex/lux.shp", package = "terra"))
expect_true(is(studyAreaName(v), "character"))
}
# studyAreaName with SPDF/SP
# coords <- structure(c(-122.98, -116.1, -99.2, -106, -122.98, 59.9, 65.73, 63.58, 54.79, 59.9),
# .Dim = c(5L, 2L))
# Sr1 <- Polygon(coords)
# Srs1 <- Polygons(list(Sr1), "s1")
# StudyArea <- SpatialPolygons(list(Srs1), 1L)
coords <- structure(c(-122.98, -116.1, -99.2, -106, -122.98, 59.9, 65.73, 63.58, 54.79, 59.9),
.Dim = c(5L, 2L)
)
StudyArea <- terra::vect(coords, "polygons")
terra::crs(StudyArea) <- crsToUse
df <- data.frame(a = 1, row.names = row.names(StudyArea))
# SPDF <- SpatialPolygonsDataFrame(StudyArea, df, match.ID = TRUE)
expect_true(is(studyAreaName(StudyArea), "character"))
# expect_true(is(studyAreaName(SPDF), "character"))
# studyAreaName with random object
expect_error(studyAreaName(integer(0)))
# .checkCacheRepo
options(reproducible.cachePath = .reproducibleTempCacheDir())
mess <- capture_message(.checkCacheRepo(a))
expect_true(any(grepl(.message$NoCacheRepoSuppliedGrep, mess)))
opt11 <- options("reproducible.cachePath" = NULL)
on.exit(
{
options(opt11)
},
add = TRUE
)
mess <- capture_message(.checkCacheRepo(a))
expect_true(any(grepl(paste0(.message$NoCachePathSupplied, ". Using"), mess)))
## nextNumericName
b <- nextNumericName("test.pdf")
b1 <- nextNumericName(b)
## expect_true(grepl("_2.pdf", b1)) ## TODO: this number is not consistently 2 or 3
aMess <- capture_messages({
a <- Cache(rnorm, 1, useCache = FALSE, cachePath = tmpCache)
})
bMess <- capture_messages({
b <- Cache(rnorm, 1, useCache = FALSE, cachePath = tmpCache)
})
expect_false(identical(a, b))
expect_true(grepl("skipping Cache", aMess))
expect_true(grepl("skipping Cache", bMess))
## getOption("reproducible.useMemoise" = FALSE)
opt22 <- options("reproducible.useMemoise" = FALSE)
aMess <- capture_messages({
a <- Cache(rnorm, 1, cachePath = tmpCache)
})
bMess <- capture_messages({
a <- Cache(rnorm, 1, cachePath = tmpCache)
})
options(opt22)
cMess <- capture_messages({
a <- Cache(rnorm, 1, cachePath = tmpCache)
})
dMess <- capture_messages({
a <- Cache(rnorm, 1, cachePath = tmpCache)
})
# expect_true(identical(aMess, bMess[1]))
expect_false(any(grepl(.message$LoadedCacheResult("Memoised"), bMess)))
expect_true(any(grepl(.message$LoadedCacheResult("Memoised"), dMess)))
## showSimilar
try(clearCache(ask = FALSE, x = tmpCache), silent = TRUE)
aMess <- capture_messages({
a <- Cache(rnorm, n = 1, mean = 1, cachePath = tmpCache)
})
# lapply(letters[11], function(l) assign(paste(rep(l, 4), collapse = ""), 1, envir = .GlobalEnv))
bMess <- capture_messages({
b <- Cache(rnorm, n = 2, mean = 1, sd = 3, showSimilar = TRUE, cachePath = tmpCache)
})
expect_true(any(grepl("different n", bMess)))
expect_true(any(grepl("different .+sd", bMess)))
# expect_true(any(grepl("new argument.*sd", bMess)))
expect_true(any(grepl("next closest cacheId", bMess)))
cMess <- capture_messages({
b <- Cache(rnorm, n = 3, mean = 1, sd = 3, showSimilar = TRUE, cachePath = tmpCache)
})
expect_true(any(grepl("different n", cMess)))
expect_false(any(grepl("new argument.*sd", cMess)))
cMessCacheId <- gsub(".*cacheId (.*)\x1b\\[.*", "\\1", grep("cacheId", cMess, value = TRUE))
bMessCacheId <- gsub(".*cacheId (.*)\x1b\\[.*", "\\1", grep("cacheId", bMess, value = TRUE))
expect_false(identical(cMessCacheId, bMessCacheId))
dMess <- capture_messages({
b <- Cache(rnorm, n = 4, mean = 1, sd = 4, showSimilar = TRUE, cachePath = tmpCache)
})
# There are 2 ways this may come out -- similarity to 1 of 2 alternatives above
expect1 <- any(grepl("different n, sd", dMess))
expect2 <- any(grepl("different n", dMess)) && any(grepl("new argument.*sd", dMess))
expect_true(expect1 || (expect2))
dMessCacheId <- gsub(".*cacheId (.*)\x1b\\[.*", "\\1", grep("cacheId", dMess, value = TRUE))
bMessCacheId <- gsub(".*cacheId (.*)\x1b\\[.*", "\\1", grep("cacheId", bMess, value = TRUE))
if (expect1) {
expect_false(identical(dMessCacheId, bMessCacheId))
} else {
expect_true(identical(dMessCacheId, bMessCacheId))
}
rcompletelynew <- rmultinom
# Now check function is prefered over args
clearCache(tmpCache, ask = FALSE)
eMess <- capture_messages({
b <- Cache(rbinom, 4, 5, prob = 0.6, showSimilar = TRUE, cachePath = tmpCache)
})
fMess <- capture_messages({
b <- Cache(rmultinom, 4, 5, prob = 0.6, showSimilar = TRUE, cachePath = tmpCache)
})
gMess <- capture_messages({
b <- Cache(rmultinom, 14, 15, prob = 0.8, showSimilar = TRUE, cachePath = tmpCache)
})
hMess <- capture_messages({
b <- Cache(rbinom, 14, 15, prob = 0.8, showSimilar = TRUE, cachePath = tmpCache)
})
iMess <- capture_messages({
b <- Cache(rcompletelynew, 12, 15, prob = 0.8, showSimilar = TRUE, cachePath = tmpCache)
})
expect_true(any(grepl("no similar item", eMess))) # shouldn't find b/c new
expect_true(any(grepl("no similar item", fMess))) # shouldn't find b/c args are same
expect_true(any(grepl("next closest.+rmultin", gMess))) # should only find rmultinom
expect_true(any(grepl("next closest.+rbinom", hMess))) # should only find rbinom
expect_true(sum(grepl(".+rcompletelynew|next closest.+rmultin", iMess)) == 3) # should notice different name, but still find
### UserTags matching -- prefer similar if all userTags match
rcompletelynew <- rnorm
# Now check function is prefered over args
clearCache(tmpCache, ask = FALSE)
jMess <- capture_messages({
bj <- Cache(rnorm, 1, 2, 3, showSimilar = TRUE, cachePath = tmpCache, userTags = c("Hi"))
})
expect_true(any(grepl("no similar item", jMess))) # shouldn't find b/c new
kMess <- capture_messages({
bk <- Cache(rnorm, 1, 3, 4, showSimilar = TRUE, cachePath = tmpCache, userTags = c("By")) # not similar
})
expect_true(any(grepl("no similar item", kMess))) # shouldn't find b/c args are same
lMess <- capture_messages({
bl <- Cache(rnorm, 1, 3, 4, showSimilar = TRUE, cachePath = tmpCache, userTags = c("Hi")) # same, recovered
})
expect_true(any(grepl("Loaded", lMess))) # should only find rmultinom
mMess <- capture_messages({
bm <- Cache(rnorm, 1, 2, 3, showSimilar = TRUE, cachePath = tmpCache, userTags = c("By")) # same recovered
})
expect_true(any(grepl("Loaded", mMess))) # should only find rmultinom
nMess <- capture_messages({
bn <- Cache(rnorm, 1, 2, 2, showSimilar = TRUE, cachePath = tmpCache, userTags = c("By")) # similar to kMess
})
nMess <- grep("^.+next closest cacheId\\(s\\) (.+) of .+$", nMess, value = TRUE)
expect_true(grepl(
x = attr(bm, "tags"),
gsub("^.+next closest cacheId\\(s\\) (.+) of .+$", "\\1", nMess)
)) ## find mMess (jMess) because it's the most recent
oMess <- capture_messages({
bo <- Cache(rnorm, 1, 2, 1, showSimilar = TRUE, cachePath = tmpCache) # similar to kMess
})
oMess <- grep("^.+next closest cacheId\\(s\\) (.+) of .+$", oMess, value = TRUE)
expect_true(grepl(
x = attr(bn, "tags"),
gsub("^.+next closest cacheId\\(s\\) (.+) of .+$", "\\1", oMess) ## TODO: fix failing test
)) ## find nMess (jMess) because it's the most recent
## debugCache -- "complete"
thing <- 1
aa <- Cache(rnorm, thing, debugCache = "complete", cachePath = tmpCache)
expect_true(identical(thing, attr(aa, "debugCache1")[[1]]))
expect_true(identical(.robustDigest(thing), attr(aa, "debugCache2")$n))
expect_true(is.numeric(aa))
## debugCache -- "quick"
aa <- Cache(rnorm, thing, debugCache = "quick", cachePath = tmpCache)
expect_true(identical(.robustDigest(thing), aa$hash$n))
expect_true(identical(thing, aa$content[[1]]))
## .unlistToCharacter
expect_true(grepl("not list", unlist(.unlistToCharacter(1, 1))))
expect_true(grepl("other", unlist(.unlistToCharacter(1, 0))))
## writeFuture
comp <- # if (useDBI())
.robustDigest("sdf") # else
# "dda1fbb70d256e6b3b696ef0176c63de"
drvHere <- if (useDBI() && .requireNamespace("RSQLite")) RSQLite::SQLite() else NULL
expect_true(identical(
comp,
writeFuture(1, "sdf",
cachePath = tmpCache, userTags = "",
drv = drvHere
)
))
expect_error(writeFuture(1, "sdf", cachePath = "sdfd", userTags = ""))
if (interactive()) {
try(silent = TRUE, clearCache(tmpCache, ask = FALSE))
bMess <- capture_output({
aMess <- capture_messages({
aa <- Cache(fnCacheHelper, 1, verbose = 4, cachePath = tmpCache, cacheRepo2 = tmpCache)
})
})
expect_true(any(grepl("fnCacheHelper", aMess))) # TODO: fix this;
expect_true(any(grepl("The hashing details", aMess)))
}
})
test_that("test warnings from cached functions", {
skip_if_not_installed("sf")
testInit(libraries = c("sf"), opts = list(reproducible.useMemoise = FALSE))
warn1 <- capture_warnings({
b <- Cache(rbinom, 4, 5, prob = 6, cachePath = tmpCache)
})
fun <- function(n, size, prob) {
rbinom(n, size, prob)
}
warn2 <- capture_warnings({
d <- Cache(fun, 4, 5, 6, cachePath = tmpCache)
})
warnCompare <- "rbinom.+NAs produced"
expect_true(grepl(warnCompare, warn1)) # includes the call because .call = FALSE, and call added manually in Cache
expect_true(grepl("NAs produced", warn2))
expect_false(grepl(warnCompare, warn2)) # this is false because the warning message doesn't include the call with normal warn
})
test_that("test cache-helpers with stacks", {
skip_if_not_installed("raster")
# THIS TEST CAN BE DELETED AFTER RASTER IS DEFUNCT
testInit("raster")
tmpfile <- tempfile(tmpdir = tmpdir, fileext = ".tif")
tmpfile2 <- tempfile(tmpdir = tmpdir, fileext = ".tif")
r <- raster(extent(0, 5, 0, 5), resolution = 1, vals = rep(1:2, length.out = 25))
r1 <- raster(extent(0, 5, 0, 5), resolution = 1, vals = rep(1:2, length.out = 25))
s <- raster::stack(r, r1)
## in memory
b <- .prepareFileBackedRaster(s, tmpCache)
is(b, "RasterStack")
expect_true(length(list.files(file.path(tmpCache, "rasters"))) == 0)
## with 1 backups
r <- .writeRaster(r, filename = tmpfile, overwrite = TRUE)
s <- addLayer(r, r1)
b <- .prepareFileBackedRaster(s, tmpCache)
expect_true(all(basename(c(tmpfile)) %in% basename(list.files(tmpCache, recursive = TRUE))))
expect_false(all(basename(c(tmpfile2)) %in% basename(list.files(tmpCache, recursive = TRUE))))
## with 2 backups
r1 <- .writeRaster(r1, filename = tmpfile2, overwrite = TRUE)
s <- addLayer(r, r1)
b <- .prepareFileBackedRaster(s, tmpCache)
expect_true(all(basename(c(tmpfile, tmpfile2)) %in% basename(list.files(tmpCache, recursive = TRUE))))
## removing entry from Cache
fls <- grep(basename(tmpfile),
list.files(tmpCache, recursive = TRUE, full.names = TRUE),
value = TRUE
)
file.remove(fls)
expect_false(all(basename(c(tmpfile, tmpfile2)) %in% basename(list.files(tmpCache, recursive = TRUE))))
b <- .prepareFileBackedRaster(s, tmpCache)
expect_true(all(basename(c(tmpfile, tmpfile2)) %in% basename(list.files(tmpCache, recursive = TRUE))))
# Test deleted raster backed file
file.remove(tmpfile2)
expect_error(
{
b <- .prepareFileBackedRaster(s, tmpCache)
},
"The following file-backed rasters"
)
})
test_that("test miscellaneous unit tests cache-helpers", {
skip_if_not_installed("googledrive")
testInit("googledrive")
a <- Cache(rnorm, 1, cachePath = tmpCache)
mess <- capture_messages(clearCache(cachePath = tmpCache))
expect_true(any(grepl("x not specified, but cachePath is", mess)))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.