Supported inputs: "non_sticky_message", "sticky_message", and "message"

The latter is an alias for the former two [#109]

Author: HenrikBengtsson

NEWS

@@ -1,7 +1,7 @@
 Package: progressr
 ==================
 
-Version: 0.7.0-9001 [2021-05-16]
+Version: 0.7.0-9001 [2021-05-20]
 
 SIGNIFICANT CHANGES:
 
@@ -16,13 +16,19 @@ SIGNIFICANT CHANGES:
    them when the package is loaded, it decrease the overhead in functions,
    and it clarifies that options can be changed at runtime whereas environment
    variables should only be set at startup.
+
+ * When using withProgressShiny(), progression messages now updates the
+   'detail' component of the Shiny progress panel.  Previously, it updated
+   the 'message' component. This can be configured via new 'inputs' argument.
 
 NEW FEATURES:
 
- * withProgressShiny() gained argument 'map', which can be used to control
-   whether the progression message should update the Shiny 'message' or the
-   Shiny 'detail' component in the Shiny progress panel, e.g.
-   map = c(message = "message") or map = c(message = "detail").
+ * withProgressShiny() gained argument 'inputs', which can be used to control
+   whether or not Shiny progress components 'message' and 'detail' should be
+   updated based on the progression message, e.g.
+   inputs = list(message = "sticky_message", detail = "message") will cause
+   progression messages to update the 'detail' component and sticky ones
+   to update both.
 
  * Now supporting zero-length progressors, e.g. p <- progressor(along = x)
    where length(x) == 0.
@@ -35,7 +41,7 @@ BETA FEATURES:
  * As an alternative to specifying the relative amount of progress, say, 
    p(amount = 2), it is now possible to also specify the absolute amount of
    progress made this far, e.g. p(step = 42).  Argument 'amount' has not
-   effect when argument 'step' is specfied.  WARNING: Argument 'step' should
+   effect when argument 'step' is specified.  WARNING: Argument 'step' should
    only be used when in full control of the order when this progression
    condition is signaled.  For example, it must not be signaled as one of many
    parallel progress updates signaled concurrently, because we cannot guarantee

R/handler_shiny.R

@@ -4,11 +4,13 @@
 #'
 #' @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 inputs (named list) Specifies from what sources the Shiny progress
+#' elements 'message' and 'detail' should be updated.  Valid sources are
+#' `"message"`, `"sticky_message"` and `"non_sticky_message"`, where
+#' `"message"` is short for `c("non_sticky_message", "sticky_message")`. For
+#' example, `inputs = list(message = "sticky-message", detail = "message")`
+#' will update the Shiny 'message' component from sticky messages only,
+#' whereas the 'detail' component is updated using any message.
 #'
 #' @param \ldots Additional arguments passed to [make_progression_handler()].
 #'
@@ -27,36 +29,46 @@
 #'
 #' @keywords internal
 #' @export
-handler_shiny <- function(intrusiveness = getOption("progressr.intrusiveness.gui", 1), target = "gui", map = c(message = "message"), ...) {
+handler_shiny <- function(intrusiveness = getOption("progressr.intrusiveness.gui", 1), target = "gui", inputs = list(message = NULL, detail = "message"), ...) {
   stop_if_not(
-    is.character(map), all(map %in% c("message", "detail")),
-    !is.null(names(map)), all(names(map) %in% c("message"))
+    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))
   )
 
+  ## Expand 'message' => c("non_sticky_message", "sticky_message")
+  for (name in names(inputs)) {
+    input <- inputs[[name]]
+    if ("message" %in% input) {
+      input <- setdiff(input, "message")
+      input <- c(input, "non_sticky_message", "sticky_message")
+    }
+    inputs[[name]] <- unique(input)
+  }
+  
   ## Default: The progression message updates Shiny 'message'
   map_args <- function(state, progression) {
-    message <- state$message
+    message <- progression$message
     if (is.null(message)) return(list())
-    if (inherits(progression, "sticky")) {
-      list(detail = message)
-    } else {
-      list(message = message)
-    }
-  }
 
-  ## Should progress message update another Shiny field?
-  if ("message" %in% names(map)) {
-    if (map["message"] == "detail") {
-     map_args <- function(state, progression) {
-       message <- state$message
-       if (is.null(message)) return(list())
-       if (inherits(progression, "sticky")) {
-         list(message = message)
-       } else {
-         list(detail = message)
-       }
-     }
+    ## Update Shiny 'message' and 'detail'?
+    args <- list()
+    for (target in c("message", "detail")) {
+      if (inherits(progression, "sticky")) {
+        if ("sticky_message" %in% inputs[[target]])
+          args[[target]] <- message
+      } else {
+        if ("non_sticky_message" %in% inputs[[target]])
+          args[[target]] <- message
+      }
     }
+
+    args
   }
 
   reporter <- local({

R/withProgressShiny.R

@@ -17,25 +17,47 @@
 #' [handler_shiny()] **progressr** handler internally to report on updates.
 #'
 #' @export
-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))) {
+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.character(map), all(map %in% c("message", "detail")),
-    !is.null(names(map)), all(names(map) %in% c("message"))
+    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(map, formals(tweaked_handler_shiny)$map)) {
-      formals(tweaked_handler_shiny)$map <- map
+    if (!identical(inputs, formals(tweaked_handler_shiny)$inputs)) {
+      formals(tweaked_handler_shiny)$inputs <- inputs
       handlers$shiny <- tweaked_handler_shiny
     }
   }

incl/withProgressShiny.R

@@ -11,7 +11,6 @@ app <- shinyApp(
       X <- 1:15
       withProgressShiny(message = "Calculation in progress",
                         detail = "Starting ...",
-                        map = c(message = "detail"),
                         value = 0, {
         p <- progressor(along = X)
         y <- lapply(X, FUN=function(x) {