mirror of
https://github.com/rstudio/shiny.git
synced 2026-02-07 21:26:08 -05:00
367 lines
14 KiB
R
367 lines
14 KiB
R
#' @export
|
|
renderCachedPlot <- function(expr, cacheKeyExpr, cacheInvalidationExpr = NULL,
|
|
baseWidth = 400, aspectRatioRate = 1.25, growthRate = 1.25, res = 72,
|
|
...,
|
|
env = parent.frame(), quoted = FALSE, outputArgs = list()
|
|
) {
|
|
|
|
cacheKey <- reactive(substitute(cacheKeyExpr), env = parent.frame(), quoted = TRUE)
|
|
|
|
cacheDir <- file.path(tempdir(), "plotcache")
|
|
|
|
# This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
|
|
# is called
|
|
installExprFunction(expr, "func", env, quoted, ..stacktraceon = TRUE)
|
|
|
|
args <- list(...)
|
|
|
|
possible_dims <- all_possible_dims(baseWidth, aspectRatioRate, growthRate)
|
|
|
|
# Given the actual width/height of the image in the browser, return the
|
|
# smallest containing rectangle from possible_dims.
|
|
getDims <- function() {
|
|
cat("getDims()\n")
|
|
width <- session$clientData[[paste0('output_', outputName, '_width')]]
|
|
height <- session$clientData[[paste0('output_', outputName, '_height')]]
|
|
|
|
find_smallest_containing_rect(width, height, possible_dims)
|
|
}
|
|
|
|
# Vars to store session and output, so that they can be accessed from
|
|
# the plotObj() reactive.
|
|
session <- NULL
|
|
outputName <- NULL
|
|
|
|
# This can be used to trigger drawReactive() to re-execute. This is
|
|
# necessary in some cases.
|
|
drawReactiveTrigger <- reactiveVal(0)
|
|
|
|
# Calls drawPlot, invoking the user-provided `func` (which may or may not
|
|
# return a promise). The idea is that the (cached) return value from this
|
|
# reactive can be used for varying width/heights, as it includes the
|
|
# displaylist, which is resolution independent.
|
|
drawReactive <- reactive(label = "plotObj", {
|
|
hybrid_chain(
|
|
{
|
|
drawReactiveTrigger()
|
|
cat("drawReactive()\n")
|
|
|
|
dims <- isolate(getDims())
|
|
pixelratio <- session$clientData$pixelratio %OR% 1
|
|
|
|
key <- digest::digest(list(cacheKey(), dims$width, dims$height, res, pixelratio))
|
|
resultFilePath <- file.path(cacheDir, paste0(key, ".rds"))
|
|
|
|
if (file.exists(resultFilePath)) {
|
|
cat("drawReactive(): cached\n")
|
|
# This will NOT include the displaylist.
|
|
readRDS(resultFilePath)
|
|
|
|
} else {
|
|
cat("drawReactive(): drawPlot()\n")
|
|
# This includes the displaylist.
|
|
drawPlot(outputName, session, func, dims$width, dims$height, pixelratio, res,
|
|
resultfile = resultFilePath)
|
|
}
|
|
},
|
|
catch = function(reason) {
|
|
# Non-isolating read. A common reason for errors in plotting is because
|
|
# the dimensions are too small. By taking a dependency on width/height,
|
|
# we can try again if the plot output element changes size.
|
|
getDims()
|
|
|
|
# Propagate the error
|
|
stop(reason)
|
|
}
|
|
)
|
|
})
|
|
|
|
# This function is the one that's returned from renderPlot(), and gets
|
|
# wrapped in an observer when the output value is assigned.
|
|
renderFunc <- function(shinysession, name, ...) {
|
|
outputName <<- name
|
|
session <<- shinysession
|
|
|
|
hybrid_chain(
|
|
drawReactive(),
|
|
function(result) {
|
|
cat("renderFunc()\n")
|
|
# Do take a reactive dependency on the dimensions
|
|
dims <- getDims()
|
|
pixelratio <- session$clientData$pixelratio %OR% 1
|
|
|
|
key <- digest::digest(list(cacheKey(), dims$width, dims$height, res, pixelratio))
|
|
resultFilePath <- file.path(cacheDir, paste0(key, ".rds"))
|
|
|
|
if (file.exists(resultFilePath)) {
|
|
cat("renderFunc(): cached\n")
|
|
cachedPlot <- readRDS(resultFilePath)
|
|
img <- cachedPlot$img
|
|
|
|
} else {
|
|
if (is.null(result$recordedPlot)) {
|
|
# This is an uncommon case. (1) The output from drawPlot was saved
|
|
# to RDS (without a recordedPlot, since that can't be properly
|
|
# saved). (2) drawPlot was called with another set of inputs (so
|
|
# it didn't load from cache). (3) drawPlot was called, getting a
|
|
# cache hit and restoring the first RDS. (4) the plot is resized,
|
|
# so this reactive executes (and not drawPlot). In this situation,
|
|
# there's no recordedPlot that can be replayed, so we have to
|
|
# trigger drawPlot() to run again.
|
|
cat("renderFunc(): drawReactiveTrigger()\n")
|
|
drawReactiveTrigger(drawReactiveTrigger() + 1)
|
|
req(FALSE, cancelOutput = TRUE)
|
|
|
|
} else {
|
|
cat("renderFunc(): resizeSavedPlot()\n")
|
|
img <- resizeSavedPlot(name, shinysession, result,
|
|
dims$width, dims$height, pixelratio, res,
|
|
resultfile = resultFilePath)
|
|
}
|
|
}
|
|
|
|
# Replace exact pixel dimensions; instead tell it to fill.
|
|
img$width <- "100%"
|
|
img$height <- NULL
|
|
img
|
|
}
|
|
)
|
|
}
|
|
|
|
# If renderPlot isn't going to adapt to the height of the div, then the
|
|
# div needs to adapt to the height of renderPlot. By default, plotOutput
|
|
# sets the height to 400px, so to make it adapt we need to override it
|
|
# with NULL.
|
|
outputFunc <- plotOutput
|
|
formals(outputFunc)['height'] <- list(NULL)
|
|
|
|
markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
|
|
}
|
|
|
|
|
|
|
|
#' Disk-based plot cache
|
|
#'
|
|
#' Creates a read-through cache for plots. The plotting logic is provided as
|
|
#' \code{plotFunc}, a function that can have any number/combination of
|
|
#' arguments; the return value of \code{plotCache()} is a function that should
|
|
#' be used in the place of plotFunc. Each unique combination of inputs will be
|
|
#' cached to disk in the location specified by \code{cacheDir}.
|
|
#'
|
|
#' \code{invalidationExpr} is an expression that uses reactive values like
|
|
#' \code{input$click} and/or reactive expressions like \code{data()}. Whenever
|
|
#' it changes value, the cache is invalidated (the contents are erased). You
|
|
#' typically want to invalidate the cache when a plot made with the same input
|
|
#' variables would have a different result. For example, if the plot is a
|
|
#' scatter plot and the data set originally had 100 rows, and then changes to
|
|
#' have 200 rows, you would want to invalidate the cache so that the plots would
|
|
#' be redrawn display the new, larger data set. The \code{invalidationExpr}
|
|
#' parameter works just like the \code{eventExpr} parameter of
|
|
#' \code{\link{observeEvent}}.
|
|
#'
|
|
#' Another way to use \code{invalidationExpr} is to have it invalidate the cache
|
|
#' at a fixed time interval. For example, you might want to have invalidate the
|
|
#' cache once per hour, or once per day. See below for an example.
|
|
#'
|
|
#' @section Cache scoping:
|
|
#'
|
|
#' There are a number of different ways you may want to scope the cache. For
|
|
#' example, you may want each user session to have their own plot cache, or
|
|
#' you may want each run of the application to have a cache (shared among
|
|
#' possibly multiple simultaneous user sessions), or you may want to have a
|
|
#' cache that persists even after the application is shut down and started
|
|
#' again.
|
|
#'
|
|
#' The cache can be scoped automatically, based on where you call
|
|
#' \code{plotCache()}. If automatic scoping is used, the cache will be
|
|
#' automatically deleted when the scope exits. For example if it is scoped to
|
|
#' a session, then the cache will be deleted when the session exits.
|
|
#'
|
|
#' \describe{
|
|
#' \item{1}{To scope the cache to one session, call \code{plotCache()} inside
|
|
#' of the server function.}
|
|
#' \item{2}{To scope the cache to one run of a Shiny application (shared
|
|
#' among possibly multiple user sessions), call \code{plotCache()} in your
|
|
#' application, but outside of the server function.}
|
|
#' \item{3}{To scope the cache to a single R process (possibly across multiple
|
|
#' runs of applications), call \code{plotCache()} somewhere outside of
|
|
#' code that is run by \code{runApp()}. (This is an uncommon use case, but
|
|
#' can happen during local application development when running code in the
|
|
#' console.)}
|
|
#' }
|
|
#'
|
|
#' If you want to set the scope of the cache manually, use the
|
|
#' \code{cacheDir} parameter. This can be useful if you want the cache to
|
|
#' persist across R processes or even system reboots.
|
|
#'
|
|
#' \describe{
|
|
#' \item{4}{To have the cache persist across different R processes, use
|
|
#' \code{cacheDir=file.path(dirname(tempdir()), "my_cache_id")}.
|
|
#' This will create a subdirectory in your system temp directory named
|
|
#' \code{my_cache_id} (where \code{my_cache_id} is replaced with a unique
|
|
#' name of your choosing).}
|
|
#' \item{5}{To have the cache persist even across system reboots, you can set
|
|
#' \code{cacheDir} to a location outside of the temp directory.}
|
|
#' }
|
|
#'
|
|
#'
|
|
#'
|
|
#' @param plotFunc Plotting logic, provided as a function that takes zero or
|
|
#' more arguments. Don't worry about setting up a graphics device or creating
|
|
#' a PNG; just write to the graphics device (you must call \code{print()} on
|
|
#' ggplot2 objects).
|
|
#' @param invalidationExpr Any expression or block of code that accesses any
|
|
#' reactives whose invalidation should cause cache invalidation. Use
|
|
#' \code{NULL} if you don't want to cause cache invalidation.
|
|
#' @param baseWidth A base value for the width of the cached plot.
|
|
#' @param aspectRatioRate A multiplier for different possible aspect ratios.
|
|
#' @param growthRate A multiplier for different cached image sizes. For
|
|
#' example, with a \code{width} of 400 and a \code{growth_rate} of 1.25, there
|
|
#' will be possible cached images of widths 256, 320, 400, 500, 625, and so
|
|
#' on, both smaller and larger.
|
|
#' @param res The resolution of the PNG, in pixels per inch.
|
|
#' @param cacheDir The location on disk where the cache will be stored. If
|
|
#' \code{NULL} (the default), it uses a temp directory which will be cleaned
|
|
#' up when the cache scope exits. See the Cache Scoping section for more
|
|
#' information.
|
|
#' @param invalidation.env The environment where the \code{invalidationExpr} is
|
|
#' evaluated.
|
|
#' @param invalidation.quoted Is \code{invalidationExpr} expression quoted? By
|
|
#' default, this is FALSE. This is useful when you want to use an expression
|
|
#' that is stored in a variable; to do so, it must be quoted with
|
|
#' \code{quote()}.
|
|
#'
|
|
#' @export
|
|
createCachedPlot <- function(plotFunc, invalidationExpr,
|
|
baseWidth = 400, aspectRatioRate = 1.25, growthRate = 1.25, res = 72,
|
|
cacheDir = NULL,
|
|
invalidation.env = parent.frame(),
|
|
invalidation.quoted = FALSE,
|
|
session = getDefaultReactiveDomain()
|
|
) {
|
|
|
|
# If user didn't supply cacheDir, automatically determine it.
|
|
if (is.null(cacheDir)) {
|
|
if (!is.null(session)) {
|
|
# Case 1: scope to session
|
|
cacheScopePath <- file.path(tempdir(), paste0("shinysession-", session$token))
|
|
|
|
} else if (!is.null(getShinyOption("appToken"))) {
|
|
# Case 2: scope to app
|
|
cacheScopePath <- file.path(tempdir(), paste0("shinyapp-", getShinyOption("appToken")))
|
|
|
|
} else {
|
|
# Case 3: scope to current R process
|
|
cacheScopePath <- file.path(tempdir(), "shiny")
|
|
}
|
|
|
|
cacheDir <- file.path(cacheScopePath, createUniqueId(8))
|
|
|
|
# Remove the cache directory when it's no longer needed.
|
|
reg.finalizer(environment(), function(e) {
|
|
unlink(cacheDir, recursive = TRUE)
|
|
|
|
# If cacheScopePath is empty, remove it.
|
|
siblingPaths <- setdiff(dir(cacheScopePath, all.files = TRUE), c(".", ".."))
|
|
if (length(siblingPaths) == 0) {
|
|
file.remove(cacheScopePath)
|
|
}
|
|
})
|
|
}
|
|
|
|
if (!dirExists(cacheDir)) {
|
|
dir.create(cacheDir, recursive = TRUE, mode = "0700")
|
|
}
|
|
|
|
if (!invalidation.quoted) {
|
|
invalidationExpr <- substitute(invalidationExpr)
|
|
}
|
|
|
|
possible_dims <- all_possible_dims(baseWidth, aspectRatioRate, growthRate)
|
|
|
|
# Delete the cacheDir at the appropriate time. Use ignoreInit=TRUE because we don't
|
|
# want it to happen right in the beginning, especially when cacheDir is provided
|
|
# by the user and it might need to persist across R processes.
|
|
observeEvent(invalidationExpr, event.env = invalidation.env, event.quoted = TRUE,
|
|
ignoreInit = TRUE,
|
|
{
|
|
if (dirExists(cacheDir)) {
|
|
unlink(cacheDir, recursive = TRUE)
|
|
}
|
|
dir.create(cacheDir, recursive = TRUE, mode = "0700")
|
|
}
|
|
)
|
|
|
|
function(...) {
|
|
args <- list(...)
|
|
|
|
output_info <- getCurrentOutputInfo()
|
|
if (is.null(output_info)) {
|
|
stop("This must be run in a Shiny output.")
|
|
}
|
|
session <- getDefaultReactiveDomain()
|
|
if (is.null(session)) {
|
|
stop("This must be run from a Shiny session.")
|
|
}
|
|
|
|
target_width <- output_info$width()
|
|
target_height <- output_info$height()
|
|
|
|
dims <- find_smallest_containing_rect(target_width, target_height, possible_dims)
|
|
|
|
pixelratio <- session$clientData$pixelratio
|
|
|
|
# TODO: What if the args include weird objects like environments or reactive expressions?
|
|
key <- paste0(digest::digest(c(args, width = dims$width, height = dims$height, res = res, pixelratio = pixelratio)), ".png")
|
|
filePath <- file.path(cacheDir, key)
|
|
if (!file.exists(filePath)) {
|
|
plotPNG(
|
|
filename = filePath,
|
|
width = dims$width * pixelratio,
|
|
height = dims$height * pixelratio,
|
|
res = res * pixelratio,
|
|
function() {
|
|
do.call("plotFunc", args)
|
|
}
|
|
)
|
|
}
|
|
filePath
|
|
}
|
|
}
|
|
|
|
|
|
# Given a target rectangle with `width` and `height`, and data frame `dims` of possible
|
|
# dimensions, with column `width` and `height, find the smallest possible width x
|
|
# height pair from `dims` that fully contains `width` and `height.`
|
|
find_smallest_containing_rect <- function(width, height, dims) {
|
|
fit_rows <- width <= dims$width & height <= dims$height
|
|
|
|
if (sum(fit_rows) == 0) {
|
|
# TODO: handle case where width x height is larger than all dims
|
|
}
|
|
|
|
# Drop all the rows where width x height won't fit
|
|
dims <- dims[fit_rows, ]
|
|
|
|
# Find the possible rectangle with the smallest area
|
|
dims$area <- dims$width * dims$height
|
|
min_row <- which.min(dims$area)
|
|
|
|
list(
|
|
width = dims$width[min_row],
|
|
height = dims$height[min_row]
|
|
)
|
|
}
|
|
|
|
# Returns a data frame with all possible width-height combinations. This could
|
|
# use some fine-tuning in the future.
|
|
all_possible_dims <- function(base_width = 400, aspect_ratio_rate = 1.25, growth_rate = 1.25) {
|
|
aspect_ratios <- aspect_ratio_rate ^ (-3:3)
|
|
dims <- expand.grid(width = base_width * (growth_rate ^ (-6:6)), ratio = aspect_ratios)
|
|
dims$height <- dims$width * dims$ratio
|
|
|
|
dims$width <- round(dims$width)
|
|
dims$height <- round(dims$height)
|
|
dims
|
|
}
|