From 4e06ab26069d3366963d1a92773de34d53bb49e1 Mon Sep 17 00:00:00 2001 From: Jerry Kang Date: Wed, 8 May 2019 16:03:48 +0800 Subject: [PATCH 1/7] replace other memoised functions in args with original bodies before hashing --- R/memoise.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/R/memoise.R b/R/memoise.R index 48915d5..f2bc63e 100644 --- a/R/memoise.R +++ b/R/memoise.R @@ -122,6 +122,9 @@ memoise <- memoize <- function(f, ..., envir = environment(f), cache = cache_mem args <- c(lapply(called_args, eval, parent.frame()), lapply(default_args, eval, envir = environment())) + # Replace memoised functions in arguments with their original bodies + args <- lapply(args, function(x) if (memoise::is.memoised(x)) as.character(body(environment(x)$`_f`)) else x) + hash <- encl$`_cache`$digest( c(as.character(body(encl$`_f`)), args, lapply(encl$`_additional`, function(x) eval(x[[2L]], environment(x)))) @@ -147,7 +150,7 @@ memoise <- memoize <- function(f, ..., envir = environment(f), cache = cache_mem # This should only happen for primitive functions if (is.null(envir)) { - envir <- baseenv() + envir <- baseenv() } memo_f_env <- new.env(parent = envir) @@ -261,7 +264,7 @@ has_cache <- function(f) { # Modify the function body of the function to simply return TRUE and FALSE # rather than get or set the results of the cache body <- body(f) - body[[9]] <- quote(if (encl$`_cache`$has_key(hash)) return(TRUE) else return(FALSE)) + body[[10]] <- quote(if (encl$`_cache`$has_key(hash)) return(TRUE) else return(FALSE)) body(f) <- body f @@ -288,7 +291,7 @@ drop_cache <- function(f) { # Modify the function body of the function to simply drop the key # and return TRUE if successfully removed body <- body(f) - body[[9]] <- quote(if (encl$`_cache`$has_key(hash)) { + body[[10]] <- quote(if (encl$`_cache`$has_key(hash)) { encl$`_cache`$drop_key(hash) return(TRUE) } else { From f12d1617006ea29f858a74a1b090398b80daf748 Mon Sep 17 00:00:00 2001 From: Jerry Kang Date: Wed, 8 May 2019 18:41:03 +0800 Subject: [PATCH 2/7] add test for memoised function as argument --- tests/testthat/test-memoise.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/testthat/test-memoise.R b/tests/testthat/test-memoise.R index 89ccac1..eb32d36 100644 --- a/tests/testthat/test-memoise.R +++ b/tests/testthat/test-memoise.R @@ -246,6 +246,21 @@ test_that("argument names don't clash with names in memoised function body", { 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("other memoised function passed as arguments", { + f <- function(x) x + g <- function(fn) {i <<- fn(i) + 1; i} + i <- 0 + + fm <- memoise(f) + gm <- memoise(g) + + expect_equal(g(fm), 1) + expect_equal(gm(fm), 2) + expect_equal(gm(fm), 2) + expect_equal(g(fm), 3) + expect_equal(gm(fm), 2) +}) + context("has_cache") test_that("it works as expected with memoised functions", { mem_sum <- memoise(sum) From 846e28325ead2dee3e9dd374425dd80782e35217 Mon Sep 17 00:00:00 2001 From: Jerry Kang Date: Thu, 9 May 2019 21:54:03 +0800 Subject: [PATCH 3/7] Revert "I don't think it needs googleAuthR explicitly", fix #87 This reverts commit 7f0325f10ad1688d40522d99dd690b7279f32b9e. --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 94b3e04..d652cff 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -19,6 +19,7 @@ Suggests: aws.s3, httr, covr, + googleAuthR, googleCloudStorageR License: MIT + file LICENSE RoxygenNote: 6.1.0 From 84bc6d2c145a4219e21f7d1124407a5e4c7505b4 Mon Sep 17 00:00:00 2001 From: Jerry Kang Date: Thu, 9 May 2019 22:41:01 +0800 Subject: [PATCH 4/7] evaluate default args in a dedicated environment --- R/memoise.R | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/R/memoise.R b/R/memoise.R index f2bc63e..01dd1ce 100644 --- a/R/memoise.R +++ b/R/memoise.R @@ -118,9 +118,18 @@ memoise <- memoize <- function(f, ..., envir = environment(f), cache = cache_mem # That has not been called default_args <- default_args[setdiff(names(default_args), names(called_args))] - # Evaluate all the arguments - args <- c(lapply(called_args, eval, parent.frame()), - lapply(default_args, eval, envir = environment())) + # Evaluate called arguments + called_args <- lapply(called_args, eval, parent.frame()) + + # Emulate how R evaluate default arguments + emu_env <- new.env(parent = if (is.null(environment(encl$`_f`))) baseenv() else environment(encl$`_f`)) + for (n in setdiff(names(called_args), "")) assign(n, called_args[[n]], envir = emu_env) + for (n in names(default_args)) eval(bquote(delayedAssign(n, .(expr), eval.env= emu_env , assign.env = emu_env), + list(expr = default_args[[n]]))) + default_args <- sapply(names(default_args), get, envir = emu_env, simplify = FALSE) + + # All arguments + args <- c(called_args, default_args) # Replace memoised functions in arguments with their original bodies args <- lapply(args, function(x) if (memoise::is.memoised(x)) as.character(body(environment(x)$`_f`)) else x) @@ -264,7 +273,7 @@ has_cache <- function(f) { # Modify the function body of the function to simply return TRUE and FALSE # rather than get or set the results of the cache body <- body(f) - body[[10]] <- quote(if (encl$`_cache`$has_key(hash)) return(TRUE) else return(FALSE)) + body[[15]] <- quote(if (encl$`_cache`$has_key(hash)) return(TRUE) else return(FALSE)) body(f) <- body f @@ -291,7 +300,7 @@ drop_cache <- function(f) { # Modify the function body of the function to simply drop the key # and return TRUE if successfully removed body <- body(f) - body[[10]] <- quote(if (encl$`_cache`$has_key(hash)) { + body[[15]] <- quote(if (encl$`_cache`$has_key(hash)) { encl$`_cache`$drop_key(hash) return(TRUE) } else { From a7a7420a4d09ca63dce232d08deb707f01f1e5a1 Mon Sep 17 00:00:00 2001 From: Jerry Kang Date: Fri, 10 May 2019 22:12:23 +0800 Subject: [PATCH 5/7] test for name clash with default values --- tests/testthat/test-memoise.R | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/testthat/test-memoise.R b/tests/testthat/test-memoise.R index eb32d36..5c867e2 100644 --- a/tests/testthat/test-memoise.R +++ b/tests/testthat/test-memoise.R @@ -246,6 +246,24 @@ test_that("argument names don't clash with names in memoised function body", { 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("default values dont't clash with names in memoised function body", { + f <- function(extra = list(`_f`, `_cache`, `_additional`, + mc, encl, called_args, default_args)) { + i <<- i + 1; i + } + `_f` <- `_cache` <- `_additional` <- mc <- encl <- called_args <- default_args <- 0 + i <- 0 + + fm <- memoise(f) + + expect_equal(f(), 1) + expect_equal(fm(), 2) + expect_equal(fm(), 2) + + `_f` <- `_cache` <- `_additional` <- mc <- encl <- called_args <- default_args <- 1 + expect_equal(fm(), 3) +}) + test_that("other memoised function passed as arguments", { f <- function(x) x g <- function(fn) {i <<- fn(i) + 1; i} From cac7f70ef55bc4b856a02dcf5eedfddc436e7e44 Mon Sep 17 00:00:00 2001 From: Jerry Kang Date: Fri, 10 May 2019 23:19:19 +0800 Subject: [PATCH 6/7] sort args in order of formals --- R/memoise.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/memoise.R b/R/memoise.R index 01dd1ce..e8dc1e0 100644 --- a/R/memoise.R +++ b/R/memoise.R @@ -120,6 +120,7 @@ memoise <- memoize <- function(f, ..., envir = environment(f), cache = cache_mem # Evaluate called arguments called_args <- lapply(called_args, eval, parent.frame()) + if (is.null(names(called_args))) names(called_args) <- rep("", length(called_args)) # Emulate how R evaluate default arguments emu_env <- new.env(parent = if (is.null(environment(encl$`_f`))) baseenv() else environment(encl$`_f`)) @@ -128,8 +129,9 @@ memoise <- memoize <- function(f, ..., envir = environment(f), cache = cache_mem list(expr = default_args[[n]]))) default_args <- sapply(names(default_args), get, envir = emu_env, simplify = FALSE) - # All arguments + # All arguments in order of formals', followed by arguments passed to ... args <- c(called_args, default_args) + args <- c(args[names(formals())[names(formals()) %in% names(args)]], args[!names(args) %in% names(formals())]) # Replace memoised functions in arguments with their original bodies args <- lapply(args, function(x) if (memoise::is.memoised(x)) as.character(body(environment(x)$`_f`)) else x) @@ -273,7 +275,7 @@ has_cache <- function(f) { # Modify the function body of the function to simply return TRUE and FALSE # rather than get or set the results of the cache body <- body(f) - body[[15]] <- quote(if (encl$`_cache`$has_key(hash)) return(TRUE) else return(FALSE)) + body[[17]] <- quote(if (encl$`_cache`$has_key(hash)) return(TRUE) else return(FALSE)) body(f) <- body f @@ -300,7 +302,7 @@ drop_cache <- function(f) { # Modify the function body of the function to simply drop the key # and return TRUE if successfully removed body <- body(f) - body[[15]] <- quote(if (encl$`_cache`$has_key(hash)) { + body[[17]] <- quote(if (encl$`_cache`$has_key(hash)) { encl$`_cache`$drop_key(hash) return(TRUE) } else { From 281c540128d88438a670e5cac9b6c027177d4b71 Mon Sep 17 00:00:00 2001 From: Jerry Kang Date: Fri, 10 May 2019 23:50:58 +0800 Subject: [PATCH 7/7] test for default args order --- tests/testthat/test-memoise.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/testthat/test-memoise.R b/tests/testthat/test-memoise.R index 5c867e2..9eff72b 100644 --- a/tests/testthat/test-memoise.R +++ b/tests/testthat/test-memoise.R @@ -95,6 +95,18 @@ test_that("default arguments are evaluated correctly", { expect_equal(fnm(), 2) }) +test_that("whether default values pass explicitly or implicitly doesn't matter", { + fn <- function(x = 1, y = 1) { i <<- i + 1; i } + i <- 0 + fm <- memoise(fn) + + expect_equal(fn(), 1) + expect_equal(fm(y = 1), 2) + expect_equal(fm(), 2) + expect_equal(fm(x = 1), 2) + expect_equal(fm(x = 1, y = 1), 2) +}) + test_that("symbol collision", { cache <- function(j = 1) { i <<- i + 1; i } i <- 0