Skip to content

Commit

Permalink
fix merge
Browse files Browse the repository at this point in the history
  • Loading branch information
Eliot McIntire committed Dec 5, 2024
1 parent d313e51 commit 146807c
Showing 1 changed file with 0 additions and 244 deletions.
244 changes: 0 additions & 244 deletions tests/testthat/test-cache.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down Expand Up @@ -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()

Expand All @@ -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")

Expand Down

0 comments on commit 146807c

Please sign in to comment.