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