1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
#' Aggregate Progression Conditions
#'
#' @param progress A [progressor] function.
#'
#' @return A function of class `progress_aggregator`.
#'
#' @example incl/progress_aggregator.R
#'
#' @keywords internal
#' @export
progress_aggregator <- function(progress) {
stop_if_not(inherits(progress, "progressor"))
## Here we can find out how many steps the progressor function wants
max_steps <- environment(progress)$steps
handler <- function(p) {
stop_if_not(inherits(p, "progression"))
type <- p$type
debug <- getOption("progressr.debug", FALSE)
if (debug) {
mprintf("Progression handler %s ...", sQuote(type))
on.exit(mprintf("Progression handler %s ... done", sQuote(type)))
mprintf("- progression:")
mstr(p)
mprintf("- progressor_uuid: %s", p$progressor_uuid)
mprintf("- progression_index: %d", p$progression_index)
}
if (type == "initiate") {
} else if (type == "finish") {
} else if (type == "reset") {
} else if (type == "shutdown") {
} else if (type == "update") {
progress(child = p)
} else {
## Was this meant to be a 'control_progression' condition?
if (type %in% c("reset", "shutdown", "hide", "unhide", "interrupt")) {
stop("Unsupported 'progression' type. Was it meant to be a 'control_progression' condition?: ", sQuote(type))
} else {
stop("Unknown 'progression' type: ", sQuote(type))
}
}
## Prevent upstream calling handlers to receive progression 'p'
invokeRestart("muffleProgression")
}
handler <- make_progression_handler("progress_aggregator", handler = handler)
fcn <- function(...) {
with_progress(..., handlers = handler)
}
class(fcn) <- c("progress_aggregator", class(fcn))
fcn
}
|
