Merge branch 'release/0.1.1'

Author: HenrikBengtsson

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: progressr
-Version: 0.1.0
+Version: 0.1.1
 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(

NEWS

@@ -1,6 +1,16 @@
 Package: progressr
 ==================
 
+Version: 0.1.1 [2019-06-08]
+
+NEW FEATURES:
+
+ * with_progress() now captures standard output and conditions and relay them
+   at then end.  This is done in order to avoid interweaving such output with
+   the output produced by the progression handlers.  This behavior can be
+   controlled by arguments 'delay_stdout' and 'delay_condition'.
+ 
+
 Version: 0.1.0 [2019-06-07]
 
 NEW FEATURES:

R/slow_sum.R

@@ -4,20 +4,27 @@
 #'
 #' @param delay Delay in seconds after each addition.
 #'
+#' @param stdout If TRUE, then a text is outputted to the standard output
+#' per element.
+#'
+#' @param message If TRUE, then a message is outputted per element.
+#'
 #' @return The sum of all elements in `x`.
 #'
 #' @section Progress updates:
 #' This function signals [progression] conditions as it progresses.
 #'
 #' @export
-slow_sum <- function(x, delay = getOption("delay", 0.05)) {
+slow_sum <- function(x, delay = getOption("delay", 0.05), stdout = FALSE, message = FALSE) {
   progress <- progressor(length(x))
-  
+
   res <- 0
   for (kk in seq_along(x)) {
+    if (stdout) cat(sprintf("Adding 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]))
   }
 
   res

R/utils.R

@@ -1,3 +1,15 @@
+# More efficient than the default utils::capture.output()
+#' @importFrom utils capture.output
+capture_output <- function(expr, envir = parent.frame(), ...) {
+  res <- eval({
+    file <- rawConnection(raw(0L), open = "w")
+    on.exit(close(file))
+    capture.output(expr, file = file)
+    rawToChar(rawConnectionValue(file))
+  }, envir = envir, enclos = baseenv())
+  unlist(strsplit(res, split = "\n", fixed = TRUE), use.names = FALSE)
+}
+
 now <- function(x = Sys.time(), format = "[%H:%M:%OS3] ") {
   format(as.POSIXlt(x, tz = ""), format = format)
 }
@@ -12,16 +24,15 @@ mprintf <- function(..., appendLF = TRUE, debug = getOption("progressr.debug", F
   message(now(), sprintf(...), appendLF = appendLF)
 }
 
-#' @importFrom utils capture.output
 mprint <- function(..., appendLF = TRUE, debug = getOption("progressr.debug", FALSE)) {
   if (!debug) return()
-  message(paste(now(), capture.output(print(...)), sep = "", collapse = "\n"), appendLF = appendLF)
+  message(paste(now(), capture_output(print(...)), sep = "", collapse = "\n"), appendLF = appendLF)
 }
 
-#' @importFrom utils capture.output str
+#' @importFrom utils str
 mstr <- function(..., appendLF = TRUE, debug = getOption("progressr.debug", FALSE)) {
   if (!debug) return()
-  message(paste(now(), capture.output(str(...)), sep = "", collapse = "\n"), appendLF = appendLF)
+  message(paste(now(), capture_output(str(...)), sep = "", collapse = "\n"), appendLF = appendLF)
 }
 
 stop_if_not <- function(...) {

R/with_progress.R

@@ -8,12 +8,19 @@
 #' @param cleanup If TRUE, all progression handlers will be shutdown
 #' at the end regardless of the progression is complete or not.
 #'
+#' @param delay_stdout If TRUE, standard output is captured and relayed
+#' at the end just before any captured conditions are relayed.
+#'
+#' @param delay_conditions A character vector specifying [base::condition]
+#' classes to be captured and relayed at the end after any captured
+#' standard output is relayed.
+#'
 #' @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) {
+with_progress <- function(expr, handlers = getOption("progressr.handlers", txtprogressbar_handler()), cleanup = TRUE, delay_stdout = TRUE, delay_conditions = c("condition")) {
   stop_if_not(is.logical(cleanup), length(cleanup) == 1L, !is.na(cleanup))
 
   ## FIXME: With zero handlers, progression conditions will be
@@ -59,16 +66,78 @@ with_progress <- function(expr, handlers = getOption("progressr.handlers", txtpr
     })
   }
 
+  ## Captured stdout output and conditions
+  stdout_file <- NULL
+  conditions <- list()
+  if (delay_stdout || length(delay_conditions) > 0) {
+    ## Delay standard output?
+    if (delay_stdout) {
+      stdout_file <- rawConnection(raw(0L), open = "w")
+      sink(stdout_file, type = "output", split = FALSE)
+      on.exit({
+        sink(type = "output", split = FALSE)
+        stdout <- rawToChar(rawConnectionValue(stdout_file))
+        close(stdout_file)
+        if (length(stdout) > 0) cat(stdout, file = stdout())
+      })
+    }
+    
+    ## Delay conditions?
+    if (length(delay_conditions) > 0) {
+      on.exit({
+        if (length(conditions) > 0L) {
+          for (kk in seq_along(conditions)) {
+            c <- conditions[[kk]]
+            if (inherits(c, "message")) {
+              message(c)
+            } else if (inherits(c, "warning")) {
+              warning(c)
+            } else if (inherits(c, "condition")) {
+              signalCondition(c)
+            }
+          }
+        }
+      }, add = TRUE)
+    }
+  }
+
   ## Reset all handlers up start
   withCallingHandlers({
-    withRestarts({
-      signalCondition(control_progression("reset"))
-    }, muffleProgression = function(p) NULL)
+      withRestarts({
+        signalCondition(control_progression("reset"))
+      }, muffleProgression = function(p) NULL)
   }, progression = handler)
 
   ## Evaluate expression
-  withCallingHandlers(expr, progression = handler)
-
+  withCallingHandlers(
+    expr,
+    progression = handler,
+    condition = function(c) {
+      if (inherits(c, c("progression", "error"))) return()
+      if (inherits(c, delay_conditions)) {
+        ## Record
+        conditions[[length(conditions) + 1L]] <<- c
+        ## Muffle
+        if (inherits(c, "message")) {
+          invokeRestart("muffleMessage")
+        } else if (inherits(c, "warning")) {
+          invokeRestart("muffleWarning")
+        } else if (inherits(c, "condition")) {
+          ## If there is a "muffle" restart for this condition,
+          ## then invoke that restart, i.e. "muffle" the condition
+          restarts <- computeRestarts(c)
+          for (restart in restarts) {
+            name <- restart$name
+            if (is.null(name)) next
+            if (!grepl("^muffle", name)) next
+            invokeRestart(restart)
+            break
+          }
+        }
+      }
+    }
+  )
+  
   ## Success
   status <- "ok"
 

man/slow_sum.Rd

@@ -0,0 +1,49 @@
+library(progressr)
+
+options(progressr.tests.fake_handlers = c("beepr_handler", "notifier_handler", "pbmcapply_handler", "tkprogressbar_handler", "winprogressbar_handler"))
+options(progressr.enable = TRUE)
+
+options(delay = 0.001)
+options(progressr.times = +Inf)
+options(progressr.interval = 0)
+options(progressr.clear = FALSE)
+
+record_output <- function(expr, envir = parent.frame()) {
+  conditions <- list()
+  stdout <- utils::capture.output({
+    withCallingHandlers(
+      expr,
+      condition = function(c) {
+        if (inherits(c, c("progression", "error"))) return()
+        conditions[[length(conditions) + 1L]] <<- c
+      }
+    )
+  }, split = TRUE)
+  list(stdout = stdout, conditions = conditions)
+}
+
+
+message("*** with_progress() - delaying output ...")
+
+x <- 1:5
+
+## Record truth
+output_truth <- record_output({
+ y_truth <- slow_sum(x, stdout=TRUE, message=TRUE)
+})
+
+for (delay in c(FALSE, TRUE)) {
+  message(sprintf("- with_progress() - delay = %s ...", delay))
+  output <- record_output({
+    with_progress({
+     y <- slow_sum(x, stdout=TRUE, message=TRUE)
+    }, delay_stdout = delay,
+       delay_conditions = if (delay) "condition" else character(0L))
+  })
+  stopifnot(identical(output$stdout, output_truth$stdout))
+  stopifnot(identical(output$conditions, output_truth$conditions))
+  stopifnot(identical(y, y_truth))
+  message(sprintf("- with_progress() - delay = %s ... DONE", delay))
+}
+
+message("*** with_progress() - delaying output ... DONE")