Drop cache for particular arguments

This provides the ability to drop the cache for a particular input

Fixes #66

NAMESPACE

@@ -5,6 +5,7 @@ export(cache_filesystem)
 export(cache_gcs)
 export(cache_memory)
 export(cache_s3)
+export(drop_cache)
 export(forget)
 export(has_cache)
 export(is.memoised)

NEWS.md

@@ -5,6 +5,8 @@
 * Add `compress` option for non-memory caches (#71 - @coolbutuseless)
 * Use absolute path in cache file system backend, so user can change working 
 directory after using relative path (#51, #65 - @xhdong-umd)
+* Add `drop_cache()` to drop the cached result for particular arguments (#78 -
+  richardkunze)
 
 # Version 1.1.0
 * Caches now hash the function body along with the arguments, to ensure

R/cache_filesystem.R

@@ -51,12 +51,17 @@ cache_filesystem <- function(path, algo = "xxhash64", compress = FALSE) {
     file.exists(file.path(path, key))
   }
 
+  cache_drop_key <- function(key) {
+    file.remove(file.path(path, key))
+  }
+
   list(
     digest = function(...) digest::digest(..., algo = algo),
     reset = cache_reset,
     set = cache_set,
     get = cache_get,
     has_key = cache_has_key,
+    drop_key = cache_drop_key,
     keys = function() list.files(path)
   )
 }

R/cache_gcs.R

@@ -67,6 +67,10 @@ cache_gcs <- function(cache_name = googleCloudStorageR::gcs_get_global_bucket(),
     is_here
   }
 
+  cache_drop_key <- function(key) {
+    googleCloudStorageR::gcs_delete_object(key, bucket = cache_name)
+  }
+
   cache_keys <- function() {
     items <- googleCloudStorageR::gcs_list_objects(bucket = cache_name)
     items$name
@@ -78,6 +82,7 @@ cache_gcs <- function(cache_name = googleCloudStorageR::gcs_get_global_bucket(),
     set = cache_set,
     get = cache_get,
     has_key = cache_has_key,
+    drop_key = cache_drop_key,
     keys = cache_keys
   )
 }

R/cache_memory.R

@@ -23,13 +23,18 @@ cache_memory <- function(algo = "sha512") {
     exists(key, envir = cache, inherits = FALSE)
   }
 
+  cache_drop_key <- function(key) {
+    rm(list = key, envir = cache, inherits = FALSE)
+  }
+
   cache_reset()
   list(
     digest = function(...) digest::digest(..., algo = algo),
     reset = cache_reset,
     set = cache_set,
     get = cache_get,
     has_key = cache_has_key,
+    drop_key = cache_drop_key,
     keys = function() ls(cache)
   )
 }

R/cache_s3.R

@@ -55,6 +55,10 @@ cache_s3 <- function(cache_name, algo = "sha512", compress = FALSE) {
     aws.s3::head_object(object = key, bucket = cache_name)
   }
 
+  cache_drop_key <- function(key) {
+    aws.s3::delete_bucket(key, bucket = cache_name)
+  }
+
   cache_keys <- function() {
     items <- lapply(aws.s3::get_bucket(bucket = cache_name), `[[`, "Key")
     unlist(Filter(Negate(is.null), items))
@@ -66,6 +70,7 @@ cache_s3 <- function(cache_name, algo = "sha512", compress = FALSE) {
     set = cache_set,
     get = cache_get,
     has_key = cache_has_key,
+    drop_key = cache_drop_key,
     keys = cache_keys
   )
 }

R/memoise.R

@@ -266,3 +266,35 @@ has_cache <- function(f) {
 
   f
 }
+
+#' Drops the cache of a memoised function for particular arguments.
+#' @param f Memoised function.
+#' @return A function, with the same arguments as \code{f}, that can be called to drop
+#'   the cached results of \code{f}.
+#' @seealso \code{\link{has_cache}}, \code{\link{memoise}}
+#' @export
+#' @examples
+#' mem_sum <- memoise(sum)
+#' mem_sum(1, 2, 3)
+#' mem_sum(2, 3, 4)
+#' has_cache(mem_sum)(1, 2, 3) # TRUE
+#' has_cache(mem_sum)(2, 3, 4) # TRUE
+#' drop_cache(mem_sum)(1, 2, 3) # TRUE
+#' has_cache(mem_sum)(1, 2, 3) # FALSE
+#' has_cache(mem_sum)(2, 3, 4) # TRUE
+drop_cache <- function(f) {
+  if(!is.memoised(f)) stop("`f` is not a memoised function!", call. = FALSE)
+
+  # 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)) {
+    encl$`_cache`$drop_key(hash)
+    return(TRUE)
+  } else {
+    return(FALSE)
+  })
+  body(f) <- body
+
+  f
+}

tests/testthat/test-filesystem.R

@@ -19,6 +19,9 @@ test_that("using a filesystem cache works", {
   expect_true(forget(fnm))
   expect_equal(fnm(), 5)
 
+  expect_true(drop_cache(fnm)())
+  expect_equal(fnm(), 6)
+
   expect_true(is.memoised(fnm))
   expect_false(is.memoised(fn))
 })

tests/testthat/test-gcs.R

@@ -25,6 +25,9 @@ test_that("using a gcs cache works", {
   expect_true(forget(fnm))
   expect_equal(fnm(), 5)
 
+  expect_true(drop_cache(fnm)())
+  expect_equal(fnm(), 6)
+
   expect_true(is.memoised(fnm))
   expect_false(is.memoised(fn))
 })

tests/testthat/test-memoise.R

@@ -263,6 +263,30 @@ 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

tests/testthat/test-s3.R

@@ -22,6 +22,9 @@ test_that("using a s3 cache works", {
   expect_true(forget(fnm))
   expect_equal(fnm(), 5)
 
+  expect_true(drop_cache(fnm)())
+  expect_equal(fnm(), 6)
+
   expect_true(is.memoised(fnm))
   expect_false(is.memoised(fn))
 })