1#' Report on Progress while Evaluating an R Expression
2#'
3#' @param expr An \R expression to evaluate.
4#'
5#' @param handlers A progression handler or a list of them.
6#' If NULL or an empty list, progress updates are ignored.
7#'
8#' @param cleanup If TRUE, all progression handlers will be shutdown
9#' at the end regardless of the progression is complete or not.
10#'
11#' @param delay_terminal If TRUE, output and conditions that may end up in
12#' the terminal will delayed.
13#'
14#' @param delay_stdout If TRUE, standard output is captured and relayed
15#' at the end just before any captured conditions are relayed.
16#'
17#' @param delay_conditions A character vector specifying [base::condition]
18#' classes to be captured and relayed at the end after any captured
19#' standard output is relayed.
20#'
21#' @param interrupts Controls whether interrupts should be detected or not.
22#' If TRUE and a interrupt is signaled, progress handlers are asked to
23#' report on the current amount progress when the evaluation was terminated
24#' by the interrupt, e.g. when a user pressed Ctrl-C in an interactive session,
25#' or a batch process was interrupted because it ran out of time.
26#'
27#' @param interval (numeric) The minimum time (in seconds) between
28#' successive progression updates from handlers.
29#'
30#' @param enable (logical) If FALSE, then progress is not reported.  The
31#' default is to report progress in interactive mode but not batch mode.
32#' See below for more details.
33#'
34#' @return Returns the value of the expression.
35#'
36#' @example incl/with_progress.R
37#'
38#' @details
39#' _IMPORTANT: This function is meant for end users only.  It should not
40#' be used by R packages, which only task is to _signal_ progress updates,
41#' not to decide if, when, and how progress should be reported._
42#'
43#' @section Progression handler functions:
44#' Formally, progression handlers are calling handlers that are called
45#' when a [progression] condition is signaled.  These handlers are functions
46#' that takes one argument which is the [progression] condition.
47#'
48#' @section Progress updates in batch mode:
49#' When running R from the command line, R runs in a non-interactive mode
50#' (`interactive()` returns `FALSE`).  The default behavior of
51#' `with_progress()` is to _not_ report on progress in non-interactive mode.
52#' To have progress being reported on also then, set R options
53#' \option{progressr.enable} or environment variable \env{R_PROGRESSR_ENABLE}
54#' to `TRUE`.  Alternatively, one can set argument `enable=TRUE` when calling
55#' `with_progress()`.  For example,
56#' ```sh
57#' $ Rscript -e "library(progressr)" -e "with_progress(slow_sum(1:5))"
58#' ```
59#' will _not_ report on progress, whereas:
60#' ```sh
61#' $ export R_PROGRESSR_ENABLE=TRUE
62#' $ Rscript -e "library(progressr)" -e "with_progress(slow_sum(1:5))"
63#' ```
64#' will.
65#'
66#' @seealso
67#' [base::withCallingHandlers()]
68#'
69#' @export
70with_progress <- function(expr, handlers = progressr::handlers(), cleanup = TRUE, delay_terminal = NULL, delay_stdout = NULL, delay_conditions = NULL, interrupts = getOption("progressr.interrupts", TRUE), interval = NULL, enable = NULL) {
71  stop_if_not(is.logical(cleanup), length(cleanup) == 1L, !is.na(cleanup))
72  stop_if_not(is.logical(interrupts), length(interrupts) == 1L, !is.na(interrupts))
73
74  debug <- getOption("progressr.debug", FALSE)
75  if (debug) {
76    message("with_progress() ...")
77    on.exit(message("with_progress() ... done"), add = TRUE)
78  }
79
80  ## FIXME: With zero handlers, progression conditions will be
81  ##        passed on upstream just as without with_progress().
82  ##        Is that what we want? /HB 2019-05-17
83
84  # Nothing to do?
85  if (length(handlers) == 0L) {
86    if (debug) message("No progress handlers - skipping")
87    return(expr)
88  }
89
90  ## Temporarily set progressr options
91  options <- list()
92
93  ## Enabled or not?
94  if (!is.null(enable)) {
95    stop_if_not(is.logical(enable), length(enable) == 1L, !is.na(enable))
96
97    # Nothing to do?
98    if (!enable) {
99      if (debug) message("Progress disabled - skipping")
100      return(expr)
101    }
102
103    options[["progressr.enable"]] <- enable
104  }
105
106  if (!is.null(interval)) {
107    stop_if_not(is.numeric(interval), length(interval) == 1L, !is.na(interval))
108    options[["progressr.interval"]] <- interval
109  }
110
111  if (length(options) > 0L) {
112    oopts <- options(options)
113    on.exit(options(oopts), add = TRUE)
114  }
115
116  progressr_in_globalenv("allow")
117  on.exit(progressr_in_globalenv("disallow"), add = TRUE)
118
119  handlers <- as_progression_handler(handlers)
120
121  ## Nothing to do?
122  if (length(handlers) == 0L) {
123    if (debug) message("No remaining progress handlers - skipping")
124    return(expr)
125  }
126
127  ## Do we need to buffer?
128  delays <- use_delays(handlers,
129    terminal   = delay_terminal,
130    stdout     = delay_stdout,
131    conditions = delay_conditions
132  )
133  if (debug) {
134    what <- c(
135      if (delays$terminal) "terminal",
136      if (delays$stdout) "stdout",
137      delays$conditions
138    )
139    message("- Buffering: ", paste(sQuote(what), collapse = ", "))
140  }
141
142  calling_handler <- make_calling_handler(handlers)
143
144  ## Flag indicating whether nor not with_progress() exited due to an error
145  status <- "incomplete"
146
147  ## Tell all progression handlers to shutdown at the end and
148  ## the status of the evaluation.
149  if (cleanup) {
150    on.exit({
151      if (debug) message("- signaling 'shutdown' to all handlers")
152      withCallingHandlers({
153        withRestarts({
154          signalCondition(control_progression("shutdown", status = status))
155        }, muffleProgression = function(p) NULL)
156      }, progression = calling_handler)
157    }, add = TRUE)
158  }
159
160  ## Delay standard output?
161  stdout_file <- delay_stdout(delays, stdout_file = NULL)
162  on.exit(flush_stdout(stdout_file), add = TRUE)
163
164  ## Delay conditions?
165  conditions <- list()
166  if (length(delays$conditions) > 0) {
167    on.exit(flush_conditions(conditions), add = TRUE)
168  }
169
170  ## Reset all handlers upfront
171  if (debug) message("- signaling 'reset' to all handlers")
172  withCallingHandlers({
173    withRestarts({
174      signalCondition(control_progression("reset"))
175    }, muffleProgression = function(p) NULL)
176  }, progression = calling_handler)
177
178  ## Just for debugging purposes
179  progression_counter <- 0
180
181  ## Evaluate expression
182  capture_conditions <- TRUE
183  withCallingHandlers({
184    res <- withVisible(expr)
185  }, progression = function(p) {
186    progression_counter <<- progression_counter + 1
187    if (debug) message(sprintf("- received a %s (n=%g)", sQuote(class(p)[1]), progression_counter))
188
189    ## Don't capture conditions that are produced by progression handlers
190    capture_conditions <<- FALSE
191    on.exit(capture_conditions <<- TRUE)
192
193    ## Any buffered output to flush?
194    if (isTRUE(attr(delays$terminal, "flush"))) {
195      if (length(conditions) > 0L || has_buffered_stdout(stdout_file)) {
196        calling_handler(control_progression("hide"))
197        stdout_file <<- flush_stdout(stdout_file, close = FALSE)
198        conditions <<- flush_conditions(conditions)
199        calling_handler(control_progression("unhide"))
200      }
201    }
202
203    calling_handler(p)
204  },
205  interrupt = function(c) {
206    ## Ignore interrupts?
207    if (!interrupts) return()
208
209    suspendInterrupts({
210      ## Don't capture conditions that are produced by progression handlers
211      capture_conditions <<- FALSE
212      on.exit(capture_conditions <<- TRUE)
213
214      ## Any buffered output to flush?
215      if (isTRUE(attr(delays$terminal, "flush"))) {
216        if (length(conditions) > 0L || has_buffered_stdout(stdout_file)) {
217          calling_handler(control_progression("hide"))
218          stdout_file <<- flush_stdout(stdout_file, close = FALSE)
219          conditions <<- flush_conditions(conditions)
220        }
221      }
222
223      calling_handler(control_progression("interrupt"))
224    })
225  },
226  condition = function(c) {
227    if (!capture_conditions || inherits(c, c("progression", "error"))) return()
228    if (debug) message("- received a ", sQuote(class(c)[1]))
229
230    if (inherits(c, delays$conditions)) {
231      ## Record
232      conditions[[length(conditions) + 1L]] <<- c
233      ## Muffle
234      if (inherits(c, "message")) {
235        invokeRestart("muffleMessage")
236      } else if (inherits(c, "warning")) {
237        invokeRestart("muffleWarning")
238      } else if (inherits(c, "condition")) {
239        ## If there is a "muffle" restart for this condition,
240        ## then invoke that restart, i.e. "muffle" the condition
241        restarts <- computeRestarts(c)
242        for (restart in restarts) {
243          name <- restart$name
244          if (is.null(name)) next
245          if (!grepl("^muffle", name)) next
246          invokeRestart(restart)
247          break
248        }
249      }
250    }
251  })
252
253  ## Success
254  status <- "ok"
255
256  if (isTRUE(res$visible)) {
257    res$value
258  } else {
259    invisible(res$value)
260  }
261}
262