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
|
#' Progression Handler: Progress Reported as a MS Windows Progress Bars in the GUI
#'
#' A progression handler for `winProgressBar()` in the \pkg{utils} package.
#'
#' @inheritParams make_progression_handler
#'
#' @param inputs (named list) Specifies from what sources the MS Windows
#' progress elements 'title' and 'label' should be updated. Valid sources are
#' `"message"`, `"sticky_message"` and `"non_sticky_message"`, where
#' `"message"` is short for `c("non_sticky_message", "sticky_message")`. For
#' example, `inputs = list(title = "sticky_message", label = "message")`
#' will update the 'title' component from sticky messages only,
#' whereas the 'label' component is updated using any message.
#'
#' @param \ldots Additional arguments passed to [make_progression_handler()].
#'
#' @examples
#' \donttest{\dontrun{
#' handlers(handler_winprogressbar())
#' with_progress(y <- slow_sum(1:100))
#' }}
#'
#' @section Requirements:
#' This progression handler requires MS Windows.
#'
#' @export
handler_winprogressbar <- function(intrusiveness = getOption("progressr.intrusiveness.gui", 1), target = "gui", inputs = list(title = NULL, label = "message"), ...) {
## Additional arguments passed to the progress-handler backend
## Used for package testing purposes only when we want to perform
## everything except the last part where the backend is called
if (!is_fake("handler_winprogressbar")) {
if (.Platform$OS.type != "windows") {
stop("handler_winprogressbar requires MS Windows: ",
sQuote(.Platform$OS.type))
}
## Import functions
winProgressBar <- utils::winProgressBar
setWinProgressBar <- utils::setWinProgressBar
} else {
winProgressBar <- function(title = "R progress bar", label = "", min = 0, max = 1, initial = 0, width = 300) rawConnection(raw(0L))
setWinProgressBar <- function(pb, value, title = NULL, label = NULL) NULL
}
stop_if_not(
is.list(inputs),
!is.null(names(inputs)),
all(names(inputs) %in% c("title", "label")),
all(vapply(inputs, FUN = function(x) {
if (is.null(x)) return(TRUE)
if (!is.character(x)) return(FALSE)
x %in% c("message", "non_sticky_message", "sticky_message")
}, FUN.VALUE = FALSE))
)
## Expand 'message' => c("non_sticky_message", "sticky_message")
for (name in names(inputs)) {
input <- inputs[[name]]
if ("message" %in% input) {
input <- setdiff(input, "message")
input <- c(input, "non_sticky_message", "sticky_message")
}
inputs[[name]] <- unique(input)
}
backend_args <- handler_backend_args(...)
reporter <- local({
pb_config <- NULL
## Update winProgressBar
update_pb <- function(state, progression, ...) {
## Update 'title' and 'label' (optional)
args <- message_to_backend_targets(progression, inputs = inputs, ...)
for (name in names(args)) pb_config[[name]] <<- args[[name]]
## Update progress bar
args <- pb_config
args$value <- state$step
do.call(what = setWinProgressBar, args = args)
}
list(
reset = function(...) {
pb_config <<- NULL
},
initiate = function(config, state, progression, ...) {
if (!state$enabled || config$times == 1L) return()
## NOTE: 'pb_config' may be re-used for winProgressBar:s
if (config$clear) stop_if_not(is.null(pb_config))
args <- c(
backend_args,
list(max = config$max_steps, initial = state$step),
list(...)
)
## winProgressBar() arguments 'title' and 'label' must not be NULL;
## use the defaults
for (name in c("title", "label")) {
if (is.null(args[[name]])) {
args[[name]] <- formals(winProgressBar)[[name]]
}
}
## WORKAROUND: If the progress bar is created with label = "", then
## it will *not* be possible to modify it with winSetProgressBar()
## afterward, cf. "Space will be allocated for the label only if
## it is non-empty" in help("winProgressBar", package = "utils").
if (args$label == "") args$label <- " "
## Create progress bar
args <- args[names(args) %in% names(formals(winProgressBar))]
pb <- do.call(winProgressBar, args = args)
## Record arguments used by setWinProgressBar() later on
args$pb <- pb
args <- args[names(args) %in% names(formals(setWinProgressBar))]
pb_config <<- args
pb_config
},
interrupt = function(config, state, progression, ...) {
if (!state$enabled) return()
msg <- conditionMessage(progression)
update_pb(state, progression, message = msg)
},
update = function(config, state, progression, ...) {
if (!state$enabled || config$times <= 2L) return()
update_pb(state, progression)
},
finish = function(config, state, progression, ...) {
## Already finished?
if (is.null(pb_config)) return()
if (!state$enabled) return()
if (config$clear) {
close(pb_config$pb)
pb_config <<- NULL
} else {
update_pb(state, progression)
}
}
)
})
make_progression_handler("winprogressbar", reporter, intrusiveness = intrusiveness, target = target, ...)
}
|
