mirror of
https://github.com/rstudio/shiny.git
synced 2026-02-04 11:44:59 -05:00
223 lines
7.7 KiB
R
223 lines
7.7 KiB
R
#' Reporting progress (object-oriented API)
|
|
#'
|
|
#' Reports progress to the user during long-running operations.
|
|
#'
|
|
#' This package exposes two distinct programming APIs for working with
|
|
#' progress. \code{\link{withProgress}} and \code{\link{setProgress}}
|
|
#' together provide a simple function-based interface, while the
|
|
#' \code{Progress} reference class provides an object-oriented API.
|
|
#'
|
|
#' Instantiating a \code{Progress} object causes a progress panel to be
|
|
#' created, and it will be displayed the first time the \code{set}
|
|
#' method is called. Calling \code{close} will cause the progress panel
|
|
#' to be removed.
|
|
#'
|
|
#' \strong{Methods}
|
|
#' \describe{
|
|
#' \item{\code{initialize(session, min = 0, max = 1)}}{
|
|
#' Creates a new progress panel (but does not display it).
|
|
#' }
|
|
#' \item{\code{set(message = NULL, detail = NULL, value = NULL)}}{
|
|
#' Updates the progress panel. When called the first time, the
|
|
#' progress panel is displayed.
|
|
#' }
|
|
#' \item{\code{close()}}{
|
|
#' Removes the progress panel. Future calls to \code{set} and
|
|
#' \code{close} will be ignored.
|
|
#' }
|
|
#' }
|
|
#'
|
|
#' @param session The Shiny session object, as provided by
|
|
#' \code{shinyServer} to the server function.
|
|
#' @param min The value that represents the starting point of the
|
|
#' progress bar. Must be less tham \code{max}.
|
|
#' @param max The value that represents the end of the progress bar.
|
|
#' Must be greater than \code{min}.
|
|
#' @param message A single-element character vector; the message to be
|
|
#' displayed to the user, or \code{NULL} to hide the current message
|
|
#' (if any).
|
|
#' @param detail A single-element character vector; the detail message
|
|
#' to be displayed to the user, or \code{NULL} to hide the current
|
|
#' detail message (if any). The detail message will be shown with a
|
|
#' de-emphasized appearance relative to \code{message}.
|
|
#' @param value Single-element numeric vector; the value at which to set
|
|
#' the progress bar, relative to \code{min} and \code{max}.
|
|
#' \code{NULL} hides the progress bar, if it is currently visible.
|
|
#'
|
|
#' @examples
|
|
#' \dontrun{
|
|
#' # server.R
|
|
#' shinyServer(function(input, output, session) {
|
|
#' output$plot <- renderPlot({
|
|
#' progress <- Progress$new(session, min=1, max=15)
|
|
#' on.exit(progress$close())
|
|
#'
|
|
#' progress$set(message = 'Calculation in progress',
|
|
#' detail = 'This may take a while...')
|
|
#'
|
|
#' for (i in 1:15) {
|
|
#' progress$set(value = i)
|
|
#' Sys.sleep(0.5)
|
|
#' }
|
|
#' plot(cars)
|
|
#' })
|
|
#' })
|
|
#' }
|
|
#' @seealso \code{\link{progressInit}}, \code{\link{withProgress}}
|
|
#' @rdname Progress
|
|
#' @export
|
|
Progress <- setRefClass(
|
|
'Progress',
|
|
fields = list(
|
|
.session = 'environment',
|
|
.id = 'character',
|
|
.min = 'numeric',
|
|
.max = 'numeric',
|
|
.closed = 'logical'
|
|
),
|
|
methods = list(
|
|
initialize = function(session = getDefaultReactiveDomain(), min = 0, max = 1) {
|
|
# A hacky check to make sure the session object is indeed a session object.
|
|
if (is.null(session$onFlush)) stop("'session' is not a session object.")
|
|
|
|
.closed <<- FALSE
|
|
.session <<- session
|
|
.id <<- paste(as.character(as.raw(runif(8, min=0, max=255))), collapse='')
|
|
.min <<- min
|
|
.max <<- max
|
|
|
|
.session$sendCustomMessage('shiny-progress-open', list(id = .id))
|
|
},
|
|
set = function(message = NULL, detail = NULL, value = NULL) {
|
|
if (.closed) {
|
|
# TODO: Warn?
|
|
return()
|
|
}
|
|
|
|
data <- list(id = .id)
|
|
if (!missing(message))
|
|
data$message <- message
|
|
if (!missing(detail))
|
|
data$detail <- detail
|
|
if (!missing(value)) {
|
|
if (is.null(value) || is.na(value))
|
|
data$value <- NULL
|
|
else {
|
|
data$value <- min(1, max(0, (value - .min) / (.max - .min)))
|
|
}
|
|
}
|
|
|
|
.session$sendCustomMessage('shiny-progress-update', data)
|
|
},
|
|
close = function() {
|
|
if (.closed) {
|
|
# TODO: Warn?
|
|
return()
|
|
}
|
|
|
|
.session$sendCustomMessage('shiny-progress-close', list(id = .id))
|
|
}
|
|
)
|
|
)
|
|
|
|
.currentProgress <- new.env()
|
|
|
|
#' Reporting progress (functional API)
|
|
#'
|
|
#' Reports progress to the user during long-running operations.
|
|
#'
|
|
#' This package exposes two distinct programming APIs for working with
|
|
#' progress. \code{withProgress} and \code{setProgress} together provide
|
|
#' a simple function-based interface, while the \code{\link{Progress}}
|
|
#' reference class provides an object-oriented API.
|
|
#'
|
|
#' Use \code{withProgress} to wrap the scope of your work; doing so will
|
|
#' cause a new progress panel to be created, and it will be displayed the
|
|
#' first time \code{setProgress} is called. When \code{withProgress} exits,
|
|
#' the corresponding progress panel will be removed.
|
|
#'
|
|
#' Generally, \code{withProgress}/\code{setProgress} should be
|
|
#' sufficient; the exception is if the work to be done is asynchronous
|
|
#' (this is not common) or otherwise cannot be encapsulated by a single
|
|
#' scope. In that case, you can use the \code{Progress} reference class.
|
|
#'
|
|
#' @param session The Shiny session object, as provided by
|
|
#' \code{shinyServer} to the server function.
|
|
#' @param expr The work to be done. This expression should contain calls
|
|
#' to \code{setProgress}.
|
|
#' @param min The value that represents the starting point of the
|
|
#' progress bar. Must be less tham \code{max}.
|
|
#' @param max The value that represents the end of the progress bar.
|
|
#' Must be greater than \code{min}.
|
|
#' @param env The environment in which \code{expr} should be evaluated.
|
|
#' @param quoted Whether \code{expr} is a quoted expression (this is not
|
|
#' common).
|
|
#' @param message A single-element character vector; the message to be
|
|
#' displayed to the user, or \code{NULL} to hide the current message
|
|
#' (if any).
|
|
#' @param detail A single-element character vector; the detail message
|
|
#' to be displayed to the user, or \code{NULL} to hide the current
|
|
#' detail message (if any). The detail message will be shown with a
|
|
#' de-emphasized appearance relative to \code{message}.
|
|
#' @param value Single-element numeric vector; the value at which to set
|
|
#' the progress bar, relative to \code{min} and \code{max}.
|
|
#' \code{NULL} hides the progress bar, if it is currently visible.
|
|
#'
|
|
#' @examples
|
|
#' \dontrun{
|
|
#' # server.R
|
|
#' shinyServer(function(input, output, session) {
|
|
#' output$plot <- renderPlot({
|
|
#' withProgress(session, min=1, max=15, {
|
|
#' setProgress(message = 'Calculation in progress',
|
|
#' detail = 'This may take a while...')
|
|
#' for (i in 1:15) {
|
|
#' setProgress(value = i)
|
|
#' Sys.sleep(0.5)
|
|
#' }
|
|
#' })
|
|
#' plot(cars)
|
|
#' })
|
|
#' })
|
|
#' }
|
|
#' @seealso \code{\link{progressInit}}, \code{\link{Progress}}
|
|
#' @rdname withProgress
|
|
#' @export
|
|
withProgress <- function(session = getDefaultReactiveDomain(), expr,
|
|
min = 0, max = 1, env=parent.frame(), quoted=FALSE) {
|
|
|
|
# A hacky check to make sure the session object is indeed a session object.
|
|
if (is.null(session$onFlush)) stop("'session' is not a session object.")
|
|
|
|
func <- exprToFunction(expr, env, quoted)
|
|
|
|
p <- Progress$new(session, min = min, max = max)
|
|
|
|
.currentProgress$stack <- c(p, .currentProgress$stack)
|
|
on.exit({
|
|
.currentProgress$stack <- .currentProgress$stack[-1]
|
|
p$close()
|
|
})
|
|
|
|
return(func())
|
|
}
|
|
|
|
#' @rdname withProgress
|
|
#' @export
|
|
setProgress <- function(message = NULL, detail = NULL, value = NULL) {
|
|
if (is.null(.currentProgress$stack) || length(.currentProgress$stack) == 0) {
|
|
warning('setProgress was called outside of withProgress; ignoring')
|
|
return()
|
|
}
|
|
|
|
args <- list()
|
|
if (!missing(message))
|
|
args$message <- message
|
|
if (!missing(detail))
|
|
args$detail <- detail
|
|
if (!missing(value))
|
|
args$value <- value
|
|
do.call(.currentProgress$stack[[1]]$set, args)
|
|
invisible()
|
|
}
|