Add argument 'map' to withProgressShiny() [#109]

Author: HenrikBengtsson

R/handler_shiny.R

@@ -4,6 +4,12 @@
 #'
 #' @inheritParams make_progression_handler
 #'
+#' @param map Specifies whether the progression message should be mapped
+#' to the 'message' and 'detail' element in the Shiny progress panel.
+#' This argument should be a named character string with value `"message"`
+#' or `"detail"` and where the name should be `message`, e.g.
+#' `map = c(message = "message")` or `map = c(message = "detail")`.
+#'
 #' @param \ldots Additional arguments passed to [make_progression_handler()].
 #'
 #' @examples
@@ -21,12 +27,28 @@
 #'
 #' @keywords internal
 #' @export
-handler_shiny <- function(intrusiveness = getOption("progressr.intrusiveness.gui", 1), target = "gui", ...) {
+handler_shiny <- function(intrusiveness = getOption("progressr.intrusiveness.gui", 1), target = "gui", map = c(message = "message"), ...) {
+  stop_if_not(
+    is.character(map), all(map %in% c("message", "detail")),
+    !is.null(names(map)), all(names(map) %in% c("message"))
+  )
+
+  ## Default: The progression message updates Shiny 'message'
+  map_args <- function(state) list(message = state$message)
+
+  ## Should progress message update another Shiny field?
+  if ("message" %in% names(map)) {
+    if (map["message"] == "detail") {
+     map_args <- function(state) list(detail = state$message)
+    }
+  }
+
   reporter <- local({
     list(
       update = function(config, state, progression, ...) {
         amount <- if (config$max_steps == 0) 1 else progression$amount / config$max_steps
-        shiny::incProgress(amount = amount, message = state$message)
+        args <- c(list(amount = amount), map_args(state))
+        do.call(shiny::incProgress, args = args)
       }
     )
   })

R/withProgressShiny.R

@@ -1,20 +1,46 @@
 #' Use Progressr in Shiny Apps: Plug-in Backward Compatibility 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.
+#' This function requires the \pkg{shiny} package and will use the
+#' [handler_shiny()] **progressr** handler internally to report on updates.
 #'
 #' @export
-withProgressShiny <- function(expr, ..., env = parent.frame(), quoted = FALSE, handlers = c(shiny = handler_shiny, progressr::handlers(default = NULL))) {
+withProgressShiny <- function(expr, ..., message = NULL, detail = NULL, map = c(message = "message"), env = parent.frame(), quoted = FALSE, handlers = c(shiny = handler_shiny, progressr::handlers(default = NULL))) {
   if (!quoted) expr <- substitute(expr)
+
+  stop_if_not("shiny" %in% names(handlers))
+  if (sum(names(handlers) == "shiny") > 1) {
+    warning("Detected a 'shiny' handler set via progressr::handlers()")
+  }
+
+  stop_if_not(
+    is.character(map), all(map %in% c("message", "detail")),
+    !is.null(names(map)), all(names(map) %in% c("message"))
+  )
+
+  ## Customize the shiny 'message' target?
+  if (is.function(handlers$shiny) &&
+      !inherits(handlers$shiny, "progression_handler")) {
+    tweaked_handler_shiny <- handlers$shiny
+    if (!identical(map, formals(tweaked_handler_shiny)$map)) {
+      formals(tweaked_handler_shiny)$map <- map
+      handlers$shiny <- tweaked_handler_shiny
+    }
+  }
+  
   expr <- bquote(progressr::with_progress({.(expr)}, handlers = .(handlers)))
-  res <- withVisible(shiny::withProgress(expr, ..., env = env, quoted = TRUE))
+  res <- withVisible(shiny::withProgress(expr, ..., message = message, detail = detail, env = env, quoted = TRUE))
   if (res$visible) res$value else invisible(res$value)
 }

incl/withProgressShiny.R

@@ -10,11 +10,13 @@ app <- shinyApp(
     output$plot <- renderPlot({
       X <- 1:15
       withProgressShiny(message = "Calculation in progress",
-                        detail = "This may take a while ...", value = 0, {
+                        detail = "Starting ...",
+                        map = c(message = "detail"),
+                        value = 0, {
         p <- progressor(along = X)
         y <- lapply(X, FUN=function(x) {
           Sys.sleep(0.25)
-          p()
+          p(sprintf("x=%d", x))
         })
       })