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
|
#' Progression Handler: Progress Reported as a Tcl/Tk Progress Bars in the GUI
#'
#' A progression handler for [tcltk::tkProgressBar()].
#'
#' @inheritParams make_progression_handler
#' @inheritParams handler_winprogressbar
#'
#' @param \ldots Additional arguments passed to [make_progression_handler()].
#'
#' @example incl/handler_tkprogressbar.R
#'
#' @section Requirements:
#' This progression handler requires the \pkg{tcltk} package and that the
#' current R session supports Tcl/Tk (`capabilities("tcltk")`).
#'
#' @export
handler_tkprogressbar <- function(intrusiveness = getOption("progressr.intrusiveness.gui", 1), target = "terminal", inputs = list(title = NULL, label = "message"), ...) {
## Additional arguments passed to the progress-handler backend
backend_args <- handler_backend_args(...)
## 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_tkprogressbar")) {
if (!capabilities("tcltk")) {
stop("handler_tkprogressbar requires TclTk support")
}
## Import functions
tkProgressBar <- tcltk::tkProgressBar
setTkProgressBar <- tcltk::setTkProgressBar
} else {
tkProgressBar <- function(title = "R progress bar", label = "", min = 0, max = 1, initial = 0, width = 300) rawConnection(raw(0L))
setTkProgressBar <- 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 tkProgressBar
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 = setTkProgressBar, 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 tkProgressBar:s
if (config$clear) stop_if_not(is.null(pb_config))
args <- c(
backend_args,
list(max = config$max_steps, initial = state$step),
list(...)
)
## tkProgressBar() 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(tkProgressBar)[[name]]
}
}
## Create progress bar
args <- args[names(args) %in% names(formals(tkProgressBar))]
pb <- do.call(tkProgressBar, args = args)
## Record arguments used by setTkProgressBar() later on
args$pb <- pb
args <- args[names(args) %in% names(formals(setTkProgressBar))]
pb_config <<- args
},
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("tkprogressbar", reporter, intrusiveness = intrusiveness, target = target, ...)
}
|
