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