diff --git a/tests/testthat/test-cache.R b/tests/testthat/test-cache.R index 7b61ea91f..2ff0ad342 100644 --- a/tests/testthat/test-cache.R +++ b/tests/testthat/test-cache.R @@ -609,205 +609,6 @@ test_that("test quoted FUN in Cache", { expect_true(all.equalWONewCache(A, C)) }) -test_that("test Cache argument inheritance to inner functions", { - testInit("terra", - verbose = TRUE, - opts = list( - "reproducible.showSimilar" = FALSE, - "reproducible.useMemoise" = FALSE - ) - ) - opts <- options(reproducible.cachePath = tmpdir) - on.exit(options(opts), add = TRUE) - tmpDirFiles <- dir(tempdir()) - on.exit( - { - newOnes <- setdiff(tmpDirFiles, dir(tempdir())) - unlink(newOnes, recursive = TRUE) - }, - add = TRUE - ) - - outer <- function(n, not = NULL) { - Cache(rnorm, n, notOlderThan = not) - } - - mess <- capture_messages(Cache(outer, n = 2)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, mess)), 2) - clearCache(ask = FALSE, x = tmpdir) - - # options(reproducible.cachePath = tmpCache) - out <- capture_messages(Cache(outer, n = 2)) - expect_true(all(unlist(lapply( - c(.message$NoCacheRepoSuppliedGrep, .message$NoCacheRepoSuppliedGrep), - function(mess) any(cli::ansi_grepl(mess, out)) - )))) - - # does Sys.time() propagate to outer ones - out <- capture_messages(Cache(outer(n = 2, not = Sys.time() + 1), notOlderThan = Sys.time() + 1)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 2) - - # does Sys.time() propagate to outer ones -- no message about cachePath being tempdir() - mess <- capture_messages(Cache(outer(n = 2, not = Sys.time()), notOlderThan = Sys.time(), cachePath = tmpdir)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, mess)), 1) - - # does cachePath propagate to outer ones -- no message about cachePath being tempdir() - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_true(length(out) == 2) - expect_true(sum(cli::ansi_grepl(paste(.message$LoadedCacheResult(), "outer call"), out)) == 1) - - # check that the rnorm inside "outer" returns cached value even if outer "outer" function is changed - outer <- function(n) { - a <- 1 - Cache(rnorm, n) - } - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_true(length(out) == 4) - msgGrep <- paste(paste(.message$LoadedCacheResult(), "rnorm call"), - "There is no similar item in the cachePath", - sep = "|" - ) - expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) - - # Override with explicit argument - outer <- function(n) { - a <- 1 - Cache(rnorm, n, notOlderThan = Sys.time() + 1) - } - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 1) - - # change the outer function, so no cache on that, & have notOlderThan on rnorm, - # so no Cache on that - outer <- function(n) { - b <- 1 - Cache(rnorm, n, notOlderThan = Sys.time() + 1) - } - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_equal(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)), 1) - - # expect_true(all(cli::ansi_grepl("There is no similar item in the cachePath", out))) - # Second time will get a cache on outer - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - expect_true(length(out) == 2) - expect_true(sum(cli::ansi_grepl(paste(.message$LoadedCacheResult(), "outer call"), out)) == 1) - - # doubly nested - inner <- function(mean, useCache = TRUE) { - d <- 1 - Cache(rnorm, n = 3, mean = mean, useCache = useCache) - } - outer <- function(n, useCache = TRUE, ...) { - Cache(inner, 0.1, useCache = useCache, ...) - } - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir)) - - outer <- function(n) { - Cache(inner, 0.1, notOlderThan = Sys.time() - 1e4) - } - - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir, notOlderThan = Sys.time())) - msgGrep <- paste(paste(.message$LoadedCacheResult(), "inner call"), - "There is no similar item in the cachePath", - sep = "|" - ) - expect_true(sum(cli::ansi_grepl(.message$NoCacheRepoSuppliedGrep, out)) == 1) - - # expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) - - outer <- function(n) { - Cache(inner, 0.1, notOlderThan = Sys.time()) - } - inner <- function(mean) { - d <- 1 - Cache(rnorm, n = 3, mean = mean, notOlderThan = Sys.time() - 1e5) - } - - out <- capture_messages(Cache(outer, n = 2, cachePath = tmpdir, notOlderThan = Sys.time())) - msgGrep <- paste(paste(.message$LoadedCacheResult(), "rnorm call"), - "There is no similar item in the cachePath", - sep = "|" - ) - expect_true(sum(cli::ansi_grepl(msgGrep, out)) == 1) - - # Check userTags -- all items have it - clearCache(tmpdir, ask = FALSE) - outerTag <- "howdie" - aa <- Cache(outer, n = 2, cachePath = tmpdir, userTags = outerTag) - bb <- showCache(tmpdir, userTags = outerTag) - cc <- showCache(tmpdir) - data.table::setorderv(bb, c(.cacheTableHashColName(), "tagKey", "tagValue")) - data.table::setorderv(cc, c(.cacheTableHashColName(), "tagKey", "tagValue")) - expect_true(identical(bb, cc)) - - # Check userTags -- all items have the outer tag propagate, plus inner ones only have inner ones - innerTag <- "notHowdie" - inner <- function(mean) { - d <- 1 - Cache(rnorm, n = 3, mean = mean, notOlderThan = Sys.time() - 1e5, userTags = innerTag) - } - - clearCache(tmpdir, ask = FALSE) - aa <- Cache(outer, n = 2, cachePath = tmpdir, userTags = outerTag) - bb <- showCache(tmpdir, userTags = outerTag) - cc <- showCache(tmpdir) - data.table::setorderv(cc) - data.table::setorderv(bb) - expect_true(identical(bb, cc)) - - # - bb <- showCache(tmpdir, userTags = "notHowdie") - cc <- showCache(tmpdir) - data.table::setorderv(cc) - data.table::setorderv(bb) - expect_false(identical(bb, cc)) - expect_true(length(unique(bb[[.cacheTableHashColName()]])) == 1) - expect_true(length(unique(cc[[.cacheTableHashColName()]])) == 3) -}) - -test_that("test future", { - skip_on_cran() - skip_on_ci() - # skip_if_not_installed("future") - - .onLinux <- .Platform$OS.type == "unix" && unname(Sys.info()["sysname"]) == "Linux" - # if (.onLinux) { - testInit(c("terra", "future"), - verbose = TRUE, tmpFileExt = ".rds", - opts = list( - "future.supportsMulticore.unstable" = "quiet", - "reproducible.futurePlan" = "multicore" - ) - ) - - # There is now a warning with future package - a <- list() - (aa <- system.time({ - for (i in c(1:3)) a[[i]] <- Cache(cachePath = tmpCache, rnorm, 1e6 + i) - })) - sca <- showCache(tmpCache) - expect_true(length(unique(sca[[.cacheTableHashColName()]])) == 3) - - try(unlink(tmpCache, recursive = TRUE)) - b <- list() - (bb <- system.time({ - for (i in 1:3) b[[i]] <- Cache(cachePath = tmpCache, rnorm(1e6 + i)) - })) - bb <- showCache(tmpCache) - expect_true(length(unique(bb[[.cacheTableHashColName()]])) == 3) - - # Test the speed of rerunning same line - d <- list() - (dd <- system.time({ - for (i in 1:3) d[[i]] <- Cache(cachePath = tmpCache, rnorm(1e6 + i)) - })) - expect_true((dd[[3]] * 2) < aa[[3]]) - for (i in 1:3) { - expect_true(identical(attr(d[[i]], ".Cache")$newCache, FALSE)) - } - # } -}) - test_that("test mergeCache", { testInit("data.table", verbose = TRUE) @@ -999,27 +800,6 @@ test_that("test cc", { expect_true(any(cli::ansi_grepl("Cache already empty", mess))) }) -test_that("test pre-creating conn", { - if (!useDBI()) skip("Only relevant for DBI backend") - testInit("terra", ask = FALSE, tmpFileExt = c(".tif", ".tif")) - on.exit({ - DBI::dbDisconnect(conn) - }) - - conn <- dbConnectAll(cachePath = tmpdir, conn = NULL) - ra <- terra::rast(terra::ext(0, 10, 0, 10), vals = sample(1:100)) - rb <- terra::rast(terra::ext(0, 10, 0, 10), vals = sample(1:100)) - r1 <- Cache(.writeRaster, ra, filename = tmpfile[1], overwrite = TRUE, cachePath = tmpCache) - r2 <- Cache(.writeRaster, rb, - filename = tmpfile[2], overwrite = TRUE, cachePath = tmpdir, - conn = conn - ) - expect_true(file.exists(Filenames(r1))) - expect_true(file.exists(Filenames(r2))) - expect_false(cli::ansi_grepl(basename(dirname(Filenames(r1))), "rasters")) # changed behaviour as of reproducible 1.2.0.9020 - expect_false(cli::ansi_grepl(basename(dirname(Filenames(r2))), "rasters")) # changed behaviour as of reproducible 1.2.0.9020 -}) - test_that("test .defaultUserTags", { testInit() @@ -1031,30 +811,6 @@ test_that("test .defaultUserTags", { expect_false(anyNewTags) }) -test_that("test failed Cache recovery -- message to delete cacheId", { - if (!useDBI()) skip("Not relevant for multipleDBfiles") - testInit(opts = list("reproducible.useMemoise" = FALSE)) - - b <- Cache(rnorm, 1, cachePath = tmpdir) - sc <- showCache(tmpdir) - ci <- unique(sc[[.cacheTableHashColName()]]) - unlink(CacheStoredFile(tmpdir, ci)) - - - rm(b) - mess <- capture_messages({ - warn <- capture_warnings({ - err <- capture_error({ - d <- Cache(rnorm, 1, cachePath = tmpdir) - }) - }) - }) - expect_true(sum(cli::ansi_grepl(paste0("(trying to recover).*(", ci, ")"), mess)) == 1) - expect_true(sum(cli::ansi_grepl(paste0("(trying to recover).*(", ci, ")"), err)) == 0) - expect_true(any(cli::ansi_grepl(paste0("[cannot|failed to] open"), paste(warn, err, mess)))) - expect_true(is.numeric(d)) -}) - test_that("test changing reproducible.cacheSaveFormat midstream", { skip_if_not_installed("qs")