#' Create a Progressor Function that Signals Progress Updates
#'
#' @inheritParams progression
#'
#' @param steps (integer) Number of progressing steps.
#'
#' @param along (vector; alternative) Alternative that sets
#' `steps = length(along)`.
#'
#' @param offset,scale (integer; optional) scale and offset applying transform
#' `steps <- scale * steps + offset`.
#'
#' @param transform (function; optional) A function that takes the effective
#' number of `steps` as input and returns another finite and non-negative
#' number of steps.
#'
#' @param label (character) A label.
#'
#' @param trace (logical) If TRUE, then the call stack is recorded, otherwise
#' not.
#'
#' @param initiate (logical) If TRUE, the progressor will signal a
#' [progression] 'initiate' condition when created.
#'
#' @param auto_finish (logical) If TRUE, then the progressor will signal a
#' [progression] 'finish' condition as soon as the last step has been reached.
#'
#' @param enable (logical) If TRUE, [progression] conditions are signaled when
#' calling the progressor function created by this function.
#' If FALSE, no [progression] conditions is signaled because the progressor
#' function is an empty function that does nothing.
#'
#' @param on_exit,envir (logical) If TRUE, then the created progressor will
#' signal a [progression] 'finish' condition when the calling frame exits.
#' This is ignored if the calling frame (`envir`) is the global environment.
#'
#' @return A function of class `progressor`.
#'
#' @details
#' A `progressor` function can only be created inside a local environment,
#' e.g. inside a function, within a `local()` call, or within a
#' `with_progress()` call. Notably, it _cannot_ be create at the top level,
#' e.g. immediately at the R prompt or outside a local environment in an
#' R script. If attempted, an informative error message is produced, e.g.
#'
#' ```r
#' > p <- progressr::progressor(100)
#' Error in progressr::progressor(100) :
#' A progressor must not be created in the global environment unless
#' wrapped in a with_progress() or without_progress() call. Alternatively,
#' create it inside a function or in a local() environment to make sure
#' there is a finite life span of the progressor
#' ```
#'
#' @export
progressor <- local({
progressor_count <- 0L
void_progressor <- function(...) NULL
environment(void_progressor)$enable <- FALSE
class(void_progressor) <- c("progressor", class(void_progressor))
function(steps = length(along), along = NULL, offset = 0L, scale = 1L, transform = function(steps) scale * steps + offset, message = character(0L), label = NA_character_, trace = FALSE, initiate = TRUE, auto_finish = TRUE, on_exit = !identical(envir, globalenv()), enable = getOption("progressr.enable", TRUE), envir = parent.frame()) {
stop_if_not(is.logical(enable), length(enable) == 1L, !is.na(enable))
## Quickly return a moot progressor function?
if (!enable) return(void_progressor)
stop_if_not(!is.null(steps) || !is.null(along))
stop_if_not(length(steps) == 1L, is.numeric(steps), !is.na(steps),
steps >= 0)
stop_if_not(length(offset) == 1L, is.numeric(offset), !is.na(offset))
stop_if_not(length(scale) == 1L, is.numeric(scale), !is.na(scale))
stop_if_not(is.function(transform))
label <- as.character(label)
stop_if_not(length(label) == 1L)
steps <- transform(steps)
stop_if_not(length(steps) == 1L, is.numeric(steps), !is.na(steps),
steps >= 0)
stop_if_not(is.logical(on_exit), length(on_exit) == 1L, !is.na(on_exit))
if (identical(envir, globalenv())) {
if (!progressr_in_globalenv()) {
stop("A progressor must not be created in the global environment unless wrapped in a with_progress() or without_progress() call. Alternatively, create it inside a function or in a local() environment to make sure there is a finite life span of the progressor")
}
if (on_exit) {
stop("It is not possible to create a progressor in the global environment with on_exit = TRUE")
}
}
owner_session_uuid <- session_uuid(attributes = TRUE)
progressor_count <<- progressor_count + 1L
progressor_uuid <- progressor_uuid(progressor_count)
progression_index <- 0L
fcn <- function(message = character(0L), ..., type = "update") {
progression_index <<- progression_index + 1L
cond <- progression(
type = type,
message = message,
...,
progressor_uuid = progressor_uuid,
progression_index = progression_index,
owner_session_uuid = owner_session_uuid,
call = if (trace) sys.call() else NULL,
calls = if (trace) sys.calls() else NULL
)
withRestarts(
signalCondition(cond),
muffleProgression = function(p) NULL
)
invisible(cond)
}
formals(fcn)$message <- message
class(fcn) <- c("progressor", class(fcn))
## WORKAROUND: Use teeny, custom enviroment for the progressor function.
## The default would otherwise be to inherit the parent frame, which
## might contain very large objects.
progressor_envir <- new.env(parent = getNamespace(.packageName))
for (name in c("progression_index", "progressor_uuid",
"owner_session_uuid", "progressor_count",
"enable", "initiate", "auto_finish", "trace",
"steps", "label", "offset", "scale")) {
progressor_envir[[name]] <- get(name)
}
environment(fcn) <- progressor_envir
## Is there already be an active '...progressr'?
## If so, make sure it is finished and then remove it
if (exists("...progressor", mode = "function", envir = envir)) {
...progressor <- get("...progressor", mode = "function", envir = envir)
## Ideally, we produce a warning or an error here if the existing
## progressor is not finished. Currently, we don't have a way to
## query that, so we leave that for the future. /HB 2021-02-28
## Finish it (although it might already have been done via auto-finish)
...progressor(type = "finish")
## Remove it (while avoiding false 'R CMD check' NOTE)
do.call(unlockBinding, args = list("...progressor", env = envir))
rm("...progressor", envir = envir)
}
## Initiate?
if (initiate) {
fcn(
type = "initiate",
steps = steps,
auto_finish = auto_finish
)
}
## Add on.exit(...progressor(type = "finish"))?
if (on_exit) {
assign("...progressor", value = fcn, envir = envir)
lockBinding("...progressor", env = envir)
call <- call("...progressor", type = "finish")
do.call(base::on.exit, args = list(call, add = TRUE), envir = envir)
}
fcn
}
})
#' @importFrom utils object.size
#' @export
print.progressor <- function(x, ...) {
s <- sprintf("%s:", class(x)[1])
e <- environment(x)
pe <- parent.env(e)
s <- c(s, paste("- label:", e$label))
s <- c(s, paste("- steps:", e$steps))
s <- c(s, paste("- initiate:", e$initiate))
s <- c(s, paste("- auto_finish:", e$auto_finish))
if (is.function(e$message)) {
message <- "<a function>"
} else {
message <- hpaste(deparse(e$message))
}
s <- c(s, paste("- default message:", message))
call <- vapply(e$calls, FUN = function(call) deparse(call[1]), FUN.VALUE = "")
stack <- if (e$trace) paste(call, collapse = " -> ") else "<disabled>"
s <- c(s, paste("- call stack:", stack))
s <- c(s, paste("- progressor_uuid:", e$progressor_uuid))
s <- c(s, paste("- progressor_count:", pe$progressor_count))
s <- c(s, paste("- progression_index:", e$progression_index))
owner_session_uuid <- e$owner_session_uuid
s <- c(s, paste("- owner_session_uuid:", owner_session_uuid))
s <- c(s, paste("- enable:", e$enable))
size <- object.size(x)
size2 <- serialization_size(x)
s <- c(s, sprintf("- size: %s [%s serialized]", format(size, units = "auto", standard = "SI"), format(size2, units = "auto", standard = "SI")))
s <- paste(s, collapse = "\n")
cat(s, "\n", sep = "")
invisible(x)
}
progressr_in_globalenv <- local({
state <- FALSE
function(action = c("query", "allow", "disallow")) {
action <- match.arg(action)
if (action == "query") return(state)
old_state <- state
state <<- switch(action, allow = TRUE, disallow = FALSE)
invisible(old_state)
}
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.