Demo implementation of the multiple-caches feature

NAMESPACE

@@ -20,6 +20,7 @@ export(hitCache)
 export(loadCache)
 export(loadLogfile)
 export(logMessage)
+export(registerCache)
 export(requestLogSummary)
 export(saveCache)
 export(setCache)

R/cache.R

@@ -23,7 +23,7 @@ cacheOff <- function () {
 #' @export
 clearCache <- function () {
     logMessage("CACHE CLEAR")
-    rm(list=cacheKeys(), envir=cache)
+    rm(list=cacheKeys(), envir = identifyCache())
 }
 
 #' HTTP Cache API
@@ -37,15 +37,15 @@ clearCache <- function () {
 #' @name cache-api
 #' @export
 hitCache <- function (key) {
-    exists(key, envir=cache)
+    exists(key, envir = identifyCache())
 }
 
 #' @rdname cache-api
 #' @export
 getCache <- function (key) {
     if (hitCache(key)) {
         logMessage("CACHE HIT", key)
-        return(get(key, envir=cache))
+        return(get(key, envir = identifyCache()))
     } else {
         return(NULL)
     }
@@ -55,10 +55,12 @@ getCache <- function (key) {
 #' @export
 setCache <- function (key, value) {
     logMessage("CACHE SET", key)
-    assign(key, value, envir=cache)
+    assign(key, value, envir = identifyCache())
 }
 
-cacheKeys <- function () ls(all.names=TRUE, envir=cache)
+cacheKeys <- function (){
+    setdiff(ls(all.names=TRUE, envir = identifyCache()), cache_identifier_key)
+}
 
 #' Construct a unique cache key for a request
 #'
@@ -125,14 +127,14 @@ dropCache <- function (x) {
 #' @export
 dropOnly <- function (x) {
     logMessage("CACHE DROP", x)
-    suppressWarnings(rm(list=x, envir=cache))
+    suppressWarnings(rm(list=x, envir=identifyCache()))
 }
 
 #' @rdname dropCache
 #' @export
 dropPattern <- function (x) {
     logMessage("CACHE DROP", x)
-    rm(list=ls(envir=cache, pattern=x), envir=cache)
+    rm(list=ls(envir=cache, pattern=x), envir=identifyCache())
 }
 
 # dropBelow <- function (x) {

R/load-cache.R

@@ -1,9 +1,23 @@
+
 ## Create the cache env
 cache <- NULL
 initCache <- function () {
     cache <<- new.env(hash=TRUE)
 }
+cache_identifier_key <- '__CACHE_IDENTIFIER_FUNCTION__'
+#' @export
+registerCache <- function(fn){
+    stopifnot(
+        'fn must be a function' = is.function(fn)
+    )
+    assign(cache_identifier_key, fn, envir=cache)
+}
+identifyCache <- function(){
+    idfun <- get(cache_identifier_key, envir = cache)
+    idfun()
+}
 initCache()
+registerCache(function() cache)
 
 #' Save and load cache state
 #'
@@ -13,7 +27,7 @@ initCache()
 #' @return Nothing; called for side effects.
 #' @export
 saveCache <- function (file) {
-    saveRDS(cache, file=file)
+    saveRDS(identifyCache(), file=file)
 }
 
 #' @rdname saveCache