/
dlg_message.R
337 lines (320 loc) · 11.4 KB
/
dlg_message.R
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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
#' Display a modal message box.
#'
#' A message box with icon, text, and one to three buttons.
#'
#' @param message The message to display in the dialog box. Use `\\n` for line
#' break, or provide a vector of character strings, one for each line (except under RStudio where it is not possible to force line break inside the message string).
#' @param type The type of dialog box: `'ok'`, `'okcancel'`, `'yesno'` or
#' `'yesnocancel'`.
#' @param ... Pass further arguments to methods.
#' @param gui The 'gui' object concerned by this dialog box.
#' @return The modified 'gui' object is returned invisibly. A string with the
#' name of the button (`"ok"`, `"cancel"`, `"yes"` or `"no"`) that the user
#' pressed can be obtained from `gui$res` (see example).
#' `msg_box()` just returns the name of the button (`"ok"`), while
#' `ok_cancel_box()` returns `TRUE` if "ok" was clicked or `FALSE` if "cancel"
#' was clicked.
#' @note On 'RStudio' or with 'zenity' under Linux, only two buttons are
#' available. So, when using `type = "yesnocancel"`, two successive dialog boxes
#' are displayed: one with the message and `'yes'`/`'no'` buttons, and a second
#' one asking to continue, and if the user clicks `'no'`, the function returns
#' `"cancel"`. This is clearly sub-optimal. So, for a clean experience on all
#' supported platforms, try to avoid `'yesnocancel'` as much as possible.
#' @export
#' @name dlg_message
#' @seealso [dlg_list()], [dlg_input()]
#' @keywords misc
#' @concept Modal dialog box
#' @examples
#' \dontrun{
#' # A simple information box
#' dlg_message("Hello world!")$res
#'
#' # Ask to continue
#' dlg_message(c("This is a long task!", "Continue?"), "okcancel")$res
#'
#' # Ask a question
#' dlg_message("Do you like apples?", "yesno")$res
#'
#' # Idem, but one can interrupt too
#' res <- dlg_message("Do you like oranges?", "yesnocancel")$res
#' if (res == "cancel")
#' cat("Ah, ah! You refuse to answer!\n")
#'
#' # Simpler version with msgBox and okCancelBox
#' msg_box("Information message") # Use this to interrupt script and inform user
#' if (ok_cancel_box("Continue?")) cat("we continue\n") else cat("stop it!\n")
#' }
dlg_message <- function(message, type = c("ok", "okcancel", "yesno",
"yesnocancel"), ..., gui = .GUI) {
# Define the S3 method
if (!gui$startUI("dlg_message", call = match.call(), default = "ok",
msg = "Displaying a modal message dialog box",
msg.no.ask = "A modal message dialog box was by-passed"))
return(invisible(gui))
# Check and rework main arguments and place them in gui$args
if (missing(message))
message <- "[Your message here...]"
message <- paste(as.character(message), collapse = "\n")
type <- match.arg(type)
gui$setUI(args = list(message = message, type = type))
# ... and dispatch to the method
UseMethod("dlg_message", gui)
}
#' @export
#' @rdname dlg_message
dlgMessage <- dlg_message # Backward compatibility
#' @export
#' @rdname dlg_message
msg_box <- function(message) {
# Simplified versions of dlg_message()
dlg_message(message = message)$res
}
#' @export
#' @rdname dlg_message
msgBox <- msg_box # Backward compatibility
#' @export
#' @rdname dlg_message
ok_cancel_box <- function(message) {
dlg_message(message = message, type = "okcancel")$res == "ok"
}
#' @export
#' @rdname dlg_message
okCancelBox <- ok_cancel_box # Backward compatibility
#' @export
#' @rdname dlg_message
dlg_message.gui <- function(message, type = c("ok", "okcancel", "yesno",
"yesnocancel"), ..., gui = .GUI) {
# Used to break the chain of NextMethod(), searching for a usable method
# in the current context
msg <- paste("No workable method available to display",
"a message dialog box using:")
msg <- paste(msg, paste(guiWidgets(gui), collapse = ", "))
gui$setUI(status = "error", msg = msg, widgets = "none")
stop(msg)
}
#' @export
#' @rdname dlg_message
dlg_message.textCLI <- function(message, type = c("ok", "okcancel", "yesno",
"yesnocancel"), ..., gui = .GUI) {
# The pure textual version used a fallback in case no GUI could be used
gui$setUI(widgets = "textCLI")
# Display the message and wait for user action
if (gui$args$type == "ok") {
readline(paste0(gui$args$message, "\n(hit ENTER to continue) "))
res <- "ok"
} else {
# Use a non-graphical select.list() for the others
choices <- switch(gui$args$type,
okcancel = c("ok", "cancel"),
yesno = c("yes", "no"),
yesnocancel = c("yes", "no", "cancel")
)
res <- select.list(choices, title = gui$args$message, graphics = FALSE)
if (res == "" && type != "yesno") res <- "cancel"
if (res == "") res <- "no" # Selection of 0 with yes/no => no
}
gui$setUI(res = res, status = NULL)
invisible(gui)
}
#' @inheritParams get_system
#' @export
#' @rdname dlg_message
dlg_message.nativeGUI <- function(message, type = c("ok", "okcancel", "yesno",
"yesnocancel"), rstudio = getOption("svDialogs.rstudio", TRUE), ...,
gui = .GUI) {
# The native version of the message box
gui$setUI(widgets = "nativeGUI")
# A simple message box
# type can be 'ok' (info), 'okcancel', 'yesno', 'yesnocancel' (question)
# This dialog box is always modal
# Returns invisibly a character with the button that was pressed
res <- switch(get_system(rstudio),
RStudio = .rstudio_dlg_message(gui$args$message, gui$args$type),
Windows = .win_dlg_message(gui$args$message, gui$args$type),
Darwin = .mac_dlg_message(gui$args$message, gui$args$type),
.unix_dlg_message(gui$args$message, gui$args$type, ...)
)
# Do we need to further dispatch?
if (is.null(res)) {
NextMethod("dlg_message", gui)
} else {
gui$setUI(res = res, status = NULL)
invisible(gui)
}
}
# RStudio version (need at least version 1.1.67)
# No yesnocancel box => ask in two stages (ugly, but what to do?)
.rstudio_dlg_message <- function(message, type = c("ok", "okcancel", "yesno",
"yesnocancel")) {
if (rstudioapi::getVersion() < '1.1.67')
return(NULL)
type <- match.arg(type)
if (type == "ok") {
alarm()
rstudioapi::showDialog(title = "R Message", message = message,
url = "")
return(invisible("ok"))
} else if (type == "yesnocancel") {
type <- "yesno"
confirm <- TRUE
} else confirm <- FALSE
# Now, we have only "okcancel" or "yesno"
if (type == "okcancel") {
res <- rstudioapi::showQuestion(title = "R Question", message = message,
ok = "OK", cancel = "Cancel")
if (res) res <- "ok" else res <- "cancel"
} else {
res <- rstudioapi::showQuestion(title = "R Question", message = message,
ok = "Yes", cancel = "No")
if (res) res <- "yes" else res <- "no"
}
# Do we ask to continue (if was yesnocancel)?
if (confirm) {
res2 <- rstudioapi::showQuestion(title = "R Question",
message = "Continue?", ok = "Yes", cancel = "No")
if (!res2) res <- "cancel"
}
res
}
# Windows version
.win_dlg_message <- function(message, type = c("ok", "okcancel", "yesno",
"yesnocancel")) {
res <- winDialog(type = type, message = message)
# Rework result to match the result from the other functions
if (type == "ok") {
invisible("ok")
} else {
tolower(res)
}
}
# MacOS version
.mac_dlg_message <- function(message, type= c("ok", "okcancel", "yesno",
"yesnocancel")) {
message <- .replace_quotes(message)
# Display a modal message with native Mac dialog box
#if (.Platform$GUI == "AQUA") app <- "(name of application \"R\")" else
# This works from Mac OS X 10.5 Leopard:
if (.Platform$GUI == "AQUA") {
app <- "(name of application id \"Rgui\")"
} else if (.is_jgr()) {
app <- "\"JGR\""
} else {
app <- "\"Terminal\""
}
type <- match.arg(type)
buttons <- switch(type,
ok = "\"OK\"",
okcancel = "\"Cancel\",\"OK\"",
yesno = "\"No\",\"Yes\"",
yesnocancel = ",\"Cancel\",\"No\",\"Yes\"",
stop("type can only be 'ok', 'okcancel', 'yesno', 'yesnocancel'"))
if (type == "ok") {
beep <- " -e 'beep'"
icon <- "caution"
title <- "\"Information\""
more <- " default button 1"
} else {
beep <- ""
icon <- "note"
title <- "\"Question\""
if (type == "yesnocancel")
more <- " default button 3 cancel button 1" else
if (type == "yesno") more <- " default button 2" else
more <- " default button 2 cancel button 1"
}
# TODO: Escape single and double quotes in message
cmd <- paste0("exit `osascript", beep, " -e 'tell application ", app,
" to set dlg to display dialog \"", message, "\" with title ", title,
more, " with icon ", icon, " buttons {", buttons,
"}' -e 'if button returned of dlg is \"No\" then 2' 2> /dev/null`")
res <- system(cmd, ignore.stdout = TRUE, ignore.stderr = TRUE, wait = TRUE)
# Decrypt result
if (type == "ok") {
if (res > 0) {
return(NULL)
} else {
return(invisible("ok"))
}
}
if (res == 2)
return("no")
if (res == 1)
return("cancel")
if (type == "okcancel") {
return("ok")
} else {
return("yes")
}
}
# Linux/Unix version
.unix_dlg_message <- function(message, type = c("ok", "okcancel", "yesno",
"yesnocancel"), zenity = FALSE) {
message <- .escape_quotes(message)
exec <- .get_yad_or_zenity(zenity)
if (exec == "")
return(NULL) # Try next method
is_yad <- attr(exec, "is_yad")
exec <- as.character(exec)
type <- match.arg(type)
if (type == "ok") {
alarm()
if (is_yad) {
msg <- paste("'", exec, "' --image=gtk-dialog-info --text=\"", message,
"\" --title=\"Information\" --button=OK:0 --on-top --skip-taskbar",
sep = "")
} else {# zenity
msg <- paste("'", exec, "' --info --text=\"", message,
"\" --title=\"Information\"", sep = "")
}
system(msg)
return("ok")
} else if (is_yad) {
msg <- switch(type,
yesno = paste0("'", exec, "' --image=gtk-dialog-question --text=\"",
message, "\" --button=No:1 --button=Yes:0 --title=\"Question\"",
"--on-top --skip-taskbar"),
okcancel = paste0("'", exec, "' --image=gtk-dialog-question --text=\"",
message, "\" --button=Cancel:1 --button=OK:0 --title=\"Question\"",
"--on-top --skip-taskbar"),
yesnocancel = paste0("'", exec, "' --image=gtk-dialog-question --text=\"",
message, "\" --button=Cancel:2 --button=No:1 --button=Yes:0",
" --title=\"Question\" --on-top --skip-taskbar"),
stop("unknown type"))
results <- switch(type,
yesno = c("yes", "no"),
okcancel = c("ok", "cancel"),
yesnocancel = c("yes", "no", "cancel"),
stop("unknown type"))
res <- system(msg)
if (res > length(results) - 1)
res <- length(results) - 1 # Use last item by default
res <- results[res + 1]
} else {# This is zenity
if (type == "yesnocancel") {
type <- "yesno"
confirm <- TRUE
} else confirm <- FALSE
# Now, we have only "okcancel" or "yesno"
if (type == "okcancel") {
msg <- paste0("'", exec, "' --question --text=\"", message,
"\" --ok-label=\"OK\" --cancel-label=\"Cancel\" --title=\"Question\"")
results <- c("ok", "cancel")
} else {
msg <- paste0("'", exec, "' --question --text=\"", message,
"\" --ok-label=\"Yes\" --cancel-label=\"No\" --title=\"Question\"")
results <- c("yes", "no")
}
res <- system(msg)
if (res > 1) res <- 1
res <- results[res + 1]
# Do we ask to continue (if was yesnocancel)?
if (confirm) {
conf <- system(paste0("'", exec, "' --question --text=\"Continue?\"",
" --ok-label=\"OK\" --cancel-label=\"Cancel\" --title=\"Confirm\""))
if (conf == 1)
res <- "cancel"
}
}
res
}