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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
#' Progression Handler: Progress Reported via 'pbmcapply' Progress Bars (Text) in the Terminal
#'
#' A progression handler for [pbmcapply::progressBar()].
#'
#' @inheritParams make_progression_handler
#'
#' @inheritParams handler_txtprogressbar
#'
#' @param char (character) The symbols to form the progress bar for
#' [utils::txtProgressBar()].
#'
#' @param style (character) The progress-bar style according to
#" [pbmcapply::progressBar()].
#'
#' @param substyle (integer) The progress-bar substyle according to
#' [pbmcapply::progressBar()].
#'
#' @param \ldots Additional arguments passed to [make_progression_handler()].
#'
#' @section Requirements:
#' This progression handler requires the \pkg{pbmcapply} package.
#'
#' @section Appearance:
#' Below are a few examples on how to use and customize this progress handler.
#' In all cases, we use `handlers(global = TRUE)`.
#' Since `style = "txt"` corresponds to using [handler_txtprogressbar()]
#' with `style = substyle`, the main usage of this handler is with
#' `style = "ETA"` (default) for which `substyle` is ignored.
#'
#' ```{asciicast handler_pbmcapply-default}
#' #| asciicast_at = "all",
#' #| asciicast_knitr_output = "svg",
#' #| asciicast_cursor = FALSE
#' handlers("pbmcapply")
#' y <- slow_sum(1:25)
#' ```
#'
#' @example incl/handler_pbmcapply.R
#'
#' @importFrom utils file_test flush.console txtProgressBar setTxtProgressBar
#' @export
handler_pbmcapply <- function(char = "=", substyle = 3L, style = "ETA", file = stderr(), intrusiveness = getOption("progressr.intrusiveness.terminal", 1), target = "terminal", ...) {
## Additional arguments passed to the progress-handler backend
backend_args <- handler_backend_args(char = char, substyle = substyle, style = style, ...)
if (!is_fake("handler_pbmcapply")) {
progressBar <- pbmcapply::progressBar
eraseTxtProgressBar <- function(pb) {
pb_env <- environment(pb$getVal)
with(pb_env, {
style_eta <- exists(".time0", inherits = FALSE)
if (!style_eta) {
if (style == 1L || style == 2L) {
n <- .nb
} else if (style == 3L) {
n <- 3L + nw * width + 6L
}
} else {
## FIXME: Seems to work; if not, see pbmcapply:::txtProgressBarETA()
n <- width
}
cat("\r", strrep(" ", times = n), "\r", sep = "", file = file)
.nb <- 0L
flush.console()
})
}
} else {
progressBar <- function(..., style, substyle) txtProgressBar(..., style = substyle)
setTxtProgressBar <- function(...) NULL
eraseTxtProgressBar <- function(pb) NULL
redrawTxtProgressBar <- function(pb) NULL
}
reporter <- local({
## Import functions
pb <- NULL
make_pb <- function(max, ...) {
if (!is.null(pb)) return(pb)
## SPECIAL CASE: pbmcapply::progressBar() does not support max == min
## (its 'min' argument defaults to 0)
if (max == 0) {
pb_tmp <- txtProgressBar()
class(pb_tmp) <- c("voidProgressBar", class(pb_tmp))
} else {
args <- c(list(max = max, ...), backend_args)
pb_tmp <- do.call(progressBar, args = args)
}
pb <<- pb_tmp
pb
}
list(
reset = function(...) {
pb <<- NULL
},
hide = function(...) {
if (is.null(pb)) return()
eraseTxtProgressBar(pb)
},
unhide = function(...) {
if (is.null(pb)) return()
redrawTxtProgressBar(pb)
},
interrupt = function(config, state, progression, ...) {
eraseTxtProgressBar(pb)
redrawTxtProgressBar(pb)
msg <- conditionMessage(progression)
msg <- paste(c("", msg, ""), collapse = "\n")
cat(msg, file = file)
},
initiate = function(config, state, progression, ...) {
if (!state$enabled || config$times == 1L) return()
stop_if_not(is.null(pb))
make_pb(max = config$max_steps, file = file)
},
update = function(config, state, progression, ...) {
if (!state$enabled || config$times <= 2L) return()
make_pb(max = config$max_steps, file = file)
stop_if_not(!is.null(pb))
if (inherits(progression, "sticky")) {
eraseTxtProgressBar(pb)
message(paste0(state$message, ""))
redrawTxtProgressBar(pb)
}
if (progression$amount == 0) return()
setTxtProgressBar(pb, value = state$step)
},
finish = function(config, state, progression, ...) {
## Already finished?
if (is.null(pb)) return()
if (!state$enabled) return()
if (config$clear) {
eraseTxtProgressBar(pb)
## Suppress newline outputted by close()
pb_env <- environment(pb$getVal)
file <- pb_env$file
pb_env$file <- tempfile()
on.exit({
if (file_test("-f", pb_env$file)) file.remove(pb_env$file)
pb_env$file <- file
})
} else {
setTxtProgressBar(pb, value = state$step)
}
close(pb)
pb <<- NULL
}
)
})
make_progression_handler("pbmcapply", reporter, intrusiveness = intrusiveness, target = target, ...)
}
|
