caching <- function() {
# Default should be on, so if httpcache.on isn't set, return TRUE
isTRUE(getOption("httpcache.on", TRUE))
}
#' Manage the HTTP cache
#'
#' These functions turn the cache on and off and clear the contents of the
#' query cache.
#' @return Nothing. Functions are run for their side effects.
#' @aliases cacheOn cacheOff clearCache
#' @name cache-management
#' @export
cacheOn <- function() options(httpcache.on = TRUE)
#' @rdname cache-management
#' @export
cacheOff <- function() {
options(httpcache.on = FALSE)
clearCache()
}
#' @rdname cache-management
#' @export
clearCache <- function() {
logMessage("CACHE CLEAR")
rm(list = cacheKeys(), envir = cache)
}
#' HTTP Cache API
#'
#' These functions provide access to what's stored in the cache.
#' @param key character, typically a URL or similar
#' @param value For `setCache`, an R object to set in the cache for `key`.
#' @return `hitCache` returns logical whether `key` exists in the
#' cache. `getCache` returns the value stored in the cache, or `NULL`
#' if there is nothing cached. `setCache` is called for its side effects.
#' @name cache-api
#' @export
hitCache <- function(key) {
exists(key, envir = cache)
}
#' @rdname cache-api
#' @export
getCache <- function(key) {
if (hitCache(key)) {
logMessage("CACHE HIT", key)
return(get(key, envir = cache))
} else {
return(NULL)
}
}
#' @rdname cache-api
#' @export
setCache <- function(key, value) {
logMessage("CACHE SET", key)
assign(key, value, envir = cache)
}
cacheKeys <- function() ls(all.names = TRUE, envir = cache)
#' Construct a unique cache key for a request
#'
#' This function encapsulates the logic of making a cache key, allowing other
#' code or libraries to access the HTTP cache programmatically.
#'
#' @param url character request URL
#' @param query Optional query parameters for the request
#' @param body Optional request body
#' @param extras character Optional additional annotations to include in the
#' cache key.
#' @return Character value, starting with \code{url} and including hashed query
#' and body values if provided, to be used as the cache key for this request.
#' @export
buildCacheKey <- function(url, query = NULL, body = NULL, extras = c()) {
if (!is.null(query)) {
extras <- c(extras, paste0("QUERY=", digest(query)))
}
if (!is.null(body)) {
extras <- c(extras, paste0("BODY=", digest(body)))
}
if (length(extras)) {
url <- paste(url, paste0(extras, collapse = "&"), sep = "?")
}
return(url)
}
#' Context manager to temporarily turn cache off if it is on
#'
#' If you don't want to store the response of a GET request in the cache,
#' wrap it in `uncached()`. It will neither read from nor write to cache.
#'
#' `uncached` will not invalidate cache records, if present. It only ignores
#' them.
#'
#' @param ... Things to evaluate with caching off
#' @return Whatever ... returns.
#' @examples
#' uncached(GET("http://httpbin.org/get"))
#' @export
uncached <- function(...) {
old <- getOption("httpcache.on")
on.exit(options(httpcache.on = old))
options(httpcache.on = FALSE)
eval.parent(...)
}
#' Invalidate cache
#'
#' These functions let you control cache invalidation. `dropOnly`
#' invalidates cache only for the specified URL. `dropPattern` uses
#' regular expression matching to invalidate cache. `dropCache` is a
#' convenience wrapper around `dropPattern` that invalidates cache for
#' any resources that start with the given URL.
#' @param x character URL or regular expression
#' @return Nothing. Functions are run for their side effects.
#' @export
dropCache <- function(x) {
# Drop x and anything below it in the tree
dropPattern(paste0("^", regexEscape(popQuery(x))))
}
#' @rdname dropCache
#' @export
dropOnly <- function(x) {
logMessage("CACHE DROP", x)
suppressWarnings(rm(list = x, envir = cache))
}
#' @rdname dropCache
#' @export
dropPattern <- function(x) {
logMessage("CACHE DROP", x)
rm(list = ls(envir = cache, pattern = x), envir = cache)
}
regexEscape <- function(x) {
# Escape all reserved characters that are valid URL chars with \\
for (i in unlist(strsplit(".+?*", ""))) {
x <- gsub(paste0("(\\", i, ")"), "[\\1]", x)
}
return(x)
}
popQuery <- function(x) {
# Remove query parameters from a URL
return(sub("\\?.*$", "", x))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.