diff --git a/R/render-cached-plot.R b/R/render-cached-plot.R index 968000052..13c3a6af8 100644 --- a/R/render-cached-plot.R +++ b/R/render-cached-plot.R @@ -1,18 +1,72 @@ #' @export renderCachedPlot <- function(expr, cacheKeyExpr, cacheInvalidationExpr = NULL, baseWidth = 400, aspectRatioRate = 1.25, growthRate = 1.25, res = 72, + scope = c("app", "session"), ..., env = parent.frame(), quoted = FALSE, outputArgs = list() ) { + scope <- match.arg(scope) cacheKey <- reactive(substitute(cacheKeyExpr), env = parent.frame(), quoted = TRUE) cacheInvalidation <- reactive(substitute(cacheInvalidationExpr), env = parent.frame(), quoted = TRUE) - cacheDir <- file.path(tempdir(), "plotcache") + .cacheDir <- NULL + cacheDir <- function() { + # Memoize + if (is.null(.cacheDir)) { + if (is.null(outputName)) { + stop("outputName is NULL. cacheDir() was called too early.") + } - dir.create(cacheDir, recursive = TRUE, mode = "0700") # This shouldn't be here + appCachePath <- file.path(tempdir(), paste0("shinyapp-", getShinyOption("appToken"))) + + if (scope == "app") { + cacheScopePath <- appCachePath + } else if (scope == "session") { + cacheScopePath <- file.path(appCachePath, paste0("shinysession-", session$token)) + } + .cacheDir <<- file.path(cacheScopePath, paste0("output-", outputName)) + } + + .cacheDir + } + + ensureCacheDirExists <- function() { + if (!dirExists(cacheDir())) { + cat("Creating ", cacheDir(), "\n") + dir.create(cacheDir(), recursive = TRUE, mode = "0700") + + # Set up removal of cache directory at appropriate time. The removal + # callback is registered here, paired with the creation of the cache + # dir, to ensure it's not scheduled multiple times for one directory. + deleteCacheDir <- function() { + # Just to be safe, don't try to delete the cache dir if it's already + # gone. + if (!dirExists(cacheDir())) { + return() + } + + unlink(cacheDir(), recursive = TRUE) + + # Recursively delete empty parent dirs, up to temp dir. + currentDir <- dirname(cacheDir()) + while (currentDir != tempdir() && + length(dir(currentDir, all.files = TRUE, no.. = TRUE)) == 0) + { + dirRemove(currentDir) + currentDir <- dirname(currentDir) + } + } + + if (scope == "app") { + onStop(deleteCacheDir, session = NULL) + } else if (scope == "session") { + onSessionEnded(deleteCacheDir) + } + } + } # Delete the cacheDir at the appropriate time. Use ignoreInit=TRUE because # we don't want it to happen right in the beginning, especially when @@ -22,10 +76,7 @@ renderCachedPlot <- function(expr, cacheKeyExpr, cacheInvalidationExpr = NULL, substitute(cacheInvalidationExpr), event.env = parent.frame(), event.quoted = TRUE, ignoreInit = TRUE, { - if (dirExists(cacheDir)) { - unlink(cacheDir, recursive = TRUE) - } - dir.create(cacheDir, recursive = TRUE, mode = "0700") + unlink(file.path(cacheDir(), "*.rds")) # Cause drawReactive() to re-execute, so renderFunc doesn't use the # cached value. @@ -73,8 +124,10 @@ renderCachedPlot <- function(expr, cacheKeyExpr, cacheInvalidationExpr = NULL, dims <- isolate(getDims()) pixelratio <- session$clientData$pixelratio %OR% 1 + ensureCacheDirExists() + key <- digest::digest(list(cacheKey(), dims$width, dims$height, res, pixelratio)) - resultFilePath <- file.path(cacheDir, paste0(key, ".rds")) + resultFilePath <- file.path(cacheDir(), paste0(key, ".rds")) if (file.exists(resultFilePath)) { cat("drawReactive(): cached\n") @@ -114,8 +167,10 @@ renderCachedPlot <- function(expr, cacheKeyExpr, cacheInvalidationExpr = NULL, dims <- getDims() pixelratio <- session$clientData$pixelratio %OR% 1 + ensureCacheDirExists() + key <- digest::digest(list(cacheKey(), dims$width, dims$height, res, pixelratio)) - resultFilePath <- file.path(cacheDir, paste0(key, ".rds")) + resultFilePath <- file.path(cacheDir(), paste0(key, ".rds")) if (file.exists(resultFilePath)) { cat("renderFunc(): cached\n") diff --git a/R/utils.R b/R/utils.R index 87898b6fa..ca9e744a8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -269,6 +269,25 @@ dirExists <- function(paths) { file.exists(paths) & file.info(paths)$isdir } +# Removes empty directory (vectorized). This is needed because file.remove() +# on Unix will remove empty directories, but on Windows, it will not. On +# Windows, you would need to use unlink(recursive=TRUE), which is not very +# safe. This function does it safely on Unix and Windows. +dirRemove <- function(path) { + for (p in path) { + if (!dirExists(p)) { + stop("Cannot remove non-existent directory ", p, ".") + } + if (length(dir(p, all.files = TRUE, no.. = TRUE)) != 0) { + stop("Cannot remove non-empty directory ", p, ".") + } + result <- unlink(p, recursive = TRUE) + if (result == 1) { + stop("Error removing directory ", p, ".") + } + } +} + # Attempt to join a path and relative path, and turn the result into a # (normalized) absolute path. The result will only be returned if it is an # existing file/directory and is a descendant of dir.