1context("memoise")
2
3test_that("memoisation works", {
4  fn <- function() { i <<- i + 1; i }
5  i <- 0
6
7  expect_warning(fnm <- memoise(fn), NA)
8  expect_equal(fn(), 1)
9  expect_equal(fn(), 2)
10  expect_equal(fnm(), 3)
11  expect_equal(fnm(), 3)
12  expect_equal(fn(), 4)
13  expect_equal(fnm(), 3)
14
15  expect_false(forget(fn))
16  expect_true(forget(fnm))
17  expect_true(forget(fnm))
18  expect_equal(fnm(), 5)
19
20  expect_true(is.memoised(fnm))
21  expect_false(is.memoised(fn))
22})
23
24test_that("memoisation depends on argument", {
25  fn <- function(j) { i <<- i + 1; i }
26  i <- 0
27
28  expect_warning(fnm <- memoise(fn), NA)
29  expect_equal(fn(1), 1)
30  expect_equal(fn(1), 2)
31  expect_equal(fnm(1), 3)
32  expect_equal(fnm(1), 3)
33  expect_equal(fn(1), 4)
34  expect_equal(fnm(1), 3)
35  expect_equal(fnm(2), 5)
36  expect_equal(fnm(2), 5)
37  expect_equal(fnm(1), 3)
38  expect_equal(fn(2), 6)
39})
40
41test_that("interface of wrapper matches interface of memoised function", {
42  fn <- function(j) { i <<- i + 1; i }
43  i <- 0
44
45  expect_equal(formals(fn), formals(memoise(fn)))
46  expect_equal(formals(runif), formals(memoise(runif)))
47  expect_equal(formals(paste), formals(memoise(paste)))
48})
49
50test_that("dot arguments are used for hash", {
51  fn <- function(...) { i <<- i + 1; i }
52  i <- 0
53
54  expect_warning(fnm <- memoise(fn), NA)
55  expect_equal(fn(1), 1)
56  expect_equal(fnm(1), 2)
57  expect_equal(fnm(1), 2)
58  expect_equal(fnm(1, 2), 3)
59  expect_equal(fnm(1), 2)
60  expect_equal(fnm(1, 2), 3)
61  expect_equal(fnm(), 4)
62
63  expect_true(forget(fnm))
64
65  expect_equal(fnm(1), 5)
66  expect_equal(fnm(1, 2), 6)
67  expect_equal(fnm(), 7)
68})
69
70test_that("default arguments are used for hash", {
71  fn <- function(j = 1) { i <<- i + 1; i }
72  i <- 0
73
74  expect_warning(fnm <- memoise(fn), NA)
75  expect_equal(fn(1), 1)
76  expect_equal(fnm(1), 2)
77  expect_equal(fnm(1), 2)
78  expect_equal(fnm(), 2)
79  expect_equal(fnm(2), 3)
80  expect_equal(fnm(), 2)
81})
82
83test_that("default arguments are evaluated correctly", {
84  expect_false(exists("g"))
85  g <- function() 1
86  fn <- function(j = g()) { i <<- i + 1; i }
87  i <- 0
88
89  expect_warning(fnm <- memoise(fn), NA)
90  expect_equal(fn(1), 1)
91  expect_equal(fnm(1), 2)
92  expect_equal(fnm(1), 2)
93  expect_equal(fnm(), 2)
94  expect_equal(fnm(2), 3)
95  expect_equal(fnm(), 2)
96})
97
98test_that("symbol collision", {
99  cache <- function(j = 1) { i <<- i + 1; i }
100  i <- 0
101  cachem <- memoise(cache)
102
103  expect_equal(cache(), 1)
104  expect_equal(cache(), 2)
105  expect_equal(cachem(), 3)
106  expect_equal(cachem(), 3)
107  expect_equal(cache(), 4)
108  expect_equal(cachem(), 3)
109
110  expect_true(forget(cachem))
111  expect_equal(cachem(), 5)
112})
113
114test_that("different body avoids collisions", {
115  # Same args, different body
116  m <- cachem::cache_mem()
117  times2 <- memoise(function(x) { x * 2 }, cache = m)
118  times4 <- memoise(function(x) { x * 4 }, cache = m)
119
120  expect_identical(times2(10), 20)
121  expect_equal(m$size(), 1)
122  expect_identical(times4(10), 40)
123  expect_equal(m$size(), 2)
124})
125
126test_that("different formals avoids collisions", {
127  # Different formals (even if not used) avoid collisions, because formals
128  # are used in key.
129  m <- cachem::cache_mem()
130  f <- function(x, y) { x * 2 }
131  times2  <- memoise(function(x, y) { x * 2 }, cache = m)
132  times2a <- memoise(function(x, y = 1) { x * 2 }, cache = m)
133
134  expect_identical(times2(10),  20)
135  expect_equal(m$size(), 1)
136  expect_identical(times2a(10), 20)
137  expect_equal(m$size(), 2)
138})
139
140test_that("same body results in collisions", {
141  # Two identical memoised functions should result in cache hits so that cache
142  # can be shared more easily.
143  # https://github.com/r-lib/memoise/issues/58
144  m <- cachem::cache_mem()
145  times2  <- memoise(function(x, y) { x * 2 }, cache = m)
146  times2a <- memoise(function(x, y) { x * 2 }, cache = m)
147
148  expect_identical(times2(10),  20)
149  expect_identical(times2a(10), 20)
150  expect_equal(m$size(), 1)
151})
152
153test_that("same body results in collisions", {
154  # Even though t2 and t4 produce different results, the memoised versions,
155  # times2 and times4, have cache collisions because the functions have the same
156  # body and formals. It would be nice if we could somehow avoid this.
157  m <- cachem::cache_mem()
158
159  t2 <- local({
160    n <- 2
161    function(x) x * n
162  })
163  t4 <- local({
164    n <- 4
165    function(x) x * n
166  })
167
168  times2 <- memoise(t2, cache = m)
169  times4 <- memoise(t4, cache = m)
170
171  expect_identical(times2(10),  20)
172  expect_identical(times4(10), 20)  # Bad (but expected) cache collision!
173  expect_equal(m$size(), 1)
174})
175
176
177test_that("visibility", {
178  vis <- function() NULL
179  invis <- function() invisible()
180
181  expect_true(withVisible(memoise(vis)())$visible)
182  expect_false(withVisible(memoise(invis)())$visible)
183})
184
185test_that("is.memoised", {
186  i <- 0
187  expect_false(is.memoised(i))
188  expect_false(is.memoised(is.memoised))
189  expect_true(is.memoised(memoise(identical)))
190})
191
192test_that("visibility", {
193  vis <- function() NULL
194  invis <- function() invisible()
195
196  expect_true(withVisible(memoise(vis)())$visible)
197  expect_false(withVisible(memoise(invis)())$visible)
198})
199
200test_that("can memoise anonymous function", {
201  expect_warning(fm <- memoise(function(a = 1) a), NA)
202  expect_equal(names(formals(fm))[[1]], "a")
203  expect_equal(fm(1), 1)
204  expect_equal(fm(2), 2)
205  expect_equal(fm(1), 1)
206})
207
208test_that("can memoise primitive", {
209  expect_warning(fm <- memoise(`+`), NA)
210  expect_equal(names(formals(fm)), names(formals(args(`+`))))
211  expect_equal(fm(1, 2), 1 + 2)
212  expect_equal(fm(2, 3), 2 + 3)
213  expect_equal(fm(1, 2), 1 + 2)
214})
215
216test_that("printing a memoised function prints the original definition", {
217
218  fn <- function(j) { i <<- i + 1; i }
219
220  fnm <- memoise(fn)
221
222  fn_output <- capture.output(fn)
223  fnm_output <- capture.output(fnm)
224
225  expect_equal(fnm_output[1], "Memoised Function:")
226
227  expect_equal(fnm_output[-1], fn_output)
228})
229
230test_that("memoisation can depend on non-arguments", {
231  fn <- function(x) { i <<- i + 1; i }
232  i <- 0
233  j <- 2
234
235  fn2 <- function(y, ...) {
236    fnm <- memoise(fn, ~y)
237    fnm(...)
238  }
239  expect_error(memoise(fn, j), "`j` must be a formula\\.")
240
241  expect_error(memoise(fn, ~j, k), "`k` must be a formula\\.")
242
243  expect_error(memoise(fn, j ~ 1), "`x` must be a one sided formula \\[not j ~ 1\\]\\.")
244
245  fnm <- memoise(fn, ~j)
246  expect_equal(fn(1), 1)
247  expect_equal(fn(1), 2)
248  expect_equal(fnm(1), 3)
249  expect_equal(fnm(1), 3)
250  j <- 1
251  expect_equal(fnm(1), 4)
252  expect_equal(fnm(1), 4)
253  j <- 2
254  expect_equal(fnm(1), 3)
255  expect_equal(fnm(1), 3)
256  j <- 3
257  expect_equal(fnm(1), 5)
258  expect_equal(fnm(1), 5)
259})
260
261test_that("it fails if already memoised", {
262  mem_sum <- memoise(sum)
263  expect_error(memoise(mem_sum), "`f` must not be memoised.")
264})
265
266test_that("it evaluates arguments in proper environment", {
267  e <- new.env(parent = baseenv())
268  e$a <- 5
269  fun <- function(x, y = a) { x + y }
270  environment(fun) <- e
271  fun_mem <- memoise(fun)
272  expect_equal(fun(1), fun_mem(1))
273  expect_equal(fun(10), fun_mem(10))
274})
275
276test_that("it does have namespace clashes with internal memoise symbols", {
277  e <- new.env(parent = baseenv())
278  e$f <- 5
279  fun <- function(x, y = f) { x + y }
280  environment(fun) <- e
281  fun_mem <- memoise(fun)
282  expect_equal(fun(1), fun_mem(1))
283  expect_equal(fun(10), fun_mem(10))
284})
285
286test_that("arguments are evaluated before hashing", {
287  i <- 1
288
289  f <- memoise(function(x, y, z = 3) { x + y + z})
290  f2 <- function(x, y) f(x, y)
291
292  expect_equal(f2(1, 1), 5)
293
294  expect_equal(f2(1, 1), 5)
295
296  expect_equal(f2(2, 2), 7)
297})
298
299test_that("argument names don't clash with names in memoised function body", {
300  f <- function(
301    # Names in enclosing environment of memoising function
302    `_f`, `_cache`, `_additional`,
303    # Names in body of memoising function
304    mc, encl, called_args, default_args, args, hash, res
305  ) list(`_f`, `_cache`, `_additional`, mc, encl, called_args, default_args, args, hash, res)
306  f_mem <- memoise(f)
307
308  expect_error(f_mem(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), NA)
309  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))
310})
311
312test_that("omit_args respected", {
313  # If no arguments ignored, these 2 rnorm() calls should have different results
314  mem_rnorm <- memoise(rnorm, omit_args = c())
315
316  res1 <- mem_rnorm(10, mean = -100)
317  res2 <- mem_rnorm(10, mean = +100)
318
319  expect_false(identical(res1, res2))
320
321
322  # If 'mean' ignored when hashing, these 2 rnorm() calls will have identical results
323  mem_rnorm <- memoise(rnorm, omit_args = c('mean'))
324
325  res1 <- mem_rnorm(10, mean = -100)
326  res2 <- mem_rnorm(10, mean = +100)
327
328  expect_true(identical(res1, res2))
329})
330
331context("has_cache")
332test_that("it works as expected with memoised functions", {
333  mem_sum <- memoise(sum)
334  expect_false(has_cache(mem_sum)(1, 2, 3))
335
336  mem_sum(1, 2, 3)
337
338  expect_true(has_cache(mem_sum)(1, 2, 3))
339
340  mem_sum <- memoise(sum)
341  expect_false(has_cache(mem_sum)(1, 2, 3))
342})
343
344test_that("it errors with an un-memoised function", {
345  expect_error(has_cache(sum)(1, 2, 3), "`f` is not a memoised function.")
346})
347
348context("drop_cache")
349test_that("it works as expected with memoised functions", {
350  mem_sum <- memoise(sum)
351  expect_false(drop_cache(mem_sum)(1, 2, 3))
352
353  mem_sum(1, 2, 3)
354  mem_sum(2, 3, 4)
355
356  expect_true(has_cache(mem_sum)(1, 2, 3))
357  expect_true(has_cache(mem_sum)(2, 3, 4))
358
359  expect_true(drop_cache(mem_sum)(1, 2, 3))
360
361  expect_false(has_cache(mem_sum)(1, 2, 3))
362  expect_true(has_cache(mem_sum)(2, 3, 4))
363
364  mem_sum <- memoise(sum)
365  expect_false(drop_cache(mem_sum)(1, 2, 3))
366})
367
368test_that("it errors with an un-memoised function", {
369  expect_error(drop_cache(sum)(1, 2, 3), "`f` is not a memoised function.")
370})
371
372context("timeout")
373test_that("it stays the same if not enough time has passed", {
374  duration <- 10
375  first <- timeout(duration, 0)
376
377  expect_equal(first, timeout(duration, 1))
378  expect_equal(first, timeout(duration, 5))
379  expect_equal(first, timeout(duration, 7))
380  expect_equal(first, timeout(duration, 9))
381
382  expect_true(first != timeout(duration, 10))
383
384
385  duration <- 100
386  first <- timeout(duration, 0)
387
388  expect_equal(first, timeout(duration, 10))
389  expect_equal(first, timeout(duration, 50))
390  expect_equal(first, timeout(duration, 70))
391  expect_equal(first, timeout(duration, 99))
392
393  expect_true(first != timeout(duration, 100))
394})
395
396context("missing")
397test_that("it works with missing arguments", {
398  fn <- function(x, y) {
399    i <<- i + 1
400    if (missing(y)) {
401      y <- 1
402    }
403    x + y
404  }
405  fnm <- memoise(fn)
406  i <- 0
407
408  expect_equal(fn(1), fnm(1))
409  expect_equal(fn(1, 2), fnm(1, 2))
410  expect_equal(i, 4)
411  fnm(1)
412  expect_equal(i, 4)
413  fnm(1, 2)
414  expect_equal(i, 4)
415})
416