context("memoise") test_that("memoisation works", { fn <- function() { i <<- i + 1; i } i <- 0 expect_warning(fnm <- memoise(fn), NA) expect_equal(fn(), 1) expect_equal(fn(), 2) expect_equal(fnm(), 3) expect_equal(fnm(), 3) expect_equal(fn(), 4) expect_equal(fnm(), 3) expect_false(forget(fn)) expect_true(forget(fnm)) expect_true(forget(fnm)) expect_equal(fnm(), 5) expect_true(is.memoised(fnm)) expect_false(is.memoised(fn)) }) test_that("memoisation depends on argument", { fn <- function(j) { i <<- i + 1; i } i <- 0 expect_warning(fnm <- memoise(fn), NA) expect_equal(fn(1), 1) expect_equal(fn(1), 2) expect_equal(fnm(1), 3) expect_equal(fnm(1), 3) expect_equal(fn(1), 4) expect_equal(fnm(1), 3) expect_equal(fnm(2), 5) expect_equal(fnm(2), 5) expect_equal(fnm(1), 3) expect_equal(fn(2), 6) }) test_that("interface of wrapper matches interface of memoised function", { fn <- function(j) { i <<- i + 1; i } i <- 0 expect_equal(formals(fn), formals(memoise(fn))) expect_equal(formals(runif), formals(memoise(runif))) expect_equal(formals(paste), formals(memoise(paste))) }) test_that("dot arguments are used for hash", { fn <- function(...) { i <<- i + 1; i } i <- 0 expect_warning(fnm <- memoise(fn), NA) expect_equal(fn(1), 1) expect_equal(fnm(1), 2) expect_equal(fnm(1), 2) expect_equal(fnm(1, 2), 3) expect_equal(fnm(1), 2) expect_equal(fnm(1, 2), 3) expect_equal(fnm(), 4) expect_true(forget(fnm)) expect_equal(fnm(1), 5) expect_equal(fnm(1, 2), 6) expect_equal(fnm(), 7) }) test_that("default arguments are used for hash", { fn <- function(j = 1) { i <<- i + 1; i } i <- 0 expect_warning(fnm <- memoise(fn), NA) expect_equal(fn(1), 1) expect_equal(fnm(1), 2) expect_equal(fnm(1), 2) expect_equal(fnm(), 2) expect_equal(fnm(2), 3) expect_equal(fnm(), 2) }) test_that("default arguments are evaluated correctly", { expect_false(exists("g")) g <- function() 1 fn <- function(j = g()) { i <<- i + 1; i } i <- 0 expect_warning(fnm <- memoise(fn), NA) expect_equal(fn(1), 1) expect_equal(fnm(1), 2) expect_equal(fnm(1), 2) expect_equal(fnm(), 2) expect_equal(fnm(2), 3) expect_equal(fnm(), 2) }) test_that("symbol collision", { cache <- function(j = 1) { i <<- i + 1; i } i <- 0 cachem <- memoise(cache) expect_equal(cache(), 1) expect_equal(cache(), 2) expect_equal(cachem(), 3) expect_equal(cachem(), 3) expect_equal(cache(), 4) expect_equal(cachem(), 3) expect_true(forget(cachem)) expect_equal(cachem(), 5) }) test_that("different body avoids collisions", { # Same args, different body m <- cachem::cache_mem() times2 <- memoise(function(x) { x * 2 }, cache = m) times4 <- memoise(function(x) { x * 4 }, cache = m) expect_identical(times2(10), 20) expect_equal(m$size(), 1) expect_identical(times4(10), 40) expect_equal(m$size(), 2) }) test_that("different formals avoids collisions", { # Different formals (even if not used) avoid collisions, because formals # are used in key. m <- cachem::cache_mem() f <- function(x, y) { x * 2 } times2 <- memoise(function(x, y) { x * 2 }, cache = m) times2a <- memoise(function(x, y = 1) { x * 2 }, cache = m) expect_identical(times2(10), 20) expect_equal(m$size(), 1) expect_identical(times2a(10), 20) expect_equal(m$size(), 2) }) test_that("same body results in collisions", { # Two identical memoised functions should result in cache hits so that cache # can be shared more easily. # https://github.com/r-lib/memoise/issues/58 m <- cachem::cache_mem() times2 <- memoise(function(x, y) { x * 2 }, cache = m) times2a <- memoise(function(x, y) { x * 2 }, cache = m) expect_identical(times2(10), 20) expect_identical(times2a(10), 20) expect_equal(m$size(), 1) }) test_that("same body results in collisions", { # Even though t2 and t4 produce different results, the memoised versions, # times2 and times4, have cache collisions because the functions have the same # body and formals. It would be nice if we could somehow avoid this. m <- cachem::cache_mem() t2 <- local({ n <- 2 function(x) x * n }) t4 <- local({ n <- 4 function(x) x * n }) times2 <- memoise(t2, cache = m) times4 <- memoise(t4, cache = m) expect_identical(times2(10), 20) expect_identical(times4(10), 20) # Bad (but expected) cache collision! expect_equal(m$size(), 1) }) test_that("visibility", { vis <- function() NULL invis <- function() invisible() expect_true(withVisible(memoise(vis)())$visible) expect_false(withVisible(memoise(invis)())$visible) }) test_that("is.memoised", { i <- 0 expect_false(is.memoised(i)) expect_false(is.memoised(is.memoised)) expect_true(is.memoised(memoise(identical))) }) test_that("visibility", { vis <- function() NULL invis <- function() invisible() expect_true(withVisible(memoise(vis)())$visible) expect_false(withVisible(memoise(invis)())$visible) }) test_that("can memoise anonymous function", { expect_warning(fm <- memoise(function(a = 1) a), NA) expect_equal(names(formals(fm))[[1]], "a") expect_equal(fm(1), 1) expect_equal(fm(2), 2) expect_equal(fm(1), 1) }) test_that("can memoise primitive", { expect_warning(fm <- memoise(`+`), NA) expect_equal(names(formals(fm)), names(formals(args(`+`)))) expect_equal(fm(1, 2), 1 + 2) expect_equal(fm(2, 3), 2 + 3) expect_equal(fm(1, 2), 1 + 2) }) test_that("printing a memoised function prints the original definition", { fn <- function(j) { i <<- i + 1; i } fnm <- memoise(fn) fn_output <- capture.output(fn) fnm_output <- capture.output(fnm) expect_equal(fnm_output[1], "Memoised Function:") expect_equal(fnm_output[-1], fn_output) }) test_that("memoisation can depend on non-arguments", { fn <- function(x) { i <<- i + 1; i } i <- 0 j <- 2 fn2 <- function(y, ...) { fnm <- memoise(fn, ~y) fnm(...) } expect_error(memoise(fn, j), "`j` must be a formula\\.") expect_error(memoise(fn, ~j, k), "`k` must be a formula\\.") expect_error(memoise(fn, j ~ 1), "`x` must be a one sided formula \\[not j ~ 1\\]\\.") fnm <- memoise(fn, ~j) expect_equal(fn(1), 1) expect_equal(fn(1), 2) expect_equal(fnm(1), 3) expect_equal(fnm(1), 3) j <- 1 expect_equal(fnm(1), 4) expect_equal(fnm(1), 4) j <- 2 expect_equal(fnm(1), 3) expect_equal(fnm(1), 3) j <- 3 expect_equal(fnm(1), 5) expect_equal(fnm(1), 5) }) test_that("it fails if already memoised", { mem_sum <- memoise(sum) expect_error(memoise(mem_sum), "`f` must not be memoised.") }) test_that("it evaluates arguments in proper environment", { e <- new.env(parent = baseenv()) e$a <- 5 fun <- function(x, y = a) { x + y } environment(fun) <- e fun_mem <- memoise(fun) expect_equal(fun(1), fun_mem(1)) expect_equal(fun(10), fun_mem(10)) }) test_that("it does have namespace clashes with internal memoise symbols", { e <- new.env(parent = baseenv()) e$f <- 5 fun <- function(x, y = f) { x + y } environment(fun) <- e fun_mem <- memoise(fun) expect_equal(fun(1), fun_mem(1)) expect_equal(fun(10), fun_mem(10)) }) test_that("arguments are evaluated before hashing", { i <- 1 f <- memoise(function(x, y, z = 3) { x + y + z}) f2 <- function(x, y) f(x, y) expect_equal(f2(1, 1), 5) expect_equal(f2(1, 1), 5) expect_equal(f2(2, 2), 7) }) test_that("argument names don't clash with names in memoised function body", { f <- function( # Names in enclosing environment of memoising function `_f`, `_cache`, `_additional`, # Names in body of memoising function mc, encl, called_args, default_args, args, hash, res ) list(`_f`, `_cache`, `_additional`, mc, encl, called_args, default_args, args, hash, res) f_mem <- memoise(f) expect_error(f_mem(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), NA) expect_identical(f(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), f_mem(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)) }) test_that("omit_args respected", { # If no arguments ignored, these 2 rnorm() calls should have different results mem_rnorm <- memoise(rnorm, omit_args = c()) res1 <- mem_rnorm(10, mean = -100) res2 <- mem_rnorm(10, mean = +100) expect_false(identical(res1, res2)) # If 'mean' ignored when hashing, these 2 rnorm() calls will have identical results mem_rnorm <- memoise(rnorm, omit_args = c('mean')) res1 <- mem_rnorm(10, mean = -100) res2 <- mem_rnorm(10, mean = +100) expect_true(identical(res1, res2)) }) context("has_cache") test_that("it works as expected with memoised functions", { mem_sum <- memoise(sum) expect_false(has_cache(mem_sum)(1, 2, 3)) mem_sum(1, 2, 3) expect_true(has_cache(mem_sum)(1, 2, 3)) mem_sum <- memoise(sum) expect_false(has_cache(mem_sum)(1, 2, 3)) }) test_that("it errors with an un-memoised function", { expect_error(has_cache(sum)(1, 2, 3), "`f` is not a memoised function.") }) context("drop_cache") test_that("it works as expected with memoised functions", { mem_sum <- memoise(sum) expect_false(drop_cache(mem_sum)(1, 2, 3)) mem_sum(1, 2, 3) mem_sum(2, 3, 4) expect_true(has_cache(mem_sum)(1, 2, 3)) expect_true(has_cache(mem_sum)(2, 3, 4)) expect_true(drop_cache(mem_sum)(1, 2, 3)) expect_false(has_cache(mem_sum)(1, 2, 3)) expect_true(has_cache(mem_sum)(2, 3, 4)) mem_sum <- memoise(sum) expect_false(drop_cache(mem_sum)(1, 2, 3)) }) test_that("it errors with an un-memoised function", { expect_error(drop_cache(sum)(1, 2, 3), "`f` is not a memoised function.") }) context("timeout") test_that("it stays the same if not enough time has passed", { duration <- 10 first <- timeout(duration, 0) expect_equal(first, timeout(duration, 1)) expect_equal(first, timeout(duration, 5)) expect_equal(first, timeout(duration, 7)) expect_equal(first, timeout(duration, 9)) expect_true(first != timeout(duration, 10)) duration <- 100 first <- timeout(duration, 0) expect_equal(first, timeout(duration, 10)) expect_equal(first, timeout(duration, 50)) expect_equal(first, timeout(duration, 70)) expect_equal(first, timeout(duration, 99)) expect_true(first != timeout(duration, 100)) }) context("missing") test_that("it works with missing arguments", { fn <- function(x, y) { i <<- i + 1 if (missing(y)) { y <- 1 } x + y } fnm <- memoise(fn) i <- 0 expect_equal(fn(1), fnm(1)) expect_equal(fn(1, 2), fnm(1, 2)) expect_equal(i, 4) fnm(1) expect_equal(i, 4) fnm(1, 2) expect_equal(i, 4) })
Generated by dwww version 1.15 on Wed May 22 15:47:50 CEST 2024.