Return the value of expr from with_progress()

Author: DavisVaughan

NEWS

@@ -3,8 +3,9 @@ Package: progressr
 
 Version: 0.6.0-9000 [2020-05-18]
 
- * ...
- 
+ * with_progress() and without_progress() now return the result of evaluating
+   'expr'.
+
 
 Version: 0.6.0 [2020-05-18]
 

R/with_progress.R

@@ -232,55 +232,61 @@ with_progress <- function(expr, handlers = progressr::handlers(), cleanup = TRUE
 
   ## Evaluate expression
   capture_conditions <- TRUE
-  withCallingHandlers(
-    expr,
-    progression = function(p) {
-      ## Don't capture conditions that are produced by progression handlers
-      capture_conditions <<- FALSE
-      on.exit(capture_conditions <<- TRUE)
+  res <- withVisible(
+    withCallingHandlers(
+      expr,
+      progression = function(p) {
+        ## Don't capture conditions that are produced by progression handlers
+        capture_conditions <<- FALSE
+        on.exit(capture_conditions <<- TRUE)
 
-      ## Any buffered output to flush?
-      if (flush_terminal) {
-        if (length(conditions) > 0L || has_buffered_stdout(stdout_file)) {
-          calling_handler(control_progression("hide"))
-          stdout_file <<- flush_stdout(stdout_file, close = FALSE)
-          conditions <<- flush_conditions(conditions)
-          calling_handler(control_progression("unhide"))
+        ## Any buffered output to flush?
+        if (flush_terminal) {
+          if (length(conditions) > 0L || has_buffered_stdout(stdout_file)) {
+            calling_handler(control_progression("hide"))
+            stdout_file <<- flush_stdout(stdout_file, close = FALSE)
+            conditions <<- flush_conditions(conditions)
+            calling_handler(control_progression("unhide"))
+          }
         }
-      }
-      
-      calling_handler(p)
-    },
-    condition = function(c) {
-      if (!capture_conditions || 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
+
+        calling_handler(p)
+      },
+      condition = function(c) {
+        if (!capture_conditions || 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"
-  
-  invisible(NULL)
+
+  if (res$visible) {
+    res$value
+  } else {
+    invisible(res$value)
+  }
 }
 
 

R/without_progress.R

@@ -5,9 +5,15 @@
 #' @rdname with_progress
 #' @export
 without_progress <- function(expr) {
-  withCallingHandlers(expr, progression = function(p) {
-    invokeRestart("muffleProgression")
-  })
-  
-  invisible(NULL)
+  res <- withVisible(
+    withCallingHandlers(expr, progression = function(p) {
+      invokeRestart("muffleProgression")
+    })
+  )
+
+  if (res$visible) {
+    res$value
+  } else {
+    invisible(res$value)
+  }
 }

tests/with_progress.R

@@ -167,6 +167,20 @@ if (requireNamespace("utils", quietly = TRUE)) {
 message("with_progress() - multiple handlers ... done")
 
 
+message("with_progress() - return value and visibility ...")
+
+res <- with_progress(x)
+stopifnot(identical(x, res))
+
+res <- withVisible(with_progress(x))
+stopifnot(identical(res$visible, TRUE))
+
+res <- withVisible(with_progress(y <- x))
+stopifnot(identical(res$visible, FALSE))
+
+message("with_progress() - return value and visibility ... done")
+
+
 message("with_progress() ... done")
 
 source("incl/end.R")

tests/without_progress.R

@@ -13,4 +13,19 @@ with_progress(without_progress(y <- slow_sum(x)))
 
 message("without_progress() ... done")
 
+
+message("without_progress() - return value and visibility ...")
+
+res <- without_progress(x)
+stopifnot(identical(x, res))
+
+res <- withVisible(without_progress(x))
+stopifnot(identical(res$visible, TRUE))
+
+res <- withVisible(without_progress(y <- x))
+stopifnot(identical(res$visible, FALSE))
+
+message("without_progress() - return value and visibility ... done")
+
+
 source("incl/end.R")