1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
#' Use Progressr in Shiny Apps: Plug-in Backward-Compatible Replacement for shiny::withProgress()
#'
#' A plug-in, backward-compatible replacement for [shiny::withProgress()].
#'
#' @inheritParams handler_shiny
#'
#' @param expr,\ldots,env,quoted Arguments passed to [shiny::withProgress()] as is.
#'
#' @param message,detail (character string) The message and the detail message to be passed to [shiny::withProgress()].
#'
#' @param handlers Zero or more progression handlers used to report on progress.
#'
#' @return The value of [shiny::withProgress].
#'
#' @example incl/withProgressShiny.R
#'
#' @section Requirements:
#' This function requires the \pkg{shiny} package and will use the
#' [handler_shiny()] **progressr** handler internally to report on updates.
#'
#' @export
withProgressShiny <- function(expr, ..., message = NULL, detail = NULL, inputs = list(message = NULL, detail = "message"), env = parent.frame(), quoted = FALSE, handlers = c(shiny = handler_shiny, progressr::handlers(default = NULL))) {
if (!quoted) expr <- substitute(expr)
stop_if_not(is.list(inputs), all(names(inputs) %in% c("message", "detail")))
stop_if_not("shiny" %in% names(handlers))
if (sum(names(handlers) == "shiny") > 1) {
warning("Detected a 'shiny' handler set via progressr::handlers()")
}
## Optional, configure 'inputs' from attribute 'input' of arguments
## 'message' and 'detail', if and only if that attribute is available.
args <- list(message = message, detail = detail)
for (name in names(args)) {
input <- unique(attr(args[[name]], "input"))
if (is.null(input)) next
unknown <- setdiff(input, c("message", "sticky_message", "non_sticky_message"))
if (length(unknown) > 0) {
stop(sprintf("Unknown value of attribute %s on argument %s: %s",
sQuote("input"), sQuote(name), commaq(unknown)))
}
inputs[[name]] <- input
}
stop_if_not(
is.list(inputs),
!is.null(names(inputs)),
all(names(inputs) %in% c("message", "detail")),
all(vapply(inputs, FUN = function(x) {
if (is.null(x)) return(TRUE)
if (!is.character(x)) return(FALSE)
x %in% c("message", "non_sticky_message", "sticky_message")
}, FUN.VALUE = FALSE))
)
## Customize the shiny 'message' target?
if (is.function(handlers$shiny) &&
!inherits(handlers$shiny, "progression_handler")) {
tweaked_handler_shiny <- handlers$shiny
if (!identical(inputs, formals(tweaked_handler_shiny)$inputs)) {
formals(tweaked_handler_shiny)$inputs <- inputs
handlers$shiny <- tweaked_handler_shiny
}
}
expr <- bquote(progressr::with_progress({.(expr)}, handlers = .(handlers)))
res <- withVisible(shiny::withProgress(expr, ..., message = message, detail = detail, env = env, quoted = TRUE))
if (res$visible) res$value else invisible(res$value)
}
|
