Merge branch 'release/0.1.2'

Author: HenrikBengtsson

.gitignore

@@ -2,3 +2,4 @@
 *~
 **/*~
 .local
+inst/doc

DESCRIPTION

@@ -1,21 +1,25 @@
 Package: progressr
-Version: 0.1.1
+Version: 0.1.2
 Title: A Unifying API for Progress Updates
 Description: A minimal API for reporting progress updates upstream.  The design is to separate the representation of progress updates from how they are presented.  What type of progress to signal is controlled by the developer.  How these progress updates are rendered is controlled by the end user.  For instance, some users may prefer visual feedback such as a horizontal progress bar in the terminal, whereas others may prefer auditory feedback.
 Authors@R: c(
   person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"),
          email = "[email protected]"))
 License: GPL (>= 3)
 Imports:
-  digest
+    digest
 Suggests:
-  utils,
-  tcltk,
-  beepr,
-  notifier,
-  pbmcapply,
-  plyr,
-  progress
+    utils,
+    tcltk,
+    beepr,
+    notifier,
+    pbmcapply,
+    plyr,
+    progress,
+    future,
+    doFuture,
+    future.apply,
+    furrr
 Remotes:
   gaborcsardi/notifier@d92b1b6
 URL: https://github.com/HenrikBengtsson/progressr

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(print,progression)
+S3method(print,progression_handler)
 S3method(print,progressor)
 export(ascii_alert_handler)
 export(beepr_handler)

NEWS

@@ -1,6 +1,24 @@
 Package: progressr
 ==================
 
+Version: 0.1.2 [2019-06-14]
+
+NEW FEATURES:
+
+ * with_progress() gained arguments 'enable' and 'interval' as an alternative
+   to setting corresponding options progressr.*.
+
+ * Now option 'progressr.interval' defaults to 0.0 (was 0.5 seconds).
+
+ * Added print() for 'progression_handler' objects.
+ 
+BUG FIXES:
+
+ * with_progress(..., delay_conditions = "condition"), introduced in v0.1.0,
+   would also capture conditions produced by progression handlers, e.g.
+   progress::progress_bar() output would not be displayed until the very end.
+
+
 Version: 0.1.1 [2019-06-08]
 
 NEW FEATURES:

R/progression_handler.R

@@ -28,7 +28,7 @@
 #' @return A function of class `progression_handler`.
 #'
 #' @export
-progression_handler <- function(name, reporter = list(), handler = NULL, enable = getOption("progressr.enable", interactive()), enable_after = getOption("progressr.enable_after", 0.0), times = getOption("progressr.times", +Inf), interval = getOption("progressr.interval", 0.5), intrusiveness = 1.0, clear = getOption("progressr.clear", TRUE)) {
+progression_handler <- function(name, reporter = list(), handler = NULL, enable = getOption("progressr.enable", interactive()), enable_after = getOption("progressr.enable_after", 0.0), times = getOption("progressr.times", +Inf), interval = getOption("progressr.interval", 0.0), intrusiveness = 1.0, clear = getOption("progressr.clear", TRUE)) {
   if (!enable) times <- 0
   name <- as.character(name)
   stop_if_not(length(name) == 1L, !is.na(name), nzchar(name))
@@ -279,3 +279,35 @@ progression_handler <- function(name, reporter = list(), handler = NULL, enable
 
   handler
 }
+
+
+#' @export
+print.progression_handler <- function(x, ...) {
+  print(sys.calls())
+  s <- sprintf("Progression handler of class %s:", sQuote(class(x)[1]))
+  
+  env <- environment(x)
+  s <- c(s, " * configuration:")
+  s <- c(s, sprintf("   - name: %s", sQuote(env$name %||% "<NULL>")))
+  s <- c(s, sprintf("   - max_steps: %s", env$max_steps %||% "<NULL>"))
+  s <- c(s, sprintf("   - enable: %s", env$enable))
+  s <- c(s, sprintf("   - enable_after: %g seconds", env$enable_after))
+  s <- c(s, sprintf("   - times: %g", env$times))
+  s <- c(s, sprintf("   - interval: %g seconds", env$interval))
+  s <- c(s, sprintf("   - intrusiveness: %g", env$intrusiveness))
+  s <- c(s, sprintf("   - auto_finish: %s", env$auto_finish))
+  s <- c(s, sprintf("   - clear: %s", env$clear))
+  s <- c(s, sprintf("   - milestones: %s", hpaste(env$milestones %||% "<NULL>")))
+  s <- c(s, sprintf("   - owner: %s", hpaste(env$owner %||% "<NULL>")))
+
+  s <- c(s, " * state:")
+  s <- c(s, sprintf("   - enabled: %s", env$enabled))
+  s <- c(s, sprintf("   - finished: %s", env$finished))
+  s <- c(s, sprintf("   - step: %s", env$step %||% "<NULL>"))
+  s <- c(s, sprintf("   - prev_milestone: %s", env$prev_milestone %||% "<NULL>"))
+  s <- c(s, sprintf("   - delta: %g", (env$step - env$prev_milestone) %||% 0L))
+  s <- c(s, sprintf("   - timestamps: %s", hpaste(env$timestamps %||% "<NULL>")))
+
+  s <- paste(s, collapse = "\n")
+  cat(s, "\n", sep = "")
+}

R/slow_sum.R

@@ -18,14 +18,14 @@
 slow_sum <- function(x, delay = getOption("delay", 0.05), stdout = FALSE, message = FALSE) {
   progress <- progressor(length(x))
 
-  res <- 0
+  sum <- 0
   for (kk in seq_along(x)) {
-    if (stdout) cat(sprintf("Adding element #%d\n", kk))
+    if (stdout) cat(sprintf("O: Element #%d\n", kk))
     Sys.sleep(delay)
-    res <- res + x[kk]
-    progress(message = sprintf("Adding %g", kk))
-    if (message) message(sprintf("Added value %g", x[kk]))
+    sum <- sum + x[kk]
+    progress(message = sprintf("P: Adding %g", kk))
+    if (message) message(sprintf("M: Added value %g", x[kk]))
   }
 
-  res
+  sum
 }

R/utils.R

@@ -1,3 +1,35 @@
+## From R.utils 2.0.2 (2015-05-23)
+hpaste <- function(..., sep = "", collapse = ", ", lastCollapse = NULL, maxHead = if (missing(lastCollapse)) 3 else Inf, maxTail = if (is.finite(maxHead)) 1 else Inf, abbreviate = "...") {
+  if (is.null(lastCollapse)) lastCollapse <- collapse
+
+  # Build vector 'x'
+  x <- paste(..., sep = sep)
+  n <- length(x)
+
+  # Nothing todo?
+  if (n == 0) return(x)
+  if (is.null(collapse)) return(x)
+
+  # Abbreviate?
+  if (n > maxHead + maxTail + 1) {
+    head <- x[seq_len(maxHead)]
+    tail <- rev(rev(x)[seq_len(maxTail)])
+    x <- c(head, abbreviate, tail)
+    n <- length(x)
+  }
+
+  if (!is.null(collapse) && n > 1) {
+    if (lastCollapse == collapse) {
+      x <- paste(x, collapse = collapse)
+    } else {
+      xT <- paste(x[1:(n-1)], collapse = collapse)
+      x <- paste(xT, x[n], sep = lastCollapse)
+    }
+  }
+
+  x
+} # hpaste()
+
 # More efficient than the default utils::capture.output()
 #' @importFrom utils capture.output
 capture_output <- function(expr, envir = parent.frame(), ...) {
@@ -70,6 +102,12 @@ is_fake <- local({
 known_progression_handlers <- function() {
   ns <- asNamespace(.packageName)
   handlers <- ls(envir = ns, pattern = "_handler$")
-  handlers <- setdiff(handlers, "progression_handler")
-  mget(handlers, envir = ns, inherits = FALSE)
+  handlers <- setdiff(handlers, c("progression_handler", "print.progression_handler"))
+  handlers <- mget(handlers, envir = ns, inherits = FALSE)
+  handlers
+}
+
+
+`%||%` <- function(lhs, rhs) {
+  if (is.null(lhs)) rhs else lhs
 }

R/with_progress.R

@@ -15,20 +15,40 @@
 #' classes to be captured and relayed at the end after any captured
 #' standard output is relayed.
 #'
+#' @param interval (numeric) The minimum time (in seconds) between
+#' successive progression updates from handlers.
+#'
+#' @param enable (logical) If FALSE, then progress is not reported.
+#'
 #' @return Return nothing (reserved for future usage).
 #'
 #' @example incl/with_progress.R
 #'
 #' @export
-with_progress <- function(expr, handlers = getOption("progressr.handlers", txtprogressbar_handler()), cleanup = TRUE, delay_stdout = TRUE, delay_conditions = c("condition")) {
+with_progress <- function(expr, handlers = getOption("progressr.handlers", txtprogressbar_handler), cleanup = TRUE, delay_stdout = getOption("progressr.delay_stdout", interactive()), delay_conditions = getOption("progressr.delay_conditions", if (interactive()) c("condition") else character(0L)), interval = NULL, enable = NULL) {
   stop_if_not(is.logical(cleanup), length(cleanup) == 1L, !is.na(cleanup))
 
   ## FIXME: With zero handlers, progression conditions will be
   ##        passed on upstream just as without with_progress().
   ##        Is that what we want? /HB 2019-05-17
   if (length(handlers) == 0L) return(expr)
   if (!is.list(handlers)) handlers <- list(handlers)
-  
+
+  ## Temporarily set progressr options
+  options <- list()
+  if (!is.null(interval)) {
+    stop_if_not(is.numeric(interval), length(interval) == 1L, !is.na(interval))
+    options[["progressr.interval"]] <- interval
+  }
+  if (!is.null(enable)) {
+    stop_if_not(is.logical(enable), length(enable) == 1L, !is.na(enable))
+    options[["progressr.enable"]] <- enable
+  }
+  if (length(options) > 0L) {  
+    oopts <- options(options)
+    on.exit(options(oopts))
+  }
+
   for (kk in seq_along(handlers)) {
     handler <- handlers[[kk]]
     stopifnot(is.function(handler))
@@ -63,7 +83,7 @@ with_progress <- function(expr, handlers = getOption("progressr.handlers", txtpr
           signalCondition(control_progression("shutdown", status = status))
         }, muffleProgression = function(p) NULL)
       }, progression = handler)
-    })
+    }, add = TRUE)
   }
 
   ## Captured stdout output and conditions
@@ -79,7 +99,7 @@ with_progress <- function(expr, handlers = getOption("progressr.handlers", txtpr
         stdout <- rawToChar(rawConnectionValue(stdout_file))
         close(stdout_file)
         if (length(stdout) > 0) cat(stdout, file = stdout())
-      })
+      }, add = TRUE)
     }
 
     ## Delay conditions?
@@ -99,7 +119,7 @@ with_progress <- function(expr, handlers = getOption("progressr.handlers", txtpr
         }
       }, add = TRUE)
     }
-  }
+  } ## if (delay_stdout || length(delay_conditions) > 0)
 
   ## Reset all handlers up start
   withCallingHandlers({
@@ -109,11 +129,17 @@ with_progress <- function(expr, handlers = getOption("progressr.handlers", txtpr
   }, progression = handler)
 
   ## Evaluate expression
+  capture_conditions <- TRUE
   withCallingHandlers(
     expr,
-    progression = handler,
+    progression = function(p) {
+      ## Don't capture conditions that are produced by progression handlers
+      capture_conditions <<- FALSE
+      on.exit(capture_conditions <<- TRUE)
+      handler(p)
+    },
     condition = function(c) {
-      if (inherits(c, c("progression", "error"))) return()
+      if (!capture_conditions || inherits(c, c("progression", "error"))) return()
       if (inherits(c, delay_conditions)) {
         ## Record
         conditions[[length(conditions) + 1L]] <<- c

README.md

@@ -14,13 +14,13 @@ Assume that we have a function `slow_sum()` for adding up the values in a vector
 ```r
 slow_sum <- function(x) {
   progress <- progressr::progressor(length(x))
-  res <- 0
+  sum <- 0
   for (kk in seq_along(x)) {
     Sys.sleep(0.1)
-    res <- res + x[kk]
-    progress()
+    sum <- sum + x[kk]
+    progress(message = sprintf("Added %g", x[kk]))
   }
-  res
+  sum
 }
 ```
 
@@ -59,7 +59,7 @@ options(progressr.handlers = progress_handler)
 This progress handler will present itself as:
 ```r
 > with_progress(y <- slow_sum(1:10))
-[=====================>--------------------------------]  40%
+[==================>---------------------------]  40% Added 4
 ```
 
 
@@ -83,11 +83,33 @@ will present itself as sounds played at the beginning, while progressing, and at
 
 It is possible to have multiple progress handlers presenting progress updates at the same time.  For example, to get both visual and auditory updates, use:
 ```r
-options(progressr.handlers = list(txtprogress_barhandler, beepr_handler))
+options(progressr.handlers = list(txtprogressbar_handler, beepr_handler))
+```
+
+
+### Debugging
+
+To debug progress updates, use:
+```r
+> options(progressr.handlers = debug_handler)
+> with_progress(y <- slow_sum(1:10))
+[13:33:50.776] (1.033s => +0.001s) shutdown: 10/10 (+0) '' {clear=TRUE, enabled=TRUE, status=ok}
+[13:33:49.743] (0.000s => +0.002s) initiate: 0/10 (+0) '' {clear=TRUE, enabled=TRUE, status=}
+[13:33:49.847] (0.104s => +0.001s) update: 1/10 (+1) 'Added 1' {clear=TRUE, enabled=TRUE, status=}
+[13:33:49.950] (0.206s => +0.001s) update: 2/10 (+1) 'Added 2' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.052] (0.309s => +0.000s) update: 3/10 (+1) 'Added 3' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.154] (0.411s => +0.001s) update: 4/10 (+1) 'Added 4' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.257] (0.514s => +0.001s) update: 5/10 (+1) 'Added 5' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.361] (0.618s => +0.002s) update: 6/10 (+1) 'Added 6' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.464] (0.721s => +0.001s) update: 7/10 (+1) 'Added 7' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.567] (0.824s => +0.001s) update: 8/10 (+1) 'Added 8' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.670] (0.927s => +0.001s) update: 9/10 (+1) 'Added 9' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.773] (1.030s => +0.001s) update: 10/10 (+1) 'Added 10' {clear=TRUE, enabled=TRUE, status=}
+[13:33:50.774] (1.031s => +0.003s) update: 10/10 (+0) 'Added 10' {clear=TRUE, enabled=TRUE, status=}
 ```
 
 <small>
-(*) To set the default progress presenter in all R session, set this option in your '~/.Rprofile' file.
+(*) To set the default progress presenter in all R session, set this option in your `~/.Rprofile` file.
 </small>