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