Nothing
# ---
# repo: r-lib/rlang
# file: standalone-downstream-deps.R
# last-updated: 2022-01-19
# license: https://unlicense.org
# ---
#
# No dependencies but uses rlang and pak if available. In interactive
# sessions the user is prompted to update outdated packages. If they
# choose no, they are informed about the global option
# `rlib_downstream_check` to turn off these prompts. In non
# interactive sessions a warning is issued. This happens when the
# outdated dep is being loaded.
#
# ## Changelog
#
# 2022-01-19:
#
# * Prompt results are no longer cached in the `org:r-lib` search path
# environment in non-interactive sessions. This is to avoid side
# effects causing R CMD check failures.
#
#
# 2021-06-08:
#
# * User response is cached in the global env to avoid asking again
# when session is reloaded.
#
#
# 2021-05-20:
#
# * Fixed issue when downstream package is not installed.
#
#
# 2021-05-17:
#
# * Added an `info` argument intended to inform users about the
# consequences of not updating right away.
#
#
# 2021-05-12:
#
# * All packages are now updated at once. The user is not prompted
# again after accepting or declining to update the packages, even
# when one of the packages is loaded later on.
#
#
# 2021-05-07:
#
# * In interactive sessions, user is now prompted to update outdated
# packages.
#
# * Added global option `rlib_downstream_check` to turn off prompts or
# warnings.
#
# * Renamed to `check_downstream()`.
#
# * The requirement format is now "pkg (>= 0.0.0)", consistently with
# DESCRIPTION fields.
#
# nocov start
check_downstream <- function(ver,
...,
info = NULL) {
env <- topenv(parent.frame())
if (!isNamespace(env)) {
stop("`check_downstream()` must be called from a namespace.", call. = FALSE)
}
pkg <- unname(getNamespaceName(env))
deps <- c(...)
if (!is.character(deps)) {
stop("`...` must be strings.", call. = FALSE)
}
deps_key <- paste0(deps, collapse = " ")
deps <- .rlang_downstream_parse_deps(deps)
on_package_load <- function(pkg, expr) {
if (isNamespaceLoaded(pkg)) {
expr
} else {
thunk <- function(...) expr
setHook(packageEvent(pkg, "onLoad"), thunk)
}
}
is_interactive <- .rlang_downstream_compat("is_interactive")
if (is_interactive()) {
cache <- .rlang_downstream_get_cache()
cache[[pkg]][[deps_key]] <- FALSE
}
checked <- FALSE
for (dep in deps) {
on_package_load(
dep[["pkg"]],
.rlang_downstream_check(
pkg,
ver,
deps,
info = info,
deps_key = deps_key
)
)
}
}
.rlang_downstream_parse_deps <- function(deps) {
str_trim <- function(x) {
sub("^\\s+", "", sub("\\s+$", "", x))
}
deps <- lapply(strsplit(deps, "\\("), str_trim)
deps <- lapply(deps, sub, pattern = "\\)$", replacement = "")
deps <- lapply(deps, .rlang_downstream_parse_min_requirement)
deps
}
.rlang_downstream_parse_min_requirement <- function(dep) {
if (length(dep) != 2) {
stop("Parsing error during downstream check.", call. = FALSE)
}
is_string <- function(x) {
is.character(x) && length(x) == 1 && !is.na(x)
}
parts <- strsplit(dep[[2]], " +")[[1]]
if (length(parts) != 2) {
stop("Parsing error during downstream check.", call. = FALSE)
}
op <- parts[[1]]
ver <- parts[[2]]
stopifnot(is_string(op), is_string(ver))
if (op != ">=") {
stop("Can only check `>=` requirements.", call. = FALSE)
}
c(pkg = dep[[1]], min = ver)
}
.rlang_downstream_check <- function(pkg,
pkg_ver,
deps,
info,
deps_key = as.character(stats::runif(1)),
env = parent.frame()) {
isFALSE <- function(x) {
is.logical(x) && length(x) == 1L && !is.na(x) && !x
}
if (isFALSE(getOption("rlib_downstream_check"))) {
return(NULL)
}
# Check cache in the global environment. This cache gets saved along
# with the session. This avoids getting repeated checks when session
# is reloaded, e.g. when revisiting RStudio servers.
is_interactive <- .rlang_downstream_compat("is_interactive")
if (is_interactive()) {
cache <- .rlang_downstream_get_cache()
if (isTRUE(cache[[pkg]][[deps_key]])) {
return(NULL)
}
}
# Still check closure env in case the cache in the global
# environment has been deleted
if (isTRUE(env$checked)) {
return(NULL)
}
# Don't ask again. Flip now instead of on exit to defensively
# prevent recursion.
if (is_interactive()) {
cache[[pkg]][deps_key] <- list(TRUE)
}
env$checked <- TRUE
pkgs <- vapply(deps, `[[`, "", "pkg")
mins <- vapply(deps, `[[`, "", "min")
# Don't use `requireNamespace()` to avoid loading packages
is_on_disk <- function(pkg) nzchar(system.file(package = pkg))
on_disk <- vapply(pkgs, is_on_disk, NA)
pkgs <- pkgs[on_disk]
mins <- mins[on_disk]
vers <- lapply(pkgs, utils::packageVersion)
ok <- as.logical(Map(`>=`, vers, mins))
if (all(ok)) {
return(TRUE)
}
pkgs <- pkgs[!ok]
mins <- mins[!ok]
pkgs_quoted <- paste0("`", pkgs, "` (>= ", mins, ")")
pkgs_enum <- .rlang_downstream_collapse(pkgs_quoted, final = "and")
n <- length(pkgs)
if (n == 1) {
header <- paste0("The package ", pkgs_enum, " is required")
} else {
header <- paste0("The packages ", pkgs_enum, " are required")
}
header <- sprintf("%s as of %s %s.", header, pkg, pkg_ver)
warn <- .rlang_downstream_compat("warn")
inform <- .rlang_downstream_compat("inform")
is_interactive <- .rlang_downstream_compat("is_interactive")
if (!is_interactive() || !is.null(getOption("rlang:::no_downstream_prompt"))) {
warn(header)
return(FALSE)
}
if (n == 1) {
question <- "Would you like to update it now?"
} else {
question <- "Would you like to update them now?"
}
# Use "i" bullets by default
if (!is.null(info) && is.null(names(info))) {
names(info) <- rep("i", length(info))
}
prompt <- c(
"!" = question,
" " = "You will likely need to restart R if you update now.",
info
)
inform(c(header, prompt))
if (utils::menu(c("Yes", "No")) != 1) {
inform("Set `options(rlib_downstream_check = FALSE)` to disable this prompt.")
return(FALSE)
}
if (is_installed("pak")) {
pkg_install <- get(envir = asNamespace("pak"), "pkg_install")
pkg_install(pkgs, ask = FALSE)
} else {
utils::install.packages(pkgs)
}
TRUE
}
# Keep in sync with standalone-linked-version.R
.rlang_downstream_howto_reinstall_msg <- function(pkg) {
os <- tolower(Sys.info()[["sysname"]])
if (os == "windows") {
url <- "https://github.com/jennybc/what-they-forgot/issues/62"
c(
i = sprintf("Please update %s to the latest version.", pkg),
i = sprintf("Updating packages on Windows requires precautions:\n <%s>", url)
)
} else {
c(
i = sprintf("Please update %s with `install.packages(\"%s\")` and restart R.", pkg, pkg)
)
}
}
.rlang_downstream_collapse <- function(x, sep = ", ", final = "or") {
n <- length(x)
if (n < 2) {
return(x)
}
n <- length(x)
head <- x[seq_len(n - 1)]
last <- x[length(x)]
head <- paste(head, collapse = sep)
# Write a or b. But a, b, or c.
if (n > 2) {
paste0(head, sep, final, " ", last)
} else {
paste0(head, " ", final, " ", last)
}
}
.rlang_downstream_compat <- function(fn, try_rlang = TRUE) {
# Compats that behave the same independently of rlang's presence
out <- switch(
fn,
is_installed = return(function(pkg) requireNamespace(pkg, quietly = TRUE))
)
# Only use rlang if it is fully loaded (#1482)
if (try_rlang &&
requireNamespace("rlang", quietly = TRUE) &&
environmentIsLocked(asNamespace("rlang"))) {
switch(
fn,
is_interactive = return(rlang::is_interactive)
)
# Make sure rlang knows about "x" and "i" bullets
if (utils::packageVersion("rlang") >= "0.4.2") {
switch(
fn,
abort = return(rlang::abort),
warn = return((rlang::warn)),
inform = return(rlang::inform)
)
}
}
# Fall back to base compats
is_interactive_compat <- function() {
opt <- getOption("rlang_interactive")
if (!is.null(opt)) {
opt
} else {
interactive()
}
}
format_msg <- function(x) paste(x, collapse = "\n")
switch(
fn,
is_interactive = return(is_interactive_compat),
abort = return(function(msg) stop(format_msg(msg), call. = FALSE)),
warn = return(function(msg) warning(format_msg(msg), call. = FALSE)),
inform = return(function(msg) message(format_msg(msg)))
)
stop(sprintf("Internal error in rlang shims: Unknown function `%s()`.", fn))
}
.rlang_downstream_get_cache <- function() {
if (!"org:r-lib" %in% search()) {
do.call(
attach,
list(
list(),
pos = length(search()),
name = "org:r-lib"
)
)
}
cache_env <- as.environment("org:r-lib")
check_cache_name <- "rlang_downstream_check"
cache <- cache_env[[check_cache_name]]
if (is.null(cache)) {
cache <- new.env(parent = emptyenv())
cache_env[[check_cache_name]] <- cache
}
cache
}
#nocov end
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.