1 |
#' Include `CSS` files from `/inst/css/` package directory to application header |
|
2 |
#' |
|
3 |
#' `system.file` should not be used to access files in other packages, it does |
|
4 |
#' not work with `devtools`. Therefore, we redefine this method in each package |
|
5 |
#' as needed. Thus, we do not export this method |
|
6 |
#' |
|
7 |
#' @param pattern (`character`) pattern of files to be included |
|
8 |
#' |
|
9 |
#' @return HTML code that includes `CSS` files |
|
10 |
#' @keywords internal |
|
11 |
include_css_files <- function(pattern = "*") { |
|
12 | 2x |
css_files <- list.files( |
13 | 2x |
system.file("css", package = "teal.widgets", mustWork = TRUE), |
14 | 2x |
pattern = pattern, full.names = TRUE |
15 |
) |
|
16 | 2x |
if (length(css_files) == 0) { |
17 | ! |
return(NULL) |
18 |
} |
|
19 | 2x |
return(shiny::singleton(tags$head(lapply(css_files, shiny::includeCSS)))) |
20 |
} |
1 |
#' @name plot_with_settings |
|
2 |
#' @rdname plot_with_settings |
|
3 |
#' @export |
|
4 |
plot_with_settings_ui <- function(id) { |
|
5 | 1x |
checkmate::assert_string(id) |
6 | ||
7 | 1x |
ns <- NS(id) |
8 | ||
9 | 1x |
tagList( |
10 | 1x |
shiny::singleton(tags$head( |
11 | 1x |
shiny::includeScript(system.file("js", "resize_plot.js", package = "teal.widgets")), |
12 | 1x |
tags$script( |
13 | 1x |
sprintf( |
14 | 1x |
'establishPlotResizing("%s", "%s", "%s");', |
15 | 1x |
ns("plot_main"), # graph parent id |
16 | 1x |
ns("flex_width"), # session input$ variable name |
17 | 1x |
ns("plot_modal_width") # session input$ variable name |
18 |
) |
|
19 |
) |
|
20 |
)), |
|
21 | 1x |
include_css_files("plot_with_settings"), |
22 | 1x |
tags$div( |
23 | 1x |
id = ns("plot-with-settings"), |
24 | 1x |
tags$div( |
25 | 1x |
class = "plot-settings-buttons", |
26 | 1x |
type_download_ui(ns("downbutton")), |
27 | 1x |
actionButton( |
28 | 1x |
ns("expand"), |
29 | 1x |
label = character(0), |
30 | 1x |
icon = icon("up-right-and-down-left-from-center"), |
31 | 1x |
class = "btn-sm" |
32 |
), |
|
33 | 1x |
shinyWidgets::dropdownButton( |
34 | 1x |
circle = FALSE, |
35 | 1x |
icon = icon("maximize"), |
36 | 1x |
inline = TRUE, |
37 | 1x |
right = TRUE, |
38 | 1x |
label = "", |
39 | 1x |
inputId = ns("expbut"), |
40 | 1x |
uiOutput(ns("slider_ui")), |
41 | 1x |
uiOutput(ns("width_warning")) |
42 |
) |
|
43 |
), |
|
44 | 1x |
uiOutput(ns("plot_out_main"), class = "plot_out_container", width = "100%") |
45 |
) |
|
46 |
) |
|
47 |
} |
|
48 | ||
49 |
#' Plot-with-settings module |
|
50 |
#' |
|
51 |
#' @rdname plot_with_settings |
|
52 |
#' @description `r lifecycle::badge("stable")`\cr |
|
53 |
#' Universal module for plots with settings for height, width, and download. |
|
54 |
#' |
|
55 |
#' @export |
|
56 |
#' |
|
57 |
#' @param id (`character(1)`) `shiny` module id. |
|
58 |
#' |
|
59 |
#' @param plot_r (`reactive` or `function`)\cr |
|
60 |
#' `reactive` expression or a simple `function` to draw a plot. |
|
61 |
#' A simple `function` is needed e.g. for base plots like `plot(1)` as the output can not be caught when downloading. |
|
62 |
#' Take into account that simple functions are less efficient than reactive, as not catching the result. |
|
63 |
#' @param height (`numeric`) optional\cr |
|
64 |
#' vector with three elements c(VAL, MIN, MAX), where VAL is the starting value of the slider in |
|
65 |
#' the main and modal plot display. The value in the modal display is taken from the value of the |
|
66 |
#' slider in the main plot display. |
|
67 |
#' @param width (`numeric`) optional\cr |
|
68 |
#' vector with three elements `c(VAL, MIN, MAX)`, where VAL is the starting value of the slider in |
|
69 |
#' the main and modal plot display; `NULL` for default display. The value in the modal |
|
70 |
#' display is taken from the value of the slider in the main plot display. |
|
71 |
#' @param show_hide_signal optional, (`reactive logical` a mechanism to allow modules which call this |
|
72 |
#' module to show/hide the plot_with_settings UI) |
|
73 |
#' @param brushing (`logical`) optional\cr |
|
74 |
#' mechanism to enable / disable brushing on the main plot (in particular: not the one displayed |
|
75 |
#' in modal). All the brushing data is stored as a reactive object in the `"brush"` element of |
|
76 |
#' returned list. See the example for details. |
|
77 |
#' @param clicking (`logical`)\cr |
|
78 |
#' a mechanism to enable / disable clicking on data points on the main plot (in particular: not the |
|
79 |
#' one displayed in modal). All the clicking data is stored as a reactive object in the `"click"` |
|
80 |
#' element of returned list. See the example for details. |
|
81 |
#' @param dblclicking (`logical`) optional\cr |
|
82 |
#' mechanism to enable / disable double-clicking on data points on the main plot (in particular: |
|
83 |
#' not the one displayed in modal). All the double clicking data is stored as a reactive object in |
|
84 |
#' the `"dblclick"` element of returned list. See the example for details. |
|
85 |
#' @param hovering (`logical(1)`) optional\cr |
|
86 |
#' mechanism to enable / disable hovering over data points on the main plot (in particular: not |
|
87 |
#' the one displayed in modal). All the hovering data is stored as a reactive object in the |
|
88 |
#' `"hover"` element of returned list. See the example for details. |
|
89 |
#' @param graph_align (`character(1)`) optional,\cr |
|
90 |
#' one of `"left"` (default), `"center"`, `"right"` or `"justify"`. The alignment of the graph on |
|
91 |
#' the main page. |
|
92 |
#' |
|
93 |
#' @details By default the plot is rendered with `72 dpi`. In order to change this, to for example 96 set |
|
94 |
#' `options(teal.plot_dpi = 96)`. The minimum allowed `dpi` value is `24` and it must be a whole number. |
|
95 |
#' If an invalid value is set then the default value is used and a warning is outputted to the console. |
|
96 |
#' |
|
97 |
#' @return A `shiny` module. |
|
98 |
#' |
|
99 |
#' @examples |
|
100 |
#' # Example using a reactive as input to plot_r |
|
101 |
#' library(shiny) |
|
102 |
#' library(ggplot2) |
|
103 |
#' |
|
104 |
#' ui <- fluidPage( |
|
105 |
#' plot_with_settings_ui( |
|
106 |
#' id = "plot_with_settings" |
|
107 |
#' ) |
|
108 |
#' ) |
|
109 |
#' |
|
110 |
#' server <- function(input, output, session) { |
|
111 |
#' plot_r <- reactive({ |
|
112 |
#' ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + |
|
113 |
#' geom_point() |
|
114 |
#' }) |
|
115 |
#' |
|
116 |
#' plot_with_settings_srv( |
|
117 |
#' id = "plot_with_settings", |
|
118 |
#' plot_r = plot_r, |
|
119 |
#' height = c(400, 100, 1200), |
|
120 |
#' width = c(500, 250, 750) |
|
121 |
#' ) |
|
122 |
#' } |
|
123 |
#' |
|
124 |
#' if (interactive()) { |
|
125 |
#' shinyApp(ui, server) |
|
126 |
#' } |
|
127 |
#' |
|
128 |
#' # Example using a function as input to plot_r |
|
129 |
#' library(lattice) |
|
130 |
#' |
|
131 |
#' ui <- fluidPage( |
|
132 |
#' radioButtons("download_option", "Select the Option", list("ggplot", "trellis", "grob", "base")), |
|
133 |
#' plot_with_settings_ui( |
|
134 |
#' id = "plot_with_settings" |
|
135 |
#' ), |
|
136 |
#' sliderInput("nums", "Value", 1, 10, 1) |
|
137 |
#' ) |
|
138 |
#' |
|
139 |
#' server <- function(input, output, session) { |
|
140 |
#' plot_r <- function() { |
|
141 |
#' numbers <- seq_len(input$nums) |
|
142 |
#' if (input$download_option == "ggplot") { |
|
143 |
#' ggplot(data.frame(n = numbers), aes(.data$n)) + |
|
144 |
#' geom_bar() |
|
145 |
#' } else if (input$download_option == "trellis") { |
|
146 |
#' densityplot(numbers) |
|
147 |
#' } else if (input$download_option == "grob") { |
|
148 |
#' tr_plot <- densityplot(numbers) |
|
149 |
#' ggplotGrob( |
|
150 |
#' ggplot(data.frame(n = numbers), aes(.data$n)) + |
|
151 |
#' geom_bar() |
|
152 |
#' ) |
|
153 |
#' } else if (input$download_option == "base") { |
|
154 |
#' plot(numbers) |
|
155 |
#' } |
|
156 |
#' } |
|
157 |
#' |
|
158 |
#' plot_with_settings_srv( |
|
159 |
#' id = "plot_with_settings", |
|
160 |
#' plot_r = plot_r, |
|
161 |
#' height = c(400, 100, 1200), |
|
162 |
#' width = c(500, 250, 750) |
|
163 |
#' ) |
|
164 |
#' } |
|
165 |
#' |
|
166 |
#' if (interactive()) { |
|
167 |
#' shinyApp(ui, server) |
|
168 |
#' } |
|
169 |
#' |
|
170 |
#' # Example with brushing/hovering/clicking/double-clicking |
|
171 |
#' ui <- fluidPage( |
|
172 |
#' plot_with_settings_ui( |
|
173 |
#' id = "plot_with_settings" |
|
174 |
#' ), |
|
175 |
#' fluidRow( |
|
176 |
#' column(4, tags$h3("Brush"), verbatimTextOutput("brushing_data")), |
|
177 |
#' column(4, tags$h3("Click"), verbatimTextOutput("clicking_data")), |
|
178 |
#' column(4, tags$h3("DblClick"), verbatimTextOutput("dblclicking_data")), |
|
179 |
#' column(4, tags$h3("Hover"), verbatimTextOutput("hovering_data")) |
|
180 |
#' ) |
|
181 |
#' ) |
|
182 |
#' |
|
183 |
#' server <- function(input, output, session) { |
|
184 |
#' plot_r <- reactive({ |
|
185 |
#' ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + |
|
186 |
#' geom_point() |
|
187 |
#' }) |
|
188 |
#' |
|
189 |
#' plot_data <- plot_with_settings_srv( |
|
190 |
#' id = "plot_with_settings", |
|
191 |
#' plot_r = plot_r, |
|
192 |
#' height = c(400, 100, 1200), |
|
193 |
#' brushing = TRUE, |
|
194 |
#' clicking = TRUE, |
|
195 |
#' dblclicking = TRUE, |
|
196 |
#' hovering = TRUE |
|
197 |
#' ) |
|
198 |
#' |
|
199 |
#' output$brushing_data <- renderPrint(plot_data$brush()) |
|
200 |
#' output$clicking_data <- renderPrint(plot_data$click()) |
|
201 |
#' output$dblclicking_data <- renderPrint(plot_data$dblclick()) |
|
202 |
#' output$hovering_data <- renderPrint(plot_data$hover()) |
|
203 |
#' } |
|
204 |
#' |
|
205 |
#' if (interactive()) { |
|
206 |
#' shinyApp(ui, server) |
|
207 |
#' } |
|
208 |
#' |
|
209 |
#' # Example which allows module to be hidden/shown |
|
210 |
#' library("shinyjs") |
|
211 |
#' |
|
212 |
#' ui <- fluidPage( |
|
213 |
#' useShinyjs(), |
|
214 |
#' actionButton("button", "Show/Hide"), |
|
215 |
#' plot_with_settings_ui( |
|
216 |
#' id = "plot_with_settings" |
|
217 |
#' ) |
|
218 |
#' ) |
|
219 |
#' |
|
220 |
#' server <- function(input, output, session) { |
|
221 |
#' plot_r <- plot_r <- reactive( |
|
222 |
#' ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) + |
|
223 |
#' geom_point() |
|
224 |
#' ) |
|
225 |
#' |
|
226 |
#' show_hide_signal_rv <- reactiveVal(TRUE) |
|
227 |
#' |
|
228 |
#' observeEvent(input$button, show_hide_signal_rv(!show_hide_signal_rv())) |
|
229 |
#' |
|
230 |
#' plot_with_settings_srv( |
|
231 |
#' id = "plot_with_settings", |
|
232 |
#' plot_r = plot_r, |
|
233 |
#' height = c(400, 100, 1200), |
|
234 |
#' width = c(500, 250, 750), |
|
235 |
#' show_hide_signal = reactive(show_hide_signal_rv()) |
|
236 |
#' ) |
|
237 |
#' } |
|
238 |
#' |
|
239 |
#' if (interactive()) { |
|
240 |
#' shinyApp(ui, server) |
|
241 |
#' } |
|
242 |
#' |
|
243 |
plot_with_settings_srv <- function(id, |
|
244 |
plot_r, |
|
245 |
height = c(600, 200, 2000), |
|
246 |
width = NULL, |
|
247 |
show_hide_signal = reactive(TRUE), |
|
248 |
brushing = FALSE, |
|
249 |
clicking = FALSE, |
|
250 |
dblclicking = FALSE, |
|
251 |
hovering = FALSE, |
|
252 |
graph_align = "left") { |
|
253 | 23x |
checkmate::assert_string(id) |
254 | 23x |
checkmate::assert( |
255 | 23x |
checkmate::check_class(plot_r, "function"), |
256 | 23x |
checkmate::check_class(plot_r, "reactive") |
257 |
) |
|
258 | 22x |
checkmate::assert_numeric(height, min.len = 1, any.missing = FALSE) |
259 | 21x |
checkmate::assert_numeric(height, len = 3, any.missing = FALSE, finite = TRUE) |
260 | 21x |
checkmate::assert_numeric(height[1], lower = height[2], upper = height[3], .var.name = "height") |
261 | 21x |
checkmate::assert_numeric(width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
262 | 21x |
checkmate::assert_numeric(width[1], lower = width[2], upper = width[3], null.ok = TRUE, .var.name = "width") |
263 | ||
264 | 20x |
checkmate::assert_class(show_hide_signal, c("reactive", "function")) |
265 | 19x |
checkmate::assert_flag(brushing) |
266 | 18x |
checkmate::assert_flag(clicking) |
267 | 17x |
checkmate::assert_flag(dblclicking) |
268 | 16x |
checkmate::assert_flag(hovering) |
269 | 15x |
checkmate::assert_string(graph_align) |
270 | 15x |
checkmate::assert_subset(graph_align, c("left", "right", "center", "justify")) |
271 | ||
272 | 14x |
moduleServer(id, function(input, output, session) { |
273 | 14x |
ns <- session$ns |
274 | 14x |
default_w <- function() session$clientData[[paste0("output_", ns("plot_main_width"))]] |
275 | 14x |
default_h <- function() session$clientData[[paste0("output_", ns("plot_main_height"))]] |
276 | ||
277 | 14x |
default_slider_width <- reactiveVal(width) |
278 | 14x |
delayed_flex_width <- debounce(reactive(input$flex_width), millis = 100) |
279 | ||
280 | 14x |
if (is.null(width)) { |
281 |
# if width = NULL then set default_slider_width to be the value of the plot width on load |
|
282 | ! |
observeEvent(session$clientData[[paste0("output_", ns("plot_main_width"))]], |
283 | ! |
handlerExpr = { |
284 | ! |
default_slider_width(default_w() * c(1, 0.5, 2.8)) |
285 |
}, |
|
286 | ! |
once = TRUE, |
287 | ! |
ignoreNULL = TRUE |
288 |
) |
|
289 | ||
290 | ! |
observeEvent(delayed_flex_width(), { |
291 | ! |
if (delayed_flex_width() > 0 && !isFALSE(input$width_resize_switch)) { |
292 | ! |
default_slider_width(delayed_flex_width() * c(1, 0.5, 2.8)) |
293 | ! |
updateSliderInput(session, inputId = "width", value = delayed_flex_width()) |
294 |
} |
|
295 |
}) |
|
296 |
} |
|
297 | ||
298 | 14x |
plot_type <- reactive({ |
299 | 14x |
if (inherits(plot_r(), "ggplot")) { |
300 | 2x |
"gg" |
301 | 12x |
} else if (inherits(plot_r(), "trellis")) { |
302 | 2x |
"trel" |
303 | 10x |
} else if (inherits(plot_r(), "grob")) { |
304 | 2x |
"grob" |
305 | 8x |
} else if (inherits(plot_r(), c("NULL", "histogram", "list")) && !inherits(plot_r, "reactive")) { |
306 | 6x |
"base" |
307 |
} else { |
|
308 | 2x |
"other" |
309 |
} |
|
310 |
}) |
|
311 | ||
312 |
# allow modules which use this module to turn on and off the UI |
|
313 | 14x |
observeEvent(show_hide_signal(), { |
314 | 8x |
if (show_hide_signal()) { |
315 | 8x |
shinyjs::show("plot-with-settings") |
316 |
} else { |
|
317 | ! |
shinyjs::hide("plot-with-settings") |
318 |
} |
|
319 |
}) |
|
320 | ||
321 | 14x |
output$slider_ui <- renderUI({ |
322 | 8x |
tags$div( |
323 | 8x |
optionalSliderInputValMinMax( |
324 | 8x |
inputId = ns("height"), |
325 | 8x |
label = "Plot height", |
326 | 8x |
value_min_max = round(height), |
327 | 8x |
ticks = FALSE, |
328 | 8x |
step = 1L, |
329 | 8x |
round = TRUE |
330 |
), |
|
331 | 8x |
tags$b("Plot width"), |
332 | 8x |
shinyWidgets::switchInput( |
333 | 8x |
inputId = ns("width_resize_switch"), |
334 | 8x |
onLabel = "ON", |
335 | 8x |
offLabel = "OFF", |
336 | 8x |
label = "Auto width", |
337 | 8x |
value = `if`(is.null(width), TRUE, FALSE), |
338 | 8x |
size = "mini", |
339 | 8x |
labelWidth = "80px" |
340 |
), |
|
341 | 8x |
optionalSliderInputValMinMax( |
342 | 8x |
inputId = ns("width"), |
343 | 8x |
label = NULL, |
344 | 8x |
value_min_max = round(isolate(default_slider_width())), |
345 | 8x |
ticks = FALSE, |
346 | 8x |
step = 1L, |
347 | 8x |
round = TRUE |
348 |
) |
|
349 |
) |
|
350 |
}) |
|
351 | ||
352 | 14x |
observeEvent(input$width_resize_switch | delayed_flex_width(), { |
353 | 8x |
if (length(input$width_resize_switch) && input$width_resize_switch) { |
354 | ! |
shinyjs::disable("width") |
355 | ! |
updateSliderInput(session, inputId = "width", value = delayed_flex_width()) |
356 |
} else { |
|
357 | 8x |
shinyjs::enable("width") |
358 |
} |
|
359 |
}) |
|
360 | ||
361 | 14x |
ranges <- reactiveValues(x = NULL, y = NULL) |
362 | ||
363 | 14x |
observeEvent(input$plot_dblclick, { |
364 | 1x |
brush <- input$plot_brush |
365 | 1x |
if (!is.null(brush)) { |
366 | ! |
ranges$x <- c(brush$xmin, brush$xmax) |
367 | ! |
ranges$y <- c(brush$ymin, brush$ymax) |
368 |
} else { |
|
369 | 1x |
ranges$x <- NULL |
370 | 1x |
ranges$y <- NULL |
371 |
} |
|
372 |
}) |
|
373 | ||
374 | 14x |
p_height <- reactive(`if`(!is.null(input$height), input$height, height[1])) |
375 | 14x |
p_width <- reactive(`if`(!is.null(input$width), input$width, default_slider_width()[1])) |
376 | 14x |
output$plot_main <- renderPlot( |
377 | 14x |
apply_plot_modifications( |
378 | 14x |
plot_obj = plot_suppress(plot_r()), |
379 | 14x |
plot_type = plot_suppress(plot_type()), |
380 | 14x |
dblclicking = dblclicking, |
381 | 14x |
ranges = ranges |
382 |
), |
|
383 | 14x |
res = get_plot_dpi(), |
384 | 14x |
height = p_height, |
385 | 14x |
width = p_width |
386 |
) |
|
387 | ||
388 | 14x |
output$plot_modal <- renderPlot( |
389 | 14x |
apply_plot_modifications( |
390 | 14x |
plot_obj = plot_suppress(plot_r()), |
391 | 14x |
plot_type = plot_suppress(plot_type()), |
392 | 14x |
dblclicking = dblclicking, |
393 | 14x |
ranges = ranges |
394 |
), |
|
395 | 14x |
res = get_plot_dpi(), |
396 | 14x |
height = reactive(input$height_in_modal), |
397 | 14x |
width = reactive(input$width_in_modal) |
398 |
) |
|
399 | ||
400 | 14x |
output$plot_out_main <- renderUI({ |
401 | 8x |
req(plot_suppress(plot_r())) |
402 | 4x |
tags$div( |
403 | 4x |
align = graph_align, |
404 | 4x |
plotOutput( |
405 | 4x |
ns("plot_main"), |
406 | 4x |
height = "100%", |
407 | 4x |
brush = `if`(brushing, brushOpts(ns("plot_brush"), resetOnNew = FALSE), NULL), |
408 | 4x |
click = `if`(clicking, clickOpts(ns("plot_click")), NULL), |
409 | 4x |
dblclick = `if`(dblclicking, dblclickOpts(ns("plot_dblclick")), NULL), |
410 | 4x |
hover = `if`(hovering, hoverOpts(ns("plot_hover")), NULL) |
411 |
) |
|
412 |
) |
|
413 |
}) |
|
414 | ||
415 | 14x |
output$width_warning <- renderUI({ |
416 | 8x |
grDevices::pdf(nullfile()) # reset Rplots.pdf for shiny server |
417 | 8x |
w <- grDevices::dev.size("px")[1] |
418 | 8x |
grDevices::dev.off() |
419 | 8x |
if (p_width() < w) { |
420 | 8x |
helpText( |
421 | 8x |
icon("triangle-exclamation"), |
422 | 8x |
"Plot might be cut off for small widths." |
423 |
) |
|
424 |
} |
|
425 |
}) |
|
426 | ||
427 | 14x |
type_download_srv( |
428 | 14x |
id = "downbutton", |
429 | 14x |
plot_reactive = plot_r, |
430 | 14x |
plot_type = plot_type, |
431 | 14x |
plot_w = p_width, |
432 | 14x |
default_w = default_w, |
433 | 14x |
plot_h = p_height, |
434 | 14x |
default_h = default_h |
435 |
) |
|
436 | ||
437 | 14x |
output$plot_out_modal <- renderUI({ |
438 | 9x |
plotOutput(ns("plot_modal"), height = input$height_in_modal, width = input$width_in_modal) |
439 |
}) |
|
440 | ||
441 | 14x |
observeEvent(input$expand, { |
442 | 1x |
showModal( |
443 | 1x |
tags$div( |
444 | 1x |
class = "plot-modal", |
445 | 1x |
modalDialog( |
446 | 1x |
easyClose = TRUE, |
447 | 1x |
tags$div( |
448 | 1x |
class = "plot-modal-sliders", |
449 | 1x |
optionalSliderInputValMinMax( |
450 | 1x |
inputId = ns("height_in_modal"), |
451 | 1x |
label = "Plot height", |
452 | 1x |
value_min_max = round(c(p_height(), height[2:3])), |
453 | 1x |
ticks = FALSE, |
454 | 1x |
step = 1L, |
455 | 1x |
round = TRUE |
456 |
), |
|
457 | 1x |
optionalSliderInputValMinMax( |
458 | 1x |
inputId = ns("width_in_modal"), |
459 | 1x |
label = "Plot width", |
460 | 1x |
value_min_max = round(c( |
461 | 1x |
ifelse( |
462 | 1x |
is.null(input$width) || !isFALSE(input$width_resize_switch), |
463 | 1x |
ifelse( |
464 | 1x |
is.null(input$plot_modal_width) || input$plot_modal_width > default_slider_width()[3], |
465 | 1x |
default_slider_width()[1], |
466 | 1x |
input$plot_modal_width |
467 |
), |
|
468 | 1x |
input$width |
469 |
), |
|
470 | 1x |
default_slider_width()[2:3] |
471 |
)), |
|
472 | 1x |
ticks = FALSE, |
473 | 1x |
step = 1L, |
474 | 1x |
round = TRUE |
475 |
) |
|
476 |
), |
|
477 | 1x |
tags$div( |
478 | 1x |
class = "float-right", |
479 | 1x |
type_download_ui(ns("modal_downbutton")) |
480 |
), |
|
481 | 1x |
tags$div( |
482 | 1x |
align = "center", |
483 | 1x |
uiOutput(ns("plot_out_modal"), class = "plot_out_container") |
484 |
) |
|
485 |
) |
|
486 |
) |
|
487 |
) |
|
488 |
}) |
|
489 | ||
490 | 14x |
type_download_srv( |
491 | 14x |
id = "modal_downbutton", |
492 | 14x |
plot_reactive = plot_r, |
493 | 14x |
plot_type = plot_type, |
494 | 14x |
plot_w = reactive(input$width_in_modal), |
495 | 14x |
default_w = default_w, |
496 | 14x |
plot_h = reactive(input$height_in_modal), |
497 | 14x |
default_h = default_h |
498 |
) |
|
499 | ||
500 | 14x |
return( |
501 | 14x |
list( |
502 | 14x |
brush = reactive({ |
503 |
# refresh brush data on the main plot size change |
|
504 | 1x |
input$height |
505 | 1x |
input$width |
506 | 1x |
input$plot_brush |
507 |
}), |
|
508 | 14x |
click = reactive({ |
509 |
# refresh click data on the main plot size change |
|
510 | 1x |
input$height |
511 | 1x |
input$width |
512 | 1x |
input$plot_click |
513 |
}), |
|
514 | 14x |
dblclick = reactive({ |
515 |
# refresh double click data on the main plot size change |
|
516 | 1x |
input$height |
517 | 1x |
input$width |
518 | 1x |
input$plot_dblclick |
519 |
}), |
|
520 | 14x |
hover = reactive({ |
521 |
# refresh hover data on the main plot size change |
|
522 | 1x |
input$height |
523 | 1x |
input$width |
524 | 1x |
input$plot_hover |
525 |
}), |
|
526 | 14x |
dim = reactive(c(p_width(), p_height())) |
527 |
) |
|
528 |
) |
|
529 |
}) |
|
530 |
} |
|
531 | ||
532 |
#' @keywords internal |
|
533 |
type_download_ui <- function(id) { |
|
534 | 3x |
ns <- NS(id) |
535 | 3x |
shinyWidgets::dropdownButton( |
536 | 3x |
circle = FALSE, |
537 | 3x |
icon = icon("download"), |
538 | 3x |
inline = TRUE, |
539 | 3x |
right = TRUE, |
540 | 3x |
label = "", |
541 | 3x |
inputId = ns("downl"), |
542 | 3x |
tags$div( |
543 | 3x |
radioButtons(ns("file_format"), |
544 | 3x |
label = "File type", |
545 | 3x |
choices = c("png" = "png", "pdf" = "pdf", "svg" = "svg"), |
546 |
), |
|
547 | 3x |
textInput(ns("file_name"), |
548 | 3x |
label = "File name (without extension)", |
549 | 3x |
value = paste0("plot_", strftime(Sys.time(), format = "%Y%m%d_%H%M%S")) |
550 |
), |
|
551 | 3x |
conditionalPanel( |
552 | 3x |
condition = paste0("input['", ns("file_name"), "'] != ''"), |
553 | 3x |
downloadButton(ns("data_download"), label = character(0), class = "btn-sm w-full") |
554 |
) |
|
555 |
) |
|
556 |
) |
|
557 |
} |
|
558 | ||
559 |
#' @keywords internal |
|
560 |
type_download_srv <- function(id, plot_reactive, plot_type, plot_w, default_w, plot_h, default_h) { |
|
561 | 32x |
moduleServer( |
562 | 32x |
id, |
563 | 32x |
function(input, output, session) { |
564 | 32x |
output$data_download <- downloadHandler( |
565 | 32x |
filename = function() { |
566 | 20x |
paste(input$file_name, input$file_format, sep = ".") |
567 |
}, |
|
568 | 32x |
content = function(file) { |
569 | 20x |
width <- `if`(!is.null(plot_w()), plot_w(), default_w()) |
570 | 20x |
height <- `if`(!is.null(plot_h()), plot_h(), default_h()) |
571 | ||
572 |
# svg and pdf have width in inches and 1 inch = get_plot_dpi() pixels |
|
573 | 20x |
switch(input$file_format, |
574 | 12x |
png = grDevices::png(file, width, height), |
575 | 4x |
pdf = grDevices::pdf(file, width / get_plot_dpi(), height / get_plot_dpi()), |
576 | 4x |
svg = grDevices::svg(file, width / get_plot_dpi(), height / get_plot_dpi()) |
577 |
) |
|
578 | ||
579 | 20x |
print_plot(plot_reactive, plot_type) |
580 | ||
581 | 20x |
grDevices::dev.off() |
582 |
} |
|
583 |
) |
|
584 |
} |
|
585 |
) |
|
586 |
} |
|
587 | ||
588 |
#' Clean brushed points |
|
589 |
#' |
|
590 |
#' @description `r lifecycle::badge("stable")`\cr |
|
591 |
#' Cleans and organizes output to account for NAs and remove empty rows. Wrapper around `shiny::brushedPoints`. |
|
592 |
#' @param data (`data.frame`)\cr |
|
593 |
#' A data.frame from which to select rows. |
|
594 |
#' @param brush (`list`)\cr |
|
595 |
#' The data from a brush e.g. `input$plot_brush`. |
|
596 |
#' |
|
597 |
#' @return A `data.frame` of selected rows. |
|
598 |
#' |
|
599 |
#' @examples |
|
600 |
#' |
|
601 |
#' brush <- list( |
|
602 |
#' mapping = list( |
|
603 |
#' x = "AGE", |
|
604 |
#' y = "BMRKR1" |
|
605 |
#' ), |
|
606 |
#' xmin = 30, xmax = 40, |
|
607 |
#' ymin = 0.7, ymax = 10, |
|
608 |
#' direction = "xy" |
|
609 |
#' ) |
|
610 |
#' |
|
611 |
#' data <- data.frame( |
|
612 |
#' STUDYID = letters[1:20], |
|
613 |
#' USUBJID = LETTERS[1:20], |
|
614 |
#' AGE = sample(25:40, size = 20, replace = TRUE), |
|
615 |
#' BMRKR1 = runif(20, min = 0, max = 12) |
|
616 |
#' ) |
|
617 |
#' nrow(clean_brushedPoints(data, brush)) |
|
618 |
#' data$AGE[1:10] <- NA |
|
619 |
#' nrow(clean_brushedPoints(data, brush)) |
|
620 |
#' |
|
621 |
#' @export |
|
622 |
#' |
|
623 |
clean_brushedPoints <- function(data, brush) { # nolint object_name_linter. |
|
624 | 6x |
checkmate::assert_data_frame(data) |
625 | 4x |
checkmate::assert_list(brush, null.ok = TRUE) |
626 | ||
627 |
# define original panelvar1 and panelvar2 before getting overwritten |
|
628 | 4x |
original_panelvar1 <- brush$mapping$panelvar1 |
629 | 4x |
original_panelvar2 <- brush$mapping$panelvar2 |
630 | ||
631 |
# Assign NULL to `mapping$panelvar1` and `mapping$panelvar1` if `brush$panelvar1` and `brush$panelvar1` are NULL |
|
632 |
# This will not evaluate the `panelMatch` step in `brushedPoints` and thus will return a non empty dataframe |
|
633 | 4x |
if (is.null(brush$panelvar1)) brush$mapping$panelvar1 <- NULL |
634 | 4x |
if (is.null(brush$panelvar2)) brush$mapping$panelvar2 <- NULL |
635 | ||
636 | 4x |
bp_df <- brushedPoints(data, brush) |
637 | ||
638 |
# Keep required rows only based on the value of `brush$panelvar1` |
|
639 | 3x |
df <- if (is.null(brush$panelvar1) && is.character(original_panelvar1) && |
640 | 3x |
is.null(brush$panelvar2) && is.character(original_panelvar2)) { |
641 | ! |
df_var1 <- bp_df[is.na(bp_df[[original_panelvar1]]), ] |
642 | ! |
df_var1[is.na(df_var1[[original_panelvar2]]), ] |
643 | 3x |
} else if (is.null(brush$panelvar1) && is.character(original_panelvar1)) { |
644 | ! |
bp_df[is.na(bp_df[[original_panelvar1]]), ] |
645 | 3x |
} else if (is.null(brush$panelvar2) && is.character(original_panelvar2)) { |
646 | ! |
bp_df[is.na(bp_df[[original_panelvar2]]), ] |
647 |
} else { |
|
648 | 3x |
bp_df |
649 |
} |
|
650 | ||
651 |
# filter out rows that are only NAs |
|
652 | 3x |
df <- df[rowSums(is.na(df)) != ncol(df), ] |
653 | 3x |
df |
654 |
} |
|
655 | ||
656 |
#' @keywords internal |
|
657 |
#' |
|
658 |
get_plot_dpi <- function() { |
|
659 | 53x |
default_dpi <- 72 |
660 | 53x |
dpi <- getOption("teal.plot_dpi", default_dpi) |
661 | 53x |
if (!checkmate::test_integerish(dpi, lower = 24, any.missing = FALSE, len = 1)) { |
662 | 4x |
warning(paste("Invalid value for option 'teal.plot_dpi', therefore defaulting to", default_dpi, "dpi")) |
663 | 4x |
dpi <- default_dpi |
664 |
} |
|
665 | 53x |
dpi |
666 |
} |
|
667 | ||
668 |
#' Print plot for download functionality |
|
669 |
#' |
|
670 |
#' @param plot (`reactive`)\cr |
|
671 |
#' reactive expression to draw a plot |
|
672 |
#' @param plot_type (`reactive`)\cr |
|
673 |
#' reactive plot type (`gg`, `trel`, `grob`, `other`) |
|
674 |
#' |
|
675 |
#' @return Nothing returned, the plot is printed. |
|
676 |
#' @keywords internal |
|
677 |
#' |
|
678 |
print_plot <- function(plot, plot_type) { |
|
679 | 26x |
switch(plot_type(), |
680 | 2x |
"grob" = grid::grid.draw(plot()), |
681 |
"other" = { |
|
682 | 2x |
graphics::plot.new() |
683 | 2x |
graphics::text( |
684 | 2x |
x = graphics::grconvertX(0.5, from = "npc"), |
685 | 2x |
y = graphics::grconvertY(0.5, from = "npc"), |
686 | 2x |
labels = "This plot graphic type is not yet supported to download" |
687 |
) |
|
688 |
}, |
|
689 | 18x |
"base" = plot(), |
690 | 4x |
print(plot()) |
691 |
) |
|
692 |
} |
1 |
#' @name table_with_settings |
|
2 |
#' |
|
3 |
#' @title `table_with_settings` module |
|
4 |
#' |
|
5 |
#' @description `r lifecycle::badge("stable")`\cr |
|
6 |
#' Module designed to create a `shiny` table output based on `rtable` object (`ElementaryTable` or `TableTree`) input. |
|
7 |
#' @inheritParams shiny::moduleServer |
|
8 |
#' @param ... (`character`)\cr |
|
9 |
#' Useful for providing additional HTML classes for the output tag. |
|
10 |
#' |
|
11 |
#' @rdname table_with_settings |
|
12 |
#' @export |
|
13 |
#' |
|
14 |
table_with_settings_ui <- function(id, ...) { |
|
15 | 1x |
checkmate::assert_string(id) |
16 | ||
17 | 1x |
ns <- NS(id) |
18 | ||
19 | 1x |
tagList( |
20 | 1x |
include_css_files("table_with_settings"), |
21 | 1x |
tags$div( |
22 | 1x |
id = ns("table-with-settings"), |
23 | 1x |
tags$div( |
24 | 1x |
class = "table-settings-buttons", |
25 | 1x |
type_download_ui_table(ns("downbutton")), |
26 | 1x |
actionButton( |
27 | 1x |
inputId = ns("expand"), label = character(0), |
28 | 1x |
icon = icon("up-right-and-down-left-from-center"), class = "btn-sm" |
29 |
), |
|
30 |
), |
|
31 | 1x |
tags$div( |
32 | 1x |
class = "table-settings-table", |
33 | 1x |
uiOutput(ns("table_out_main"), width = "100%", ...) |
34 |
) |
|
35 |
) |
|
36 |
) |
|
37 |
} |
|
38 | ||
39 |
#' @inheritParams shiny::moduleServer |
|
40 |
#' @param table_r (`reactive`)\cr |
|
41 |
#' reactive expression that yields an `rtable` object (`ElementaryTable` or `TableTree`) |
|
42 |
#' @param show_hide_signal (`reactive logical`) optional\cr |
|
43 |
#' mechanism to allow modules which call this module to show/hide the table_with_settings UI. |
|
44 |
#' |
|
45 |
#' @rdname table_with_settings |
|
46 |
#' |
|
47 |
#' @return A `shiny` module. |
|
48 |
#' |
|
49 |
#' @export |
|
50 |
#' |
|
51 |
#' @examples |
|
52 |
#' library(shiny) |
|
53 |
#' library(rtables) |
|
54 |
#' library(magrittr) |
|
55 |
#' |
|
56 |
#' ui <- fluidPage( |
|
57 |
#' table_with_settings_ui( |
|
58 |
#' id = "table_with_settings" |
|
59 |
#' ) |
|
60 |
#' ) |
|
61 |
#' |
|
62 |
#' server <- function(input, output, session) { |
|
63 |
#' table_r <- reactive({ |
|
64 |
#' l <- basic_table() %>% |
|
65 |
#' split_cols_by("ARM") %>% |
|
66 |
#' analyze(c("SEX", "AGE")) |
|
67 |
#' |
|
68 |
#' tbl <- build_table(l, DM) |
|
69 |
#' |
|
70 |
#' tbl |
|
71 |
#' }) |
|
72 |
#' |
|
73 |
#' table_with_settings_srv(id = "table_with_settings", table_r = table_r) |
|
74 |
#' } |
|
75 |
#' |
|
76 |
#' if (interactive()) { |
|
77 |
#' shinyApp(ui, server) |
|
78 |
#' } |
|
79 |
#' |
|
80 |
table_with_settings_srv <- function(id, table_r, show_hide_signal = reactive(TRUE)) { |
|
81 | 5x |
checkmate::assert_class(table_r, c("reactive", "function")) |
82 | 4x |
checkmate::assert_class(show_hide_signal, c("reactive", "function")) |
83 | ||
84 | 3x |
if (!requireNamespace("rtables", quietly = TRUE)) { |
85 | ! |
stop("package rtables is required, please install") |
86 |
} |
|
87 | ||
88 | 3x |
moduleServer(id, function(input, output, session) { |
89 | 3x |
ns <- session$ns |
90 |
# Turn on and off the UI |
|
91 | 3x |
observeEvent(show_hide_signal(), { |
92 | 3x |
if (show_hide_signal()) { |
93 | 2x |
shinyjs::show("table-with-settings") |
94 |
} else { |
|
95 | 1x |
shinyjs::hide("table-with-settings") |
96 |
} |
|
97 |
}) |
|
98 | ||
99 | 3x |
output$table_out_main <- output$table_out_modal <- renderUI({ |
100 | 6x |
rtables::as_html(table_r()) |
101 |
}) |
|
102 | ||
103 | 3x |
type_download_srv_table( |
104 | 3x |
id = "downbutton", |
105 | 3x |
table_reactive = table_r |
106 |
) |
|
107 | ||
108 | 3x |
observeEvent(input$expand, { |
109 | 1x |
showModal( |
110 | 1x |
tags$div( |
111 | 1x |
class = "table-modal", |
112 | 1x |
modalDialog( |
113 | 1x |
easyClose = TRUE, |
114 | 1x |
tags$div( |
115 | 1x |
class = "float-right", |
116 | 1x |
type_download_ui_table(ns("modal_downbutton")) |
117 |
), |
|
118 | 1x |
uiOutput(ns("table_out_modal"), class = "table_out_container") |
119 |
) |
|
120 |
) |
|
121 |
) |
|
122 |
}) |
|
123 | ||
124 | 3x |
type_download_srv_table( |
125 | 3x |
id = "modal_downbutton", |
126 | 3x |
table_reactive = table_r |
127 |
) |
|
128 |
}) |
|
129 |
} |
|
130 | ||
131 |
type_download_ui_table <- function(id) { |
|
132 | 2x |
ns <- NS(id) |
133 | 2x |
shinyWidgets::dropdownButton( |
134 | 2x |
circle = FALSE, |
135 | 2x |
icon = icon("download"), |
136 | 2x |
inline = TRUE, |
137 | 2x |
right = TRUE, |
138 | 2x |
label = "", |
139 | 2x |
inputId = ns("dwnl"), |
140 | 2x |
tags$div( |
141 | 2x |
class = "modal-download-ui-table-container", |
142 | 2x |
radioButtons(ns("file_format"), |
143 | 2x |
label = "File type", |
144 | 2x |
choices = c("formatted txt" = ".txt", "csv" = ".csv", "pdf" = ".pdf"), |
145 |
), |
|
146 | 2x |
textInput(ns("file_name"), |
147 | 2x |
label = "File name (without extension)", |
148 | 2x |
value = paste0("table_", strftime(Sys.time(), format = "%Y%m%d_%H%M%S")) |
149 |
), |
|
150 | 2x |
conditionalPanel( |
151 | 2x |
condition = paste0("input['", ns("file_format"), "'] != '.csv'"), |
152 | 2x |
tags$div( |
153 | 2x |
class = "lock-btn", |
154 | 2x |
title = "on / off", |
155 | 2x |
shinyWidgets::prettyToggle( |
156 | 2x |
ns("pagination_switch"), |
157 | 2x |
value = FALSE, |
158 | 2x |
label_on = NULL, |
159 | 2x |
label_off = NULL, |
160 | 2x |
status_on = "default", |
161 | 2x |
status_off = "default", |
162 | 2x |
outline = FALSE, |
163 | 2x |
plain = TRUE, |
164 | 2x |
icon_on = icon("fas fa-toggle-off"), |
165 | 2x |
icon_off = icon("fas fa-toggle-on"), |
166 | 2x |
animation = "pulse" |
167 |
) |
|
168 |
), |
|
169 | 2x |
tags$div( |
170 | 2x |
class = "paginate-ui", |
171 | 2x |
shinyWidgets::numericInputIcon( |
172 | 2x |
inputId = ns("lpp"), |
173 | 2x |
label = "Paginate table:", |
174 | 2x |
value = 70, |
175 | 2x |
icon = list("lines / page") |
176 |
), |
|
177 | 2x |
uiOutput(ns("lpp_warning")) |
178 |
) |
|
179 |
), |
|
180 | 2x |
conditionalPanel( |
181 | 2x |
condition = paste0("input['", ns("file_name"), "'] != ''"), |
182 | 2x |
downloadButton(ns("data_download"), label = character(0), class = "btn-sm w-full") |
183 |
) |
|
184 |
) |
|
185 |
) |
|
186 |
} |
|
187 | ||
188 |
type_download_srv_table <- function(id, table_reactive) { |
|
189 | 12x |
moduleServer( |
190 | 12x |
id, |
191 | 12x |
function(input, output, session) { |
192 | 12x |
observeEvent(input$pagination_switch, { |
193 | 13x |
if (input$pagination_switch) { |
194 | 7x |
shinyjs::enable("lpp") |
195 |
} else { |
|
196 | 6x |
shinyjs::disable("lpp") |
197 |
} |
|
198 |
}) |
|
199 | ||
200 | 12x |
output$lpp_warning <- renderUI({ |
201 | 31x |
catch_warning <- if (input$file_format != ".csv" && input$pagination_switch) { |
202 | 9x |
try(rtables::paginate_table( |
203 | 9x |
tt = table_reactive(), |
204 | 9x |
lpp = as.numeric(input$lpp) |
205 | 9x |
), silent = TRUE) |
206 |
} |
|
207 | ||
208 | 21x |
if (inherits(catch_warning, "try-error")) { |
209 | 4x |
helpText( |
210 | 4x |
class = "error", |
211 | 4x |
icon("triangle-exclamation"), |
212 | 4x |
"Maximum lines per page includes the reprinted header. Please enter a numeric value or increase the value." |
213 |
) |
|
214 |
} |
|
215 |
}) |
|
216 | ||
217 | 12x |
output$data_download <- downloadHandler( |
218 | 12x |
filename = function() { |
219 | 22x |
paste0(input$file_name, input$file_format) |
220 |
}, |
|
221 | 12x |
content = function(file) { |
222 | 22x |
if (input$file_format == ".txt") { |
223 | 8x |
rtables::export_as_txt( |
224 | 8x |
x = table_reactive(), |
225 | 8x |
file = file, |
226 | 8x |
paginate = input$pagination_switch, |
227 | 8x |
lpp = if (input$pagination_switch) as.numeric(input$lpp) |
228 |
) |
|
229 | 14x |
} else if (input$file_format == ".csv") { |
230 | 7x |
result <- rtables::matrix_form(table_reactive())$strings |
231 | 7x |
utils::write.table( |
232 | 7x |
x = result, |
233 | 7x |
file = file, |
234 | 7x |
sep = ",", |
235 | 7x |
col.names = FALSE, |
236 | 7x |
row.names = TRUE, |
237 | 7x |
append = FALSE |
238 |
) |
|
239 |
} else { |
|
240 | 7x |
rtables::export_as_pdf( |
241 | 7x |
x = table_reactive(), |
242 | 7x |
file = file, |
243 | 7x |
paginate = input$pagination_switch, |
244 | 7x |
lpp = if (input$pagination_switch) as.numeric(input$lpp) |
245 |
) |
|
246 |
} |
|
247 |
} |
|
248 |
) |
|
249 |
} |
|
250 |
) |
|
251 |
} |
1 |
#' Get bootstrap current version |
|
2 |
#' @note will work properly mainly inside a tag `.renderHook` |
|
3 |
#' @keywords internal |
|
4 |
get_bs_version <- function() { |
|
5 | 1x |
theme <- bslib::bs_current_theme() |
6 | 1x |
if (bslib::is_bs_theme(theme)) { |
7 | ! |
bslib::theme_version(theme) |
8 |
} else { |
|
9 | 1x |
"3" |
10 |
} |
|
11 |
} |
|
12 | ||
13 |
#' This function checks the plot type and applies specific modifications |
|
14 |
#' to the plot object based on the provided parameters. |
|
15 |
#' |
|
16 |
#' @param plot_obj The original plot object. |
|
17 |
#' @param plot_type The type of the plot, either `gg` (`ggplot2`) or `grob` (`grid`, `graphics`). |
|
18 |
#' @param dblclicking A logical value indicating whether double-clicking on data points on |
|
19 |
#' the main plot is enabled or disabled. |
|
20 |
#' @param ranges A list containing x and y values of ranges. |
|
21 |
#' |
|
22 |
#' @keywords internal |
|
23 |
apply_plot_modifications <- function(plot_obj, plot_type, dblclicking, ranges) { |
|
24 | 13x |
if (plot_type == "gg" && dblclicking) { |
25 | 1x |
plot_obj + |
26 | 1x |
ggplot2::coord_cartesian(xlim = ranges$x, ylim = ranges$y, expand = FALSE) |
27 | 12x |
} else if (plot_type == "grob") { |
28 | 2x |
grid::grid.newpage() |
29 | 2x |
grid::grid.draw(plot_obj) |
30 |
} else { |
|
31 | 10x |
plot_obj |
32 |
} |
|
33 |
} |
|
34 | ||
35 |
#' This function opens a PDF graphics device using [grDevices::pdf()] to suppress |
|
36 |
#' the plot display in the IDE. The purpose of this function is to avoid opening graphic devices |
|
37 |
#' directly in the IDE. |
|
38 |
#' |
|
39 |
#' @param x lazy binding which generates the plot(s) |
|
40 |
#' |
|
41 |
#' @keywords internal |
|
42 |
plot_suppress <- function(x) { |
|
43 | 32x |
grDevices::pdf(nullfile()) |
44 | 32x |
on.exit(grDevices::dev.off()) |
45 | 32x |
force(x) |
46 |
} |
1 |
#' Wrapper for `pickerInput` |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")` |
|
4 |
#' Wrapper for [shinyWidgets::pickerInput()] with additional features. |
|
5 |
#' When `fixed = TRUE` or when the number of `choices` is less or equal to 1 (see `fixed_on_single`), |
|
6 |
#' the `pickerInput` widget is hidden and non-interactive widget will be displayed |
|
7 |
#' instead. Toggle of `HTML` elements is just the visual effect to avoid displaying |
|
8 |
#' `pickerInput` widget when there is only one choice. |
|
9 |
#' |
|
10 |
#' @inheritParams shinyWidgets::pickerInput |
|
11 |
#' |
|
12 |
#' @param sep (`character(1)`)\cr |
|
13 |
#' A separator string to split the `choices` or `selected` inputs into the values of the different |
|
14 |
#' columns. |
|
15 |
#' |
|
16 |
#' @param label_help (`shiny.tag`) optional,\cr |
|
17 |
#' e.g. an object returned by [shiny::helpText()]. |
|
18 |
#' |
|
19 |
#' @param fixed (`logical(1)`) optional,\cr |
|
20 |
#' whether to block user to select choices. |
|
21 |
#' |
|
22 |
#' @param fixed_on_single (`logical(1)`) optional,\cr |
|
23 |
#' whether to block user to select a choice when there is only one or less choice. |
|
24 |
#' When `FALSE`, user is still able to select or deselect the choice. |
|
25 |
#' |
|
26 |
#' @param width (`character(1)`)\cr |
|
27 |
#' The width of the input passed to `pickerInput` e.g. `'auto'`, `'fit'`, `'100px'` or `'75%'` |
|
28 |
#' |
|
29 |
#' @return (`shiny.tag`) HTML tag with `pickerInput` widget and |
|
30 |
#' non-interactive element listing selected values. |
|
31 |
#' |
|
32 |
#' @export |
|
33 |
#' |
|
34 |
#' @examples |
|
35 |
#' library(shiny) |
|
36 |
#' |
|
37 |
#' # Create a minimal example data frame |
|
38 |
#' data <- data.frame( |
|
39 |
#' AGE = c(25, 30, 40, 35, 28), |
|
40 |
#' SEX = c("Male", "Female", "Male", "Female", "Male"), |
|
41 |
#' PARAMCD = c("Val1", "Val2", "Val3", "Val4", "Val5"), |
|
42 |
#' PARAM = c("Param1", "Param2", "Param3", "Param4", "Param5"), |
|
43 |
#' AVISIT = c("Visit1", "Visit2", "Visit3", "Visit4", "Visit5"), |
|
44 |
#' stringsAsFactors = TRUE |
|
45 |
#' ) |
|
46 |
#' |
|
47 |
#' ui_grid <- function(...) { |
|
48 |
#' fluidPage( |
|
49 |
#' fluidRow( |
|
50 |
#' lapply(list(...), function(x) column(4, wellPanel(x))) |
|
51 |
#' ) |
|
52 |
#' ) |
|
53 |
#' } |
|
54 |
#' |
|
55 |
#' ui <- ui_grid( |
|
56 |
#' tags$div( |
|
57 |
#' optionalSelectInput( |
|
58 |
#' inputId = "c1", |
|
59 |
#' label = "Fixed choices", |
|
60 |
#' choices = LETTERS[1:5], |
|
61 |
#' selected = c("A", "B"), |
|
62 |
#' fixed = TRUE |
|
63 |
#' ), |
|
64 |
#' verbatimTextOutput(outputId = "c1_out") |
|
65 |
#' ), |
|
66 |
#' tags$div( |
|
67 |
#' optionalSelectInput( |
|
68 |
#' inputId = "c2", |
|
69 |
#' label = "Single choice", |
|
70 |
#' choices = "A", |
|
71 |
#' selected = "A" |
|
72 |
#' ), |
|
73 |
#' verbatimTextOutput(outputId = "c2_out") |
|
74 |
#' ), |
|
75 |
#' tags$div( |
|
76 |
#' optionalSelectInput( |
|
77 |
#' inputId = "c3", |
|
78 |
#' label = "NULL choices", |
|
79 |
#' choices = NULL |
|
80 |
#' ), |
|
81 |
#' verbatimTextOutput(outputId = "c3_out") |
|
82 |
#' ), |
|
83 |
#' tags$div( |
|
84 |
#' optionalSelectInput( |
|
85 |
#' inputId = "c4", |
|
86 |
#' label = "Default", |
|
87 |
#' choices = LETTERS[1:5], |
|
88 |
#' selected = "A" |
|
89 |
#' ), |
|
90 |
#' verbatimTextOutput(outputId = "c4_out") |
|
91 |
#' ), |
|
92 |
#' tags$div( |
|
93 |
#' optionalSelectInput( |
|
94 |
#' inputId = "c5", |
|
95 |
#' label = "Named vector", |
|
96 |
#' choices = c(`A - value A` = "A", `B - value B` = "B", `C - value C` = "C"), |
|
97 |
#' selected = "A" |
|
98 |
#' ), |
|
99 |
#' verbatimTextOutput(outputId = "c5_out") |
|
100 |
#' ), |
|
101 |
#' tags$div( |
|
102 |
#' selectInput( |
|
103 |
#' inputId = "c6_choices", label = "Update choices", choices = letters, multiple = TRUE |
|
104 |
#' ), |
|
105 |
#' optionalSelectInput( |
|
106 |
#' inputId = "c6", |
|
107 |
#' label = "Updated choices", |
|
108 |
#' choices = NULL, |
|
109 |
#' multiple = TRUE, |
|
110 |
#' fixed_on_single = TRUE |
|
111 |
#' ), |
|
112 |
#' verbatimTextOutput(outputId = "c6_out") |
|
113 |
#' ) |
|
114 |
#' ) |
|
115 |
#' |
|
116 |
#' server <- function(input, output, session) { |
|
117 |
#' observeEvent(input$c6_choices, ignoreNULL = FALSE, { |
|
118 |
#' updateOptionalSelectInput( |
|
119 |
#' session = session, |
|
120 |
#' inputId = "c6", |
|
121 |
#' choices = input$c6_choices, |
|
122 |
#' selected = input$c6_choices |
|
123 |
#' ) |
|
124 |
#' }) |
|
125 |
#' |
|
126 |
#' output$c1_out <- renderPrint(input$c1) |
|
127 |
#' output$c2_out <- renderPrint(input$c2) |
|
128 |
#' output$c3_out <- renderPrint(input$c3) |
|
129 |
#' output$c4_out <- renderPrint(input$c4) |
|
130 |
#' output$c5_out <- renderPrint(input$c5) |
|
131 |
#' output$c6_out <- renderPrint(input$c6) |
|
132 |
#' } |
|
133 |
#' |
|
134 |
#' if (interactive()) { |
|
135 |
#' shinyApp(ui, server) |
|
136 |
#' } |
|
137 |
#' |
|
138 |
optionalSelectInput <- function(inputId, # nolint |
|
139 |
label = NULL, |
|
140 |
choices = NULL, |
|
141 |
selected = NULL, |
|
142 |
multiple = FALSE, |
|
143 |
sep = NULL, |
|
144 |
options = list(), |
|
145 |
label_help = NULL, |
|
146 |
fixed = FALSE, |
|
147 |
fixed_on_single = FALSE, |
|
148 |
width = NULL) { |
|
149 | ! |
checkmate::assert_string(inputId) |
150 | ! |
checkmate::assert( |
151 | ! |
checkmate::check_string(label, null.ok = TRUE), |
152 | ! |
checkmate::check_class(label, "shiny.tag"), |
153 | ! |
checkmate::check_class(label, "shiny.tag.list"), |
154 | ! |
checkmate::check_class(label, "html") |
155 |
) |
|
156 | ! |
stopifnot(is.null(choices) || length(choices) >= 1) |
157 | ! |
stopifnot( |
158 | ! |
is.null(selected) || |
159 | ! |
length(selected) == 0 || |
160 | ! |
all(selected %in% choices) || |
161 | ! |
all(selected %in% unlist(choices, recursive = FALSE)) |
162 |
) |
|
163 | ! |
checkmate::assert_flag(multiple) |
164 | ! |
checkmate::assert_string(sep, null.ok = TRUE) |
165 | ! |
checkmate::assert_list(options) |
166 | ! |
checkmate::assert( |
167 | ! |
checkmate::check_string(label_help, null.ok = TRUE), |
168 | ! |
checkmate::check_class(label_help, "shiny.tag"), |
169 | ! |
checkmate::check_class(label_help, "shiny.tag.list"), |
170 | ! |
checkmate::check_class(label_help, "html") |
171 |
) |
|
172 | ! |
checkmate::assert_flag(fixed) |
173 | ! |
checkmate::assert_flag(fixed_on_single) |
174 | ||
175 | ! |
if (!is.null(width)) { |
176 | ! |
validateCssUnit(width) |
177 |
} |
|
178 | ||
179 | ! |
default_options <- list( |
180 | ! |
"actions-box" = multiple, |
181 | ! |
"none-selected-text" = "- Nothing selected -", |
182 | ! |
"max-options" = ifelse(multiple, Inf, 1), |
183 | ! |
"show-subtext" = TRUE, |
184 | ! |
"live-search" = ifelse(length(choices) > 10, TRUE, FALSE) |
185 |
) |
|
186 | ||
187 |
# if called outside the fluidPage then will assume bs 3 |
|
188 | ! |
bs_version <- get_bs_version() |
189 | ! |
if (isTRUE(bs_version != "3")) default_options[["style"]] <- "btn-outline-secondary" |
190 | ||
191 | ! |
options <- if (!identical(options, list())) { |
192 | ! |
c(options, default_options[setdiff(names(default_options), names(options))]) |
193 |
} else { |
|
194 | ! |
default_options |
195 |
} |
|
196 | ||
197 | ! |
if (is.null(choices)) { |
198 | ! |
choices <- "" |
199 | ! |
selected <- NULL |
200 |
} |
|
201 | ||
202 | ! |
if (length(choices) <= 1 && fixed_on_single) fixed <- TRUE |
203 | ||
204 | ! |
raw_choices <- extract_raw_choices(choices, attr(choices, "sep")) |
205 | ! |
raw_selected <- extract_raw_choices(selected, attr(choices, "sep")) |
206 | ||
207 | ! |
ui_picker <- tags$div( |
208 | ! |
id = paste0(inputId, "_input"), |
209 |
# visibility feature marked with display: none/block instead of shinyjs::hide/show |
|
210 |
# as mechanism to hide/show is handled by javascript code |
|
211 | ! |
style = if (fixed) "display: none;" else "display: block;", |
212 | ! |
shinyWidgets::pickerInput( |
213 | ! |
inputId = inputId, |
214 | ! |
label = label, |
215 | ! |
choices = raw_choices, |
216 | ! |
selected = raw_selected, |
217 | ! |
multiple = TRUE, |
218 | ! |
width = width, |
219 | ! |
options = options, |
220 | ! |
choicesOpt = picker_options(choices) |
221 |
) |
|
222 |
) |
|
223 | ||
224 | ! |
if (!is.null(label_help)) { |
225 | ! |
ui_picker[[3]] <- append(ui_picker[[3]], list(tags$div(class = "label-help", label_help)), after = 1) |
226 |
} |
|
227 | ||
228 | ! |
ui_fixed <- tags$div( |
229 | ! |
id = paste0(inputId, "_fixed"), |
230 |
# visibility feature marked with display: none/block instead of shinyjs::hide/show |
|
231 |
# as mechanism to hide/show is handled by javascript code |
|
232 | ! |
style = if (fixed) "display: block;" else "display: none;", |
233 | ! |
tags$label(class = "control-label", label), |
234 |
# selected values as verbatim text |
|
235 | ! |
tags$code( |
236 | ! |
id = paste0(inputId, "_selected_text"), |
237 | ! |
if (length(selected) > 0) { |
238 | ! |
toString(selected) |
239 |
} else { |
|
240 | ! |
"NULL" |
241 |
} |
|
242 |
), |
|
243 | ! |
label_help |
244 |
) |
|
245 | ||
246 | ! |
tags$div( |
247 | ! |
include_css_files(pattern = "picker_input"), |
248 | ||
249 |
# when selected values in ui_picker change |
|
250 |
# then update ui_fixed - specifically, update '{id}_selected_text' element |
|
251 | ! |
tags$script( |
252 | ! |
sprintf( |
253 |
" |
|
254 | ! |
$(function() { |
255 | ! |
$('#%1$s').on('change', function(e) { |
256 | ! |
var select_concat = $(this).val().length ? $(this).val().join(', ') : 'NULL'; |
257 | ! |
$('#%1$s_selected_text').html(select_concat); |
258 |
}) |
|
259 |
})", |
|
260 | ! |
inputId |
261 |
) |
|
262 |
), |
|
263 | ||
264 |
# if ui_picker has only one or less option or is fixed then hide {id}_input and show {id}_fixed |
|
265 | ! |
if (fixed_on_single) { |
266 | ! |
js <- sprintf( |
267 | ! |
"$(function() { |
268 | ! |
$('#%1$s').on('change', function(e) { |
269 | ! |
var options = $('#%1$s').find('option'); |
270 | ! |
if (options.length == 1) { |
271 | ! |
$('#%1$s_input').hide(); |
272 | ! |
$('#%1$s_fixed').show(); |
273 |
} else { |
|
274 | ! |
$('#%1$s_input').show(); |
275 | ! |
$('#%1$s_fixed').hide(); |
276 |
} |
|
277 |
}) |
|
278 |
})", |
|
279 | ! |
inputId |
280 |
) |
|
281 | ! |
tags$script(js) |
282 |
}, |
|
283 | ! |
tags$div(ui_picker, ui_fixed) |
284 |
) |
|
285 |
} |
|
286 | ||
287 |
#' @rdname optionalSelectInput |
|
288 |
#' @param session (`shiny.session`)\cr |
|
289 |
#' @export |
|
290 |
updateOptionalSelectInput <- function(session, # nolint |
|
291 |
inputId, # nolint |
|
292 |
label = NULL, |
|
293 |
selected = NULL, |
|
294 |
choices = NULL) { |
|
295 | ! |
raw_choices <- extract_raw_choices(choices, attr(choices, "sep")) |
296 | ! |
raw_selected <- extract_raw_choices(selected, attr(choices, "sep")) |
297 | ||
298 |
# update picker input |
|
299 | ! |
shinyWidgets::updatePickerInput( |
300 | ! |
session = session, |
301 | ! |
inputId = inputId, |
302 | ! |
label = label, |
303 | ! |
selected = as.character(raw_selected), |
304 | ! |
choices = raw_choices, |
305 | ! |
choicesOpt = picker_options(choices) |
306 |
) |
|
307 | ||
308 | ! |
invisible(NULL) |
309 |
} |
|
310 | ||
311 |
#' Get icons to represent variable types in dataset |
|
312 |
#' |
|
313 |
#' @param var_type (`character`)\cr |
|
314 |
#' of R internal types (classes). |
|
315 |
#' |
|
316 |
#' @return (`character`)\cr |
|
317 |
#' vector of HTML icons corresponding to data type in each column. |
|
318 |
#' @keywords internal |
|
319 |
#' |
|
320 |
variable_type_icons <- function(var_type) { |
|
321 | ! |
checkmate::assert_character(var_type, any.missing = FALSE) |
322 | ||
323 | ! |
class_to_icon <- list( |
324 | ! |
numeric = "arrow-up-1-9", |
325 | ! |
integer = "arrow-up-1-9", |
326 | ! |
logical = "pause", |
327 | ! |
Date = "calendar", |
328 | ! |
POSIXct = "calendar", |
329 | ! |
POSIXlt = "calendar", |
330 | ! |
factor = "chart-bar", |
331 | ! |
character = "keyboard", |
332 | ! |
primary_key = "key", |
333 | ! |
unknown = "circle-question" |
334 |
) |
|
335 | ! |
class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome"))) |
336 | ||
337 | ! |
res <- unname(vapply( |
338 | ! |
var_type, |
339 | ! |
FUN.VALUE = character(1), |
340 | ! |
FUN = function(class) { |
341 | ! |
if (class == "") { |
342 | ! |
class |
343 | ! |
} else if (is.null(class_to_icon[[class]])) { |
344 | ! |
class_to_icon[["unknown"]] |
345 |
} else { |
|
346 | ! |
class_to_icon[[class]] |
347 |
} |
|
348 |
} |
|
349 |
)) |
|
350 | ||
351 | ! |
return(res) |
352 |
} |
|
353 | ||
354 |
#' Optional content for `optionalSelectInput` |
|
355 |
#' |
|
356 |
#' Prepares content to be displayed in `optionalSelectInput` with icons and labels |
|
357 |
#' |
|
358 |
#' @param var_name (`character`)\cr |
|
359 |
#' variable name |
|
360 |
#' @param var_label (`character`)\cr |
|
361 |
#' variable alternative name - for example variable label |
|
362 |
#' @param var_type (`character`) |
|
363 |
#' class of the variable. |
|
364 |
#' |
|
365 |
#' @return (`character`) HTML contents with all elements combined |
|
366 |
#' @keywords internal |
|
367 |
#' |
|
368 |
picker_options_content <- function(var_name, var_label, var_type) { |
|
369 | ! |
if (length(var_name) == 0) { |
370 | ! |
return(character(0)) |
371 |
} |
|
372 | ! |
if (length(var_type) == 0 && length(var_label) == 0) { |
373 | ! |
return(var_name) |
374 |
} |
|
375 | ! |
checkmate::assert_character(var_name, min.len = 1, any.missing = FALSE) |
376 | ! |
stopifnot( |
377 | ! |
identical(var_type, character(0)) || length(var_type) == length(var_name), |
378 | ! |
identical(var_label, character(0)) || length(var_label) == length(var_name) |
379 |
) |
|
380 | ||
381 | ! |
var_icon <- variable_type_icons(var_type) |
382 | ||
383 | ! |
res <- trimws(paste( |
384 | ! |
var_icon, |
385 | ! |
var_name, |
386 | ! |
vapply( |
387 | ! |
var_label, |
388 | ! |
function(x) { |
389 | ! |
ifelse(x == "", "", toString(tags$small(x, class = "text-muted"))) |
390 |
}, |
|
391 | ! |
character(1) |
392 |
) |
|
393 |
)) |
|
394 | ||
395 | ! |
return(res) |
396 |
} |
|
397 | ||
398 |
#' Create `choicesOpt` for `pickerInput` |
|
399 |
#' |
|
400 |
#' @param choices (`choices_labeled` or `character`)\cr |
|
401 |
#' choices vector |
|
402 |
#' |
|
403 |
#' @return (`list`)\cr |
|
404 |
#' to be passed as `choicesOpt` argument. |
|
405 |
#' @keywords internal |
|
406 |
picker_options <- function(choices) { |
|
407 | ! |
if (inherits(choices, "choices_labeled")) { |
408 | ! |
raw_choices <- extract_raw_choices(choices, sep = attr(choices, "sep")) |
409 | ! |
return( |
410 | ! |
list( |
411 | ! |
content = picker_options_content( |
412 | ! |
var_name = raw_choices, |
413 | ! |
var_label = extract_choices_labels(choices), |
414 | ! |
var_type = if (is.null(attr(choices, "types"))) character(0) else attr(choices, "types") |
415 |
) |
|
416 |
) |
|
417 |
) |
|
418 | ! |
} else if (all(vapply(choices, inherits, logical(1), "choices_labeled"))) { |
419 | ! |
choices <- unlist(unname(choices)) |
420 | ! |
return( |
421 | ! |
list(content = picker_options_content( |
422 | ! |
var_name = choices, |
423 | ! |
var_label = extract_choices_labels(choices), |
424 | ! |
var_type = if (is.null(attr(choices, "types"))) character(0) else attr(choices, "types") |
425 |
)) |
|
426 |
) |
|
427 |
} else { |
|
428 | ! |
return(NULL) |
429 |
} |
|
430 |
} |
|
431 | ||
432 |
#' Extract raw values from choices |
|
433 |
#' |
|
434 |
#' @param choices (`choices_labeled`, `list` or `character`)\cr |
|
435 |
#' object containing choices |
|
436 |
#' @param sep (`character(1)`)\cr |
|
437 |
#' A separator string to split the `choices` or `selected` inputs into the values of |
|
438 |
#' the different columns. |
|
439 |
#' @return choices simplified |
|
440 |
#' @keywords internal |
|
441 |
extract_raw_choices <- function(choices, sep) { |
|
442 | ! |
if (!is.null(sep)) { |
443 | ! |
vapply(choices, paste, collapse = sep, character(1)) |
444 | ! |
} else if (inherits(choices, "choices_labeled")) { |
445 | ! |
unname(unlist(choices)) |
446 |
} else { |
|
447 | ! |
choices |
448 |
} |
|
449 |
} |
|
450 | ||
451 |
#' if min or max are `NA` then the slider widget will be hidden |
|
452 |
#' |
|
453 |
#' @description `r lifecycle::badge("stable")`\cr |
|
454 |
#' Hidden input widgets are useful to have the `input[[inputId]]` variable |
|
455 |
#' on available in the server function but no corresponding visual clutter from |
|
456 |
#' input widgets that provide only a single choice. |
|
457 |
#' |
|
458 |
#' @inheritParams shiny::sliderInput |
|
459 |
#' @param label_help (`shiny.tag`) optional\cr |
|
460 |
#' object of class `shiny.tag`, e.g. an object returned by [shiny::helpText()] |
|
461 |
#' @param ... optional arguments to `sliderInput` |
|
462 |
#' |
|
463 |
#' @return (`shiny.tag`) HTML tag with `sliderInput` widget. |
|
464 |
#' |
|
465 |
#' @export |
|
466 |
#' |
|
467 |
#' @examples |
|
468 |
#' optionalSliderInput("a", "b", 0, 1, 0.2) |
|
469 |
optionalSliderInput <- function(inputId, label, min, max, value, label_help = NULL, ...) { # nolint |
|
470 | 25x |
checkmate::assert_number(min, na.ok = TRUE) |
471 | 25x |
checkmate::assert_number(max, na.ok = TRUE) |
472 | 25x |
checkmate::assert_numeric(value, min.len = 1, max.len = 2, any.missing = FALSE) |
473 | ||
474 | 25x |
is_na_min <- is.na(min) |
475 | 25x |
is_na_max <- is.na(max) |
476 | ||
477 | 25x |
hide <- is_na_min || is_na_max |
478 | ||
479 | 25x |
if (length(value) == 2) { |
480 | 2x |
value1 <- value[1] |
481 | 2x |
value2 <- value[2] |
482 |
} else { |
|
483 | 23x |
value1 <- value |
484 | 23x |
value2 <- value |
485 |
} |
|
486 | ||
487 | 25x |
if (is_na_min) { |
488 | 2x |
min <- value1 - 1 |
489 |
} |
|
490 | 25x |
if (is_na_max) { |
491 | 1x |
max <- value2 + 1 |
492 |
} |
|
493 | ||
494 | 25x |
if (min > value1 || max < value2) { |
495 | 2x |
stop("arguments inconsistent: min <= value <= max expected") |
496 |
} |
|
497 | ||
498 | 23x |
slider <- sliderInput(inputId, label, min, max, value, ...) |
499 | ||
500 | 23x |
if (!is.null(label_help)) { |
501 | ! |
slider[[3]] <- append(slider[[3]], list(tags$div(class = "label-help", label_help)), after = 1) |
502 |
} |
|
503 | ||
504 | 23x |
if (hide) { |
505 | 2x |
shinyjs::hidden(slider) |
506 |
} else { |
|
507 | 21x |
slider |
508 |
} |
|
509 |
} |
|
510 | ||
511 |
#' For `teal` modules we parameterize an `optionalSliderInput` with one argument |
|
512 |
#' `value_min_max` |
|
513 |
#' |
|
514 |
#' @description `r lifecycle::badge("stable")` |
|
515 |
#' The [optionalSliderInput()] function needs three arguments to determine |
|
516 |
#' whether to hide the `sliderInput` widget or not. For `teal` modules we specify an |
|
517 |
#' optional slider input with one argument here called `value_min_max`. |
|
518 |
#' |
|
519 |
#' @inheritParams optionalSliderInput |
|
520 |
#' |
|
521 |
#' @param value_min_max (`numeric(1)` or `numeric(3)`)\cr |
|
522 |
#' If of length 1 then the value gets set to that number and the `sliderInput` will be hidden. |
|
523 |
#' Otherwise, if it is of length three the three elements will map to `value`, `min` and `max` of |
|
524 |
#' the [optionalSliderInput()] function. |
|
525 |
#' |
|
526 |
#' @return (`shiny.tag`) HTML tag with range `sliderInput` widget. |
|
527 |
#' |
|
528 |
#' @export |
|
529 |
#' |
|
530 |
#' @examples |
|
531 |
#' |
|
532 |
#' optionalSliderInputValMinMax("a", "b", 1) |
|
533 |
#' optionalSliderInputValMinMax("a", "b", c(3, 1, 5)) |
|
534 |
optionalSliderInputValMinMax <- function(inputId, label, value_min_max, label_help = NULL, ...) { # nolint |
|
535 | 18x |
checkmate::assert( |
536 | 18x |
checkmate::check_numeric( |
537 | 18x |
value_min_max, |
538 | 18x |
finite = TRUE, |
539 | 18x |
len = 3 |
540 |
), |
|
541 | 18x |
checkmate::check_numeric( |
542 | 18x |
value_min_max, |
543 | 18x |
finite = TRUE, |
544 | 18x |
len = 1 |
545 |
) |
|
546 |
) |
|
547 | ||
548 | 18x |
x <- value_min_max |
549 | ||
550 | 18x |
vals <- if (length(x) == 3) { |
551 | 18x |
checkmate::assert_number(x[1], lower = x[2], upper = x[3], .var.name = "value_min_max") |
552 | 18x |
list(value = x[1], min = x[2], max = x[3]) |
553 | 18x |
} else if (length(x) == 1) { |
554 | ! |
list(value = x, min = NA_real_, max = NA_real_) |
555 |
} |
|
556 | ||
557 | 18x |
slider <- optionalSliderInput(inputId, label, vals$min, vals$max, vals$value, ...) |
558 | ||
559 | 18x |
if (!is.null(label_help)) { |
560 | ! |
slider[[3]] <- append(slider[[3]], list(tags$div(class = "label-help", label_help)), after = 1) |
561 |
} |
|
562 | 18x |
return(slider) |
563 |
} |
|
564 | ||
565 |
#' Extract labels from choices basing on attributes and names |
|
566 |
#' |
|
567 |
#' @param choices (`list` or `vector`)\cr |
|
568 |
#' select choices |
|
569 |
#' @param values optional\cr |
|
570 |
#' choices subset for which labels should be extracted, `NULL` for all choices. |
|
571 |
#' |
|
572 |
#' @return (`character`) vector with labels |
|
573 |
#' @keywords internal |
|
574 |
extract_choices_labels <- function(choices, values = NULL) { |
|
575 | ! |
res <- if (inherits(choices, "choices_labeled")) { |
576 | ! |
attr(choices, "raw_labels") |
577 | ! |
} else if (!is.null(names(choices)) && !setequal(names(choices), unlist(unname(choices)))) { |
578 | ! |
names(choices) |
579 |
} else { |
|
580 | ! |
NULL |
581 |
} |
|
582 | ||
583 | ! |
if (!is.null(values) && !is.null(res)) { |
584 | ! |
stopifnot(all(values %in% choices)) |
585 | ! |
res <- res[vapply(values, function(val) which(val == choices), numeric(1))] |
586 |
} |
|
587 | ||
588 | ! |
return(res) |
589 |
} |
1 |
#' Creates `ggplot2_args` object |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' Constructor of `ggplot2_args` class of objects. |
|
5 |
#' The `ggplot2_args` argument should be a part of every module which contains any `ggplot2` graphics. |
|
6 |
#' The function arguments are validated to match their `ggplot2` equivalents. |
|
7 |
#' |
|
8 |
#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`. |
|
9 |
#' |
|
10 |
#' @seealso |
|
11 |
#' * [resolve_ggplot2_args()] to resolve multiple objects into one using pre-defined priorities. |
|
12 |
#' * [parse_ggplot2_args()] to parse resolved list into list of calls. |
|
13 |
#' |
|
14 |
#' @param labs (named `list`)\cr |
|
15 |
#' where all fields have to match [ggplot2::labs()] arguments. |
|
16 |
#' @param theme (named `list`)\cr |
|
17 |
#' where all fields have to match [ggplot2::theme()] arguments. |
|
18 |
#' |
|
19 |
#' @return (`ggplot2_args`) object. |
|
20 |
#' @export |
|
21 |
#' @examples |
|
22 |
#' ggplot2_args( |
|
23 |
#' labs = list(title = "TITLE"), |
|
24 |
#' theme = list(title = ggplot2::element_text(size = 20)) |
|
25 |
#' ) |
|
26 |
ggplot2_args <- function(labs = list(), theme = list()) { |
|
27 | 92x |
checkmate::assert_list(labs) |
28 | 92x |
checkmate::assert_list(theme) |
29 | 92x |
checkmate::assert_character(names(labs), unique = TRUE, null.ok = TRUE) |
30 | 92x |
checkmate::assert_character(names(theme), unique = TRUE, null.ok = TRUE) |
31 | ||
32 | 92x |
ggplot2_theme <- methods::formalArgs(ggplot2::theme) |
33 |
# utils::getFromNamespace is not recommended nevertheless needed as it is replacing `:::`. |
|
34 |
# usage of static values will be vulnerable to any changes in ggplot2 aesthetics. |
|
35 | 92x |
ggplot2_labs <- c( |
36 | 92x |
utils::getFromNamespace(".all_aesthetics", "ggplot2"), |
37 | 92x |
methods::formalArgs(ggplot2::labs) |
38 |
) |
|
39 | 92x |
checkmate::assert_subset(names(labs), choices = ggplot2_labs, empty.ok = TRUE) |
40 | 91x |
checkmate::assert_subset(names(theme), choices = ggplot2_theme, empty.ok = TRUE) |
41 | ||
42 | 90x |
structure(list(labs = labs, theme = theme), class = "ggplot2_args") |
43 |
} |
|
44 | ||
45 |
#' Resolving and reducing multiple `ggplot2_args` objects |
|
46 |
#' |
|
47 |
#' @description `r lifecycle::badge("experimental")` |
|
48 |
#' Resolving and reducing multiple `ggplot2_args` objects. |
|
49 |
#' This function is intended to utilize user provided settings, defaults provided by the module creator and |
|
50 |
#' also `teal` option. See `Details`, below, to understand the logic. |
|
51 |
#' |
|
52 |
#' @seealso [parse_ggplot2_args()] to parse resolved list into list of calls. |
|
53 |
#' |
|
54 |
#' @param user_plot (`ggplot2_args`)\cr |
|
55 |
#' end user setup for theme and labs in the specific plot. |
|
56 |
#' Created with the [ggplot2_args()] function. The `NULL` value is supported. |
|
57 |
#' @param user_default (`ggplot2_args`)\cr |
|
58 |
#' end user setup for module default theme and labs. |
|
59 |
#' Created with the [ggplot2_args()] function. The `NULL` value is supported. |
|
60 |
#' @param module_plot (`ggplot2_args`)\cr |
|
61 |
#' module creator setup for theme and labs in the specific plot. |
|
62 |
#' Created with the [ggplot2_args()] function. The `NULL` value is supported. |
|
63 |
#' @param app_default (`ggplot2_args`)\cr |
|
64 |
#' Application level setting. Can be `NULL`. |
|
65 |
#' |
|
66 |
#' @return `ggplot2_args` object. |
|
67 |
#' |
|
68 |
#' @details |
|
69 |
#' The function picks the first non `NULL` value for each argument, checking in the following order: |
|
70 |
#' 1. `ggplot2_args` argument provided by the end user. |
|
71 |
#' Per plot (`user_plot`) and then default (`user_default`) setup. |
|
72 |
#' 2. `app_default` global R variable, `teal.ggplot2_args`. |
|
73 |
#' 3. `module_plot` which is a module creator setup. |
|
74 |
#' @export |
|
75 |
#' @examples |
|
76 |
#' resolve_ggplot2_args( |
|
77 |
#' user_plot = ggplot2_args( |
|
78 |
#' labs = list(title = "TITLE"), |
|
79 |
#' theme = list(title = ggplot2::element_text(size = 20)) |
|
80 |
#' ), |
|
81 |
#' user_default = ggplot2_args( |
|
82 |
#' labs = list(x = "XLAB") |
|
83 |
#' ) |
|
84 |
#' ) |
|
85 |
resolve_ggplot2_args <- function(user_plot = ggplot2_args(), |
|
86 |
user_default = ggplot2_args(), |
|
87 |
module_plot = ggplot2_args(), |
|
88 |
app_default = getOption("teal.ggplot2_args", ggplot2_args())) { |
|
89 | 18x |
checkmate::assert_class(user_plot, "ggplot2_args", null.ok = TRUE) |
90 | 17x |
checkmate::assert_class(user_default, "ggplot2_args", null.ok = TRUE) |
91 | 17x |
checkmate::assert_class(module_plot, "ggplot2_args", null.ok = TRUE) |
92 | 17x |
checkmate::assert_class(app_default, "ggplot2_args", null.ok = TRUE) |
93 | ||
94 | 17x |
ggplot2_args_all <- list( |
95 | 17x |
"plot" = user_plot, |
96 | 17x |
"default" = user_default, |
97 | 17x |
"teal" = app_default, |
98 | 17x |
"module" = module_plot |
99 |
) |
|
100 | ||
101 | 17x |
labs_args <- Reduce(`c`, lapply(ggplot2_args_all, function(x) x$labs)) |
102 | 17x |
labs_args <- if (is.null(labs_args)) list() else labs_args[!duplicated(names(labs_args))] |
103 | ||
104 | 17x |
theme_args <- Reduce(`c`, lapply(ggplot2_args_all, function(x) x$theme)) |
105 | 17x |
theme_args <- if (is.null(theme_args)) list() else theme_args[!duplicated(names(theme_args))] |
106 | ||
107 | 17x |
ggplot2_args(labs = labs_args, theme = theme_args) |
108 |
} |
|
109 | ||
110 |
#' Parse `ggplot2_args` object into the `ggplot2` expression |
|
111 |
#' |
|
112 |
#' @description `r lifecycle::badge("experimental")` |
|
113 |
#' A function to parse expression from the `ggplot2_args` object. |
|
114 |
#' @param ggplot2_args (`ggplot2_args`)\cr |
|
115 |
#' This argument could be a result of the [resolve_ggplot2_args()]. |
|
116 |
#' @param ggtheme (`character(1)`)\cr |
|
117 |
#' name of the `ggplot2` theme to be applied, e.g. `"dark"`. |
|
118 |
#' |
|
119 |
#' @return (`list`) of up to three elements of class `languange`: `"labs"`, `"ggtheme"` and `"theme"`. |
|
120 |
#' @export |
|
121 |
#' @examples |
|
122 |
#' parse_ggplot2_args( |
|
123 |
#' resolve_ggplot2_args(ggplot2_args( |
|
124 |
#' labs = list(title = "TITLE"), |
|
125 |
#' theme = list(title = ggplot2::element_text(size = 20)) |
|
126 |
#' )) |
|
127 |
#' ) |
|
128 |
#' |
|
129 |
#' parse_ggplot2_args( |
|
130 |
#' resolve_ggplot2_args( |
|
131 |
#' ggplot2_args( |
|
132 |
#' labs = list(title = "TITLE"), |
|
133 |
#' theme = list(title = ggplot2::element_text(size = 20)) |
|
134 |
#' ) |
|
135 |
#' ), |
|
136 |
#' ggtheme = "gray" |
|
137 |
#' ) |
|
138 |
parse_ggplot2_args <- function(ggplot2_args = teal.widgets::ggplot2_args(), |
|
139 |
ggtheme = c( |
|
140 |
"default", |
|
141 |
"gray", |
|
142 |
"bw", |
|
143 |
"linedraw", |
|
144 |
"light", |
|
145 |
"dark", |
|
146 |
"minimal", |
|
147 |
"classic", |
|
148 |
"void", |
|
149 |
"test" |
|
150 |
)) { |
|
151 | 10x |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
152 | 9x |
ggtheme <- match.arg(ggtheme) |
153 | ||
154 | 9x |
res_list <- list() |
155 | ||
156 | 9x |
labs_args <- ggplot2_args$labs |
157 | ||
158 | 9x |
labs_f <- if (length(labs_args)) { |
159 | 5x |
as.call(c(list(quote(ggplot2::labs)), labs_args)) |
160 |
} else { |
|
161 | 4x |
NULL |
162 |
} |
|
163 | ||
164 | 9x |
default_theme <- if (ggtheme != "default") { |
165 | 1x |
as.call(list(str2lang(paste0("ggplot2::theme_", ggtheme)))) |
166 |
} else { |
|
167 | 8x |
NULL |
168 |
} |
|
169 | ||
170 | 9x |
theme_args <- ggplot2_args$theme |
171 | ||
172 | 9x |
theme_f <- if (length(theme_args)) { |
173 | 2x |
as.call(c(list(quote(ggplot2::theme)), theme_args)) |
174 |
} else { |
|
175 | 7x |
NULL |
176 |
} |
|
177 | ||
178 | 9x |
final_list <- Filter(Negate(is.null), list(labs = labs_f, ggtheme = default_theme, theme = theme_f)) |
179 |
# For empty final_list we want to return empty list, not empty named list |
|
180 | 3x |
`if`(length(final_list) == 0, list(), final_list) |
181 |
} |
1 |
#' A `shiny` module that pops up verbatim text. |
|
2 |
#' @name verbatim_popup |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' This module consists of a button that once clicked pops up a |
|
5 |
#' modal window with verbatim-styled text. |
|
6 |
#' |
|
7 |
#' @param id (`character(1)`) the `shiny` id |
|
8 |
#' @param button_label (`character(1)`) the text printed on the button |
|
9 |
#' @param type (`character(1)`) specifying whether to use `[shiny::actionButton()]` or `[shiny::actionLink()]`. |
|
10 |
#' @param ... additional arguments to `[shiny::actionButton()]`(or `[shiny::actionLink()]`). |
|
11 |
#' |
|
12 |
#' @return the UI function returns a `shiny.tag.list` object |
|
13 |
#' @export |
|
14 |
#' |
|
15 |
#' @examples |
|
16 |
#' library(shiny) |
|
17 |
#' |
|
18 |
#' ui <- fluidPage(verbatim_popup_ui("my_id", button_label = "Open popup")) |
|
19 |
#' srv <- function(input, output) { |
|
20 |
#' verbatim_popup_srv( |
|
21 |
#' "my_id", |
|
22 |
#' "if (TRUE) { print('Popups are the best') }", |
|
23 |
#' title = "My custom title", |
|
24 |
#' style = TRUE |
|
25 |
#' ) |
|
26 |
#' } |
|
27 |
#' if (interactive()) shinyApp(ui, srv) |
|
28 |
#' |
|
29 |
verbatim_popup_ui <- function(id, button_label, type = c("button", "link"), ...) { |
|
30 | 5x |
checkmate::assert_string(id) |
31 | 5x |
checkmate::assert_string(button_label) |
32 | ||
33 | 5x |
ui_function <- switch(match.arg(type), |
34 | 5x |
"button" = shiny::actionButton, |
35 | 5x |
"link" = shiny::actionLink |
36 |
) |
|
37 | ||
38 | 4x |
ns <- shiny::NS(id) |
39 | 4x |
ui_args <- list( |
40 | 4x |
inputId = ns("button"), |
41 | 4x |
label = button_label |
42 |
) |
|
43 | ||
44 | 4x |
shiny::tagList( |
45 | 4x |
shiny::singleton( |
46 | 4x |
tags$head(shiny::includeScript(system.file("js/verbatim_popup.js", package = "teal.widgets"))) |
47 |
), |
|
48 | 4x |
shinyjs::useShinyjs(), |
49 | 4x |
do.call(ui_function, c(ui_args, list(...))) |
50 |
) |
|
51 |
} |
|
52 | ||
53 |
#' @name verbatim_popup |
|
54 |
#' @export |
|
55 |
#' |
|
56 |
#' @param verbatim_content (`character`, `expression`, `condition` or `reactive(1)` |
|
57 |
#' holding any of the above) the content to show in the popup modal window |
|
58 |
#' @param title (`character(1)`) the title of the modal window |
|
59 |
#' @param style (`logical(1)`) whether to style the `verbatim_content` using `styler::style_text`. |
|
60 |
#' If `verbatim_content` is a `condition` or `reactive` holding `condition` then this argument is ignored |
|
61 |
#' @param disabled (`reactive(1)`) the `shiny` reactive value holding a `logical`. The popup button is disabled |
|
62 |
#' when the flag is `TRUE` and enabled otherwise. |
|
63 |
#' |
|
64 |
verbatim_popup_srv <- function(id, verbatim_content, title, style = FALSE, disabled = shiny::reactiveVal(FALSE)) { |
|
65 | ! |
checkmate::assert_string(id) |
66 | ! |
checkmate::assert_string(title) |
67 | ! |
checkmate::assert_flag(style) |
68 | ! |
checkmate::assert_class(disabled, classes = "reactive") |
69 | ! |
moduleServer(id, function(input, output, session) { |
70 | ! |
ns <- session$ns |
71 | ! |
modal_content <- format_content(verbatim_content, style) |
72 | ! |
button_click_observer( |
73 | ! |
click_event = shiny::reactive(input$button), |
74 | ! |
copy_button_id = ns("copy_button"), |
75 | ! |
copied_area_id = ns("verbatim_content"), |
76 | ! |
modal_title = title, |
77 | ! |
modal_content = modal_content, |
78 | ! |
disabled = disabled |
79 |
) |
|
80 |
}) |
|
81 |
} |
|
82 | ||
83 |
#' Creates a `shiny` observer handling button clicks. |
|
84 |
#' |
|
85 |
#' @description |
|
86 |
#' When the button is clicked it pop up a modal window with the text. |
|
87 |
#' |
|
88 |
#' @keywords internal |
|
89 |
#' @param click_event `reactive` the click event |
|
90 |
#' @param copy_button_id (`character(1)`) the id of the button to copy the modal content. |
|
91 |
#' Automatically appended with a 1 and 2 suffix for top and bottom buttons respectively. |
|
92 |
#' @param copied_area_id (`character(1)`) the id of the element which contents are copied |
|
93 |
#' @param modal_title (`character(1)`) the title of the modal window |
|
94 |
#' @param modal_content (`reactive`) the content of the modal window |
|
95 |
#' @param disabled (`reactive(1)`) the `shiny` reactive value holding a `logical`. The popup button is disabled |
|
96 |
#' when the flag is `TRUE` and enabled otherwise. |
|
97 |
button_click_observer <- function(click_event, |
|
98 |
copy_button_id, |
|
99 |
copied_area_id, |
|
100 |
modal_title, |
|
101 |
modal_content, |
|
102 |
disabled) { |
|
103 | 1x |
shiny::observeEvent( |
104 | 1x |
disabled(), |
105 | 1x |
handlerExpr = { |
106 | ! |
if (disabled()) { |
107 | ! |
shinyjs::disable("button") |
108 |
} else { |
|
109 | ! |
shinyjs::enable("button") |
110 |
} |
|
111 |
} |
|
112 |
) |
|
113 | ||
114 | 1x |
shiny::observeEvent( |
115 | 1x |
click_event(), |
116 | 1x |
handlerExpr = { |
117 | ! |
req(modal_content()) |
118 | ! |
shiny::showModal( |
119 | ! |
shiny::modalDialog( |
120 | ! |
shiny::tagList( |
121 | ! |
include_css_files(pattern = "verbatim_popup"), |
122 | ! |
tags$div( |
123 | ! |
class = "mb-4", |
124 | ! |
shiny::actionButton( |
125 | ! |
paste0(copy_button_id, 1), |
126 | ! |
"Copy to Clipboard", |
127 | ! |
onclick = paste0("copyToClipboard('", copied_area_id, "')") |
128 |
), |
|
129 | ! |
shiny::modalButton("Dismiss") |
130 |
), |
|
131 | ! |
tags$pre(id = copied_area_id, modal_content()), |
132 |
), |
|
133 | ! |
title = modal_title, |
134 | ! |
footer = shiny::tagList( |
135 | ! |
shiny::actionButton( |
136 | ! |
paste0(copy_button_id, 2), |
137 | ! |
"Copy to Clipboard", |
138 | ! |
onclick = paste0("copyToClipboard('", copied_area_id, "')") |
139 |
), |
|
140 | ! |
shiny::modalButton("Dismiss") |
141 |
), |
|
142 | ! |
size = "l", |
143 | ! |
easyClose = TRUE |
144 |
) |
|
145 |
) |
|
146 |
} |
|
147 |
) |
|
148 |
} |
|
149 | ||
150 |
#' Formats the content of the modal popup window. |
|
151 |
#' |
|
152 |
#' @details |
|
153 |
#' Formats the content: |
|
154 |
#' * concatenates if needed |
|
155 |
#' * styles if `style` is TRUE |
|
156 |
#' |
|
157 |
#' @keywords internal |
|
158 |
#' @inheritParams verbatim_popup |
|
159 |
#' @return `reactive` with the formatted content |
|
160 |
format_content <- function(verbatim_content, style = FALSE) { |
|
161 | 11x |
shiny::reactive({ |
162 | 4x |
content <- if (inherits(verbatim_content, "reactive")) { |
163 | 2x |
tryCatch( |
164 | 2x |
verbatim_content(), |
165 | 2x |
error = function(e) { |
166 | ! |
e |
167 |
} |
|
168 |
) |
|
169 |
} else { |
|
170 | 2x |
verbatim_content |
171 |
} |
|
172 | 4x |
shiny::validate(shiny::need( |
173 | 4x |
checkmate::test_multi_class(content, classes = c("expression", "character", "condition")), |
174 | 4x |
"verbatim_content should be an expression, character or condition" |
175 |
)) |
|
176 | ||
177 | 4x |
content <- paste(as.character(content), collapse = "\n") |
178 | ||
179 | 4x |
if (style && !checkmate::test_class(content, "condition")) { |
180 | 3x |
content <- paste(styler::style_text(content), collapse = "\n") |
181 |
} |
|
182 | 4x |
content |
183 |
}) |
|
184 |
} |
1 |
#' Small well class for HTML |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")`\cr |
|
4 |
#' Adds Small Well class and overflow-x property to HTML output element. |
|
5 |
#' @param ... other arguments to pass to tag object's div attributes. |
|
6 |
#' |
|
7 |
#' @details `white_small_well` is intended to be used with [shiny::uiOutput()]. |
|
8 |
#' The overflow-x property is set to auto so that a scroll bar is added |
|
9 |
#' when the content overflows at the left and right edges of the output window. |
|
10 |
#' For example, this is useful for displaying wide tables. |
|
11 |
#' |
|
12 |
#' @return An HTML output element with class Small Well and overflow-x property |
|
13 |
#' @export |
|
14 |
#' |
|
15 |
#' @examples |
|
16 |
#' |
|
17 |
#' white_small_well(shiny::htmlOutput("summary")) |
|
18 |
white_small_well <- function(...) { |
|
19 | ! |
shiny::tagList( |
20 | ! |
include_css_files(pattern = "custom"), |
21 | ! |
tags$div( |
22 | ! |
class = "well well-sm bg-white", |
23 |
... |
|
24 |
) |
|
25 |
) |
|
26 |
} |
1 |
#' Standard UI layout |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")`\cr |
|
4 |
#' Create a standard UI layout with output on the right and an encoding panel on |
|
5 |
#' the left. This is the layout used by the `teal` modules. |
|
6 |
#' |
|
7 |
#' @param output (`shiny.tag`)\cr |
|
8 |
#' object with the output element (table, plot, listing) such as for example returned |
|
9 |
#' by [shiny::plotOutput()]. |
|
10 |
#' @param encoding (`shiny.tag`)\cr |
|
11 |
#' object containing the encoding elements. If this element is `NULL` then no encoding side |
|
12 |
#' panel on the right is created. |
|
13 |
#' @param forms (`tagList`)\cr |
|
14 |
#' for example [shiny::actionButton()] that are placed below the encodings panel |
|
15 |
#' @param pre_output (`shiny.tag`) optional,\cr |
|
16 |
#' with text placed before the output to put the output into context. For example a title. |
|
17 |
#' @param post_output (`shiny.tag`) optional, with text placed after the output to put the output |
|
18 |
#' into context. For example the [shiny::helpText()] elements are useful. |
|
19 |
#' |
|
20 |
#' @return an object of class `shiny.tag` with the UI code. |
|
21 |
#' |
|
22 |
#' @examples |
|
23 |
#' library(shiny) |
|
24 |
#' standard_layout( |
|
25 |
#' output = white_small_well(tags$h3("Tests")), |
|
26 |
#' encoding = tags$div( |
|
27 |
#' tags$label("Encodings", class = "text-primary"), |
|
28 |
#' panel_item( |
|
29 |
#' "Tests", |
|
30 |
#' optionalSelectInput( |
|
31 |
#' "tests", |
|
32 |
#' "Tests:", |
|
33 |
#' choices = c( |
|
34 |
#' "Shapiro-Wilk", |
|
35 |
#' "Kolmogorov-Smirnov (one-sample)" |
|
36 |
#' ), |
|
37 |
#' selected = "Shapiro-Wilk" |
|
38 |
#' ) |
|
39 |
#' ) |
|
40 |
#' ), |
|
41 |
#' forms = tagList( |
|
42 |
#' verbatim_popup_ui("warning", "Show Warnings"), |
|
43 |
#' verbatim_popup_ui("rcode", "Show R code") |
|
44 |
#' ) |
|
45 |
#' ) |
|
46 |
#' |
|
47 |
#' @export |
|
48 |
standard_layout <- function(output, |
|
49 |
encoding = NULL, |
|
50 |
forms = NULL, |
|
51 |
pre_output = NULL, |
|
52 |
post_output = NULL) { |
|
53 |
# checking arguments |
|
54 | 11x |
checkmate::assert_multi_class(output, c("shiny.tag", "shiny.tag.list", "html")) |
55 | 9x |
checkmate::assert_multi_class(encoding, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) |
56 | 8x |
checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) |
57 | 7x |
checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) |
58 | ||
59 |
# if encoding=NULL then forms is placed below output |
|
60 | ||
61 | 6x |
tag_output <- tags$div( |
62 | 6x |
class = "well", |
63 | 6x |
tags$div(class = "pre-output", pre_output), |
64 | 6x |
tags$div(class = "output", output), |
65 | 6x |
tags$div(class = "post-output", post_output) |
66 |
) |
|
67 | ||
68 | 6x |
tag_enc_out <- if (!is.null(encoding)) { |
69 | 2x |
tagList( |
70 | 2x |
tags$div( |
71 | 2x |
class = "col-md-3", |
72 | 2x |
tags$div(class = "well", encoding), |
73 | 2x |
if (is.null(forms)) { |
74 | 1x |
NULL |
75 |
} else { |
|
76 | 1x |
tags$div(class = "form-group", forms) |
77 |
} |
|
78 |
), |
|
79 | 2x |
tags$div(class = "col-md-9", tag_output) |
80 |
) |
|
81 |
} else { |
|
82 | 4x |
tags$div( |
83 | 4x |
class = "col-md-12", |
84 | 4x |
tag_output, |
85 | 4x |
if (is.null(forms)) { |
86 | 3x |
NULL |
87 |
} else { |
|
88 | 1x |
tags$div(class = "form-group", forms) |
89 |
} |
|
90 |
) |
|
91 |
} |
|
92 | ||
93 | 6x |
fluidRow(tag_enc_out) |
94 |
} |
1 |
#' @title Draggable Buckets |
|
2 |
#' @description `r lifecycle::badge("experimental")` |
|
3 |
#' A custom widget with draggable elements that can be put into buckets. |
|
4 |
#' |
|
5 |
#' @param input_id (`character(1)`) the `HTML` id of this widget |
|
6 |
#' @param label (`character(1)` or `shiny.tag`) the header of this widget |
|
7 |
#' @param elements (`character`) the elements to drag into buckets |
|
8 |
#' @param buckets (`character` or `list`) the names of the buckets the elements can be put in or a list of key-pair |
|
9 |
#' values where key is a name of a bucket and value is a character vector of elements in a bucket |
|
10 |
#' |
|
11 |
#' @return the `HTML` code comprising an instance of this widget |
|
12 |
#' @export |
|
13 |
#' |
|
14 |
#' @details `shinyvalidate` validation can be used with this widget. See example below. |
|
15 |
#' |
|
16 |
#' @examples |
|
17 |
#' library(shiny) |
|
18 |
#' |
|
19 |
#' ui <- fluidPage( |
|
20 |
#' draggable_buckets("id", "Choices #1", c("a", "b"), c("bucket1", "bucket2")), |
|
21 |
#' draggable_buckets("id2", "Choices #2", letters, c("vowels", "consonants")), |
|
22 |
#' verbatimTextOutput("out"), |
|
23 |
#' verbatimTextOutput("out2") |
|
24 |
#' ) |
|
25 |
#' server <- function(input, output) { |
|
26 |
#' iv <- shinyvalidate::InputValidator$new() |
|
27 |
#' iv$add_rule( |
|
28 |
#' "id", |
|
29 |
#' function(data) if (length(data[["bucket1"]]) == 0) "There should be stuff in bucket 1" |
|
30 |
#' ) |
|
31 |
#' iv$enable() |
|
32 |
#' |
|
33 |
#' observeEvent(list(input$id, input$id2), { |
|
34 |
#' print(isolate(input$id)) |
|
35 |
#' print(isolate(input$id2)) |
|
36 |
#' }) |
|
37 |
#' output$out <- renderPrint({ |
|
38 |
#' iv$is_valid() |
|
39 |
#' input$id |
|
40 |
#' }) |
|
41 |
#' output$out2 <- renderPrint(input$id2) |
|
42 |
#' } |
|
43 |
#' if (interactive()) shinyApp(ui, server) |
|
44 |
#' |
|
45 |
#' # With default elements in the bucket |
|
46 |
#' ui <- fluidPage( |
|
47 |
#' draggable_buckets("id", "Choices #1", c("a", "b"), list(bucket1 = character(), bucket2 = c("c"))), |
|
48 |
#' verbatimTextOutput("out") |
|
49 |
#' ) |
|
50 |
#' server <- function(input, output) { |
|
51 |
#' observeEvent(input$id, { |
|
52 |
#' print(isolate(input$id)) |
|
53 |
#' }) |
|
54 |
#' output$out <- renderPrint(input$id) |
|
55 |
#' } |
|
56 |
#' if (interactive()) shinyApp(ui, server) |
|
57 |
draggable_buckets <- function(input_id, label, elements = character(), buckets) { |
|
58 | ! |
checkmate::assert_string(input_id) |
59 | ! |
checkmate::assert_true(inherits(label, "character") || inherits(label, "shiny.tag")) |
60 | ! |
checkmate::assert_character(c(elements, unlist(buckets)), min.len = 0, null.ok = TRUE, unique = TRUE) |
61 | ! |
checkmate::assert( |
62 | ! |
checkmate::check_character(buckets, min.len = 1), |
63 | ! |
checkmate::check_list(buckets, types = "character", names = "unique") |
64 |
) |
|
65 | ||
66 | ! |
elements_iterator <- new.env(parent = emptyenv()) |
67 | ! |
elements_iterator$it <- 0 |
68 | ||
69 | ! |
shiny::tagList( |
70 | ! |
shiny::singleton(tags$head( |
71 | ! |
shiny::includeScript(system.file("widgets/draggable_buckets.js", package = "teal.widgets")) |
72 |
)), |
|
73 | ! |
include_css_files("draggable_buckets.css"), |
74 | ! |
shiny::div( |
75 | ! |
tags$span(label), |
76 | ! |
render_unbucketed_elements(elements = elements, elements_iterator = elements_iterator, widget_id = input_id), |
77 | ! |
render_buckets(buckets = buckets, elements_iterator = elements_iterator, widget_id = input_id), |
78 | ! |
class = "draggableBuckets", |
79 | ! |
id = input_id |
80 |
) |
|
81 |
) |
|
82 |
} |
|
83 | ||
84 |
render_unbucketed_elements <- function(elements, elements_iterator, widget_id) { |
|
85 | ! |
tags$div( |
86 | ! |
lapply(elements, function(element) { |
87 | ! |
elements_iterator$it <- elements_iterator$it + 1 |
88 | ! |
render_draggable_element( |
89 | ! |
value = element, |
90 | ! |
id = paste0(widget_id, "draggable", elements_iterator$it), |
91 | ! |
widget_id = widget_id |
92 |
) |
|
93 |
}), |
|
94 | ! |
id = paste0(widget_id, "elements"), |
95 | ! |
class = c("form-control", "elements"), |
96 | ! |
ondragover = "allowDrop(event)", |
97 | ! |
ondrop = "drop(event)", |
98 | ! |
`data-widget` = widget_id |
99 |
) |
|
100 |
} |
|
101 | ||
102 |
render_buckets <- function(buckets, elements_iterator, widget_id) { |
|
103 | ! |
buckets <- `if`( |
104 | ! |
is.list(buckets), |
105 | ! |
lapply(names(buckets), function(bucket_name) { |
106 | ! |
render_bucket( |
107 | ! |
name = bucket_name, |
108 | ! |
elements = buckets[[bucket_name]], |
109 | ! |
elements_iterator = elements_iterator, |
110 | ! |
widget_id = widget_id |
111 |
) |
|
112 |
}), |
|
113 | ! |
lapply(buckets, render_bucket, widget_id = widget_id, elements_iterator = elements_iterator) |
114 |
) |
|
115 | ! |
shiny::tagList(buckets) |
116 |
} |
|
117 | ||
118 |
render_draggable_element <- function(value, id, widget_id) { |
|
119 | ! |
tags$div( |
120 | ! |
value, |
121 | ! |
id = id, |
122 | ! |
class = "element", |
123 | ! |
draggable = "true", |
124 | ! |
ondragstart = "drag(event)", |
125 | ! |
ondragover = "allowDrop(event)", |
126 | ! |
ondrop = "dropReorder(event)", |
127 | ! |
`data-widget` = widget_id |
128 |
) |
|
129 |
} |
|
130 | ||
131 |
render_bucket <- function(name, elements = NULL, elements_iterator = NULL, widget_id = NULL) { |
|
132 | ! |
tags$div( |
133 | ! |
tags$div( |
134 | ! |
paste0(name, ":"), |
135 | ! |
class = "bucket-name", |
136 | ! |
ondragover = "allowDrop(event)", |
137 | ! |
ondrop = "dropBucketName(event)", |
138 | ! |
`data-widget` = widget_id |
139 |
), |
|
140 | ! |
lapply(elements, function(element) { |
141 | ! |
elements_iterator$it <- elements_iterator$it + 1 |
142 | ! |
render_draggable_element( |
143 | ! |
value = element, |
144 | ! |
id = paste0(widget_id, "draggable", elements_iterator$it), |
145 | ! |
widget_id = widget_id |
146 |
) |
|
147 |
}), |
|
148 | ! |
class = c("form-control", "bucket"), |
149 | ! |
ondragover = "allowDrop(event)", |
150 | ! |
ondrop = "drop(event)", |
151 | ! |
`data-label` = name, |
152 | ! |
`data-widget` = widget_id |
153 |
) |
|
154 |
} |
1 |
#' Panel group widget |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")`\cr |
|
4 |
#' Designed to group [`panel_item`] elements. Used to handle `shiny` inputs in the encoding panel. |
|
5 |
#' @param id optional, (`character`)\cr |
|
6 |
#' @param ... (`shiny.tag`)\cr |
|
7 |
#' panels created by [panel_group()] |
|
8 |
#' |
|
9 |
#' @return (`shiny.tag`) |
|
10 |
#' |
|
11 |
#' @examples |
|
12 |
#' |
|
13 |
#' library(shiny) |
|
14 |
#' panel_group( |
|
15 |
#' panel_item( |
|
16 |
#' title = "Display", |
|
17 |
#' collapsed = FALSE, |
|
18 |
#' checkboxGroupInput( |
|
19 |
#' "check", |
|
20 |
#' "Tables display", |
|
21 |
#' choices = LETTERS[1:3], |
|
22 |
#' selected = LETTERS[1] |
|
23 |
#' ), |
|
24 |
#' radioButtons( |
|
25 |
#' "radio", |
|
26 |
#' label = "Plot type", |
|
27 |
#' choices = letters[1:2], |
|
28 |
#' selected = letters[1] |
|
29 |
#' ) |
|
30 |
#' ), |
|
31 |
#' panel_item( |
|
32 |
#' title = "Pre-processing", |
|
33 |
#' radioButtons( |
|
34 |
#' "filtering", |
|
35 |
#' "What to filter", |
|
36 |
#' choices = LETTERS[1:4], |
|
37 |
#' selected = LETTERS[1] |
|
38 |
#' ), |
|
39 |
#' radioButtons( |
|
40 |
#' "na_action", |
|
41 |
#' "NA action", |
|
42 |
#' choices = letters[1:3], |
|
43 |
#' selected = letters[1] |
|
44 |
#' ) |
|
45 |
#' ) |
|
46 |
#' ) |
|
47 |
#' |
|
48 |
#' @export |
|
49 |
panel_group <- function(..., id = NULL) { |
|
50 | ! |
checkmate::assert_string(id, null.ok = TRUE) |
51 | ||
52 |
# panel-group |
|
53 |
# div |
|
54 | ||
55 | ! |
tags$div( |
56 | ! |
id = id, |
57 |
..., |
|
58 | ! |
.renderHook = function(res_tag) { |
59 | ! |
bs_version <- get_bs_version() |
60 | ! |
if (bs_version == "3") { |
61 | ! |
htmltools::tagAppendAttributes(res_tag, class = "panel-group") |
62 | ! |
} else if (bs_version %in% c("4", "5")) { |
63 | ! |
res_tag <- htmltools::tagAppendAttributes(res_tag, class = "my-4") |
64 | ! |
htmltools::tagQuery(res_tag)$ |
65 | ! |
find(".card")$ |
66 | ! |
removeClass("my-2")$ |
67 | ! |
allTags() |
68 |
} else { |
|
69 | ! |
stop("Bootstrap 3, 4, and 5 are supported.") |
70 |
} |
|
71 |
} |
|
72 |
) |
|
73 |
} |
|
74 | ||
75 |
#' Panel item widget |
|
76 |
#' |
|
77 |
#' @description `r lifecycle::badge("experimental")`\cr |
|
78 |
#' Designed to be grouped using [`panel_group`] element. Used to handle `shiny` inputs in the encoding panel. |
|
79 |
#' @param title (`character`)\cr title of panel |
|
80 |
#' @param ... content of panel |
|
81 |
#' @param collapsed (`logical`) optional,\cr |
|
82 |
#' whether to initially collapse panel |
|
83 |
#' @param input_id (`character`) optional\cr |
|
84 |
#' name of the panel item element. If supplied, this will register a shiny input variable that |
|
85 |
#' indicates whether the panel item is open or collapsed and is accessed with `input$input_id`. |
|
86 |
#' |
|
87 |
#' @return (`shiny.tag`) |
|
88 |
#' |
|
89 |
#' @examples |
|
90 |
#' |
|
91 |
#' library(shiny) |
|
92 |
#' panel_item( |
|
93 |
#' title = "Display", |
|
94 |
#' collapsed = FALSE, |
|
95 |
#' checkboxGroupInput( |
|
96 |
#' "check", |
|
97 |
#' "Tables display", |
|
98 |
#' choices = LETTERS[1:3], |
|
99 |
#' selected = LETTERS[1] |
|
100 |
#' ), |
|
101 |
#' radioButtons( |
|
102 |
#' "radio", |
|
103 |
#' label = "Plot type", |
|
104 |
#' choices = letters[1:2], |
|
105 |
#' selected = letters[1] |
|
106 |
#' ) |
|
107 |
#' ) |
|
108 |
#' |
|
109 |
#' @export |
|
110 |
panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) { |
|
111 | ! |
stopifnot(checkmate::test_character(title, len = 1) || inherits(title, c("shiny.tag", "shiny.tag.list", "html"))) |
112 | ! |
checkmate::assert_flag(collapsed) |
113 | ! |
checkmate::assert_string(input_id, null.ok = TRUE) |
114 | ||
115 | ! |
div_id <- paste0(input_id, "_div") |
116 | ! |
panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1)) |
117 | ||
118 | ||
119 | ! |
tags$div(.renderHook = function(res_tag) { |
120 | ! |
bs_version <- get_bs_version() |
121 | ||
122 |
# alter tag structure |
|
123 | ! |
if (bs_version == "3") { |
124 | ! |
res_tag$children <- list( |
125 | ! |
tags$div( |
126 | ! |
id = div_id, |
127 | ! |
class = "panel panel-default", |
128 | ! |
tags$div( |
129 | ! |
class = paste("panel-heading", ifelse(collapsed, "collapsed", "")), |
130 | ! |
`data-toggle` = "collapse", |
131 | ! |
href = paste0("#", panel_id), |
132 | ! |
`aria-expanded` = ifelse(collapsed, "false", "true"), |
133 | ! |
icon(ifelse(collapsed, "angle-right", "angle-down"), class = "dropdown-icon"), |
134 | ! |
tags$label( |
135 | ! |
class = "panel-title inline", |
136 | ! |
title, |
137 |
) |
|
138 |
), |
|
139 | ! |
tags$div( |
140 | ! |
class = paste("panel-collapse collapse", ifelse(collapsed, "", "in")), |
141 | ! |
id = panel_id, |
142 | ! |
tags$div( |
143 | ! |
class = "panel-body", |
144 |
... |
|
145 |
) |
|
146 |
) |
|
147 |
) |
|
148 |
) |
|
149 | ! |
} else if (bs_version %in% c("4", "5")) { |
150 | ! |
res_tag$children <- list( |
151 | ! |
tags$div( |
152 | ! |
class = "card my-2", |
153 | ! |
tags$div( |
154 | ! |
class = "card-header", |
155 | ! |
tags$div( |
156 | ! |
class = paste("card-heading", ifelse(collapsed, "collapsed", "")), |
157 |
# bs4 |
|
158 | ! |
`data-toggle` = "collapse", |
159 |
# bs5 |
|
160 | ! |
`data-bs-toggle` = "collapse", |
161 | ! |
href = paste0("#", panel_id), |
162 | ! |
`aria-expanded` = ifelse(collapsed, "false", "true"), |
163 | ! |
icon(ifelse(collapsed, "angle-right", "angle-down"), class = "dropdown-icon"), |
164 | ! |
tags$label( |
165 | ! |
class = "card-title inline", |
166 | ! |
title, |
167 |
) |
|
168 |
) |
|
169 |
), |
|
170 | ! |
tags$div( |
171 | ! |
id = panel_id, |
172 | ! |
class = paste("collapse", ifelse(collapsed, "", "show")), |
173 | ! |
tags$div( |
174 | ! |
class = "card-body", |
175 |
... |
|
176 |
) |
|
177 |
) |
|
178 |
) |
|
179 |
) |
|
180 |
} else { |
|
181 | ! |
stop("Bootstrap 3, 4, and 5 are supported.") |
182 |
} |
|
183 | ||
184 | ||
185 | ! |
tagList( |
186 | ! |
include_css_files(pattern = "panel.css"), |
187 | ! |
tags$head(shiny::includeScript(system.file("js/panel_group.js", package = "teal.widgets"))), |
188 | ! |
res_tag |
189 |
) |
|
190 |
}) |
|
191 |
} |
1 |
#' Builds a `basic_table_args` object |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' This function has to be used to build an input for a `basic_table_args` argument. |
|
5 |
#' The `basic_table_args` argument should be a part of every module which contains any `rtables` object. |
|
6 |
#' Arguments are validated to match their `rtables` equivalents. |
|
7 |
#' |
|
8 |
#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`. |
|
9 |
#' |
|
10 |
#' @seealso |
|
11 |
#' * [resolve_basic_table_args()] to resolve multiple objects into one using pre-defined priorities. |
|
12 |
#' * [parse_basic_table_args()] to parse resolved list into list of calls. |
|
13 |
#' |
|
14 |
#' @param ... arguments compatible with [rtables::basic_table()]. |
|
15 |
#' |
|
16 |
#' @return (`basic_table_args`) object. |
|
17 |
#' @export |
|
18 |
#' @examples |
|
19 |
#' basic_table_args(subtitles = "SUBTITLE") |
|
20 |
basic_table_args <- function(...) { |
|
21 | 118x |
table_args_l <- list(...) |
22 | 118x |
checkmate::assert_character(names(table_args_l), unique = TRUE, null.ok = TRUE) |
23 | ||
24 | 118x |
basic_table_formals <- methods::formalArgs(rtables::basic_table) |
25 | 118x |
checkmate::assert_subset(names(table_args_l), choices = basic_table_formals, empty.ok = TRUE) |
26 | ||
27 | 114x |
structure(table_args_l, class = "basic_table_args") |
28 |
} |
|
29 | ||
30 |
#' Resolves and reduces multiple `basic_table_args` objects |
|
31 |
#' |
|
32 |
#' @description `r lifecycle::badge("experimental")` |
|
33 |
#' Resolving and reducing multiple `basic_table_args` objects. |
|
34 |
#' This function is intended to utilize user provided settings, defaults provided by the module creator and |
|
35 |
#' also `teal` option. See `Details`, below, to understand the logic. |
|
36 |
#' |
|
37 |
#' @seealso [parse_basic_table_args()] to parse resolved list into list of calls. |
|
38 |
#' |
|
39 |
#' @param user_table (`basic_table_args`)\cr |
|
40 |
#' end user setup for [rtables::basic_table()] of a specific table. |
|
41 |
#' Created with the [basic_table_args()] function. The `NULL` value is supported. |
|
42 |
#' @param user_default (`basic_table_args`)\cr |
|
43 |
#' end user default setup for [rtables::basic_table()] |
|
44 |
#' of a specific table. Created with the [basic_table_args()] function. The `NULL` value is supported. |
|
45 |
#' @param module_table (`ggplot2_args`)\cr |
|
46 |
#' module creator setup for [rtables::basic_table()] of a specific table. |
|
47 |
#' Created with the [basic_table_args()] function. The `NULL` value is supported. |
|
48 |
#' @param app_default (`basic_table_args`)\cr |
|
49 |
#' Application level setting. Can be `NULL`. |
|
50 |
#' |
|
51 |
#' @return `basic_table_args` object. |
|
52 |
#' @details |
|
53 |
#' The function picks the first non `NULL` value for each argument, checking in the following order: |
|
54 |
#' 1. `basic_table_args` argument provided by the end user. |
|
55 |
#' Per table (`user_table`) and then default (`user_default`) setup. |
|
56 |
#' 2. `app_default` global R variable, `teal.basic_table_args`. |
|
57 |
#' 3. `module_table` which is a module creator setup. |
|
58 |
#' @export |
|
59 |
#' @examples |
|
60 |
#' resolve_basic_table_args( |
|
61 |
#' user_table = basic_table_args(title = "TITLE"), |
|
62 |
#' user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE") |
|
63 |
#' ) |
|
64 |
resolve_basic_table_args <- function(user_table = basic_table_args(), |
|
65 |
user_default = basic_table_args(), |
|
66 |
module_table = basic_table_args(), |
|
67 |
app_default = getOption("teal.basic_table_args", basic_table_args())) { |
|
68 | 24x |
checkmate::assert_class(user_table, "basic_table_args", null.ok = TRUE) |
69 | 23x |
checkmate::assert_class(user_default, "basic_table_args", null.ok = TRUE) |
70 | 23x |
checkmate::assert_class(module_table, "basic_table_args", null.ok = TRUE) |
71 | 23x |
checkmate::assert_class(app_default, "basic_table_args", null.ok = TRUE) |
72 | ||
73 | 23x |
table_args_all <- list( |
74 | 23x |
"table" = user_table, |
75 | 23x |
"default" = user_default, |
76 | 23x |
"teal" = app_default, |
77 | 23x |
"module" = module_table |
78 |
) |
|
79 | ||
80 | 23x |
table_args_f <- Reduce(`c`, table_args_all) |
81 | ||
82 | 23x |
if (length(table_args_f) == 0) { |
83 | 9x |
basic_table_args() |
84 |
} else { |
|
85 | 14x |
do.call(basic_table_args, table_args_f[!duplicated(names(table_args_f))]) |
86 |
} |
|
87 |
} |
|
88 | ||
89 |
#' Parses `basic_table_args` object into the `basic_table` expression |
|
90 |
#' |
|
91 |
#' @description `r lifecycle::badge("experimental")` |
|
92 |
#' A function to parse expression from the `basic_table_args` object. |
|
93 |
#' @param basic_table_args (`basic_table_args`)\cr |
|
94 |
#' This argument could be a result of the [`resolve_basic_table_args()`]. |
|
95 |
#' |
|
96 |
#' @return (`language`) the `rtables::basic_table()` filled with additional arguments. |
|
97 |
#' @export |
|
98 |
#' @examples |
|
99 |
#' parse_basic_table_args( |
|
100 |
#' resolve_basic_table_args( |
|
101 |
#' user_table = basic_table_args(title = "TITLE"), |
|
102 |
#' user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE") |
|
103 |
#' ) |
|
104 |
#' ) |
|
105 |
parse_basic_table_args <- function(basic_table_args = teal.widgets::basic_table_args()) { |
|
106 | 8x |
checkmate::assert_class(basic_table_args, "basic_table_args", null.ok = TRUE) |
107 | ||
108 | 7x |
if (length(basic_table_args) == 0) { |
109 | 3x |
quote(rtables::basic_table()) |
110 |
} else { |
|
111 | 4x |
as.call(c(list(quote(rtables::basic_table)), basic_table_args)) |
112 |
} |
|
113 |
} |
1 |
#' Nested Closeable Modal Popup |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' Alternative to `shiny::modalDialog`. Create a nested modal popup that can be shown/hidden |
|
5 |
#' using `jQuery` and modal `id`, without disturbing the parent modal. |
|
6 |
#' |
|
7 |
#' @param id (`character(1)`) `shiny` module id for the component.\cr |
|
8 |
#' Note that this id can be used to show/hide this modal |
|
9 |
#' with the appended `jQuery` methods show/hide. |
|
10 |
#' @param ... (`shiny.tag`) `shiny` UI elements that will be displayed in the modal UI |
|
11 |
#' @param modal_args (`list`) optional list of arguments for the `shiny::modalDialog` function |
|
12 |
#' to customize the modal. Has `easyClose` set to `TRUE` as default |
|
13 |
#' |
|
14 |
#' @return (`shiny.tag`) returns `HTML` for `shiny` module UI which can be nested into a modal popup |
|
15 |
#' @export |
|
16 |
#' |
|
17 |
#' @examples |
|
18 |
#' library(shiny) |
|
19 |
#' library(shinyjs) |
|
20 |
#' |
|
21 |
#' ui <- fluidPage( |
|
22 |
#' useShinyjs(), |
|
23 |
#' actionButton("show_1", "$(\"#modal_1\").modal(\"show\")"), |
|
24 |
#' nested_closeable_modal( |
|
25 |
#' "modal_1", |
|
26 |
#' modal_args = list( |
|
27 |
#' size = "l", |
|
28 |
#' title = "First Modal", |
|
29 |
#' easyClose = TRUE, |
|
30 |
#' footer = NULL |
|
31 |
#' ), |
|
32 |
#' tags$div( |
|
33 |
#' "This modal can be closed by running", tags$code("$(\"#modal_1\").modal(\"hide\")"), |
|
34 |
#' "in the JS console!", |
|
35 |
#' tags$br(), |
|
36 |
#' "Note that the second modal is placed right within this modal", |
|
37 |
#' tags$br(), |
|
38 |
#' "Alternatively, calling the", tags$code("removeModal()"), |
|
39 |
#' "will remove all the active modal popups", |
|
40 |
#' tags$br(), tags$br(), |
|
41 |
#' actionButton("show_2", "$(\"#modal_2\").modal(\"show\")"), |
|
42 |
#' actionButton("hide_1", "$(\"#modal_1\").modal(\"hide\")"), |
|
43 |
#' nested_closeable_modal( |
|
44 |
#' id = "modal_2", |
|
45 |
#' modal_args = list( |
|
46 |
#' size = "m", |
|
47 |
#' title = "Second Modal", |
|
48 |
#' footer = NULL, |
|
49 |
#' easyClose = TRUE |
|
50 |
#' ), |
|
51 |
#' tags$div( |
|
52 |
#' "This modal can be closed by running", tags$code("$(\"#modal_1\").modal(\"hide\")"), |
|
53 |
#' "in the JS console!", |
|
54 |
#' "Note that removing the parent will remove the child. |
|
55 |
#' But, reopening will remember the open state of child", |
|
56 |
#' actionButton("hide_2", "$(\"#modal_2\").modal(\"hide\")"), |
|
57 |
#' actionButton("hide_all", "$(\"#modal_1\").modal(\"hide\")") |
|
58 |
#' ) |
|
59 |
#' ) |
|
60 |
#' ) |
|
61 |
#' ) |
|
62 |
#' ) |
|
63 |
#' |
|
64 |
#' server <- function(input, output) { |
|
65 |
#' observeEvent(input$show_1, { |
|
66 |
#' runjs("$(\"#modal_1\").modal(\"show\")") |
|
67 |
#' }) |
|
68 |
#' observeEvent(input$show_2, { |
|
69 |
#' runjs("$(\"#modal_2\").modal(\"show\")") |
|
70 |
#' }) |
|
71 |
#' observeEvent(c(input$hide_1, input$hide_all), { |
|
72 |
#' runjs("$(\"#modal_1\").modal(\"hide\")") |
|
73 |
#' }) |
|
74 |
#' observeEvent(input$hide_2, { |
|
75 |
#' runjs("$(\"#modal_2\").modal(\"hide\")") |
|
76 |
#' }) |
|
77 |
#' } |
|
78 |
#' |
|
79 |
#' if (interactive()) { |
|
80 |
#' shinyApp(ui, server) |
|
81 |
#' } |
|
82 |
nested_closeable_modal <- function(id, ..., modal_args = list(easyClose = TRUE)) { |
|
83 | ! |
checkmate::assert_string(id) |
84 | ! |
checkmate::assert_list(modal_args) |
85 | ! |
modal_args <- append(list(...), modal_args) |
86 | ! |
tagList( |
87 | ! |
htmltools::tagQuery(do.call(modalDialog, modal_args))$ |
88 | ! |
removeAttrs("id")$ |
89 | ! |
addAttrs(id = id, `aria-hidden` = "true", class = "custom-modal", `data-backdrop` = "false")$ |
90 | ! |
children("div")$ |
91 | ! |
children("div")$ |
92 | ! |
children("div")$ |
93 | ! |
siblings(".modal-footer")$ |
94 | ! |
find("button")$ |
95 | ! |
removeAttrs(c("data-dismiss", "data-bs-dismiss"))$ |
96 | ! |
addAttrs(onclick = paste0("$('#", id, "').modal('hide');"))$ |
97 | ! |
allTags() |
98 |
) |
|
99 |
} |
1 |
#' Map `lenghtMenu` property |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("stable")`\cr |
|
4 |
#' Maps the `lengthMenu` selected value property of `DT::datatable` to a `shiny` variable. |
|
5 |
#' @param dt_name `ns()` of `inputId` of the `DT::datatable` |
|
6 |
#' @param dt_rows `ns()` of `inputId` of the variable that holds the current selected value of `lengthMenu` |
|
7 |
#' |
|
8 |
#' @name get_dt_rows |
|
9 |
#' |
|
10 |
#' @return (`shiny::tagList`) A `shiny tagList`. |
|
11 |
#' |
|
12 |
#' @examplesIf require("DT") |
|
13 |
#' library(shiny) |
|
14 |
#' library(DT) |
|
15 |
#' |
|
16 |
#' ui <- function(id) { |
|
17 |
#' ns <- NS(id) |
|
18 |
#' tagList( |
|
19 |
#' DTOutput(ns("data_table")), |
|
20 |
#' get_dt_rows(ns("data_table"), ns("dt_rows")) |
|
21 |
#' ) |
|
22 |
#' } |
|
23 |
#' |
|
24 |
#' # use the input$dt_rows in the Shiny Server function |
|
25 |
#' server <- function(id) { |
|
26 |
#' moduleServer(id, function(input, output, session) { |
|
27 |
#' output$data_table <- renderDataTable( |
|
28 |
#' { |
|
29 |
#' iris |
|
30 |
#' }, |
|
31 |
#' options = list(pageLength = input$dt_rows) |
|
32 |
#' ) |
|
33 |
#' }) |
|
34 |
#' } |
|
35 |
#' |
|
36 |
#' if (interactive()) { |
|
37 |
#' shinyApp( |
|
38 |
#' ui = ui("my_table_module"), |
|
39 |
#' server = function(input, output, session) server("my_table_module") |
|
40 |
#' ) |
|
41 |
#' } |
|
42 |
#' @export |
|
43 |
get_dt_rows <- function(dt_name, dt_rows) { |
|
44 | ! |
tags$head( |
45 | ! |
tags$script( |
46 | ! |
sprintf( |
47 | ! |
"$(document).ready(function() { |
48 | ! |
$('%s').on('length.dt', function(e, settings, len) { |
49 | ! |
Shiny.onInputChange('%s', len); |
50 |
}); |
|
51 |
});", |
|
52 | ! |
paste0("#", dt_name), |
53 | ! |
dt_rows |
54 |
) |
|
55 |
) |
|
56 |
) |
|
57 |
} |