TESTS: Adjust unit tests for new with_progress() warning [#178]

Author: HenrikBengtsson

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: progressr
-Version: 0.16.0-9010
+Version: 0.16.0-9012
 Title: An Inclusive, Unifying API for Progress Updates
 Description: A minimal, unifying API for scripts and packages to report progress updates from anywhere including when using parallel processing.  The package is designed such that the developer can to focus on what progress should be reported on without having to worry about how to present it.  The end user has full control of how, where, and when to render these progress updates, e.g. in the terminal using utils::txtProgressBar(), cli::cli_progress_bar(), in a graphical user interface using utils::winProgressBar(), tcltk::tkProgressBar() or shiny::withProgress(), via the speakers using beepr::beep(), or on a file system via the size of a file. Anyone can add additional, customized, progression handlers. The 'progressr' package uses R's condition framework for signaling progress updated. Because of this, progress can be reported from almost anywhere in R, e.g. from classical for and while loops, from map-reduce API:s like the lapply() family of functions, 'purrr', 'plyr', and 'foreach'. It will also work with parallel processing via the 'future' framework, e.g. future.apply::future_lapply(), furrr::future_map(), and 'foreach' with 'doFuture'. The package is compatible with Shiny applications.
 Authors@R: c(person("Henrik", "Bengtsson",

R/global_progression_handler.R

@@ -217,25 +217,7 @@ global_progression_handler <- local({
       }
     } else if (type == "update") {
       if (is.null(current_progressor_uuid)) {
-        ## We might receive zero-amount progress updates after the fact that the
-        ## progress has been completed
-        amount <- progression$amount
-        if (!is.numeric(amount) || amount > 0) {
-          ## But otherwise, it might be a coding mistake ...
-          
-          ## unless the 'progression' signaled within with_progress(), which
-          ## in case it might be re-signaled such that it reaches the global
-          ## 'progression' handler here
-          is_with_progress <- function(call) {
-            identical(call, quote(with_progress)) || identical(call, quote(progressr::with_progress))
-          }
-          calls <- lapply(sys.calls(), FUN = .subset2, 1L)
-          if (!any(vapply(calls, FUN = is_with_progress, FUN.VALUE = FALSE))) {
-            msg <- conditionMessage(progression)
-            if (length(msg) == 0) msg <- "character(0)"
-            warning(sprintf("Received a progression %s request (amount=%g; msg=%s) but is not listening to this progressor. This can happen when code signals more progress updates than it configured the progressor to do. When the progressor completes all steps, it shuts down resulting in the global progression handler to no longer listen to it. To troubleshoot this, try with progressr::handlers(\"debug\")", sQuote(type), amount, sQuote(msg)))
-          }
-        }
+        warn_about_too_many_progressions(progression, global = TRUE)
         return()
       }
 

R/warn_about_too_many_progressions.R

@@ -0,0 +1,31 @@
+warn_about_too_many_progressions <- function(progression, global = FALSE) {
+  ## We might receive progress updates after the fact that the progressor
+  ## has been completed
+
+  ## This is okay if it's a zero-amount progression
+  amount <- progression$amount
+  if (is.numeric(amount) && amount == 0) return()
+  
+  ## This is okay if it's signaled from within with_progress() and then
+  ## caught by the global 'progression' handler
+  if (global) {
+    ## ... unless the 'progression' signaled within with_progress(), which
+    ## in case it might be re-signaled such that it reaches the global
+    ## 'progression' handler here
+    is_with_progress <- function(call) {
+      identical(call, quote(with_progress)) || identical(call, quote(progressr::with_progress))
+    }
+    calls <- lapply(sys.calls(), FUN = .subset2, 1L)
+    if (any(vapply(calls, FUN = is_with_progress, FUN.VALUE = FALSE))) {
+      return()
+    }
+  }
+
+  ## In all cases, this is a mistake that we should warn about
+  m <- conditionMessage(progression)
+  m <- if (length(m) == 0) "character(0)" else sQuote(m)
+  info <- sprintf("amount=%g; msg=%s", amount, m)
+  msg <- if (global) "The global progression handlers" else "with_progress()"
+  msg <- sprintf("%s received a progression %s request (%s), but is no longer listening to this progressor. This can happen when code signals more progress updates than steps in the progressor. To troubleshoot this, retry with progressr::handlers(\"debug\")", msg, sQuote(progression$type), info)
+  warning(msg, call. = FALSE)
+} ## warn_about_too_many_progressions()

R/with_progress.R

@@ -233,16 +233,8 @@ with_progress <- function(expr, handlers = progressr::handlers(), cleanup = TRUE
       if (debug) message(sprintf("- received a %s (n=%g)", sQuote(class(p)[1]), progression_counter))
 
       if (finished) {
-        ## We might receive zero-amount progress updates after the fact that
-        ## the progress has been completed ...
-        amount <- p$amount
-        if (!is.numeric(amount) || amount > 0) {
-          ## ... but otherwise, it might be a coding mistake
-          msg <- conditionMessage(p)
-          if (length(msg) == 0) msg <- "character(0)"
-          type <- p$type
-          warning(sprintf("Received a progression %s request (amount=%g; msg=%s) but is not listening to this progressor. This can happen when code signals more progress updates than it configured the progressor to do. When the progressor completes all steps, it shuts down resulting in the global progression handler to no longer listen to it. To troubleshoot this, try with progressr::handlers(\"debug\")", sQuote(type), amount, sQuote(msg)))
-        }
+        warn_about_too_many_progressions(p)
+        return()
       }
 
       ## Don't capture conditions that are produced by progression handlers

tests/with_progress,relay.R

@@ -42,9 +42,14 @@ for (kk in seq_along(handlers)) {
           }
         })
       }, classes = type)
+      output <- relay$stdout
+      message <- gsub("\n$", "", relay$msgs)
+      if (delta > 0) {
+        message <- grep("no longer listening to this progressor", message, invert = TRUE, value = TRUE)
+      }
       stopifnot(
-        identical(relay$stdout, truth),
-        identical(gsub("\n$", "", relay$msgs), truth)
+        identical(output, truth),
+        identical(message, truth)
       )
     } ## for (delta ...)
   } ## for (signal ...)