tryCatch <- function(expr, ..., finally) {
base::tryCatch(
withCallingHandlers(
expr,
error = function(e) {
promiseDomain$onError(e)
}
),
...,
finally = finally
)
}
spliceOnFinally <- function(onFinally) {
list(
onFulfilled = finallyToFulfilled(onFinally),
onRejected = finallyToRejected(onFinally)
)
}
finallyToFulfilled <- function(onFinally) {
force(onFinally)
function(value, .visible) {
onFinally()
if (.visible)
value
else
invisible(value)
}
}
finallyToRejected <- function(onFinally) {
force(onFinally)
function(reason) {
onFinally()
stop(reason)
}
}
promiseDomain <- list(
onThen = function(onFulfilled, onRejected, onFinally) {
force(onFulfilled)
force(onRejected)
force(onFinally)
# Verify that if onFinally is non-NULL, onFulfilled and onRejected are NULL
if (!is.null(onFinally) && (!is.null(onFulfilled) || !is.null(onRejected))) {
stop("A single `then` call cannot combine `onFinally` with `onFulfilled`/`onRejected`")
}
# TODO: All wrapped functions should also be rewritten to reenter the domain
# jcheng 2019-07-26: Actually, this seems not to be necessary--the domain
# is getting reentered during callbacks. But I can't figure out now how it's
# happening.
domain <- current_promise_domain()
shouldWrapFinally <- !is.null(onFinally) && !is.null(domain) && !is.null(domain$wrapOnFinally)
newOnFinally <- if (shouldWrapFinally) {
domain$wrapOnFinally(onFinally)
} else {
onFinally
}
if (!is.null(newOnFinally)) {
spliced <- spliceOnFinally(newOnFinally)
onFulfilled <- spliced$onFulfilled
onRejected <- spliced$onRejected
}
shouldWrapFulfilled <- !is.null(onFulfilled) && !is.null(domain) && !shouldWrapFinally
shouldWrapRejected <- !is.null(onRejected) && !is.null(domain) && !shouldWrapFinally
results <- list(
onFulfilled = if (shouldWrapFulfilled) domain$wrapOnFulfilled(onFulfilled) else onFulfilled,
onRejected = if (shouldWrapRejected) domain$wrapOnRejected(onRejected) else onRejected
)
results[!vapply(results, is.null, logical(1))]
},
onError = function(error) {
domain <- current_promise_domain()
if (is.null(domain))
return()
domain$onError(error)
}
)
globals <- new.env(parent = emptyenv())
current_promise_domain <- function() {
globals$domain
}
#' Promise domains
#'
#' Promise domains are used to temporarily set up custom environments that
#' intercept and influence the registration of callbacks. Create new promise
#' domain objects using `new_promise_domain`, and temporarily activate a promise
#' domain object (for the duration of evaluating a given expression) using
#' `with_promise_domain`.
#'
#' While `with_promise_domain` is on the call stack, any calls to [then()] (or
#' higher level functions or operators, like [catch()] or the various [pipes])
#' will belong to the promise domain. In addition, when a `then` callback that
#' belongs to a promise domain is invoked, then any new calls to `then` will
#' also belong to that promise domain. In other words, a promise domain
#' "infects" not only the immediate calls to `then`, but also to "nested" calls
#' to `then`.
#'
#' For more background, read the
#' [original design doc](https://gist.github.com/jcheng5/b1c87bb416f6153643cd0470ac756231).
#'
#' For examples, see the source code of the Shiny package, which uses promise
#' domains extensively to manage graphics devices and reactivity.
#'
#' @param domain A promise domain object to install while `expr` is evaluated.
#' @param expr Any R expression, to be evaluated under the influence of
#' `domain`.
#' @param replace If `FALSE`, then the effect of the `domain` will be added
#' to the effect of any currently active promise domain(s). If `TRUE`, then
#' the current promise domain(s) will be ignored for the duration of the
#' `with_promise_domain` call.
#'
#' @export
with_promise_domain <- function(domain, expr, replace = FALSE) {
oldval <- current_promise_domain()
if (replace)
globals$domain <- domain
else
globals$domain <- compose_domains(oldval, domain)
on.exit(globals$domain <- oldval)
if (!is.null(domain))
domain$wrapSync(expr)
else
force(expr)
}
# Like with_promise_domain, but doesn't include the wrapSync call.
reenter_promise_domain <- function(domain, expr, replace = FALSE) {
oldval <- current_promise_domain()
if (replace)
globals$domain <- domain
else
globals$domain <- compose_domains(oldval, domain)
on.exit(globals$domain <- oldval)
force(expr)
}
#' @param wrapOnFulfilled A function that takes a single argument: a function
#' that was passed as an `onFulfilled` argument to [then()]. The
#' `wrapOnFulfilled` function should return a function that is suitable for
#' `onFulfilled` duty.
#' @param wrapOnRejected A function that takes a single argument: a function
#' that was passed as an `onRejected` argument to [then()]. The
#' `wrapOnRejected` function should return a function that is suitable for
#' `onRejected` duty.
#' @param wrapSync A function that takes a single argument: a (lazily evaluated)
#' expression that the function should [force()]. This expression represents
#' the `expr` argument passed to [with_promise_domain()]; `wrapSync` allows
#' the domain to manipulate the environment before/after `expr` is evaluated.
#' @param onError A function that takes a single argument: an error. `onError`
#' will be called whenever an exception occurs in a domain (that isn't caught
#' by a `tryCatch`). Providing an `onError` callback doesn't cause errors to
#' be caught, necessarily; instead, `onError` callbacks behave like calling
#' handlers.
#' @param ... Arbitrary named values that will become elements of the promise
#' domain object, and can be accessed as items in an environment (i.e. using
#' `[[` or `$`).
#' @param wrapOnFinally A function that takes a single argument: a function
#' that was passed as an `onFinally` argument to [then()]. The
#' `wrapOnFinally` function should return a function that is suitable for
#' `onFinally` duty. If `wrapOnFinally` is `NULL` (the default), then the
#' domain will use both `wrapOnFulfilled` and `wrapOnRejected` to wrap the
#' `onFinally`. If it's important to distinguish between normal
#' fulfillment/rejection handlers and finally handlers, then be sure to
#' provide `wrapOnFinally`, even if it's just [base::identity()].
#' @rdname with_promise_domain
#' @export
new_promise_domain <- function(
wrapOnFulfilled = identity,
wrapOnRejected = identity,
wrapSync = force,
onError = force,
...,
wrapOnFinally = NULL
) {
list2env(list(
wrapOnFulfilled = wrapOnFulfilled,
wrapOnRejected = wrapOnRejected,
wrapOnFinally = wrapOnFinally,
wrapSync = wrapSync,
onError = onError,
...
), parent = emptyenv())
}
compose_domains <- function(base, new) {
if (is.null(base)) {
return(new)
}
list(
wrapOnFulfilled = function(onFulfilled) {
# Force eager evaluation of base$wrapOnFulfilled(onFulfilled)
base <- base$wrapOnFulfilled(onFulfilled)
new$wrapOnFulfilled(base)
},
wrapOnRejected = function(onRejected) {
# Force eager evaluation of base$wrapOnRejected(onRejected)
base <- base$wrapOnRejected(onRejected)
new$wrapOnRejected(base)
},
# Only include the new wrapSync, assuming that we've already applied the
# base domain's wrapSync. This assumption won't hold if we either export
# compose_domains in the future, or if we use it in cases where the base
# domain isn't currently active.
wrapSync = new$wrapSync,
onError = function(e) {
base$onError(e)
new$onError(e)
}
)
}
without_promise_domain <- function(expr) {
with_promise_domain(NULL, expr, replace = TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.