use sitcky / non sticky with winProgressBar

[gitdemont]

Hi @HenrikBengtsson ,

In winProgressBar (alike in shiny::Progress) 2 components can be tweaked, namely title and label. It would be great for users to update one or the other like what we can do with progressr::handler_shiny

as a proposal:

#' Progression Handler: Progress Reported as a MS Windows Progress Bars in the GUI
#'
#' A progression handler for `winProgressBar()` in the \pkg{utils} package.
#'
#' @inheritParams make_progression_handler
#' 
#' @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()].
#'
#'#' @examples
#' \donttest{\dontrun{
#' handlers(handler_winprogressbar())
#' with_progress(y <- slow_sum(1:100))
#' }}
#' 
#' @section Requirements:
#' This progression handler requires MS Windows.
#'
#' @export
handler_winprogressbar <- function(intrusiveness = getOption("progressr.intrusiveness.gui", 1), target = "gui", inputs = list(title = "sticky_message", label = "non_sticky_message"), ...) {
  ## Additional arguments passed to the progress-handler backend
  backend_args <- handler_backend_args(...)

  ## Used for package testing purposes only when we want to perform
  ## everything except the last part where the backend is called
  not_fake <- !is_fake("handler_winprogressbar")
  if (not_fake) {
    if (.Platform$OS.type != "windows") {
      stop("handler_winprogressbar requires MS Windows: ",
           sQuote(.Platform$OS.type))
    }
    ## Import functions
    winProgressBar <- utils::winProgressBar
    setWinProgressBar <- utils::setWinProgressBar
  } else {
    winProgressBar <- function(...) rawConnection(raw(0L))
    setWinProgressBar <- function(...) NULL
  }
  alw_ini <- methods::formalArgs(winProgressBar)
  alw_upd <- methods::formalArgs(setWinProgressBar)

  reporter <- local({
    pb <- NULL

    stop_if_not(
      is.list(inputs),
      !is.null(names(inputs)),
      all(names(inputs) %in% c("title", "label")),
      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)
    }

    ## Update winProgressBar
    set_pb <- function(state, progression) {
      args <- list()
      for (target in c("title", "label")) {
        if (inherits(progression, "sticky")) {
          if ("sticky_message" %in% inputs[[target]])
            args[[target]] <- progression$message
        } else {
          if ("non_sticky_message" %in% inputs[[target]])
            args[[target]] <- progression$message
        }
      }
      for (target in c("title", "label")) if (is.null(args[[target]])) args[[target]] <- pb$args[[target]]
      args <- c(list(pb = pb$bar, value = state$step), args)
      if(not_fake) args <- args[names(args) %in% alw_upd]
      pb$args <<- args[setdiff(names(args), "pb")]
      do.call(what = setWinProgressBar, args = args)
    }

    list(
      reset = function(...) {
        pb <<- NULL
      },

      initiate = function(config, state, progression, ...) {
        if (!state$enabled || config$times == 1L) return()
        ## NOTE: 'pb' may be re-used for winProgressBar:s
        if (config$clear) stop_if_not(is.null(pb))
        args <- c(backend_args, list(max = config$max_steps, initial = state$step), list(...))
        if(not_fake) args <- args[names(args) %in% alw_ini]
        # Empty title or label are replaced to avoid error while creating the progress bar
        # In addition, if the progress bar has been created with default label="" value label,
        # it won't be possible to modify with setProgressBar afterwards,
        # so as a trick label value is replaced with " " when NULL or equal to ""
        if (length(args$title) == 0) args$title = " "
        if (length(args$label) == 0 || args$label == "") args$label = " "
        pb <<- c(list(bar = do.call(winProgressBar, args = args)), list(args = args))
        pb
      },

      update = function(config, state, progression, ...) {
        if (!state$enabled || config$times <= 2L) return()
        set_pb(state, progression)
      },

      finish = function(config, state, progression, ...) {
        ## Already finished?
        if (is.null(pb)) return()
        if (!state$enabled) return()
        if (config$clear) {
          close(pb$bar)
          pb <<- NULL
        } else {
          set_pb(state, progression)
        }
      }
    )
  })

  make_progression_handler("winprogressbar", reporter, intrusiveness = intrusiveness, target = target, ...)
}

This should also allow to fix an issue with using label in progressr::handler_winprogressbar

library(progressr)
future::plan(multisession)
slow_sum <- function(x) {
  p <- progressr::progressor(along = x)
  sum <- 0
  for (kk in seq_along(x)) {
    Sys.sleep(0.1)
    sum <- sum + x[kk]
    p(message = sprintf("Added %g", x[kk]))
  }
  sum
}
with_progress(y <- slow_sum(1:10), handlers = handler_winprogressbar(label = "error"))
#Error in (function (title = "R progress bar", label = "", min = 0, max = 1, : 
#formal argument "label" matched by multiple actual arguments

[HenrikBengtsson]

Thanks for this suggestion. It makes sense to introduce this feature also for this handle. This is now implemented in the develop version. Analogously to handler_shiny(), and for backward compatible reasons, I decided to make the default inputs = list(title = NULL, label = "message") for now.

In the future, it probably makes sense to revisit these defaults. Maybe

1. inputs = list(title = "sticky_message", label = "message"), or
2. inputs = list(title = "sticky_message", label = "non_sticky_message")

is a better default, and analogously for handler_shiny().

[gitdemont]

Great, just installed it works perfectly ! Thanks for the implementation.