Nothing
# NOTE: patched to use `cli_error()`
# nocov start --- compat-defer ---
#
# This drop-in file implements withr::defer(). Please find the most
# recent version in withr's repository.
#
# 2022-03-03
# * Support for `source()` and `knitr::knit()`
# * Handlers are now stored in environments instead of lists to avoid
# infinite recursion issues.
# * The handler list is now soft-namespaced.
defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) { }
local({
defer <<- defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) {
priority <- match.arg(priority)
invisible(
add_handler(
envir,
handler = new_handler(substitute(expr), parent.frame()),
front = priority == "first"
)
)
}
new_handler <- function(expr, envir) {
hnd <- new.env(FALSE, size = 2)
hnd[["expr"]] <- expr
hnd[["envir"]] <- envir
hnd
}
add_handler <- function(envir,
handler,
front,
frames = as.list(sys.frames()),
calls = as.list(sys.calls())) {
envir <- exit_frame(envir, frames, calls)
if (front) {
handlers <- c(list(handler), get_handlers(envir))
} else {
handlers <- c(get_handlers(envir), list(handler))
}
set_handlers(envir, handlers, frames = frames, calls = calls)
handler
}
set_handlers <- function(envir, handlers, frames, calls) {
if (is.null(get_handlers(envir))) {
# Ensure that list of handlers called when environment "ends"
setup_handlers(envir)
}
attr(envir, "withr_handlers") <- handlers
}
# Evaluate `frames` lazily
setup_handlers <- function(envir,
frames = as.list(sys.frames()),
calls = as.list(sys.calls())) {
if (is_top_level_global_env(envir, frames)) {
# For session scopes we use reg.finalizer()
if (is_interactive()) {
message(
sprintf("Setting global deferred event(s).\n"),
"i These will be run:\n",
" * Automatically, when the R session ends.\n",
" * On demand, if you call `withr::deferred_run()`.\n",
"i Use `withr::deferred_clear()` to clear them without executing."
)
}
reg.finalizer(envir, function(env) deferred_run(env), onexit = TRUE)
} else {
# for everything else we use on.exit()
call <- make_call(execute_handlers, envir)
# We have to use do.call here instead of eval because of the way on.exit
# determines its evaluation context
# (https://stat.ethz.ch/pipermail/r-devel/2013-November/067867.html)
do.call(base::on.exit, list(call, TRUE), envir = envir)
}
}
exit_frame <- function(envir,
frames = as.list(sys.frames()),
calls = as.list(sys.calls())) {
frame_loc <- frame_loc(envir, frames)
if (!frame_loc) {
return(envir)
}
if (in_knitr(envir)) {
out <- knitr_frame(envir, frames, calls, frame_loc)
if (!is.null(out)) {
return(out)
}
}
out <- source_frame(envir, frames, calls, frame_loc)
if (!is.null(out)) {
return(out)
}
envir
}
knitr_frame <- function(envir, frames, calls, frame_loc) {
knitr_ns <- asNamespace("knitr")
# This doesn't handle correctly the recursive case (knitr called
# within a chunk). Handling this would be a little fiddly for an
# uncommon edge case.
for (i in seq(1, frame_loc)) {
if (identical(topenv(frames[[i]]), knitr_ns)) {
return(frames[[i]])
}
}
NULL
}
source_frame <- function(envir, frames, calls, frame_loc) {
i <- frame_loc
if (i < 4) {
return(NULL)
}
is_call <- function(x, fn) {
is.call(x) && identical(x[[1]], fn)
}
calls <- as.list(calls)
if (!is_call(calls[[i - 3]], quote(source))) {
return(NULL)
}
if (!is_call(calls[[i - 2]], quote(withVisible))) {
return(NULL)
}
if (!is_call(calls[[i - 1]], quote(eval))) {
return(NULL)
}
if (!is_call(calls[[i - 0]], quote(eval))) {
return(NULL)
}
frames[[i - 3]]
}
frame_loc <- function(envir, frames) {
n <- length(frames)
if (!n) {
return(0)
}
for (i in seq_along(frames)) {
if (identical(frames[[n - i + 1]], envir)) {
return(n - i + 1)
}
}
0
}
in_knitr <- function(envir) {
knitr_in_progress() && identical(knitr::knit_global(), envir)
}
is_top_level_global_env <- function(envir, frames) {
if (!identical(envir, globalenv())) {
return(FALSE)
}
# Check if another global environment is on the stack
!any(vapply(frames, identical, NA, globalenv()))
}
get_handlers <- function(envir) {
attr(envir, "withr_handlers")
}
execute_handlers <- function(envir) {
handlers <- get_handlers(envir)
errors <- list()
for (handler in handlers) {
tryCatch(eval(handler$expr, handler$envir),
error = function(e) {
errors[[length(errors) + 1]] <<- e
}
)
}
attr(envir, "withr_handlers") <- NULL
for (error in errors) {
stop(error) %??%
cli_error("Error in a deferred {.code on.exit()} clause")
}
}
make_call <- function(...) {
as.call(list(...))
}
# base implementation of rlang::is_interactive()
is_interactive <- function() {
opt <- getOption("rlang_interactive")
if (!is.null(opt)) {
return(opt)
}
if (knitr_in_progress()) {
return(FALSE)
}
if (identical(Sys.getenv("TESTTHAT"), "true")) {
return(FALSE)
}
interactive()
}
knitr_in_progress <- function() {
isTRUE(getOption("knitr.in.progress"))
}
}) # defer() namespace
# 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.