teal.widgets coverage - 85.65%

Files
Source

#' Wrapper for `pickerInput`
#'
#' @description
#' Wrapper for [shinyWidgets::pickerInput()] with additional features.
#' When `fixed = TRUE` or when the number of `choices` is less or equal to 1 (see `fixed_on_single`),
#' the `pickerInput` widget is hidden and non-interactive widget will be displayed
#' instead. Toggle of `HTML` elements is just the visual effect to avoid displaying
#' `pickerInput` widget when there is only one choice.
#'
#' @inheritParams shinyWidgets::pickerInput
#'
#' @param sep (`character(1)`)\cr
#'  A separator string to split the `choices` or `selected` inputs into the values of the different
#'  columns.
#'
#' @param label_help (`shiny.tag`) optional,\cr
#'  e.g. an object returned by [shiny::helpText()].
#'
#' @param fixed (`logical(1)`) optional,\cr
#'  whether to block user to select choices.
#'
#' @param fixed_on_single (`logical(1)`) optional,\cr
#'  whether to block user to select a choice when there is only one or less choice.
#'  When `FALSE`, user is still able to select or deselect the choice.
#'
#' @param width (`character(1)`)\cr
#'  The width of the input passed to `pickerInput`  e.g. `'auto'`, `'fit'`, `'100px'` or `'75%'`
#'
#' @return (`shiny.tag`) HTML tag with `pickerInput` widget and
#'  non-interactive element listing selected values.
#'
#' @export
#'
#' @examples
#' library(shiny)
#'
#' ui_grid <- function(...) {
#'   bslib::page_fluid(
#'     bslib::layout_columns(
#'       col_widths = c(4, 4, 4),
#'       ...
#'     )
#'   )
#' }
#'
#' ui <- ui_grid(
#'   wellPanel(
#'     optionalSelectInput(
#'       inputId = "c1",
#'       label = "Fixed choices",
#'       choices = LETTERS[1:5],
#'       selected = c("A", "B"),
#'       fixed = TRUE
#'     ),
#'     verbatimTextOutput(outputId = "c1_out")
#'   ),
#'   wellPanel(
#'     optionalSelectInput(
#'       inputId = "c2",
#'       label = "Single choice",
#'       choices = "A",
#'       selected = "A"
#'     ),
#'     verbatimTextOutput(outputId = "c2_out")
#'   ),
#'   wellPanel(
#'     optionalSelectInput(
#'       inputId = "c3",
#'       label = "NULL choices",
#'       choices = NULL
#'     ),
#'     verbatimTextOutput(outputId = "c3_out")
#'   ),
#'   wellPanel(
#'     optionalSelectInput(
#'       inputId = "c4",
#'       label = "Default",
#'       choices = LETTERS[1:5],
#'       selected = "A"
#'     ),
#'     verbatimTextOutput(outputId = "c4_out")
#'   ),
#'   wellPanel(
#'     optionalSelectInput(
#'       inputId = "c5",
#'       label = "Named vector",
#'       choices = c(`A - value A` = "A", `B - value B` = "B", `C - value C` = "C"),
#'       selected = "A"
#'     ),
#'     verbatimTextOutput(outputId = "c5_out")
#'   ),
#'   wellPanel(
#'     selectInput(
#'       inputId = "c6_choices", label = "Update choices", choices = letters, multiple = TRUE
#'     ),
#'     optionalSelectInput(
#'       inputId = "c6",
#'       label = "Updated choices",
#'       choices = NULL,
#'       multiple = TRUE,
#'       fixed_on_single = TRUE
#'     ),
#'     verbatimTextOutput(outputId = "c6_out")
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   observeEvent(input$c6_choices, ignoreNULL = FALSE, {
#'     updateOptionalSelectInput(
#'       session = session,
#'       inputId = "c6",
#'       choices = input$c6_choices,
#'       selected = input$c6_choices
#'     )
#'   })
#'
#'   output$c1_out <- renderPrint(input$c1)
#'   output$c2_out <- renderPrint(input$c2)
#'   output$c3_out <- renderPrint(input$c3)
#'   output$c4_out <- renderPrint(input$c4)
#'   output$c5_out <- renderPrint(input$c5)
#'   output$c6_out <- renderPrint(input$c6)
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
optionalSelectInput <- function(inputId, # nolint
                                label = NULL,
                                choices = NULL,
                                selected = NULL,
                                multiple = FALSE,
                                sep = NULL,
                                options = list(),
                                label_help = NULL,
                                fixed = FALSE,
                                fixed_on_single = FALSE,
                                width = NULL) {
  checkmate::assert_string(inputId)
  checkmate::assert(
    checkmate::check_string(label, null.ok = TRUE),
    checkmate::check_class(label, "shiny.tag"),
    checkmate::check_class(label, "shiny.tag.list"),
    checkmate::check_class(label, "html")
  )
  stopifnot(is.null(choices) || length(choices) >= 1)
  stopifnot(
    is.null(selected) ||
      length(selected) == 0 ||
      all(selected %in% choices) ||
      all(selected %in% unlist(choices, recursive = FALSE))
  )
  checkmate::assert_flag(multiple)
  checkmate::assert_string(sep, null.ok = TRUE)
  checkmate::assert_list(options)
  checkmate::assert(
    checkmate::check_string(label_help, null.ok = TRUE),
    checkmate::check_class(label_help, "shiny.tag"),
    checkmate::check_class(label_help, "shiny.tag.list"),
    checkmate::check_class(label_help, "html")
  )
  checkmate::assert_flag(fixed)
  checkmate::assert_flag(fixed_on_single)

  if (!is.null(width)) {
    validateCssUnit(width)
  }

  default_options <- list(
    "actions-box" = multiple,
    "none-selected-text" = "- Nothing selected -",
    "allow-clear" = !multiple,
    "max-options" = ifelse(multiple, Inf, 1),
    "show-subtext" = TRUE,
    "live-search" = ifelse(length(choices) > 10, TRUE, FALSE)
  )

  options <- if (!identical(options, list())) {
    c(options, default_options[setdiff(names(default_options), names(options))])
  } else {
    default_options
  }

  if (is.null(choices)) {
    choices <- ""
    selected <- NULL
  }

  if (length(choices) <= 1 && fixed_on_single) fixed <- TRUE

  raw_choices <- extract_raw_choices(choices, attr(choices, "sep"))
  raw_selected <- extract_raw_choices(selected, attr(choices, "sep"))

  # Making sure the default dropdown popup can be displayed in the whole body, even outside the sidebars.
  if (is.null(options$container)) {
    options$container <- "body"
  }

  ui_picker <- tags$div(
    id = paste0(inputId, "_input"),
    # visibility feature marked with display: none/block instead of shinyjs::hide/show
    #  as mechanism to hide/show is handled by javascript code
    style = if (fixed) "display: none;" else "display: block;",
    shinyWidgets::pickerInput(
      inputId = inputId,
      label = label,
      choices = raw_choices,
      selected = raw_selected,
      multiple = TRUE,
      width = width,
      options = options,
      choicesOpt = picker_options(choices)
    )
  )

  if (!is.null(label_help)) {
    ui_picker[[3]] <- append(ui_picker[[3]], list(tags$div(class = "label-help", label_help)), after = 1)
  }

  ui_fixed <- tags$div(
    id = paste0(inputId, "_fixed"),
    # visibility feature marked with display: none/block instead of shinyjs::hide/show
    #  as mechanism to hide/show is handled by javascript code
    style = if (fixed) "display: block;" else "display: none;",
    tags$label(class = "control-label", label),
    # selected values as verbatim text
    tags$code(
      id = paste0(inputId, "_selected_text"),
      if (length(selected) > 0) {
        toString(selected)
      } else {
        "NULL"
      }
    ),
    label_help
  )

  tags$div(
    # when selected values in ui_picker change
    # then update ui_fixed - specifically, update '{id}_selected_text' element
    tags$script(
      sprintf(
        "
        $(function() {
          $('#%1$s').on('change', function(e) {
            var select_concat = $(this).val().length ? $(this).val().join(', ') : 'NULL';
            $('#%1$s_selected_text').html(select_concat);
          })
        })",
        inputId
      )
    ),

    # if ui_picker has only one or less option or is fixed then hide {id}_input and show {id}_fixed
    if (fixed_on_single) {
      js <- sprintf(
        "$(function() {
          $('#%1$s').on('change', function(e) {
            var options = $('#%1$s').find('option');
            if (options.length == 1) {
              $('#%1$s_input').hide();
              $('#%1$s_fixed').show();
            } else {
              $('#%1$s_input').show();
              $('#%1$s_fixed').hide();
            }
          })
        })",
        inputId
      )
      tags$script(js)
    },
    tags$div(ui_picker, ui_fixed)
  )
}

#' @rdname optionalSelectInput
#' @param session (`shiny.session`)\cr
#' @export
updateOptionalSelectInput <- function(session, # nolint
                                      inputId, # nolint
                                      label = NULL,
                                      selected = NULL,
                                      choices = NULL) {
  raw_choices <- extract_raw_choices(choices, attr(choices, "sep"))
  raw_selected <- extract_raw_choices(selected, attr(choices, "sep"))

  # update picker input
  shinyWidgets::updatePickerInput(
    session = session,
    inputId = inputId,
    label = label,
    selected = as.character(raw_selected),
    choices = raw_choices,
    choicesOpt = picker_options(choices),
    options = list(
      `live-search` = ifelse(length(raw_choices) > 10, TRUE, FALSE)
    )
  )

  invisible(NULL)
}

#' Get icons to represent variable types in dataset
#'
#' @param var_type (`character`)\cr
#'  of R internal types (classes).
#'
#' @return (`character`)\cr
#'  vector of HTML icons corresponding to  data type in each column.
#' @keywords internal
#'
variable_type_icons <- function(var_type) {
  checkmate::assert_character(var_type, any.missing = FALSE)

  class_to_icon <- list(
    numeric = "arrow-up-1-9",
    integer = "arrow-up-1-9",
    logical = "pause",
    Date = "calendar",
    POSIXct = "calendar",
    POSIXlt = "calendar",
    factor = "chart-bar",
    character = "keyboard",
    primary_key = "key",
    unknown = "circle-question"
  )
  class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))

  res <- unname(vapply(
    var_type,
    FUN.VALUE = character(1),
    FUN = function(class) {
      if (class == "") {
        class
      } else if (is.null(class_to_icon[[class]])) {
        class_to_icon[["unknown"]]
      } else {
        class_to_icon[[class]]
      }
    }
  ))

  res
}

#' Optional content for `optionalSelectInput`
#'
#' Prepares content to be displayed in `optionalSelectInput` with icons and labels
#'
#' @param var_name (`character`)\cr
#'  variable name
#' @param var_label (`character`)\cr
#'  variable alternative name - for example variable label
#' @param var_type (`character`)
#' class of the variable.
#'
#' @return (`character`) HTML contents with all elements combined
#' @keywords internal
#'
picker_options_content <- function(var_name, var_label, var_type) {
  if (length(var_name) == 0) {
    res <- character(0)
  } else if (length(var_type) == 0 && length(var_label) == 0) {
    res <- var_name
  } else {
    checkmate::assert_character(var_name, min.len = 1, any.missing = FALSE)
    stopifnot(
      identical(var_type, character(0)) || length(var_type) == length(var_name),
      identical(var_label, character(0)) || length(var_label) == length(var_name)
    )

    var_icon <- variable_type_icons(var_type)

    res <- trimws(paste(
      var_icon,
      var_name,
      vapply(
        var_label,
        function(x) {
          ifelse(x == "", "", toString(tags$small(x, class = "text-muted")))
        },
        character(1)
      )
    ))
  }

  res
}

#' Create `choicesOpt` for `pickerInput`
#'
#' @param choices (`choices_labeled` or `character`)\cr
#'  choices vector
#'
#' @return (`list`)\cr
#'  to be passed as `choicesOpt` argument.
#' @keywords internal
picker_options <- function(choices) {
  if (inherits(choices, "choices_labeled")) {
    raw_choices <- extract_raw_choices(choices, sep = attr(choices, "sep"))
    res <- list(
      content = picker_options_content(
        var_name  = raw_choices,
        var_label = extract_choices_labels(choices),
        var_type  = if (is.null(attr(choices, "types"))) character(0) else attr(choices, "types")
      )
    )
  } else if (all(vapply(choices, inherits, logical(1), "choices_labeled"))) {
    choices <- unlist(unname(choices))
    res <- list(content = picker_options_content(
      var_name  = choices,
      var_label = extract_choices_labels(choices),
      var_type  = if (is.null(attr(choices, "types"))) character(0) else attr(choices, "types")
    ))
  } else {
    res <- NULL
  }
  res
}

#' Extract raw values from choices
#'
#' @param choices (`choices_labeled`, `list` or `character`)\cr
#'  object containing choices
#' @param sep (`character(1)`)\cr
#'  A separator string to split the `choices` or `selected` inputs into the values of
#'  the different columns.
#' @return choices simplified
#' @keywords internal
extract_raw_choices <- function(choices, sep) {
  if (!is.null(sep)) {
    vapply(choices, paste, collapse = sep, character(1))
  } else if (inherits(choices, "choices_labeled")) {
    unname(unlist(choices))
  } else {
    choices
  }
}

#' Optional Slider Input Widget
#'
#' if min or max are `NA` then the slider widget will be hidden
#'
#' @description
#' Hidden input widgets are useful to have the `input[[inputId]]` variable
#' on available in the server function but no corresponding visual clutter from
#' input widgets that provide only a single choice.
#'
#' @inheritParams shiny::sliderInput
#' @param label_help (`shiny.tag`) optional\cr
#'  object of class `shiny.tag`, e.g. an object returned by [shiny::helpText()]
#' @param ... optional arguments to `sliderInput`
#'
#' @return (`shiny.tag`) HTML tag with `sliderInput` widget.
#'
#' @export
#'
#' @examples
#' ui <- bslib::page_fluid(
#'   shinyjs::useShinyjs(),
#'   optionalSliderInput("s", "shown", 0, 1, 0.2),
#'   optionalSliderInput("h", "hidden", 0, NA, 1),
#' )
#' if (interactive()) {
#'   shiny::shinyApp(ui, function(input, output) {})
#' }
optionalSliderInput <- function(inputId, label, min, max, value, label_help = NULL, ...) { # nolint
  checkmate::assert_number(min, na.ok = TRUE)
  checkmate::assert_number(max, na.ok = TRUE)
  checkmate::assert_numeric(value, min.len = 1, max.len = 2, any.missing = FALSE)

  is_na_min <- is.na(min)
  is_na_max <- is.na(max)

  hide <- is_na_min || is_na_max

  if (length(value) == 2) {
    value1 <- value[1]
    value2 <- value[2]
  } else {
    value1 <- value
    value2 <- value
  }

  if (is_na_min) {
    min <- value1 - 1
  }
  if (is_na_max) {
    max <- value2 + 1
  }

  if (min > value1 || max < value2) {
    stop("arguments inconsistent: min <= value <= max expected")
  }

  slider <- sliderInput(inputId, label, min, max, value, ...)

  if (!is.null(label_help)) {
    slider[[3]] <- append(slider[[3]], list(tags$div(class = "label-help", label_help)), after = 1)
  }

  if (hide) {
    shinyjs::hidden(slider)
  } else {
    slider
  }
}

#' Optional Slider Input with minimal and maximal values
#'
#' For `teal` modules we parameterize an `optionalSliderInput` with one argument
#' `value_min_max`
#'
#' @description
#' The [optionalSliderInput()] function needs three arguments to determine
#' whether to hide the `sliderInput` widget or not. For `teal` modules we specify an
#' optional slider input with one argument here called `value_min_max`.
#'
#' @inheritParams optionalSliderInput
#'
#' @param value_min_max (`numeric(1)` or `numeric(3)`)\cr
#'  If of length 1 then the value gets set to that number and the `sliderInput` will be hidden.
#'  Otherwise, if it is of length three the three elements will map to `value`, `min` and `max` of
#'  the [optionalSliderInput()] function.
#'
#' @return (`shiny.tag`) HTML tag with range `sliderInput` widget.
#'
#' @export
#'
#' @examples
#'
#' ui <- bslib::page_fluid(
#'   shinyjs::useShinyjs(),
#'   optionalSliderInputValMinMax("a1", "b1", 1), # Hidden
#'   optionalSliderInputValMinMax("a2", "b2", c(3, 1, 5)) # Shown
#' )
#' if (interactive()) {
#'   shiny::shinyApp(ui, function(input, output) {})
#' }
optionalSliderInputValMinMax <- function(inputId, label, value_min_max, label_help = NULL, ...) { # nolint
  checkmate::assert(
    checkmate::check_numeric(
      value_min_max,
      finite = TRUE,
      len = 3
    ),
    checkmate::check_numeric(
      value_min_max,
      finite = TRUE,
      len = 1
    )
  )

  x <- value_min_max

  vals <- if (length(x) == 3) {
    checkmate::assert_number(x[1], lower = x[2], upper = x[3], .var.name = "value_min_max")
    list(value = x[1], min = x[2], max = x[3])
  } else if (length(x) == 1) {
    list(value = x, min = NA_real_, max = NA_real_)
  }

  slider <- optionalSliderInput(inputId, label, vals$min, vals$max, vals$value, ...)

  if (!is.null(label_help)) {
    slider[[3]] <- append(slider[[3]], list(tags$div(class = "label-help", label_help)), after = 1)
  }
  slider
}

#' Extract labels from choices basing on attributes and names
#'
#' @param choices (`list` or `vector`)\cr
#'  select choices
#' @param values optional\cr
#'  choices subset for which labels should be extracted, `NULL` for all choices.
#'
#' @return (`character`) vector with labels
#' @keywords internal
extract_choices_labels <- function(choices, values = NULL) {
  res <- if (inherits(choices, "choices_labeled")) {
    attr(choices, "raw_labels")
  } else if (!is.null(names(choices)) && !setequal(names(choices), unlist(unname(choices)))) {
    names(choices)
  } else {
    NULL
  }

  if (!is.null(values) && !is.null(res)) {
    stopifnot(all(values %in% choices))
    res <- res[vapply(values, function(val) which(val == choices), numeric(1))]
  }

  res
}

#' @keywords internal
#' @noRd
plot_with_settings_deps <- function() {
  htmltools::htmlDependency(
    name = "teal-widgets-plot-with-settings",
    version = utils::packageVersion("teal.widgets"),
    package = "teal.widgets",
    src = "plot-with-settings",
    stylesheet = "plot-with-settings.css",
    script = "plot-with-settings.js"
  )
}

#' @name plot_with_settings
#' @rdname plot_with_settings
#' @export
plot_with_settings_ui <- function(id) {
  checkmate::assert_string(id)

  ns <- NS(id)

  tags$div(
    plot_with_settings_deps(),
    shinyjs::useShinyjs(),
    bslib::card(
      id = ns("plot-with-settings"),
      full_screen = TRUE,
      tags$div(
        tags$div(
          class = "teal-widgets settings-buttons",
          bslib::tooltip(
            trigger = tags$div(
              bslib::popover(
                id = ns("expbut"),
                trigger = icon("maximize"),
                # This should be removed once https://github.com/rstudio/bslib/issues/1326 is fixed
                tags$span(HTML("&nbsp;"), style = "visibility: hidden; height: 0px; display: block;"),
                uiOutput(ns("slider_ui")),
                uiOutput(ns("width_warning"))
              )
            ),
            options = list(trigger = "hover"),
            class = "resize-button",
            "Resize"
          ),
          bslib::tooltip(
            trigger = tags$div(type_download_ui(ns("downbutton"))),
            options = list(trigger = "hover"),
            class = "download-button",
            "Download"
          )
        ),
        tags$div(
          id = ns("plot-out-main"),
          class = "teal-widgets plot-content",
          uiOutput(ns("plot_out_main"))
        )
      )
    )
  )
}

#' Plot-with-settings module
#'
#' @rdname plot_with_settings
#' @description
#' Universal module for plots with settings for height, width, and download.
#'
#' @export
#'
#' @param id (`character(1)`) `shiny` module id.
#'
#' @param plot_r (`reactive` or `function`)\cr
#'  `reactive` expression or a simple `function` to draw a plot.
#'  A simple `function` is needed e.g. for base plots like `plot(1)` as the output can not be caught when downloading.
#'  Take into account that simple functions are less efficient than reactive, as not catching the result.
#' @param height (`numeric`) optional\cr
#'  vector with three elements c(VAL, MIN, MAX), where VAL is the starting value of the slider in
#'  the main and expanded plot display.
#' @param width (`numeric`) optional\cr
#'  vector with three elements `c(VAL, MIN, MAX)`, where VAL is the starting value of the slider in
#'  the main and expanded plot display; `NULL` for default display.
#' @param show_hide_signal optional, (`reactive logical` a mechanism to allow modules which call this
#'     module to show/hide the plot_with_settings UI)
#' @param brushing (`logical`) optional\cr
#'  mechanism to enable / disable brushing on the main plot.
#' All the brushing data is stored as a reactive object in the `"brush"` element of
#'  returned list. See the example for details.
#' @param clicking (`logical`)\cr
#'  a mechanism to enable / disable clicking on data points on the main plot.
#' All the clicking data is stored as a reactive object in the `"click"`
#'  element of returned list. See the example for details.
#' @param dblclicking (`logical`) optional\cr
#'  mechanism to enable / disable double-clicking on data points on the main plot.
#' All the double clicking data is stored as a reactive object in the
#'  the `"dblclick"` element of returned list. See the example for details.
#' @param hovering (`logical(1)`) optional\cr
#'  mechanism to enable / disable hovering over data points on the main plot.
#' All the hovering data is stored as a reactive object in the
#' `"hover"` element of returned list. See the example for details.
#' @param graph_align (`character(1)`) optional,\cr
#'  one of `"left"` (default), `"center"`, `"right"` or `"justify"`. The alignment of the graph on
#'  the main page.
#'
#' @details By default the plot is rendered with `72 dpi`. In order to change this, to for example 96 set
#' `options(teal.plot_dpi = 96)`. The minimum allowed `dpi` value is `24` and it must be a whole number.
#' If an invalid value is set then the default value is used and a warning is outputted to the console.
#'
#' @return A `shiny` module.
#'
#' @examplesIf requireNamespace("lattice", quietly = TRUE)
#' # Example using a reactive as input to plot_r
#' library(shiny)
#' library(ggplot2)
#'
#' ui <- bslib::page_fluid(
#'   plot_with_settings_ui(
#'     id = "plot_with_settings"
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   plot_r <- reactive({
#'     ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) +
#'       geom_point()
#'   })
#'
#'   plot_with_settings_srv(
#'     id = "plot_with_settings",
#'     plot_r = plot_r,
#'     height = c(400, 100, 1200),
#'     width = c(500, 250, 750)
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' # Example using a function as input to plot_r
#' library(lattice)
#'
#' ui <- bslib::page_fluid(
#'   radioButtons("download_option", "Select the Option", list("ggplot", "trellis", "grob", "base")),
#'   plot_with_settings_ui(
#'     id = "plot_with_settings"
#'   ),
#'   sliderInput("nums", "Value", 1, 10, 1)
#' )
#'
#' server <- function(input, output, session) {
#'   plot_r <- function() {
#'     numbers <- seq_len(input$nums)
#'     if (input$download_option == "ggplot") {
#'       ggplot(data.frame(n = numbers), aes(.data$n)) +
#'         geom_bar()
#'     } else if (input$download_option == "trellis") {
#'       densityplot(numbers)
#'     } else if (input$download_option == "grob") {
#'       tr_plot <- densityplot(numbers)
#'       ggplotGrob(
#'         ggplot(data.frame(n = numbers), aes(.data$n)) +
#'           geom_bar()
#'       )
#'     } else if (input$download_option == "base") {
#'       plot(numbers)
#'     }
#'   }
#'
#'   plot_with_settings_srv(
#'     id = "plot_with_settings",
#'     plot_r = plot_r,
#'     height = c(400, 100, 1200),
#'     width = c(500, 250, 750)
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' # Example with brushing/hovering/clicking/double-clicking
#' ui <- bslib::page_fluid(
#'   plot_with_settings_ui(
#'     id = "plot_with_settings"
#'   ),
#'   fluidRow(
#'     column(4, tags$h3("Brush"), verbatimTextOutput("brushing_data")),
#'     column(4, tags$h3("Click"), verbatimTextOutput("clicking_data")),
#'     column(4, tags$h3("DblClick"), verbatimTextOutput("dblclicking_data")),
#'     column(4, tags$h3("Hover"), verbatimTextOutput("hovering_data"))
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   plot_r <- reactive({
#'     ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) +
#'       geom_point()
#'   })
#'
#'   plot_data <- plot_with_settings_srv(
#'     id = "plot_with_settings",
#'     plot_r = plot_r,
#'     height = c(400, 100, 1200),
#'     brushing = TRUE,
#'     clicking = TRUE,
#'     dblclicking = TRUE,
#'     hovering = TRUE
#'   )
#'
#'   output$brushing_data <- renderPrint(plot_data$brush())
#'   output$clicking_data <- renderPrint(plot_data$click())
#'   output$dblclicking_data <- renderPrint(plot_data$dblclick())
#'   output$hovering_data <- renderPrint(plot_data$hover())
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' # Example which allows module to be hidden/shown
#' library("shinyjs")
#'
#' ui <- bslib::page_fluid(
#'   useShinyjs(),
#'   actionButton("button", "Show/Hide"),
#'   plot_with_settings_ui(
#'     id = "plot_with_settings"
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   plot_r <- plot_r <- reactive(
#'     ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) +
#'       geom_point()
#'   )
#'
#'   show_hide_signal_rv <- reactiveVal(TRUE)
#'
#'   observeEvent(input$button, show_hide_signal_rv(!show_hide_signal_rv()))
#'
#'   plot_with_settings_srv(
#'     id = "plot_with_settings",
#'     plot_r = plot_r,
#'     height = c(400, 100, 1200),
#'     width = c(500, 250, 750),
#'     show_hide_signal = reactive(show_hide_signal_rv())
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
plot_with_settings_srv <- function(id,
                                   plot_r,
                                   height = c(600, 200, 2000),
                                   width = NULL,
                                   show_hide_signal = reactive(TRUE),
                                   brushing = FALSE,
                                   clicking = FALSE,
                                   dblclicking = FALSE,
                                   hovering = FALSE,
                                   graph_align = "left") {
  checkmate::assert_string(id)
  checkmate::assert(
    checkmate::check_class(plot_r, "function"),
    checkmate::check_class(plot_r, "reactive")
  )
  checkmate::assert_numeric(height, min.len = 1, any.missing = FALSE)
  checkmate::assert_numeric(height, len = 3, any.missing = FALSE, finite = TRUE)
  checkmate::assert_numeric(height[1], lower = height[2], upper = height[3], .var.name = "height")
  checkmate::assert_numeric(width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
  checkmate::assert_numeric(width[1], lower = width[2], upper = width[3], null.ok = TRUE, .var.name = "width")

  checkmate::assert_class(show_hide_signal, c("reactive", "function"))
  checkmate::assert_flag(brushing)
  checkmate::assert_flag(clicking)
  checkmate::assert_flag(dblclicking)
  checkmate::assert_flag(hovering)
  checkmate::assert_string(graph_align)
  checkmate::assert_subset(graph_align, c("left", "right", "center", "justify"))

  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    shinyjs::runjs(
      sprintf(
        'establishPlotResizing("%s", "%s");',
        ns("plot-out-main"), # graph parent id
        ns("flex_width") # session input$ variable name
      )
    )
    default_w <- function() session$clientData[[paste0("output_", ns("plot_main_width"))]]
    default_h <- function() session$clientData[[paste0("output_", ns("plot_main_height"))]]

    default_slider_width <- reactiveVal(width)
    delayed_flex_width <- debounce(reactive(input$flex_width), millis = 100)

    if (is.null(width)) {
      # if width = NULL then set default_slider_width to be the value of the plot width on load
      observeEvent(session$clientData[[paste0("output_", ns("plot_main_width"))]],
        handlerExpr = {
          default_slider_width(default_w() * c(1, 0.5, 2.8))
        },
        once = TRUE,
        ignoreNULL = TRUE
      )
    }

    plot_type <- reactive({
      if (inherits(plot_r(), "ggplot")) {
        "gg"
      } else if (inherits(plot_r(), "trellis")) {
        "trel"
      } else if (inherits(plot_r(), "grob")) {
        "grob"
      } else if (inherits(plot_r(), c("NULL", "histogram", "list")) && !inherits(plot_r, "reactive")) {
        "base"
      } else {
        "other"
      }
    })

    # allow modules which use this module to turn on and off the UI
    observeEvent(show_hide_signal(), {
      if (show_hide_signal()) {
        shinyjs::show("plot-with-settings")
      } else {
        shinyjs::hide("plot-with-settings")
      }
    })

    output$slider_ui <- renderUI({
      req(default_slider_width())
      tags$div(
        optionalSliderInputValMinMax(
          inputId = ns("height"),
          label = "Plot height",
          value_min_max = round(height),
          ticks = FALSE,
          step = 1L,
          round = TRUE
        ),
        tags$b("Plot width"),
        bslib::input_switch(
          id = ns("width_resize_switch"),
          label = "Automatic",
          value = `if`(is.null(width), TRUE, FALSE)
        ),
        optionalSliderInputValMinMax(
          inputId = ns("width"),
          label = NULL,
          value_min_max = round(isolate(default_slider_width())),
          ticks = FALSE,
          step = 1L,
          round = TRUE
        )
      )
    })

    observeEvent(input$width_resize_switch | delayed_flex_width(), {
      if (!isFALSE(input$width_resize_switch)) {
        shinyjs::disable("width")
        updateSliderInput(session, inputId = "width", value = delayed_flex_width())
      } else {
        shinyjs::enable("width")
      }
    })

    ranges <- reactiveValues(x = NULL, y = NULL)

    observeEvent(input$plot_dblclick, {
      brush <- input$plot_brush
      if (!is.null(brush)) {
        ranges$x <- c(brush$xmin, brush$xmax)
        ranges$y <- c(brush$ymin, brush$ymax)
      } else {
        ranges$x <- NULL
        ranges$y <- NULL
      }
    })

    p_height <- reactive(if (!is.null(input$height)) input$height else height[1])
    p_width <- reactive(
      if (!is.null(input$width)) {
        input$width
      } else {
        if (!is.null(default_slider_width()[1])) {
          default_slider_width()[1]
        } else {
          # Fallback to "auto"
          "auto"
        }
      }
    )
    output$plot_main <- renderPlot(
      apply_plot_modifications(
        plot_obj = plot_r(),
        plot_type = plot_type(),
        dblclicking = dblclicking,
        ranges = ranges
      ),
      res = get_plot_dpi(),
      height = p_height,
      width = p_width
    )

    output$plot_out_main <- renderUI({
      req(plot_r())
      tags$div(
        align = graph_align,
        plotOutput(
          ns("plot_main"),
          height = "100%",
          width = p_width(),
          brush = `if`(brushing, brushOpts(ns("plot_brush"), resetOnNew = FALSE), NULL),
          click = `if`(clicking, clickOpts(ns("plot_click")), NULL),
          dblclick = `if`(dblclicking, dblclickOpts(ns("plot_dblclick")), NULL),
          hover = `if`(hovering, hoverOpts(ns("plot_hover")), NULL)
        )
      )
    })

    output$width_warning <- renderUI({
      grDevices::pdf(nullfile()) # reset Rplots.pdf for shiny server
      w <- grDevices::dev.size("px")[1]
      grDevices::dev.off()
      if (p_width() < w) {
        helpText(
          icon("triangle-exclamation"),
          "Plot might be cut off for small widths."
        )
      }
    })

    type_download_srv(
      id = "downbutton",
      plot_reactive = plot_r,
      plot_type = plot_type,
      plot_w = p_width,
      default_w = default_w,
      plot_h = p_height,
      default_h = default_h
    )

    list(
      brush = reactive({
        # refresh brush data on the main plot size change
        input$height
        input$width
        input$plot_brush
      }),
      click = reactive({
        # refresh click data on the main plot size change
        input$height
        input$width
        input$plot_click
      }),
      dblclick = reactive({
        # refresh double click data on the main plot size change
        input$height
        input$width
        input$plot_dblclick
      }),
      hover = reactive({
        # refresh hover data on the main plot size change
        input$height
        input$width
        input$plot_hover
      }),
      dim = reactive(c(p_width(), p_height()))
    )
  })
}

#' @keywords internal
type_download_ui <- function(id) {
  ns <- NS(id)
  bslib::popover(
    icon("download"),
    tags$div(
      radioButtons(ns("file_format"),
        label = "File type",
        choices = c("png" = "png", "pdf" = "pdf", "svg" = "svg"),
      ),
      textInput(ns("file_name"),
        label = "File name (without extension)",
        value = paste0("plot_", strftime(Sys.time(), format = "%Y%m%d_%H%M%S"))
      ),
      uiOutput(ns("file_name_warning")),
      conditionalPanel(
        condition = paste0("input['", ns("file_name"), "'] != ''"),
        downloadButton(ns("data_download"), label = character(0), class = "btn-sm w-full")
      )
    )
  )
}

#' @keywords internal
type_download_srv <- function(id, plot_reactive, plot_type, plot_w, default_w, plot_h, default_h) {
  moduleServer(
    id,
    function(input, output, session) {
      file_name_valid <- file_name_validation_srv(input, output)

      output$data_download <- downloadHandler(
        filename = function() {
          paste(input$file_name, input$file_format, sep = ".")
        },
        content = function(file) {
          width <- `if`(!is.null(plot_w()), plot_w(), default_w())
          height <- `if`(!is.null(plot_h()), plot_h(), default_h())

          # svg and pdf have width in inches and 1 inch = get_plot_dpi() pixels
          switch(input$file_format,
            png = grDevices::png(file, width, height),
            pdf = grDevices::pdf(file, width / get_plot_dpi(), height / get_plot_dpi()),
            svg = grDevices::svg(file, width / get_plot_dpi(), height / get_plot_dpi())
          )

          print_plot(plot_reactive, plot_type)

          grDevices::dev.off()
        }
      )
    }
  )
}

#' Clean brushed points
#'
#' @description
#' Cleans and organizes output to account for NAs and remove empty rows. Wrapper around `shiny::brushedPoints`.
#' @param data (`data.frame`)\cr
#'  A data.frame from which to select rows.
#' @param brush (`list`)\cr
#'  The data from a brush e.g. `input$plot_brush`.
#'
#' @return A `data.frame` of selected rows.
#'
#' @examples
#'
#' brush <- list(
#'   mapping = list(
#'     x = "AGE",
#'     y = "BMRKR1"
#'   ),
#'   xmin = 30, xmax = 40,
#'   ymin = 0.7, ymax = 10,
#'   direction = "xy"
#' )
#'
#' data <- data.frame(
#'   STUDYID = letters[1:20],
#'   USUBJID = LETTERS[1:20],
#'   AGE = sample(25:40, size = 20, replace = TRUE),
#'   BMRKR1 = runif(20, min = 0, max = 12)
#' )
#' nrow(clean_brushedPoints(data, brush))
#' data$AGE[1:10] <- NA
#' nrow(clean_brushedPoints(data, brush))
#'
#' @export
#'
clean_brushedPoints <- function(data, brush) { # nolint object_name_linter.
  checkmate::assert_data_frame(data)
  checkmate::assert_list(brush, null.ok = TRUE)

  # define original panelvar1 and panelvar2 before getting overwritten
  original_panelvar1 <- brush$mapping$panelvar1
  original_panelvar2 <- brush$mapping$panelvar2

  # Assign NULL to `mapping$panelvar1` and `mapping$panelvar1` if `brush$panelvar1` and `brush$panelvar1` are NULL
  # This will not evaluate the `panelMatch` step in `brushedPoints` and thus will return a non empty dataframe
  if (is.null(brush$panelvar1)) brush$mapping$panelvar1 <- NULL
  if (is.null(brush$panelvar2)) brush$mapping$panelvar2 <- NULL

  bp_df <- brushedPoints(data, brush)

  # Keep required rows only based on the value of `brush$panelvar1`
  df <- if (is.null(brush$panelvar1) && is.character(original_panelvar1) &&
    is.null(brush$panelvar2) && is.character(original_panelvar2)) {
    df_var1 <- bp_df[is.na(bp_df[[original_panelvar1]]), ]
    df_var1[is.na(df_var1[[original_panelvar2]]), ]
  } else if (is.null(brush$panelvar1) && is.character(original_panelvar1)) {
    bp_df[is.na(bp_df[[original_panelvar1]]), ]
  } else if (is.null(brush$panelvar2) && is.character(original_panelvar2)) {
    bp_df[is.na(bp_df[[original_panelvar2]]), ]
  } else {
    bp_df
  }

  # filter out rows that are only NAs
  df <- df[rowSums(is.na(df)) != ncol(df), ]
  df
}

#' @keywords internal
#'
get_plot_dpi <- function() {
  default_dpi <- 72
  dpi <- getOption("teal.plot_dpi", default_dpi)
  if (!checkmate::test_integerish(dpi, lower = 24, any.missing = FALSE, len = 1)) {
    warning(paste("Invalid value for option 'teal.plot_dpi', therefore defaulting to", default_dpi, "dpi"))
    dpi <- default_dpi
  }
  dpi
}

#' Print plot for download functionality
#'
#' @param plot (`reactive`)\cr
#'  reactive expression to draw a plot
#' @param plot_type (`reactive`)\cr
#'  reactive plot type (`gg`, `trel`, `grob`, `other`)
#'
#' @return Nothing returned, the plot is printed.
#' @keywords internal
#'
print_plot <- function(plot, plot_type) {
  switch(plot_type(),
    "grob" = grid::grid.draw(plot()),
    "other" = {
      graphics::plot.new()
      graphics::text(
        x = graphics::grconvertX(0.5, from = "npc"),
        y = graphics::grconvertY(0.5, from = "npc"),
        labels = "This plot graphic type is not yet supported to download"
      )
    },
    "base" = plot(),
    print(plot())
  )
}

#' This function checks the plot type and applies specific modifications
#' to the plot object based on the provided parameters.
#'
#' @param plot_obj The original plot object.
#' @param plot_type The type of the plot, either `gg` (`ggplot2`) or `grob` (`grid`, `graphics`).
#' @param dblclicking A logical value indicating whether double-clicking on data points on
#' the main plot is enabled or disabled.
#' @param ranges A list containing x and y values of ranges.
#'
#' @keywords internal
apply_plot_modifications <- function(plot_obj, plot_type, dblclicking, ranges) {
  if (plot_type == "gg" && dblclicking) {
    plot_obj +
      ggplot2::coord_cartesian(xlim = ranges$x, ylim = ranges$y, expand = FALSE)
  } else if (plot_type == "grob") {
    grid::grid.newpage()
    grid::grid.draw(plot_obj)
  } else {
    plot_obj
  }
}

.warning_gt_webshot2 <- function(table, #
                                 webshot_installed = requireNamespace("webshot2", quietly = TRUE)) {
  if (
    checkmate::test_multi_class(table, c("gt_tbl", "tbl_split", "tbl_summary")) &&
      !webshot_installed &&
      !identical(Sys.getenv("DISABLE_GT_WEBSHOT2_WARNING"), "true") &&
      is.null(.warnings_env$gt_webshot2_warning)
  ) {
    .warnings_env$gt_webshot2_warning <- warningCondition(
      paste0(
        "The `webshot2` package is required to donwload gt tables as PDF. Please install it to use this feature.",
        " This warning will only be shown once per session."
      ),
      class = "gt_webshot2_warning"
    )
    warning(.warnings_env$gt_webshot2_warning)
  }
}

.warnings_env <- new.env(parent = emptyenv())

#' Validate the download file name
#'
#' Hides the `data_download` button and renders `output$file_name_warning` when `input$file_name`
#' does not contain any letter or number, e.g. it is empty or only whitespace or special characters.
#'
#' @param input,output Shiny module `input` and `output` objects.
#'
#' @return `reactive` returning `TRUE` when the file name is valid.
#'
#' @noRd
file_name_validation_srv <- function(input, output) {
  file_name_valid <- reactive({
    isTRUE(grepl("[[:alnum:]]", input$file_name))
  })

  observeEvent(file_name_valid(), {
    shinyjs::toggle("data_download", condition = file_name_valid())
  })

  output$file_name_warning <- renderUI({
    if (!file_name_valid()) {
      helpText(
        class = "error",
        icon("triangle-exclamation"),
        "Please provide a meaningful file name: it must contain at least one letter or number."
      )
    }
  })

  file_name_valid
}

#' Creates `ggplot2_args` object
#'
#' @description
#' Constructor of `ggplot2_args` class of objects.
#' The `ggplot2_args` argument should be a part of every module which contains any `ggplot2` graphics.
#' The function arguments are validated to match their `ggplot2` equivalents.
#'
#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`.
#'
#' @seealso
#' * [resolve_ggplot2_args()] to resolve multiple objects into one using pre-defined priorities.
#' * [parse_ggplot2_args()] to parse resolved list into list of calls.
#'
#' @param labs (named `list`)\cr
#'  where all fields have to match [ggplot2::labs()] arguments.
#' @param theme (named `list`)\cr
#'  where all fields have to match [ggplot2::theme()] arguments.
#'
#' @return (`ggplot2_args`) object.
#' @export
#' @examples
#' ggplot2_args(
#'   labs = list(title = "TITLE"),
#'   theme = list(title = ggplot2::element_text(size = 20))
#' )
ggplot2_args <- function(labs = list(), theme = list()) {
  checkmate::assert_list(labs)
  checkmate::assert_list(theme)
  checkmate::assert_character(names(labs), unique = TRUE, null.ok = TRUE)
  checkmate::assert_character(names(theme), unique = TRUE, null.ok = TRUE)

  ggplot2_theme <- methods::formalArgs(ggplot2::theme)
  # utils::getFromNamespace is not recommended nevertheless needed as it is replacing `:::`.
  # usage of static values will be vulnerable to any changes in ggplot2 aesthetics.
  ggplot2_labs <- c(
    utils::getFromNamespace(".all_aesthetics", "ggplot2"),
    methods::formalArgs(ggplot2::labs)
  )
  checkmate::assert_subset(names(labs), choices = ggplot2_labs, empty.ok = TRUE)
  checkmate::assert_subset(names(theme), choices = ggplot2_theme, empty.ok = TRUE)

  structure(list(labs = labs, theme = theme), class = "ggplot2_args")
}

#' Resolving and reducing multiple `ggplot2_args` objects
#'
#' @description
#' Resolving and reducing multiple `ggplot2_args` objects.
#' This function is intended to utilize user provided settings, defaults provided by the module creator and
#' also `teal` option. See `Details`, below, to understand the logic.
#'
#' @seealso [parse_ggplot2_args()] to parse resolved list into list of calls.
#'
#' @param user_plot (`ggplot2_args`)\cr
#'  end user setup for theme and labs in the specific plot.
#'  Created with the [ggplot2_args()] function. The `NULL` value is supported.
#' @param user_default (`ggplot2_args`)\cr
#'  end user setup for module default theme and labs.
#'  Created with the [ggplot2_args()] function. The `NULL` value is supported.
#' @param module_plot (`ggplot2_args`)\cr
#'  module creator setup for theme and labs in the specific plot.
#'  Created with the [ggplot2_args()] function. The `NULL` value is supported.
#' @param app_default (`ggplot2_args`)\cr
#'  Application level setting. Can be `NULL`.
#'
#' @return `ggplot2_args` object.
#'
#' @details
#' The function picks the first non `NULL` value for each argument, checking in the following order:
#' 1. `ggplot2_args` argument provided by the end user.
#' Per plot (`user_plot`) and then default (`user_default`) setup.
#' 2. `app_default` global R variable, `teal.ggplot2_args`.
#' 3. `module_plot` which is a module creator setup.
#' @export
#' @examples
#' resolve_ggplot2_args(
#'   user_plot = ggplot2_args(
#'     labs = list(title = "TITLE"),
#'     theme = list(title = ggplot2::element_text(size = 20))
#'   ),
#'   user_default = ggplot2_args(
#'     labs = list(x = "XLAB")
#'   )
#' )
resolve_ggplot2_args <- function(user_plot = ggplot2_args(),
                                 user_default = ggplot2_args(),
                                 module_plot = ggplot2_args(),
                                 app_default = getOption("teal.ggplot2_args", ggplot2_args())) {
  checkmate::assert_class(user_plot, "ggplot2_args", null.ok = TRUE)
  checkmate::assert_class(user_default, "ggplot2_args", null.ok = TRUE)
  checkmate::assert_class(module_plot, "ggplot2_args", null.ok = TRUE)
  checkmate::assert_class(app_default, "ggplot2_args", null.ok = TRUE)

  ggplot2_args_all <- list(
    "plot" = user_plot,
    "default" = user_default,
    "teal" = app_default,
    "module" = module_plot
  )

  labs_args <- Reduce(`c`, lapply(ggplot2_args_all, function(x) x$labs))
  labs_args <- if (is.null(labs_args)) list() else labs_args[!duplicated(names(labs_args))]

  theme_args <- Reduce(`c`, lapply(ggplot2_args_all, function(x) x$theme))
  theme_args <- if (is.null(theme_args)) list() else theme_args[!duplicated(names(theme_args))]

  ggplot2_args(labs = labs_args, theme = theme_args)
}

#' Parse `ggplot2_args` object into the `ggplot2` expression
#'
#' @description
#' A function to parse expression from the `ggplot2_args` object.
#' @param ggplot2_args (`ggplot2_args`)\cr
#'  This argument could be a result of the [resolve_ggplot2_args()].
#' @param ggtheme (`character(1)`)\cr
#'  name of the `ggplot2` theme to be applied, e.g. `"dark"`.
#'
#' @return (`list`) of up to three elements of class `languange`: `"labs"`, `"ggtheme"` and `"theme"`.
#' @export
#' @examples
#' parse_ggplot2_args(
#'   resolve_ggplot2_args(ggplot2_args(
#'     labs = list(title = "TITLE"),
#'     theme = list(title = ggplot2::element_text(size = 20))
#'   ))
#' )
#'
#' parse_ggplot2_args(
#'   resolve_ggplot2_args(
#'     ggplot2_args(
#'       labs = list(title = "TITLE"),
#'       theme = list(title = ggplot2::element_text(size = 20))
#'     )
#'   ),
#'   ggtheme = "gray"
#' )
parse_ggplot2_args <- function(ggplot2_args = teal.widgets::ggplot2_args(),
                               ggtheme = c(
                                 "default",
                                 "gray",
                                 "bw",
                                 "linedraw",
                                 "light",
                                 "dark",
                                 "minimal",
                                 "classic",
                                 "void",
                                 "test"
                               )) {
  checkmate::assert_class(ggplot2_args, "ggplot2_args")
  ggtheme <- match.arg(ggtheme)

  res_list <- list()

  labs_args <- ggplot2_args$labs

  labs_f <- if (length(labs_args)) {
    as.call(c(list(quote(ggplot2::labs)), labs_args))
  } else {
    NULL
  }

  default_theme <- if (ggtheme != "default") {
    as.call(list(str2lang(paste0("ggplot2::theme_", ggtheme))))
  } else {
    NULL
  }

  theme_args <- ggplot2_args$theme

  theme_f <- if (length(theme_args)) {
    as.call(c(list(quote(ggplot2::theme)), theme_args))
  } else {
    NULL
  }

  final_list <- Filter(Negate(is.null), list(labs = labs_f, ggtheme = default_theme, theme = theme_f))
  # For empty final_list we want to return empty list, not empty named list
  `if`(length(final_list) == 0, list(), final_list)
}

#' @keywords internal
#' @noRd
table_with_settings_deps <- function() {
  htmltools::htmlDependency(
    name = "teal-widgets-table-with-settings",
    version = utils::packageVersion("teal.widgets"),
    package = "teal.widgets",
    src = "table-with-settings",
    stylesheet = "table-with-settings.css"
  )
}

render_table_to_html_rtables <- function(x, ...) {
  rtables::as_html(x)
}

file_download_format <- function(x, filename) {
  UseMethod("file_download_format", x)
}

#' @method file_download_format default
#' @keywords internal
#' @exportS3Method
file_download_format.default <- function(x, filename) {
  filename
}

#' @method file_download_format tbl_split
#' @keywords internal
#' @exportS3Method
file_download_format.tbl_split <- function(x, filename) {
  new_filename <- tools::file_path_sans_ext(filename)
  paste0(new_filename, ".zip")
}

#' Render table object to HTML
#'
#' @param x The table object to render
#' @param ... Additional arguments (currently unused)
#' @return HTML representation of the table
#' @keywords internal
#' @noRd
render_table_to_html <- function(x, ...) {
  UseMethod("render_table_to_html", x)
}

#' @method render_table_to_html default
#' @keywords internal
#' @exportS3Method
render_table_to_html.default <- function(x, ...) {
  stop(
    "Unsupported table type. ",
    "table_with_settings supports rtables (ElementaryTable, TableTree), ",
    "gtsummary, or gt (gt_tbl) objects."
  )
}

#' @method render_table_to_html ElementaryTable
#' @keywords internal
#' @exportS3Method
render_table_to_html.ElementaryTable <- render_table_to_html_rtables

#' @method render_table_to_html TableTree
#' @keywords internal
#' @exportS3Method
render_table_to_html.TableTree <- render_table_to_html_rtables

#' @method render_table_to_html gtsummary
#' @keywords internal
#' @exportS3Method
render_table_to_html.gtsummary <- function(x, ...) {
  gt_obj <- gtsummary::as_gt(x)
  render_table_to_html(gt_obj)
}

#' @method render_table_to_html gt_tbl
#' @keywords internal
#' @exportS3Method
render_table_to_html.gt_tbl <- function(x, ...) {
  htmltools::HTML(gt::as_raw_html(x))
}

#' @method render_table_to_html tbl_split
#' @keywords internal
#' @exportS3Method
render_table_to_html.tbl_split <- function(x, ...) {
  tables <- lapply(seq_along(x), function(tbl) {
    label <- attr(x[[tbl]], "variable_level", exact = TRUE)
    htmltools::tags$div(
      if (checkmate::test_string(label)) htmltools::tags$h4("Variable level:", label),
      render_table_to_html(x[[tbl]])
    )
  })
  htmltools::tags$div(tables)
}

#' Export table object to file
#'
#' @param x The table object to export
#' @param file The file path to write to
#' @param format The file format (".txt", ".csv", or ".pdf")
#' @param paginate Logical indicating whether to paginate (for rtables)
#' @param lpp Lines per page for pagination (for rtables)
#' @param ... Additional arguments (currently unused)
#' @keywords internal
#' @noRd
export_table <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
  UseMethod("export_table", x)
}

#' @method export_table default
#' @keywords internal
#' @exportS3Method
export_table.default <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
  stop("Unsupported table type for download")
}

export_table_rtables <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
  if (format == ".txt") {
    rtables::export_as_txt(
      x = x,
      file = file,
      paginate = paginate,
      lpp = if (paginate) as.numeric(lpp)
    )
  } else if (format == ".csv") {
    result <- rtables::matrix_form(x)$strings
    utils::write.table(
      x = result,
      file = file,
      sep = ",",
      col.names = FALSE,
      row.names = TRUE,
      append = FALSE
    )
  } else {
    rtables::export_as_pdf(
      x = x,
      file = file,
      paginate = paginate,
      lpp = if (paginate) as.numeric(lpp)
    )
  }
}

#' @method export_table ElementaryTable
#' @keywords internal
#' @exportS3Method
export_table.ElementaryTable <- export_table_rtables

#' @method export_table TableTree
#' @keywords internal
#' @exportS3Method
export_table.TableTree <- export_table_rtables

#' @method export_table gtsummary
#' @keywords internal
#' @exportS3Method
export_table.gtsummary <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
  gt_obj <- gtsummary::as_gt(x)
  export_table(gt_obj, file, format, paginate, lpp, ...)
}

#' @method export_table gt_tbl
#' @keywords internal
#' @exportS3Method
export_table.gt_tbl <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
  if (format == ".csv") {
    utils::write.csv(export_table_raw(x), file = file, row.names = FALSE)
  } else if (format == ".pdf") {
    gt::gtsave(x, filename = file)
  } else {
    utils::write.table(
      x = export_table_raw(x),
      file = file,
      sep = "\t",
      quote = FALSE,
      row.names = FALSE,
      col.names = TRUE
    )
  }
}

#' @method export_table tbl_split
#' @keywords internal
#' @exportS3Method
export_table.tbl_split <- function(x, file, format, paginate = FALSE, lpp = NULL, file_name = file, ...) {
  ext <- format # ".pdf" or ".txt"
  tmp_dir <- tempfile()
  dir.create(tmp_dir)
  on.exit(unlink(tmp_dir, recursive = TRUE))

  base_name <- tools::file_path_sans_ext(basename(file_name))

  tmp_files <- lapply(seq_along(x), function(i) {
    label <- as.vector(attr(x[[i]], "variable_level", exact = TRUE))
    if (checkmate::test_string(label)) {
      base_name <- paste0(base_name, "_", gsub("[^[:alnum:]]", "_", label), "_", i)
    } else {
      base_name <- paste0(base_name, "_", i)
    }
    tmp_file <- file.path(tmp_dir, paste0(base_name, ext))
    export_table(x[[i]], file = tmp_file, format = format, paginate = paginate, lpp = lpp, ...)
    tmp_file
  })

  utils::zip(zipfile = file, files = unlist(tmp_files), flags = "-j") # -j: junk paths
}

export_table_raw <- function(x) {
  html_content <- gt::as_raw_html(x)
  html_parsed <- rvest::read_html(html_content)

  # xml_remove modifies the object so no need to ovewrite
  xml2::xml_remove(rvest::html_nodes(html_parsed, "caption, .gt_heading"))

  tbl <- rvest::html_table(html_parsed, fill = TRUE)[[1]]
  names(tbl) <- gsub("[\n\r\t]", " ", names(tbl))
  tbl
}

#' @name table_with_settings
#'
#' @title `table_with_settings` module
#'
#' @description
#' Module designed to create a `shiny` table output based on table objects.
#' Supports `rtables` objects (`ElementaryTable` or `TableTree`), `gtsummary` objects, or `gt` objects.
#' @inheritParams shiny::moduleServer
#' @param ... (`character`)\cr
#'  Useful for providing additional HTML classes for the output tag.
#'
#' @note The download of [gt::gt()] and [gtsummary::tbl_summary()] tables as PDF requires the `webshot2` package
#' to be installed.
#' A once a session warning is displayed if the package is not installed when calling `table_with_settings` with
#' a reactive table in one of those formats.
#'
#' @rdname table_with_settings
#' @export
#'
table_with_settings_ui <- function(id, ...) {
  checkmate::assert_string(id)

  ns <- NS(id)

  tags$div(
    table_with_settings_deps(),
    shinyjs::useShinyjs(),
    bslib::card(
      id = ns("table-with-settings"),
      full_screen = TRUE,
      tags$div(
        class = "teal-widgets settings-buttons",
        bslib::tooltip(
          trigger = tags$div(type_download_ui_table(ns("downbutton"))),
          options = list(trigger = "hover"),
          class = "download-button",
          "Download"
        )
      ),
      tags$div(
        class = "teal-widgets table-content",
        uiOutput(ns("table_out_main"), width = "100%", ...)
      )
    )
  )
}

#' @inheritParams shiny::moduleServer
#' @param table_r (`reactive`)\cr
#'  reactive expression that yields a table object. Supported types:
#'  - `rtables` objects (`ElementaryTable` or `TableTree`)
#'  - `gtsummary` objects
#'  - `gt` objects (`gt_tbl`)
#' @param show_hide_signal (`reactive logical`) optional\cr
#'  mechanism to allow modules which call this module to show/hide the table_with_settings UI.
#'
#' @rdname table_with_settings
#'
#' @return A `shiny` module.
#'
#' @export
#'
#' @examples
#' library(shiny)
#' library(rtables)
#' library(gtsummary)
#' library(gt)
#' library(magrittr)
#'
#' ui <- bslib::page_fluid(
#'   table_with_settings_ui(id = "rtables_table"),
#'   table_with_settings_ui(id = "gtsummary_table"),
#'   table_with_settings_ui(id = "gt_table")
#' )
#'
#' server <- function(input, output, session) {
#'   table_r_rtables <- reactive({
#'     l <- basic_table() %>%
#'       split_cols_by("ARM") %>%
#'       analyze(c("SEX", "AGE"))
#'     build_table(l, DM)
#'   })
#'
#'   table_r_gtsummary <- reactive({
#'     gtsummary::tbl_summary(mtcars)
#'   })
#'
#'   table_r_gt <- reactive({
#'     mtcars %>%
#'       gt::gt() %>%
#'       gt::tab_header(title = "Motor Trend Car Road Tests")
#'   })
#'
#'   table_with_settings_srv(id = "rtables_table", table_r = table_r_rtables)
#'   table_with_settings_srv(id = "gtsummary_table", table_r = table_r_gtsummary)
#'   table_with_settings_srv(id = "gt_table", table_r = table_r_gt)
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
table_with_settings_srv <- function(id, table_r, show_hide_signal = reactive(TRUE)) {
  checkmate::assert_class(table_r, c("reactive", "function"))
  checkmate::assert_class(show_hide_signal, c("reactive", "function"))

  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    # Turn on and off the UI
    observeEvent(show_hide_signal(), {
      if (show_hide_signal()) {
        shinyjs::show("table-with-settings")
      } else {
        shinyjs::hide("table-with-settings")
      }
    })

    output$table_out_main <- output$table_out_modal <- renderUI({
      .warning_gt_webshot2(table_r())
      render_table_to_html(table_r())
    })

    type_download_srv_table(
      id = "downbutton",
      table_reactive = table_r
    )
  })
}

type_download_ui_table <- function(id) {
  ns <- NS(id)
  bslib::popover(
    icon("download"),
    tags$div(
      radioButtons(
        ns("file_format"),
        label = tags$span("File type", shinyjs::hidden(
          tags$div(
            id = ns("pdf_warning"),
            style = c(
              "cursor: help;", "color: var(--bs-gray-600);", "margin-bottom: 0.5rem;",
              "font-size: 0.875rem;", "padding-left: 0.1rem;"
            ),
            icon("circle-info"),
            title = "Contact app support to enable PDF download by installing the `webshot2` package.",
            "PDF download is disabled."
          )
        )),
        choices = c("formatted txt" = ".txt", "csv" = ".csv", "pdf" = ".pdf")
      ),
      textInput(ns("file_name"),
        label = "File name (without extension)",
        value = paste0("table_", strftime(Sys.time(), format = "%Y%m%d_%H%M%S"))
      ),
      uiOutput(ns("file_name_warning")),
      conditionalPanel(
        condition = paste0("input['", ns("file_format"), "'] != '.csv'"),
        tags$div(
          class = "lock-btn",
          title = "on / off",
          shinyWidgets::prettyToggle(
            ns("pagination_switch"),
            value = FALSE,
            label_on = NULL,
            label_off = NULL,
            status_on = "default",
            status_off = "default",
            outline = FALSE,
            plain = TRUE,
            icon_on = icon("fas fa-toggle-off"),
            icon_off = icon("fas fa-toggle-on"),
            animation = "pulse"
          )
        ),
        tags$div(
          class = "paginate-ui",
          shinyWidgets::numericInputIcon(
            inputId = ns("lpp"),
            label = "Paginate table:",
            value = 70,
            icon = list("lines / page")
          ),
          uiOutput(ns("lpp_warning"))
        )
      ),
      conditionalPanel(
        condition = paste0("input['", ns("file_name"), "'] != ''"),
        downloadButton(ns("data_download"), label = character(0), class = "btn-sm w-full")
      )
    )
  )
}

type_download_srv_table <- function(id, table_reactive) {
  moduleServer(
    id,
    function(input, output, session) {
      observeEvent(table_reactive(), {
        if (
          checkmate::test_multi_class(table_reactive(), c("gt_tbl", "tbl_split", "tbl_summary")) &&
            !requireNamespace("webshot2", quietly = TRUE)
        ) {
          updateRadioButtons(
            inputId = "file_format",
            choices = list("formatted txt" = ".txt", "csv" = ".csv")
          )
          shinyjs::show("pdf_warning")
        }
      })
      observeEvent(input$pagination_switch, {
        if (input$pagination_switch) {
          shinyjs::enable("lpp")
        } else {
          shinyjs::disable("lpp")
        }
      })

      file_name_valid <- file_name_validation_srv(input, output)

      output$lpp_warning <- renderUI({
        table_obj <- table_reactive()
        # Pagination warning only applies to rtables
        if (
          inherits(table_obj, c("ElementaryTable", "TableTree")) &&
            input$file_format != ".csv" &&
            input$pagination_switch
        ) {
          catch_warning <- try(rtables::paginate_table(
            tt = table_obj,
            lpp = as.numeric(input$lpp)
          ), silent = TRUE)

          if (inherits(catch_warning, "try-error")) {
            helpText(
              class = "error",
              icon("triangle-exclamation"),
              paste0(
                "Maximum lines per page includes the reprinted header.",
                "Please enter a numeric value or increase the value."
              )
            )
          }
        }
      })

      output$data_download <- downloadHandler(
        filename = function() {
          file_download_format(table_reactive(), paste0(input$file_name, input$file_format))
        },
        content = function(file) {
          export_table(
            x = table_reactive(),
            file = file,
            format = input$file_format,
            paginate = input$pagination_switch,
            lpp = if (input$pagination_switch) as.numeric(input$lpp),
            file_name = input$file_name
          )
        }
      )
    }
  )
}

#' @keywords internal
#' @noRd
draggable_buckets_deps <- function() {
  htmltools::htmlDependency(
    name = "teal-widgets-draggable-buckets",
    version = utils::packageVersion("teal.widgets"),
    package = "teal.widgets",
    src = "draggable-buckets",
    script = "draggable-buckets.js",
    stylesheet = "draggable-buckets.css"
  )
}

#' @title Draggable Buckets
#' @description
#' A custom widget with draggable elements that can be put into buckets.
#'
#' @param input_id (`character(1)`) the `HTML` id of this widget
#' @param label (`character(1)` or `shiny.tag`) the header of this widget
#' @param elements (`character`) the elements to drag into buckets
#' @param buckets (`character` or `list`) the names of the buckets the elements can be put in or a list of key-pair
#' values where key is a name of a bucket and value is a character vector of elements in a bucket
#'
#' @return the `HTML` code comprising an instance of this widget
#' @export
#'
#' @details `shinyvalidate` validation can be used with this widget. See example below.
#'
#' @examples
#' library(shiny)
#'
#' ui <- bslib::page_fluid(
#'   draggable_buckets("id", "Choices #1", c("a", "b"), c("bucket1", "bucket2")),
#'   draggable_buckets("id2", "Choices #2", letters, c("vowels", "consonants")),
#'   verbatimTextOutput("out"),
#'   verbatimTextOutput("out2")
#' )
#' server <- function(input, output) {
#'   iv <- shinyvalidate::InputValidator$new()
#'   iv$add_rule(
#'     "id",
#'     function(data) if (length(data[["bucket1"]]) == 0) "There should be stuff in bucket 1"
#'   )
#'   iv$enable()
#'
#'   observeEvent(list(input$id, input$id2), {
#'     print(isolate(input$id))
#'     print(isolate(input$id2))
#'   })
#'   output$out <- renderPrint({
#'     iv$is_valid()
#'     input$id
#'   })
#'   output$out2 <- renderPrint(input$id2)
#' }
#' if (interactive()) shinyApp(ui, server)
#'
#' # With default elements in the bucket
#' ui <- bslib::page_fluid(
#'   draggable_buckets("id", "Choices #1", c("a", "b"), list(bucket1 = character(), bucket2 = c("c"))),
#'   verbatimTextOutput("out")
#' )
#' server <- function(input, output) {
#'   observeEvent(input$id, {
#'     print(isolate(input$id))
#'   })
#'   output$out <- renderPrint(input$id)
#' }
#' if (interactive()) shinyApp(ui, server)
draggable_buckets <- function(input_id, label, elements = character(), buckets) {
  checkmate::assert_string(input_id)
  checkmate::assert_true(inherits(label, "character") || inherits(label, "shiny.tag"))
  checkmate::assert_character(c(elements, unlist(buckets)), min.len = 0, null.ok = TRUE, unique = TRUE)
  checkmate::assert(
    checkmate::check_character(buckets, min.len = 1),
    checkmate::check_list(buckets, types = "character", names = "unique")
  )

  elements_iterator <- new.env(parent = emptyenv())
  elements_iterator$it <- 0

  shiny::tagList(
    draggable_buckets_deps(),
    shiny::div(
      tags$span(label),
      render_unbucketed_elements(elements = elements, elements_iterator = elements_iterator, widget_id = input_id),
      render_buckets(buckets = buckets, elements_iterator = elements_iterator, widget_id = input_id),
      class = "draggableBuckets",
      id = input_id
    )
  )
}

render_unbucketed_elements <- function(elements, elements_iterator, widget_id) {
  tags$div(
    lapply(elements, function(element) {
      elements_iterator$it <- elements_iterator$it + 1
      render_draggable_element(
        value = element,
        id = paste0(widget_id, "draggable", elements_iterator$it),
        widget_id = widget_id
      )
    }),
    id = paste0(widget_id, "elements"),
    class = c("form-control", "elements"),
    ondragover = "allowDrop(event)",
    ondrop = "drop(event)",
    `data-widget` = widget_id
  )
}

render_buckets <- function(buckets, elements_iterator, widget_id) {
  buckets <- `if`(
    is.list(buckets),
    lapply(names(buckets), function(bucket_name) {
      render_bucket(
        name = bucket_name,
        elements = buckets[[bucket_name]],
        elements_iterator = elements_iterator,
        widget_id = widget_id
      )
    }),
    lapply(buckets, render_bucket, widget_id = widget_id, elements_iterator = elements_iterator)
  )
  shiny::tagList(buckets)
}

render_draggable_element <- function(value, id, widget_id) {
  tags$div(
    value,
    id = id,
    class = "element",
    draggable = "true",
    ondragstart = "drag(event)",
    ondragover = "allowDrop(event)",
    ondrop = "dropReorder(event)",
    `data-widget` = widget_id
  )
}

render_bucket <- function(name, elements = NULL, elements_iterator = NULL, widget_id = NULL) {
  tags$div(
    tags$div(
      paste0(name, ":"),
      class = "bucket-name",
      ondragover = "allowDrop(event)",
      ondrop = "dropBucketName(event)",
      `data-widget` = widget_id
    ),
    lapply(elements, function(element) {
      elements_iterator$it <- elements_iterator$it + 1
      render_draggable_element(
        value = element,
        id = paste0(widget_id, "draggable", elements_iterator$it),
        widget_id = widget_id
      )
    }),
    class = c("form-control", "bucket"),
    ondragover = "allowDrop(event)",
    ondrop = "drop(event)",
    `data-label` = name,
    `data-widget` = widget_id
  )
}

#' Panel group widget
#'
#' @description `r lifecycle::badge("deprecated")`\cr
#' Designed to group [`panel_item`] elements. Used to handle `shiny` inputs in the encoding panel.
#' @param id optional, (`character`)\cr
#' @param ... (`shiny.tag`)\cr
#'  panels created by [panel_group()]
#'
#' @return (`shiny.tag`)
#'
#' @examples
#'
#' library(shiny)
#' panel_group(
#'   panel_item(
#'     title = "Display",
#'     collapsed = FALSE,
#'     checkboxGroupInput(
#'       "check",
#'       "Tables display",
#'       choices = LETTERS[1:3],
#'       selected = LETTERS[1]
#'     ),
#'     radioButtons(
#'       "radio",
#'       label = "Plot type",
#'       choices = letters[1:2],
#'       selected = letters[1]
#'     )
#'   ),
#'   panel_item(
#'     title = "Pre-processing",
#'     radioButtons(
#'       "filtering",
#'       "What to filter",
#'       choices = LETTERS[1:4],
#'       selected = LETTERS[1]
#'     ),
#'     radioButtons(
#'       "na_action",
#'       "NA action",
#'       choices = letters[1:3],
#'       selected = letters[1]
#'     )
#'   )
#' )
#'
#' @export
panel_group <- function(..., id = NULL) {
  lifecycle::deprecate_soft(
    when = "0.4.3",
    what = "panel_group()",
    details = paste(
      "The `panel_group()` and `panel_item()` view can be achieved by using the `bslib` package.",
      "Please use the `bslib::accordion()` and `bslib::accordion_panel()` functions instead.",
      "This function will be removed in the next release."
    )
  )
  checkmate::assert_string(id, null.ok = TRUE)

  # panel-group
  # div

  bslib::accordion(
    ...
  )
}

#' @keywords internal
#' @noRd
panel_item_deps <- function() {
  htmltools::htmlDependency(
    name = "teal-widgets-panel-item",
    version = utils::packageVersion("teal.widgets"),
    package = "teal.widgets",
    src = "panel-item",
    script = "panel-item.js",
    stylesheet = "panel-item.css"
  )
}

#' Panel item widget
#'
#' @description `r lifecycle::badge("deprecated")`\cr
#' Designed to be grouped using [`panel_group`] element. Used to handle `shiny` inputs in the encoding panel.
#' @param title (`character`)\cr title of panel
#' @param ... content of panel
#' @param collapsed (`logical`) optional,\cr
#'  whether to initially collapse panel
#' @param input_id (`character`) optional\cr
#'  name of the panel item element. If supplied, this will register a shiny input variable that
#'  indicates whether the panel item is open or collapsed and is accessed with `input$input_id`.
#'
#' @return (`shiny.tag`)
#'
#' @examples
#'
#' library(shiny)
#' panel_item(
#'   title = "Display",
#'   collapsed = FALSE,
#'   checkboxGroupInput(
#'     "check",
#'     "Tables display",
#'     choices = LETTERS[1:3],
#'     selected = LETTERS[1]
#'   ),
#'   radioButtons(
#'     "radio",
#'     label = "Plot type",
#'     choices = letters[1:2],
#'     selected = letters[1]
#'   )
#' )
#'
#' @export
panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
  lifecycle::deprecate_soft(
    when = "0.4.3",
    what = "panel_item()",
    details = paste(
      "The `panel_group()` and `panel_item()` view can be achieved by using the `bslib` package.",
      "Please use the `bslib::accordion()` and `bslib::accordion_panel()` functions instead.",
      "This function will be removed in the next release."
    )
  )
  stopifnot(checkmate::test_character(title, len = 1) || inherits(title, c("shiny.tag", "shiny.tag.list", "html")))
  checkmate::assert_flag(collapsed)
  checkmate::assert_string(input_id, null.ok = TRUE)

  bslib::accordion_panel(
    id = input_id,
    title = title,
    open = !collapsed,
    ...
  )
}

#' Builds a `basic_table_args` object
#'
#' @description
#' This function has to be used to build an input for a `basic_table_args` argument.
#' The `basic_table_args` argument should be a part of every module which contains any `rtables` object.
#' Arguments are validated to match their `rtables` equivalents.
#'
#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`.
#'
#' @seealso
#' * [resolve_basic_table_args()] to resolve multiple objects into one using pre-defined priorities.
#' * [parse_basic_table_args()] to parse resolved list into list of calls.
#'
#' @param ... arguments compatible with [rtables::basic_table()].
#'
#' @return (`basic_table_args`) object.
#' @export
#' @examples
#' basic_table_args(subtitles = "SUBTITLE")
basic_table_args <- function(...) {
  table_args_l <- list(...)
  checkmate::assert_character(names(table_args_l), unique = TRUE, null.ok = TRUE)

  basic_table_formals <- methods::formalArgs(rtables::basic_table)
  checkmate::assert_subset(names(table_args_l), choices = basic_table_formals, empty.ok = TRUE)

  structure(table_args_l, class = "basic_table_args")
}

#' Resolves and reduces multiple `basic_table_args` objects
#'
#' @description
#' Resolving and reducing multiple `basic_table_args` objects.
#' This function is intended to utilize user provided settings, defaults provided by the module creator and
#' also `teal` option. See `Details`, below, to understand the logic.
#'
#' @seealso [parse_basic_table_args()] to parse resolved list into list of calls.
#'
#' @param user_table (`basic_table_args`)\cr
#'  end user setup for [rtables::basic_table()] of a specific table.
#'  Created with the [basic_table_args()] function. The `NULL` value is supported.
#' @param user_default (`basic_table_args`)\cr
#'  end user default setup for [rtables::basic_table()]
#'  of a specific table. Created with the [basic_table_args()] function. The `NULL` value is supported.
#' @param module_table (`ggplot2_args`)\cr
#'  module creator setup for [rtables::basic_table()] of a specific table.
#'  Created with the [basic_table_args()] function. The `NULL` value is supported.
#' @param app_default (`basic_table_args`)\cr
#'  Application level setting. Can be `NULL`.
#'
#' @return `basic_table_args` object.
#' @details
#' The function picks the first non `NULL` value for each argument, checking in the following order:
#' 1. `basic_table_args` argument provided by the end user.
#' Per table (`user_table`) and then default (`user_default`) setup.
#' 2. `app_default` global R variable, `teal.basic_table_args`.
#' 3. `module_table` which is a module creator setup.
#' @export
#' @examples
#' resolve_basic_table_args(
#'   user_table = basic_table_args(title = "TITLE"),
#'   user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE")
#' )
resolve_basic_table_args <- function(user_table = basic_table_args(),
                                     user_default = basic_table_args(),
                                     module_table = basic_table_args(),
                                     app_default = getOption("teal.basic_table_args", basic_table_args())) {
  checkmate::assert_class(user_table, "basic_table_args", null.ok = TRUE)
  checkmate::assert_class(user_default, "basic_table_args", null.ok = TRUE)
  checkmate::assert_class(module_table, "basic_table_args", null.ok = TRUE)
  checkmate::assert_class(app_default, "basic_table_args", null.ok = TRUE)

  table_args_all <- list(
    "table" = user_table,
    "default" = user_default,
    "teal" = app_default,
    "module" = module_table
  )

  table_args_f <- Reduce(`c`, table_args_all)

  if (length(table_args_f) == 0) {
    basic_table_args()
  } else {
    do.call(basic_table_args, table_args_f[!duplicated(names(table_args_f))])
  }
}

#' Parses `basic_table_args` object into the `basic_table` expression
#'
#' @description
#' A function to parse expression from the `basic_table_args` object.
#' @param basic_table_args (`basic_table_args`)\cr
#'  This argument could be a result of the [`resolve_basic_table_args()`].
#'
#' @return (`language`) the `rtables::basic_table()` filled with additional arguments.
#' @export
#' @examples
#' parse_basic_table_args(
#'   resolve_basic_table_args(
#'     user_table = basic_table_args(title = "TITLE"),
#'     user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE")
#'   )
#' )
parse_basic_table_args <- function(basic_table_args = teal.widgets::basic_table_args()) {
  checkmate::assert_class(basic_table_args, "basic_table_args", null.ok = TRUE)

  if (length(basic_table_args) == 0) {
    quote(rtables::basic_table())
  } else {
    as.call(c(list(quote(rtables::basic_table)), basic_table_args))
  }
}

#' @keywords internal
#' @noRd
standard_layout_deps <- function() {
  htmltools::htmlDependency(
    name = "teal-widgets-standard-layout",
    version = utils::packageVersion("teal.widgets"),
    package = "teal.widgets",
    src = "standard-layout",
    stylesheet = "standard-layout.css"
  )
}

#' Standard UI layout
#'
#' @description
#' Create a standard UI layout with output on the right and an encoding panel on
#' the left. This is the layout used by the `teal` modules.
#'
#' @param output (`shiny.tag`)\cr
#'   object with the output element (table, plot, listing) such as for example returned
#' by [shiny::plotOutput()].
#' @param encoding (`shiny.tag`)\cr
#'  object containing the encoding elements. If this element is `NULL` then no encoding side
#'  panel on the right is  created.
#' @param forms (`tagList`)\cr
#'  for example [shiny::actionButton()] that are placed below the encodings panel
#' @param pre_output (`shiny.tag`) optional,\cr
#'  with text placed before the output to put the output into context. For example a title.
#' @param post_output (`shiny.tag`) optional, with text placed after the output to put the output
#' into context. For example the [shiny::helpText()] elements are useful.
#'
#' @return an object of class `shiny.tag` with the UI code.
#'
#' @examples
#' library(shiny)
#' standard_layout(
#'   output = white_small_well(tags$h3("Tests")),
#'   encoding = tags$div(
#'     tags$label("Encodings", class = "text-primary"),
#'     panel_item(
#'       "Tests",
#'       optionalSelectInput(
#'         "tests",
#'         "Tests:",
#'         choices = c(
#'           "Shapiro-Wilk",
#'           "Kolmogorov-Smirnov (one-sample)"
#'         ),
#'         selected = "Shapiro-Wilk"
#'       )
#'     )
#'   ),
#'   forms = tagList(
#'     verbatim_popup_ui("warning", "Show Warnings"),
#'     verbatim_popup_ui("rcode", "Show R code")
#'   )
#' )
#'
#' @export
standard_layout <- function(output,
                            encoding = NULL,
                            forms = NULL,
                            pre_output = NULL,
                            post_output = NULL) {
  # checking arguments
  checkmate::assert_multi_class(output, c("shiny.tag", "shiny.tag.list", "html"))
  checkmate::assert_multi_class(encoding, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

  # if encoding=NULL then forms is placed below output

  tag_output <- tags$div(
    class = "teal-widgets standard-layout",
    tags$div(class = "standard-layout-pre-output", pre_output),
    tags$div(class = "standard-layout-output", output),
    tags$div(class = "standard-layout-post-output", post_output)
  )

  tag_enc_out <- if (!is.null(encoding)) {
    tags$div(
      class = "teal-widgets standard-layout has-encodings",
      bslib::layout_sidebar(
        sidebar = bslib::sidebar(
          tags$div(
            encoding,
            if (is.null(forms)) {
              NULL
            } else {
              tags$div(
                tags$br(),
                forms
              )
            }
          )
        ),
        tag_output
      )
    )
  } else {
    tags$div(
      tag_output,
      if (is.null(forms)) {
        NULL
      } else {
        tags$div(class = "form-group", forms)
      }
    )
  }

  bslib::page_fluid(
    class = "teal-widgets standard-layout-wrapper",
    standard_layout_deps(),
    tag_enc_out
  )
}

#' Small well class for HTML
#'
#' @description
#' Adds Small Well class and overflow-x property to HTML output element.
#' @param ... other arguments to pass to tag object's div attributes.
#'
#' @details `white_small_well` is intended to be used with [shiny::uiOutput()].
#' The overflow-x property is set to auto so that a scroll bar is added
#' when the content overflows at the left and right edges of the output window.
#' For example, this is useful for displaying wide tables.
#'
#' @return An HTML output element with class Small Well and overflow-x property
#' @export
#'
#' @examples
#'
#' white_small_well(shiny::htmlOutput("summary"))
white_small_well <- function(...) {
  shiny::tagList(
    tags$div(
      class = "well well-sm",
      style = "background-color: white;",
      ...
    )
  )
}

#' Map `lenghtMenu` property
#'
#' @description
#' Maps the `lengthMenu` selected value property of `DT::datatable` to a `shiny` variable.
#' @param dt_name `ns()` of `inputId` of the `DT::datatable`
#' @param dt_rows `ns()` of `inputId` of the variable that holds the current selected value of `lengthMenu`
#'
#' @name get_dt_rows
#'
#' @return (`shiny::tagList`) A `shiny tagList`.
#'
#' @examplesIf requireNamespace("DT", quietly = TRUE)
#' library(shiny)
#' library(DT)
#'
#' ui <- function(id) {
#'   ns <- NS(id)
#'   tagList(
#'     get_dt_rows(ns("data_table"), ns("dt_rows")),
#'     textOutput(ns("rows")),
#'     DT::DTOutput(ns("data_table"))
#'   )
#' }
#'
#' # use the input$dt_rows in the Shiny Server function
#' server <- function(id) {
#'   moduleServer(id, function(input, output, session) {
#'     output$data_table <- DT::renderDataTable(iris)
#'     # Change rows selected to see the first line on the UI change
#'     rows <- reactive({
#'       paste0("Selected Rows ", input$dt_rows)
#'     })
#'     output$rows <- renderText(rows())
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(
#'     ui = ui("my_table_module"),
#'     server = function(input, output, session) server("my_table_module")
#'   )
#' }
#' @export
get_dt_rows <- function(dt_name, dt_rows) {
  tags$head(
    tags$script(
      sprintf(
        "$(document).ready(function() {
        $('%s').on('length.dt', function(e, settings, len) {
        Shiny.setInputValue('%s', len);
        });
        });",
        paste0("#", dt_name),
        dt_rows
      )
    )
  )
}

1		#' @keywords internal
2		#' @noRd
3		verbatim_popup_deps <- function() {
4	7x	htmltools::htmlDependency(
5	7x	name = "teal-widgets-verbatim-popup",
6	7x	version = utils::packageVersion("teal.widgets"),
7	7x	package = "teal.widgets",
8	7x	src = "verbatim-popup",
9	7x	stylesheet = "verbatim-popup.css",
10	7x	script = "verbatim-popup.js"
11		)
12		}
13
14		#' A `shiny` module that pops up verbatim text.
15		#' @name verbatim_popup
16		#' @description
17		#' This module consists of a button that once clicked pops up a
18		#' modal window with verbatim-styled text.
19		#'
20		#' @param id (`character(1)`) the `shiny` id
21		#' @param button_label (`character(1)`) the text printed on the button
22		#' @param type (`character(1)`) specifying whether to use `[shiny::actionButton()]` or `[shiny::actionLink()]`.
23		#' @param ... additional arguments to `[shiny::actionButton()]`(or `[shiny::actionLink()]`).
24		#'
25		#' @return the UI function returns a `shiny.tag.list` object
26		#' @export
27		#'
28		#' @examples
29		#' library(shiny)
30		#'
31		#' ui <- bslib::page_fluid(verbatim_popup_ui("my_id", button_label = "Open popup"))
32		#' srv <- function(input, output) {
33		#' verbatim_popup_srv(
34		#' "my_id",
35		#' "if (TRUE) { print('Popups are the best') }",
36		#' title = "My custom title",
37		#' style = TRUE
38		#' )
39		#' }
40		#' if (interactive()) shinyApp(ui, srv)
41		#'
42		verbatim_popup_ui <- function(id, button_label, type = c("button", "link"), ...) {
43	9x	checkmate::assert_string(id)
44	8x	checkmate::assert_string(button_label)
45
46	7x	ns <- shiny::NS(id)
47
48	7x	shiny::tagList(
49	7x	verbatim_popup_deps(),
50	7x	shinyjs::useShinyjs(),
51	7x	shiny::actionButton(
52	7x	inputId = ns("button"),
53	7x	label = button_label,
54	7x	class = c("teal-widgets-busy-disable", match.arg(type)),
55		...
56		)
57		)
58		}
59
60		#' @name verbatim_popup
61		#' @export
62		#'
63		#' @param verbatim_content (`character`, `expression`, `condition` or `reactive(1)`
64		#' holding any of the above) the content to show in the popup modal window
65		#' @param title (`character(1)`) the title of the modal window
66		#' @param style (`logical(1)`) whether to style the `verbatim_content` using `styler::style_text`.
67		#' If `verbatim_content` is a `condition` or `reactive` holding `condition` then this argument is ignored
68		#' @param disabled (`reactive(1)`) the `shiny` reactive value holding a `logical`. The popup button is disabled
69		#' when the flag is `TRUE` and enabled otherwise.
70		#'
71		verbatim_popup_srv <- function(id, verbatim_content, title, style = FALSE, disabled = shiny::reactiveVal(FALSE)) {
72	7x	checkmate::assert_string(id)
73	6x	checkmate::assert_string(title)
74	5x	checkmate::assert_flag(style)
75	4x	checkmate::assert_class(disabled, classes = "reactive")
76	3x	moduleServer(id, function(input, output, session) {
77	2x	ns <- session$ns
78	2x	button_click_observer(
79	2x	click_event = shiny::reactive(input$button),
80	2x	copy_button_id = ns("copy_button"),
81	2x	copied_area_id = ns("verbatim_content"),
82	2x	modal_title = title,
83	2x	modal_content = format_content(verbatim_content, style),
84	2x	disabled = disabled
85		)
86		})
87		}
88
89		#' Creates a `shiny` observer handling button clicks.
90		#'
91		#' @description
92		#' When the button is clicked it pop up a modal window with the text.
93		#'
94		#' @keywords internal
95		#' @param click_event `reactive` the click event
96		#' @param copy_button_id (`character(1)`) the id of the button to copy the modal content.
97		#' Automatically appended with a 1 and 2 suffix for top and bottom buttons respectively.
98		#' @param copied_area_id (`character(1)`) the id of the element which contents are copied
99		#' @param modal_title (`character(1)`) the title of the modal window
100		#' @param modal_content (`reactive`) the content of the modal window
101		#' @param disabled (`reactive(1)`) the `shiny` reactive value holding a `logical`. The popup button is disabled
102		#' when the flag is `TRUE` and enabled otherwise.
103		button_click_observer <- function(click_event,
104		copy_button_id,
105		copied_area_id,
106		modal_title,
107		modal_content,
108		disabled) {
109	4x	shiny::observeEvent(
110	4x	disabled(),
111	4x	handlerExpr = {
112	!	if (disabled()) {
113	!	shinyjs::disable("button")
114		} else {
115	!	shinyjs::enable("button")
116		}
117		}
118		)
119
120	4x	shiny::observeEvent(
121	4x	click_event(),
122	4x	handlerExpr = {
123	!	modal_content <- req(modal_content())
124	!	shiny::showModal(
125	!	div(
126	!	class = "teal-widgets button-click-observer",
127	!	shiny::modalDialog(
128	!	tags$div(
129	!	tags$div(
130	!	shiny::modalButton("Dismiss"),
131	!	shiny::actionButton(
132	!	paste0(copy_button_id, 1),
133	!	"Copy to Clipboard",
134	!	class = "btn-primary",
135	!	onclick = paste0("copyToClipboard('", copied_area_id, "')")
136		)
137		),
138	!	tags$pre(id = copied_area_id, modal_content),
139		),
140	!	title = modal_title,
141	!	footer = shiny::tagList(
142	!	shiny::modalButton("Dismiss"),
143	!	shiny::actionButton(
144	!	paste0(copy_button_id, 2),
145	!	"Copy to Clipboard",
146	!	class = "btn-primary",
147	!	onclick = paste0("copyToClipboard('", copied_area_id, "')")
148		)
149		),
150	!	size = "l",
151	!	easyClose = TRUE
152		)
153		)
154		)
155		}
156		)
157		}
158
159		#' Formats the content of the modal popup window.
160		#'
161		#' @details
162		#' Formats the content:
163		#' * concatenates if needed
164		#' * styles if `style` is TRUE
165		#'
166		#' @keywords internal
167		#' @inheritParams verbatim_popup
168		#' @return `reactive` with the formatted content
169		format_content <- function(verbatim_content, style = FALSE) {
170	17x	shiny::reactive({
171	10x	content <- if (inherits(verbatim_content, "reactive")) {
172	5x	tryCatch(
173	5x	verbatim_content(),
174	5x	error = function(e) {
175	2x	e
176		}
177		)
178		} else {
179	5x	verbatim_content
180		}
181	10x	shiny::validate(shiny::need(
182	10x	checkmate::test_multi_class(content, classes = c("expression", "character", "condition")),
183	10x	"verbatim_content should be an expression, character or condition"
184		))
185
186	9x	content <- paste(as.character(content), collapse = "\n")
187
188	9x	if (style && !checkmate::test_class(content, "condition")) {
189	4x	content <- paste(styler::style_text(content), collapse = "\n")
190		}
191	9x	content
192		})
193		}

1		#' This function checks the plot type and applies specific modifications
2		#' to the plot object based on the provided parameters.
3		#'
4		#' @param plot_obj The original plot object.
5		#' @param plot_type The type of the plot, either `gg` (`ggplot2`) or `grob` (`grid`, `graphics`).
6		#' @param dblclicking A logical value indicating whether double-clicking on data points on
7		#' the main plot is enabled or disabled.
8		#' @param ranges A list containing x and y values of ranges.
9		#'
10		#' @keywords internal
11		apply_plot_modifications <- function(plot_obj, plot_type, dblclicking, ranges) {
12	11x	if (plot_type == "gg" && dblclicking) {
13	1x	plot_obj +
14	1x	ggplot2::coord_cartesian(xlim = ranges$x, ylim = ranges$y, expand = FALSE)
15	10x	} else if (plot_type == "grob") {
16	2x	grid::grid.newpage()
17	2x	grid::grid.draw(plot_obj)
18		} else {
19	8x	plot_obj
20		}
21		}
22
23		.warning_gt_webshot2 <- function(table, #
24		webshot_installed = requireNamespace("webshot2", quietly = TRUE)) {
25		if (
26	16x	checkmate::test_multi_class(table, c("gt_tbl", "tbl_split", "tbl_summary")) &&
27	16x	!webshot_installed &&
28	16x	!identical(Sys.getenv("DISABLE_GT_WEBSHOT2_WARNING"), "true") &&
29	16x	is.null(.warnings_env$gt_webshot2_warning)
30		) {
31	1x	.warnings_env$gt_webshot2_warning <- warningCondition(
32	1x	paste0(
33	1x	"The `webshot2` package is required to donwload gt tables as PDF. Please install it to use this feature.",
34	1x	" This warning will only be shown once per session."
35		),
36	1x	class = "gt_webshot2_warning"
37		)
38	1x	warning(.warnings_env$gt_webshot2_warning)
39		}
40		}
41
42		.warnings_env <- new.env(parent = emptyenv())
43
44		#' Validate the download file name
45		#'
46		#' Hides the `data_download` button and renders `output$file_name_warning` when `input$file_name`
47		#' does not contain any letter or number, e.g. it is empty or only whitespace or special characters.
48		#'
49		#' @param input,output Shiny module `input` and `output` objects.
50		#'
51		#' @return `reactive` returning `TRUE` when the file name is valid.
52		#'
53		#' @noRd
54		file_name_validation_srv <- function(input, output) {
55	31x	file_name_valid <- reactive({
56	68x	isTRUE(grepl("[[:alnum:]]", input$file_name))
57		})
58
59	31x	observeEvent(file_name_valid(), {
60	68x	shinyjs::toggle("data_download", condition = file_name_valid())
61		})
62
63	31x	output$file_name_warning <- renderUI({
64	68x	if (!file_name_valid()) {
65	38x	helpText(
66	38x	class = "error",
67	38x	icon("triangle-exclamation"),
68	38x	"Please provide a meaningful file name: it must contain at least one letter or number."
69		)
70		}
71		})
72
73	31x	file_name_valid
74		}

1		#' Creates `ggplot2_args` object
2		#'
3		#' @description
4		#' Constructor of `ggplot2_args` class of objects.
5		#' The `ggplot2_args` argument should be a part of every module which contains any `ggplot2` graphics.
6		#' The function arguments are validated to match their `ggplot2` equivalents.
7		#'
8		#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`.
9		#'
10		#' @seealso
11		#' * [resolve_ggplot2_args()] to resolve multiple objects into one using pre-defined priorities.
12		#' * [parse_ggplot2_args()] to parse resolved list into list of calls.
13		#'
14		#' @param labs (named `list`)\cr
15		#' where all fields have to match [ggplot2::labs()] arguments.
16		#' @param theme (named `list`)\cr
17		#' where all fields have to match [ggplot2::theme()] arguments.
18		#'
19		#' @return (`ggplot2_args`) object.
20		#' @export
21		#' @examples
22		#' ggplot2_args(
23		#' labs = list(title = "TITLE"),
24		#' theme = list(title = ggplot2::element_text(size = 20))
25		#' )
26		ggplot2_args <- function(labs = list(), theme = list()) {
27	91x	checkmate::assert_list(labs)
28	91x	checkmate::assert_list(theme)
29	91x	checkmate::assert_character(names(labs), unique = TRUE, null.ok = TRUE)
30	91x	checkmate::assert_character(names(theme), unique = TRUE, null.ok = TRUE)
31
32	91x	ggplot2_theme <- methods::formalArgs(ggplot2::theme)
33		# utils::getFromNamespace is not recommended nevertheless needed as it is replacing `:::`.
34		# usage of static values will be vulnerable to any changes in ggplot2 aesthetics.
35	91x	ggplot2_labs <- c(
36	91x	utils::getFromNamespace(".all_aesthetics", "ggplot2"),
37	91x	methods::formalArgs(ggplot2::labs)
38		)
39	91x	checkmate::assert_subset(names(labs), choices = ggplot2_labs, empty.ok = TRUE)
40	90x	checkmate::assert_subset(names(theme), choices = ggplot2_theme, empty.ok = TRUE)
41
42	89x	structure(list(labs = labs, theme = theme), class = "ggplot2_args")
43		}
44
45		#' Resolving and reducing multiple `ggplot2_args` objects
46		#'
47		#' @description
48		#' Resolving and reducing multiple `ggplot2_args` objects.
49		#' This function is intended to utilize user provided settings, defaults provided by the module creator and
50		#' also `teal` option. See `Details`, below, to understand the logic.
51		#'
52		#' @seealso [parse_ggplot2_args()] to parse resolved list into list of calls.
53		#'
54		#' @param user_plot (`ggplot2_args`)\cr
55		#' end user setup for theme and labs in the specific plot.
56		#' Created with the [ggplot2_args()] function. The `NULL` value is supported.
57		#' @param user_default (`ggplot2_args`)\cr
58		#' end user setup for module default theme and labs.
59		#' Created with the [ggplot2_args()] function. The `NULL` value is supported.
60		#' @param module_plot (`ggplot2_args`)\cr
61		#' module creator setup for theme and labs in the specific plot.
62		#' Created with the [ggplot2_args()] function. The `NULL` value is supported.
63		#' @param app_default (`ggplot2_args`)\cr
64		#' Application level setting. Can be `NULL`.
65		#'
66		#' @return `ggplot2_args` object.
67		#'
68		#' @details
69		#' The function picks the first non `NULL` value for each argument, checking in the following order:
70		#' 1. `ggplot2_args` argument provided by the end user.
71		#' Per plot (`user_plot`) and then default (`user_default`) setup.
72		#' 2. `app_default` global R variable, `teal.ggplot2_args`.
73		#' 3. `module_plot` which is a module creator setup.
74		#' @export
75		#' @examples
76		#' resolve_ggplot2_args(
77		#' user_plot = ggplot2_args(
78		#' labs = list(title = "TITLE"),
79		#' theme = list(title = ggplot2::element_text(size = 20))
80		#' ),
81		#' user_default = ggplot2_args(
82		#' labs = list(x = "XLAB")
83		#' )
84		#' )
85		resolve_ggplot2_args <- function(user_plot = ggplot2_args(),
86		user_default = ggplot2_args(),
87		module_plot = ggplot2_args(),
88		app_default = getOption("teal.ggplot2_args", ggplot2_args())) {
89	18x	checkmate::assert_class(user_plot, "ggplot2_args", null.ok = TRUE)
90	17x	checkmate::assert_class(user_default, "ggplot2_args", null.ok = TRUE)
91	17x	checkmate::assert_class(module_plot, "ggplot2_args", null.ok = TRUE)
92	17x	checkmate::assert_class(app_default, "ggplot2_args", null.ok = TRUE)
93
94	17x	ggplot2_args_all <- list(
95	17x	"plot" = user_plot,
96	17x	"default" = user_default,
97	17x	"teal" = app_default,
98	17x	"module" = module_plot
99		)
100
101	17x	labs_args <- Reduce(`c`, lapply(ggplot2_args_all, function(x) x$labs))
102	17x	labs_args <- if (is.null(labs_args)) list() else labs_args[!duplicated(names(labs_args))]
103
104	17x	theme_args <- Reduce(`c`, lapply(ggplot2_args_all, function(x) x$theme))
105	17x	theme_args <- if (is.null(theme_args)) list() else theme_args[!duplicated(names(theme_args))]
106
107	17x	ggplot2_args(labs = labs_args, theme = theme_args)
108		}
109
110		#' Parse `ggplot2_args` object into the `ggplot2` expression
111		#'
112		#' @description
113		#' A function to parse expression from the `ggplot2_args` object.
114		#' @param ggplot2_args (`ggplot2_args`)\cr
115		#' This argument could be a result of the [resolve_ggplot2_args()].
116		#' @param ggtheme (`character(1)`)\cr
117		#' name of the `ggplot2` theme to be applied, e.g. `"dark"`.
118		#'
119		#' @return (`list`) of up to three elements of class `languange`: `"labs"`, `"ggtheme"` and `"theme"`.
120		#' @export
121		#' @examples
122		#' parse_ggplot2_args(
123		#' resolve_ggplot2_args(ggplot2_args(
124		#' labs = list(title = "TITLE"),
125		#' theme = list(title = ggplot2::element_text(size = 20))
126		#' ))
127		#' )
128		#'
129		#' parse_ggplot2_args(
130		#' resolve_ggplot2_args(
131		#' ggplot2_args(
132		#' labs = list(title = "TITLE"),
133		#' theme = list(title = ggplot2::element_text(size = 20))
134		#' )
135		#' ),
136		#' ggtheme = "gray"
137		#' )
138		parse_ggplot2_args <- function(ggplot2_args = teal.widgets::ggplot2_args(),
139		ggtheme = c(
140		"default",
141		"gray",
142		"bw",
143		"linedraw",
144		"light",
145		"dark",
146		"minimal",
147		"classic",
148		"void",
149		"test"
150		)) {
151	10x	checkmate::assert_class(ggplot2_args, "ggplot2_args")
152	9x	ggtheme <- match.arg(ggtheme)
153
154	9x	res_list <- list()
155
156	9x	labs_args <- ggplot2_args$labs
157
158	9x	labs_f <- if (length(labs_args)) {
159	5x	as.call(c(list(quote(ggplot2::labs)), labs_args))
160		} else {
161	4x	NULL
162		}
163
164	9x	default_theme <- if (ggtheme != "default") {
165	1x	as.call(list(str2lang(paste0("ggplot2::theme_", ggtheme))))
166		} else {
167	8x	NULL
168		}
169
170	9x	theme_args <- ggplot2_args$theme
171
172	9x	theme_f <- if (length(theme_args)) {
173	2x	as.call(c(list(quote(ggplot2::theme)), theme_args))
174		} else {
175	7x	NULL
176		}
177
178	9x	final_list <- Filter(Negate(is.null), list(labs = labs_f, ggtheme = default_theme, theme = theme_f))
179		# For empty final_list we want to return empty list, not empty named list
180	3x	`if`(length(final_list) == 0, list(), final_list)
181		}

1		#' @keywords internal
2		#' @noRd
3		draggable_buckets_deps <- function() {
4	1x	htmltools::htmlDependency(
5	1x	name = "teal-widgets-draggable-buckets",
6	1x	version = utils::packageVersion("teal.widgets"),
7	1x	package = "teal.widgets",
8	1x	src = "draggable-buckets",
9	1x	script = "draggable-buckets.js",
10	1x	stylesheet = "draggable-buckets.css"
11		)
12		}
13
14		#' @title Draggable Buckets
15		#' @description
16		#' A custom widget with draggable elements that can be put into buckets.
17		#'
18		#' @param input_id (`character(1)`) the `HTML` id of this widget
19		#' @param label (`character(1)` or `shiny.tag`) the header of this widget
20		#' @param elements (`character`) the elements to drag into buckets
21		#' @param buckets (`character` or `list`) the names of the buckets the elements can be put in or a list of key-pair
22		#' values where key is a name of a bucket and value is a character vector of elements in a bucket
23		#'
24		#' @return the `HTML` code comprising an instance of this widget
25		#' @export
26		#'
27		#' @details `shinyvalidate` validation can be used with this widget. See example below.
28		#'
29		#' @examples
30		#' library(shiny)
31		#'
32		#' ui <- bslib::page_fluid(
33		#' draggable_buckets("id", "Choices #1", c("a", "b"), c("bucket1", "bucket2")),
34		#' draggable_buckets("id2", "Choices #2", letters, c("vowels", "consonants")),
35		#' verbatimTextOutput("out"),
36		#' verbatimTextOutput("out2")
37		#' )
38		#' server <- function(input, output) {
39		#' iv <- shinyvalidate::InputValidator$new()
40		#' iv$add_rule(
41		#' "id",
42		#' function(data) if (length(data[["bucket1"]]) == 0) "There should be stuff in bucket 1"
43		#' )
44		#' iv$enable()
45		#'
46		#' observeEvent(list(input$id, input$id2), {
47		#' print(isolate(input$id))
48		#' print(isolate(input$id2))
49		#' })
50		#' output$out <- renderPrint({
51		#' iv$is_valid()
52		#' input$id
53		#' })
54		#' output$out2 <- renderPrint(input$id2)
55		#' }
56		#' if (interactive()) shinyApp(ui, server)
57		#'
58		#' # With default elements in the bucket
59		#' ui <- bslib::page_fluid(
60		#' draggable_buckets("id", "Choices #1", c("a", "b"), list(bucket1 = character(), bucket2 = c("c"))),
61		#' verbatimTextOutput("out")
62		#' )
63		#' server <- function(input, output) {
64		#' observeEvent(input$id, {
65		#' print(isolate(input$id))
66		#' })
67		#' output$out <- renderPrint(input$id)
68		#' }
69		#' if (interactive()) shinyApp(ui, server)
70		draggable_buckets <- function(input_id, label, elements = character(), buckets) {
71	4x	checkmate::assert_string(input_id)
72	3x	checkmate::assert_true(inherits(label, "character") \|\| inherits(label, "shiny.tag"))
73	2x	checkmate::assert_character(c(elements, unlist(buckets)), min.len = 0, null.ok = TRUE, unique = TRUE)
74	2x	checkmate::assert(
75	2x	checkmate::check_character(buckets, min.len = 1),
76	2x	checkmate::check_list(buckets, types = "character", names = "unique")
77		)
78
79	1x	elements_iterator <- new.env(parent = emptyenv())
80	1x	elements_iterator$it <- 0
81
82	1x	shiny::tagList(
83	1x	draggable_buckets_deps(),
84	1x	shiny::div(
85	1x	tags$span(label),
86	1x	render_unbucketed_elements(elements = elements, elements_iterator = elements_iterator, widget_id = input_id),
87	1x	render_buckets(buckets = buckets, elements_iterator = elements_iterator, widget_id = input_id),
88	1x	class = "draggableBuckets",
89	1x	id = input_id
90		)
91		)
92		}
93
94		render_unbucketed_elements <- function(elements, elements_iterator, widget_id) {
95	1x	tags$div(
96	1x	lapply(elements, function(element) {
97	1x	elements_iterator$it <- elements_iterator$it + 1
98	1x	render_draggable_element(
99	1x	value = element,
100	1x	id = paste0(widget_id, "draggable", elements_iterator$it),
101	1x	widget_id = widget_id
102		)
103		}),
104	1x	id = paste0(widget_id, "elements"),
105	1x	class = c("form-control", "elements"),
106	1x	ondragover = "allowDrop(event)",
107	1x	ondrop = "drop(event)",
108	1x	`data-widget` = widget_id
109		)
110		}
111
112		render_buckets <- function(buckets, elements_iterator, widget_id) {
113	1x	buckets <- `if`(
114	1x	is.list(buckets),
115	1x	lapply(names(buckets), function(bucket_name) {
116	!	render_bucket(
117	!	name = bucket_name,
118	!	elements = buckets[[bucket_name]],
119	!	elements_iterator = elements_iterator,
120	!	widget_id = widget_id
121		)
122		}),
123	1x	lapply(buckets, render_bucket, widget_id = widget_id, elements_iterator = elements_iterator)
124		)
125	1x	shiny::tagList(buckets)
126		}
127
128		render_draggable_element <- function(value, id, widget_id) {
129	1x	tags$div(
130	1x	value,
131	1x	id = id,
132	1x	class = "element",
133	1x	draggable = "true",
134	1x	ondragstart = "drag(event)",
135	1x	ondragover = "allowDrop(event)",
136	1x	ondrop = "dropReorder(event)",
137	1x	`data-widget` = widget_id
138		)
139		}
140
141		render_bucket <- function(name, elements = NULL, elements_iterator = NULL, widget_id = NULL) {
142	1x	tags$div(
143	1x	tags$div(
144	1x	paste0(name, ":"),
145	1x	class = "bucket-name",
146	1x	ondragover = "allowDrop(event)",
147	1x	ondrop = "dropBucketName(event)",
148	1x	`data-widget` = widget_id
149		),
150	1x	lapply(elements, function(element) {
151	!	elements_iterator$it <- elements_iterator$it + 1
152	!	render_draggable_element(
153	!	value = element,
154	!	id = paste0(widget_id, "draggable", elements_iterator$it),
155	!	widget_id = widget_id
156		)
157		}),
158	1x	class = c("form-control", "bucket"),
159	1x	ondragover = "allowDrop(event)",
160	1x	ondrop = "drop(event)",
161	1x	`data-label` = name,
162	1x	`data-widget` = widget_id
163		)
164		}

1		#' @keywords internal
2		#' @noRd
3		standard_layout_deps <- function() {
4	3x	htmltools::htmlDependency(
5	3x	name = "teal-widgets-standard-layout",
6	3x	version = utils::packageVersion("teal.widgets"),
7	3x	package = "teal.widgets",
8	3x	src = "standard-layout",
9	3x	stylesheet = "standard-layout.css"
10		)
11		}
12
13		#' Standard UI layout
14		#'
15		#' @description
16		#' Create a standard UI layout with output on the right and an encoding panel on
17		#' the left. This is the layout used by the `teal` modules.
18		#'
19		#' @param output (`shiny.tag`)\cr
20		#' object with the output element (table, plot, listing) such as for example returned
21		#' by [shiny::plotOutput()].
22		#' @param encoding (`shiny.tag`)\cr
23		#' object containing the encoding elements. If this element is `NULL` then no encoding side
24		#' panel on the right is created.
25		#' @param forms (`tagList`)\cr
26		#' for example [shiny::actionButton()] that are placed below the encodings panel
27		#' @param pre_output (`shiny.tag`) optional,\cr
28		#' with text placed before the output to put the output into context. For example a title.
29		#' @param post_output (`shiny.tag`) optional, with text placed after the output to put the output
30		#' into context. For example the [shiny::helpText()] elements are useful.
31		#'
32		#' @return an object of class `shiny.tag` with the UI code.
33		#'
34		#' @examples
35		#' library(shiny)
36		#' standard_layout(
37		#' output = white_small_well(tags$h3("Tests")),
38		#' encoding = tags$div(
39		#' tags$label("Encodings", class = "text-primary"),
40		#' panel_item(
41		#' "Tests",
42		#' optionalSelectInput(
43		#' "tests",
44		#' "Tests:",
45		#' choices = c(
46		#' "Shapiro-Wilk",
47		#' "Kolmogorov-Smirnov (one-sample)"
48		#' ),
49		#' selected = "Shapiro-Wilk"
50		#' )
51		#' )
52		#' ),
53		#' forms = tagList(
54		#' verbatim_popup_ui("warning", "Show Warnings"),
55		#' verbatim_popup_ui("rcode", "Show R code")
56		#' )
57		#' )
58		#'
59		#' @export
60		standard_layout <- function(output,
61		encoding = NULL,
62		forms = NULL,
63		pre_output = NULL,
64		post_output = NULL) {
65		# checking arguments
66	8x	checkmate::assert_multi_class(output, c("shiny.tag", "shiny.tag.list", "html"))
67	6x	checkmate::assert_multi_class(encoding, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
68	5x	checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
69	4x	checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
70
71		# if encoding=NULL then forms is placed below output
72
73	3x	tag_output <- tags$div(
74	3x	class = "teal-widgets standard-layout",
75	3x	tags$div(class = "standard-layout-pre-output", pre_output),
76	3x	tags$div(class = "standard-layout-output", output),
77	3x	tags$div(class = "standard-layout-post-output", post_output)
78		)
79
80	3x	tag_enc_out <- if (!is.null(encoding)) {
81	1x	tags$div(
82	1x	class = "teal-widgets standard-layout has-encodings",
83	1x	bslib::layout_sidebar(
84	1x	sidebar = bslib::sidebar(
85	1x	tags$div(
86	1x	encoding,
87	1x	if (is.null(forms)) {
88	1x	NULL
89		} else {
90	!	tags$div(
91	!	tags$br(),
92	!	forms
93		)
94		}
95		)
96		),
97	1x	tag_output
98		)
99		)
100		} else {
101	2x	tags$div(
102	2x	tag_output,
103	2x	if (is.null(forms)) {
104	1x	NULL
105		} else {
106	1x	tags$div(class = "form-group", forms)
107		}
108		)
109		}
110
111	3x	bslib::page_fluid(
112	3x	class = "teal-widgets standard-layout-wrapper",
113	3x	standard_layout_deps(),
114	3x	tag_enc_out
115		)
116		}

1		#' Wrapper for `pickerInput`
2		#'
3		#' @description
4		#' Wrapper for [shinyWidgets::pickerInput()] with additional features.
5		#' When `fixed = TRUE` or when the number of `choices` is less or equal to 1 (see `fixed_on_single`),
6		#' the `pickerInput` widget is hidden and non-interactive widget will be displayed
7		#' instead. Toggle of `HTML` elements is just the visual effect to avoid displaying
8		#' `pickerInput` widget when there is only one choice.
9		#'
10		#' @inheritParams shinyWidgets::pickerInput
11		#'
12		#' @param sep (`character(1)`)\cr
13		#' A separator string to split the `choices` or `selected` inputs into the values of the different
14		#' columns.
15		#'
16		#' @param label_help (`shiny.tag`) optional,\cr
17		#' e.g. an object returned by [shiny::helpText()].
18		#'
19		#' @param fixed (`logical(1)`) optional,\cr
20		#' whether to block user to select choices.
21		#'
22		#' @param fixed_on_single (`logical(1)`) optional,\cr
23		#' whether to block user to select a choice when there is only one or less choice.
24		#' When `FALSE`, user is still able to select or deselect the choice.
25		#'
26		#' @param width (`character(1)`)\cr
27		#' The width of the input passed to `pickerInput` e.g. `'auto'`, `'fit'`, `'100px'` or `'75%'`
28		#'
29		#' @return (`shiny.tag`) HTML tag with `pickerInput` widget and
30		#' non-interactive element listing selected values.
31		#'
32		#' @export
33		#'
34		#' @examples
35		#' library(shiny)
36		#'
37		#' ui_grid <- function(...) {
38		#' bslib::page_fluid(
39		#' bslib::layout_columns(
40		#' col_widths = c(4, 4, 4),
41		#' ...
42		#' )
43		#' )
44		#' }
45		#'
46		#' ui <- ui_grid(
47		#' wellPanel(
48		#' optionalSelectInput(
49		#' inputId = "c1",
50		#' label = "Fixed choices",
51		#' choices = LETTERS[1:5],
52		#' selected = c("A", "B"),
53		#' fixed = TRUE
54		#' ),
55		#' verbatimTextOutput(outputId = "c1_out")
56		#' ),
57		#' wellPanel(
58		#' optionalSelectInput(
59		#' inputId = "c2",
60		#' label = "Single choice",
61		#' choices = "A",
62		#' selected = "A"
63		#' ),
64		#' verbatimTextOutput(outputId = "c2_out")
65		#' ),
66		#' wellPanel(
67		#' optionalSelectInput(
68		#' inputId = "c3",
69		#' label = "NULL choices",
70		#' choices = NULL
71		#' ),
72		#' verbatimTextOutput(outputId = "c3_out")
73		#' ),
74		#' wellPanel(
75		#' optionalSelectInput(
76		#' inputId = "c4",
77		#' label = "Default",
78		#' choices = LETTERS[1:5],
79		#' selected = "A"
80		#' ),
81		#' verbatimTextOutput(outputId = "c4_out")
82		#' ),
83		#' wellPanel(
84		#' optionalSelectInput(
85		#' inputId = "c5",
86		#' label = "Named vector",
87		#' choices = c(`A - value A` = "A", `B - value B` = "B", `C - value C` = "C"),
88		#' selected = "A"
89		#' ),
90		#' verbatimTextOutput(outputId = "c5_out")
91		#' ),
92		#' wellPanel(
93		#' selectInput(
94		#' inputId = "c6_choices", label = "Update choices", choices = letters, multiple = TRUE
95		#' ),
96		#' optionalSelectInput(
97		#' inputId = "c6",
98		#' label = "Updated choices",
99		#' choices = NULL,
100		#' multiple = TRUE,
101		#' fixed_on_single = TRUE
102		#' ),
103		#' verbatimTextOutput(outputId = "c6_out")
104		#' )
105		#' )
106		#'
107		#' server <- function(input, output, session) {
108		#' observeEvent(input$c6_choices, ignoreNULL = FALSE, {
109		#' updateOptionalSelectInput(
110		#' session = session,
111		#' inputId = "c6",
112		#' choices = input$c6_choices,
113		#' selected = input$c6_choices
114		#' )
115		#' })
116		#'
117		#' output$c1_out <- renderPrint(input$c1)
118		#' output$c2_out <- renderPrint(input$c2)
119		#' output$c3_out <- renderPrint(input$c3)
120		#' output$c4_out <- renderPrint(input$c4)
121		#' output$c5_out <- renderPrint(input$c5)
122		#' output$c6_out <- renderPrint(input$c6)
123		#' }
124		#'
125		#' if (interactive()) {
126		#' shinyApp(ui, server)
127		#' }
128		#'
129		optionalSelectInput <- function(inputId, # nolint
130		label = NULL,
131		choices = NULL,
132		selected = NULL,
133		multiple = FALSE,
134		sep = NULL,
135		options = list(),
136		label_help = NULL,
137		fixed = FALSE,
138		fixed_on_single = FALSE,
139		width = NULL) {
140	14x	checkmate::assert_string(inputId)
141	12x	checkmate::assert(
142	12x	checkmate::check_string(label, null.ok = TRUE),
143	12x	checkmate::check_class(label, "shiny.tag"),
144	12x	checkmate::check_class(label, "shiny.tag.list"),
145	12x	checkmate::check_class(label, "html")
146		)
147	11x	stopifnot(is.null(choices) \|\| length(choices) >= 1)
148	11x	stopifnot(
149	11x	is.null(selected) \|\|
150	11x	length(selected) == 0 \|\|
151	11x	all(selected %in% choices) \|\|
152	11x	all(selected %in% unlist(choices, recursive = FALSE))
153		)
154	11x	checkmate::assert_flag(multiple)
155	11x	checkmate::assert_string(sep, null.ok = TRUE)
156	11x	checkmate::assert_list(options)
157	10x	checkmate::assert(
158	10x	checkmate::check_string(label_help, null.ok = TRUE),
159	10x	checkmate::check_class(label_help, "shiny.tag"),
160	10x	checkmate::check_class(label_help, "shiny.tag.list"),
161	10x	checkmate::check_class(label_help, "html")
162		)
163	10x	checkmate::assert_flag(fixed)
164	10x	checkmate::assert_flag(fixed_on_single)
165
166	10x	if (!is.null(width)) {
167	2x	validateCssUnit(width)
168		}
169
170	9x	default_options <- list(
171	9x	"actions-box" = multiple,
172	9x	"none-selected-text" = "- Nothing selected -",
173	9x	"allow-clear" = !multiple,
174	9x	"max-options" = ifelse(multiple, Inf, 1),
175	9x	"show-subtext" = TRUE,
176	9x	"live-search" = ifelse(length(choices) > 10, TRUE, FALSE)
177		)
178
179	9x	options <- if (!identical(options, list())) {
180	1x	c(options, default_options[setdiff(names(default_options), names(options))])
181		} else {
182	8x	default_options
183		}
184
185	9x	if (is.null(choices)) {
186	1x	choices <- ""
187	1x	selected <- NULL
188		}
189
190	!	if (length(choices) <= 1 && fixed_on_single) fixed <- TRUE
191
192	9x	raw_choices <- extract_raw_choices(choices, attr(choices, "sep"))
193	9x	raw_selected <- extract_raw_choices(selected, attr(choices, "sep"))
194
195		# Making sure the default dropdown popup can be displayed in the whole body, even outside the sidebars.
196	9x	if (is.null(options$container)) {
197	9x	options$container <- "body"
198		}
199
200	9x	ui_picker <- tags$div(
201	9x	id = paste0(inputId, "_input"),
202		# visibility feature marked with display: none/block instead of shinyjs::hide/show
203		# as mechanism to hide/show is handled by javascript code
204	9x	style = if (fixed) "display: none;" else "display: block;",
205	9x	shinyWidgets::pickerInput(
206	9x	inputId = inputId,
207	9x	label = label,
208	9x	choices = raw_choices,
209	9x	selected = raw_selected,
210	9x	multiple = TRUE,
211	9x	width = width,
212	9x	options = options,
213	9x	choicesOpt = picker_options(choices)
214		)
215		)
216
217	9x	if (!is.null(label_help)) {
218	2x	ui_picker[[3]] <- append(ui_picker[[3]], list(tags$div(class = "label-help", label_help)), after = 1)
219		}
220
221	9x	ui_fixed <- tags$div(
222	9x	id = paste0(inputId, "_fixed"),
223		# visibility feature marked with display: none/block instead of shinyjs::hide/show
224		# as mechanism to hide/show is handled by javascript code
225	9x	style = if (fixed) "display: block;" else "display: none;",
226	9x	tags$label(class = "control-label", label),
227		# selected values as verbatim text
228	9x	tags$code(
229	9x	id = paste0(inputId, "_selected_text"),
230	9x	if (length(selected) > 0) {
231	1x	toString(selected)
232		} else {
233	8x	"NULL"
234		}
235		),
236	9x	label_help
237		)
238
239	9x	tags$div(
240		# when selected values in ui_picker change
241		# then update ui_fixed - specifically, update '{id}_selected_text' element
242	9x	tags$script(
243	9x	sprintf(
244		"
245	9x	$(function() {
246	9x	$('#%1$s').on('change', function(e) {
247	9x	var select_concat = $(this).val().length ? $(this).val().join(', ') : 'NULL';
248	9x	$('#%1$s_selected_text').html(select_concat);
249		})
250		})",
251	9x	inputId
252		)
253		),
254
255		# if ui_picker has only one or less option or is fixed then hide {id}_input and show {id}_fixed
256	9x	if (fixed_on_single) {
257	1x	js <- sprintf(
258	1x	"$(function() {
259	1x	$('#%1$s').on('change', function(e) {
260	1x	var options = $('#%1$s').find('option');
261	1x	if (options.length == 1) {
262	1x	$('#%1$s_input').hide();
263	1x	$('#%1$s_fixed').show();
264		} else {
265	1x	$('#%1$s_input').show();
266	1x	$('#%1$s_fixed').hide();
267		}
268		})
269		})",
270	1x	inputId
271		)
272	1x	tags$script(js)
273		},
274	9x	tags$div(ui_picker, ui_fixed)
275		)
276		}
277
278		#' @rdname optionalSelectInput
279		#' @param session (`shiny.session`)\cr
280		#' @export
281		updateOptionalSelectInput <- function(session, # nolint
282		inputId, # nolint
283		label = NULL,
284		selected = NULL,
285		choices = NULL) {
286	1x	raw_choices <- extract_raw_choices(choices, attr(choices, "sep"))
287	1x	raw_selected <- extract_raw_choices(selected, attr(choices, "sep"))
288
289		# update picker input
290	1x	shinyWidgets::updatePickerInput(
291	1x	session = session,
292	1x	inputId = inputId,
293	1x	label = label,
294	1x	selected = as.character(raw_selected),
295	1x	choices = raw_choices,
296	1x	choicesOpt = picker_options(choices),
297	1x	options = list(
298	1x	`live-search` = ifelse(length(raw_choices) > 10, TRUE, FALSE)
299		)
300		)
301
302	1x	invisible(NULL)
303		}
304
305		#' Get icons to represent variable types in dataset
306		#'
307		#' @param var_type (`character`)\cr
308		#' of R internal types (classes).
309		#'
310		#' @return (`character`)\cr
311		#' vector of HTML icons corresponding to data type in each column.
312		#' @keywords internal
313		#'
314		variable_type_icons <- function(var_type) {
315	!	checkmate::assert_character(var_type, any.missing = FALSE)
316
317	!	class_to_icon <- list(
318	!	numeric = "arrow-up-1-9",
319	!	integer = "arrow-up-1-9",
320	!	logical = "pause",
321	!	Date = "calendar",
322	!	POSIXct = "calendar",
323	!	POSIXlt = "calendar",
324	!	factor = "chart-bar",
325	!	character = "keyboard",
326	!	primary_key = "key",
327	!	unknown = "circle-question"
328		)
329	!	class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
330
331	!	res <- unname(vapply(
332	!	var_type,
333	!	FUN.VALUE = character(1),
334	!	FUN = function(class) {
335	!	if (class == "") {
336	!	class
337	!	} else if (is.null(class_to_icon[[class]])) {
338	!	class_to_icon[["unknown"]]
339		} else {
340	!	class_to_icon[[class]]
341		}
342		}
343		))
344
345	!	res
346		}
347
348		#' Optional content for `optionalSelectInput`
349		#'
350		#' Prepares content to be displayed in `optionalSelectInput` with icons and labels
351		#'
352		#' @param var_name (`character`)\cr
353		#' variable name
354		#' @param var_label (`character`)\cr
355		#' variable alternative name - for example variable label
356		#' @param var_type (`character`)
357		#' class of the variable.
358		#'
359		#' @return (`character`) HTML contents with all elements combined
360		#' @keywords internal
361		#'
362		picker_options_content <- function(var_name, var_label, var_type) {
363	!	if (length(var_name) == 0) {
364	!	res <- character(0)
365	!	} else if (length(var_type) == 0 && length(var_label) == 0) {
366	!	res <- var_name
367		} else {
368	!	checkmate::assert_character(var_name, min.len = 1, any.missing = FALSE)
369	!	stopifnot(
370	!	identical(var_type, character(0)) \|\| length(var_type) == length(var_name),
371	!	identical(var_label, character(0)) \|\| length(var_label) == length(var_name)
372		)
373
374	!	var_icon <- variable_type_icons(var_type)
375
376	!	res <- trimws(paste(
377	!	var_icon,
378	!	var_name,
379	!	vapply(
380	!	var_label,
381	!	function(x) {
382	!	ifelse(x == "", "", toString(tags$small(x, class = "text-muted")))
383		},
384	!	character(1)
385		)
386		))
387		}
388
389	!	res
390		}
391
392		#' Create `choicesOpt` for `pickerInput`
393		#'
394		#' @param choices (`choices_labeled` or `character`)\cr
395		#' choices vector
396		#'
397		#' @return (`list`)\cr
398		#' to be passed as `choicesOpt` argument.
399		#' @keywords internal
400		picker_options <- function(choices) {
401	10x	if (inherits(choices, "choices_labeled")) {
402	!	raw_choices <- extract_raw_choices(choices, sep = attr(choices, "sep"))
403	!	res <- list(
404	!	content = picker_options_content(
405	!	var_name = raw_choices,
406	!	var_label = extract_choices_labels(choices),
407	!	var_type = if (is.null(attr(choices, "types"))) character(0) else attr(choices, "types")
408		)
409		)
410	10x	} else if (all(vapply(choices, inherits, logical(1), "choices_labeled"))) {
411	!	choices <- unlist(unname(choices))
412	!	res <- list(content = picker_options_content(
413	!	var_name = choices,
414	!	var_label = extract_choices_labels(choices),
415	!	var_type = if (is.null(attr(choices, "types"))) character(0) else attr(choices, "types")
416		))
417		} else {
418	10x	res <- NULL
419		}
420	10x	res
421		}
422
423		#' Extract raw values from choices
424		#'
425		#' @param choices (`choices_labeled`, `list` or `character`)\cr
426		#' object containing choices
427		#' @param sep (`character(1)`)\cr
428		#' A separator string to split the `choices` or `selected` inputs into the values of
429		#' the different columns.
430		#' @return choices simplified
431		#' @keywords internal
432		extract_raw_choices <- function(choices, sep) {
433	20x	if (!is.null(sep)) {
434	!	vapply(choices, paste, collapse = sep, character(1))
435	20x	} else if (inherits(choices, "choices_labeled")) {
436	!	unname(unlist(choices))
437		} else {
438	20x	choices
439		}
440		}
441
442		#' Optional Slider Input Widget
443		#'
444		#' if min or max are `NA` then the slider widget will be hidden
445		#'
446		#' @description
447		#' Hidden input widgets are useful to have the `input[[inputId]]` variable
448		#' on available in the server function but no corresponding visual clutter from
449		#' input widgets that provide only a single choice.
450		#'
451		#' @inheritParams shiny::sliderInput
452		#' @param label_help (`shiny.tag`) optional\cr
453		#' object of class `shiny.tag`, e.g. an object returned by [shiny::helpText()]
454		#' @param ... optional arguments to `sliderInput`
455		#'
456		#' @return (`shiny.tag`) HTML tag with `sliderInput` widget.
457		#'
458		#' @export
459		#'
460		#' @examples
461		#' ui <- bslib::page_fluid(
462		#' shinyjs::useShinyjs(),
463		#' optionalSliderInput("s", "shown", 0, 1, 0.2),
464		#' optionalSliderInput("h", "hidden", 0, NA, 1),
465		#' )
466		#' if (interactive()) {
467		#' shiny::shinyApp(ui, function(input, output) {})
468		#' }
469		optionalSliderInput <- function(inputId, label, min, max, value, label_help = NULL, ...) { # nolint
470	25x	checkmate::assert_number(min, na.ok = TRUE)
471	25x	checkmate::assert_number(max, na.ok = TRUE)
472	25x	checkmate::assert_numeric(value, min.len = 1, max.len = 2, any.missing = FALSE)
473
474	25x	is_na_min <- is.na(min)
475	25x	is_na_max <- is.na(max)
476
477	25x	hide <- is_na_min \|\| is_na_max
478
479	25x	if (length(value) == 2) {
480	2x	value1 <- value[1]
481	2x	value2 <- value[2]
482		} else {
483	23x	value1 <- value
484	23x	value2 <- value
485		}
486
487	25x	if (is_na_min) {
488	3x	min <- value1 - 1
489		}
490	25x	if (is_na_max) {
491	2x	max <- value2 + 1
492		}
493
494	25x	if (min > value1 \|\| max < value2) {
495	2x	stop("arguments inconsistent: min <= value <= max expected")
496		}
497
498	23x	slider <- sliderInput(inputId, label, min, max, value, ...)
499
500	22x	if (!is.null(label_help)) {
501	!	slider[[3]] <- append(slider[[3]], list(tags$div(class = "label-help", label_help)), after = 1)
502		}
503
504	22x	if (hide) {
505	3x	shinyjs::hidden(slider)
506		} else {
507	19x	slider
508		}
509		}
510
511		#' Optional Slider Input with minimal and maximal values
512		#'
513		#' For `teal` modules we parameterize an `optionalSliderInput` with one argument
514		#' `value_min_max`
515		#'
516		#' @description
517		#' The [optionalSliderInput()] function needs three arguments to determine
518		#' whether to hide the `sliderInput` widget or not. For `teal` modules we specify an
519		#' optional slider input with one argument here called `value_min_max`.
520		#'
521		#' @inheritParams optionalSliderInput
522		#'
523		#' @param value_min_max (`numeric(1)` or `numeric(3)`)\cr
524		#' If of length 1 then the value gets set to that number and the `sliderInput` will be hidden.
525		#' Otherwise, if it is of length three the three elements will map to `value`, `min` and `max` of
526		#' the [optionalSliderInput()] function.
527		#'
528		#' @return (`shiny.tag`) HTML tag with range `sliderInput` widget.
529		#'
530		#' @export
531		#'
532		#' @examples
533		#'
534		#' ui <- bslib::page_fluid(
535		#' shinyjs::useShinyjs(),
536		#' optionalSliderInputValMinMax("a1", "b1", 1), # Hidden
537		#' optionalSliderInputValMinMax("a2", "b2", c(3, 1, 5)) # Shown
538		#' )
539		#' if (interactive()) {
540		#' shiny::shinyApp(ui, function(input, output) {})
541		#' }
542		optionalSliderInputValMinMax <- function(inputId, label, value_min_max, label_help = NULL, ...) { # nolint
543	19x	checkmate::assert(
544	19x	checkmate::check_numeric(
545	19x	value_min_max,
546	19x	finite = TRUE,
547	19x	len = 3
548		),
549	19x	checkmate::check_numeric(
550	19x	value_min_max,
551	19x	finite = TRUE,
552	19x	len = 1
553		)
554		)
555
556	18x	x <- value_min_max
557
558	18x	vals <- if (length(x) == 3) {
559	17x	checkmate::assert_number(x[1], lower = x[2], upper = x[3], .var.name = "value_min_max")
560	16x	list(value = x[1], min = x[2], max = x[3])
561	18x	} else if (length(x) == 1) {
562	1x	list(value = x, min = NA_real_, max = NA_real_)
563		}
564
565	17x	slider <- optionalSliderInput(inputId, label, vals$min, vals$max, vals$value, ...)
566
567	16x	if (!is.null(label_help)) {
568	2x	slider[[3]] <- append(slider[[3]], list(tags$div(class = "label-help", label_help)), after = 1)
569		}
570	16x	slider
571		}
572
573		#' Extract labels from choices basing on attributes and names
574		#'
575		#' @param choices (`list` or `vector`)\cr
576		#' select choices
577		#' @param values optional\cr
578		#' choices subset for which labels should be extracted, `NULL` for all choices.
579		#'
580		#' @return (`character`) vector with labels
581		#' @keywords internal
582		extract_choices_labels <- function(choices, values = NULL) {
583	!	res <- if (inherits(choices, "choices_labeled")) {
584	!	attr(choices, "raw_labels")
585	!	} else if (!is.null(names(choices)) && !setequal(names(choices), unlist(unname(choices)))) {
586	!	names(choices)
587		} else {
588	!	NULL
589		}
590
591	!	if (!is.null(values) && !is.null(res)) {
592	!	stopifnot(all(values %in% choices))
593	!	res <- res[vapply(values, function(val) which(val == choices), numeric(1))]
594		}
595
596	!	res
597		}

1		#' @keywords internal
2		#' @noRd
3		plot_with_settings_deps <- function() {
4	1x	htmltools::htmlDependency(
5	1x	name = "teal-widgets-plot-with-settings",
6	1x	version = utils::packageVersion("teal.widgets"),
7	1x	package = "teal.widgets",
8	1x	src = "plot-with-settings",
9	1x	stylesheet = "plot-with-settings.css",
10	1x	script = "plot-with-settings.js"
11		)
12		}
13
14		#' @name plot_with_settings
15		#' @rdname plot_with_settings
16		#' @export
17		plot_with_settings_ui <- function(id) {
18	1x	checkmate::assert_string(id)
19
20	1x	ns <- NS(id)
21
22	1x	tags$div(
23	1x	plot_with_settings_deps(),
24	1x	shinyjs::useShinyjs(),
25	1x	bslib::card(
26	1x	id = ns("plot-with-settings"),
27	1x	full_screen = TRUE,
28	1x	tags$div(
29	1x	tags$div(
30	1x	class = "teal-widgets settings-buttons",
31	1x	bslib::tooltip(
32	1x	trigger = tags$div(
33	1x	bslib::popover(
34	1x	id = ns("expbut"),
35	1x	trigger = icon("maximize"),
36		# This should be removed once https://github.com/rstudio/bslib/issues/1326 is fixed
37	1x	tags$span(HTML(" "), style = "visibility: hidden; height: 0px; display: block;"),
38	1x	uiOutput(ns("slider_ui")),
39	1x	uiOutput(ns("width_warning"))
40		)
41		),
42	1x	options = list(trigger = "hover"),
43	1x	class = "resize-button",
44	1x	"Resize"
45		),
46	1x	bslib::tooltip(
47	1x	trigger = tags$div(type_download_ui(ns("downbutton"))),
48	1x	options = list(trigger = "hover"),
49	1x	class = "download-button",
50	1x	"Download"
51		)
52		),
53	1x	tags$div(
54	1x	id = ns("plot-out-main"),
55	1x	class = "teal-widgets plot-content",
56	1x	uiOutput(ns("plot_out_main"))
57		)
58		)
59		)
60		)
61		}
62
63		#' Plot-with-settings module
64		#'
65		#' @rdname plot_with_settings
66		#' @description
67		#' Universal module for plots with settings for height, width, and download.
68		#'
69		#' @export
70		#'
71		#' @param id (`character(1)`) `shiny` module id.
72		#'
73		#' @param plot_r (`reactive` or `function`)\cr
74		#' `reactive` expression or a simple `function` to draw a plot.
75		#' A simple `function` is needed e.g. for base plots like `plot(1)` as the output can not be caught when downloading.
76		#' Take into account that simple functions are less efficient than reactive, as not catching the result.
77		#' @param height (`numeric`) optional\cr
78		#' vector with three elements c(VAL, MIN, MAX), where VAL is the starting value of the slider in
79		#' the main and expanded plot display.
80		#' @param width (`numeric`) optional\cr
81		#' vector with three elements `c(VAL, MIN, MAX)`, where VAL is the starting value of the slider in
82		#' the main and expanded plot display; `NULL` for default display.
83		#' @param show_hide_signal optional, (`reactive logical` a mechanism to allow modules which call this
84		#' module to show/hide the plot_with_settings UI)
85		#' @param brushing (`logical`) optional\cr
86		#' mechanism to enable / disable brushing on the main plot.
87		#' All the brushing data is stored as a reactive object in the `"brush"` element of
88		#' returned list. See the example for details.
89		#' @param clicking (`logical`)\cr
90		#' a mechanism to enable / disable clicking on data points on the main plot.
91		#' All the clicking data is stored as a reactive object in the `"click"`
92		#' element of returned list. See the example for details.
93		#' @param dblclicking (`logical`) optional\cr
94		#' mechanism to enable / disable double-clicking on data points on the main plot.
95		#' All the double clicking data is stored as a reactive object in the
96		#' the `"dblclick"` element of returned list. See the example for details.
97		#' @param hovering (`logical(1)`) optional\cr
98		#' mechanism to enable / disable hovering over data points on the main plot.
99		#' All the hovering data is stored as a reactive object in the
100		#' `"hover"` element of returned list. See the example for details.
101		#' @param graph_align (`character(1)`) optional,\cr
102		#' one of `"left"` (default), `"center"`, `"right"` or `"justify"`. The alignment of the graph on
103		#' the main page.
104		#'
105		#' @details By default the plot is rendered with `72 dpi`. In order to change this, to for example 96 set
106		#' `options(teal.plot_dpi = 96)`. The minimum allowed `dpi` value is `24` and it must be a whole number.
107		#' If an invalid value is set then the default value is used and a warning is outputted to the console.
108		#'
109		#' @return A `shiny` module.
110		#'
111		#' @examplesIf requireNamespace("lattice", quietly = TRUE)
112		#' # Example using a reactive as input to plot_r
113		#' library(shiny)
114		#' library(ggplot2)
115		#'
116		#' ui <- bslib::page_fluid(
117		#' plot_with_settings_ui(
118		#' id = "plot_with_settings"
119		#' )
120		#' )
121		#'
122		#' server <- function(input, output, session) {
123		#' plot_r <- reactive({
124		#' ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) +
125		#' geom_point()
126		#' })
127		#'
128		#' plot_with_settings_srv(
129		#' id = "plot_with_settings",
130		#' plot_r = plot_r,
131		#' height = c(400, 100, 1200),
132		#' width = c(500, 250, 750)
133		#' )
134		#' }
135		#'
136		#' if (interactive()) {
137		#' shinyApp(ui, server)
138		#' }
139		#'
140		#' # Example using a function as input to plot_r
141		#' library(lattice)
142		#'
143		#' ui <- bslib::page_fluid(
144		#' radioButtons("download_option", "Select the Option", list("ggplot", "trellis", "grob", "base")),
145		#' plot_with_settings_ui(
146		#' id = "plot_with_settings"
147		#' ),
148		#' sliderInput("nums", "Value", 1, 10, 1)
149		#' )
150		#'
151		#' server <- function(input, output, session) {
152		#' plot_r <- function() {
153		#' numbers <- seq_len(input$nums)
154		#' if (input$download_option == "ggplot") {
155		#' ggplot(data.frame(n = numbers), aes(.data$n)) +
156		#' geom_bar()
157		#' } else if (input$download_option == "trellis") {
158		#' densityplot(numbers)
159		#' } else if (input$download_option == "grob") {
160		#' tr_plot <- densityplot(numbers)
161		#' ggplotGrob(
162		#' ggplot(data.frame(n = numbers), aes(.data$n)) +
163		#' geom_bar()
164		#' )
165		#' } else if (input$download_option == "base") {
166		#' plot(numbers)
167		#' }
168		#' }
169		#'
170		#' plot_with_settings_srv(
171		#' id = "plot_with_settings",
172		#' plot_r = plot_r,
173		#' height = c(400, 100, 1200),
174		#' width = c(500, 250, 750)
175		#' )
176		#' }
177		#'
178		#' if (interactive()) {
179		#' shinyApp(ui, server)
180		#' }
181		#'
182		#' # Example with brushing/hovering/clicking/double-clicking
183		#' ui <- bslib::page_fluid(
184		#' plot_with_settings_ui(
185		#' id = "plot_with_settings"
186		#' ),
187		#' fluidRow(
188		#' column(4, tags$h3("Brush"), verbatimTextOutput("brushing_data")),
189		#' column(4, tags$h3("Click"), verbatimTextOutput("clicking_data")),
190		#' column(4, tags$h3("DblClick"), verbatimTextOutput("dblclicking_data")),
191		#' column(4, tags$h3("Hover"), verbatimTextOutput("hovering_data"))
192		#' )
193		#' )
194		#'
195		#' server <- function(input, output, session) {
196		#' plot_r <- reactive({
197		#' ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) +
198		#' geom_point()
199		#' })
200		#'
201		#' plot_data <- plot_with_settings_srv(
202		#' id = "plot_with_settings",
203		#' plot_r = plot_r,
204		#' height = c(400, 100, 1200),
205		#' brushing = TRUE,
206		#' clicking = TRUE,
207		#' dblclicking = TRUE,
208		#' hovering = TRUE
209		#' )
210		#'
211		#' output$brushing_data <- renderPrint(plot_data$brush())
212		#' output$clicking_data <- renderPrint(plot_data$click())
213		#' output$dblclicking_data <- renderPrint(plot_data$dblclick())
214		#' output$hovering_data <- renderPrint(plot_data$hover())
215		#' }
216		#'
217		#' if (interactive()) {
218		#' shinyApp(ui, server)
219		#' }
220		#'
221		#' # Example which allows module to be hidden/shown
222		#' library("shinyjs")
223		#'
224		#' ui <- bslib::page_fluid(
225		#' useShinyjs(),
226		#' actionButton("button", "Show/Hide"),
227		#' plot_with_settings_ui(
228		#' id = "plot_with_settings"
229		#' )
230		#' )
231		#'
232		#' server <- function(input, output, session) {
233		#' plot_r <- plot_r <- reactive(
234		#' ggplot(faithful, aes(x = .data$waiting, y = .data$eruptions)) +
235		#' geom_point()
236		#' )
237		#'
238		#' show_hide_signal_rv <- reactiveVal(TRUE)
239		#'
240		#' observeEvent(input$button, show_hide_signal_rv(!show_hide_signal_rv()))
241		#'
242		#' plot_with_settings_srv(
243		#' id = "plot_with_settings",
244		#' plot_r = plot_r,
245		#' height = c(400, 100, 1200),
246		#' width = c(500, 250, 750),
247		#' show_hide_signal = reactive(show_hide_signal_rv())
248		#' )
249		#' }
250		#'
251		#' if (interactive()) {
252		#' shinyApp(ui, server)
253		#' }
254		#'
255		plot_with_settings_srv <- function(id,
256		plot_r,
257		height = c(600, 200, 2000),
258		width = NULL,
259		show_hide_signal = reactive(TRUE),
260		brushing = FALSE,
261		clicking = FALSE,
262		dblclicking = FALSE,
263		hovering = FALSE,
264		graph_align = "left") {
265	16x	checkmate::assert_string(id)
266	16x	checkmate::assert(
267	16x	checkmate::check_class(plot_r, "function"),
268	16x	checkmate::check_class(plot_r, "reactive")
269		)
270	15x	checkmate::assert_numeric(height, min.len = 1, any.missing = FALSE)
271	14x	checkmate::assert_numeric(height, len = 3, any.missing = FALSE, finite = TRUE)
272	14x	checkmate::assert_numeric(height[1], lower = height[2], upper = height[3], .var.name = "height")
273	14x	checkmate::assert_numeric(width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
274	14x	checkmate::assert_numeric(width[1], lower = width[2], upper = width[3], null.ok = TRUE, .var.name = "width")
275
276	13x	checkmate::assert_class(show_hide_signal, c("reactive", "function"))
277	12x	checkmate::assert_flag(brushing)
278	11x	checkmate::assert_flag(clicking)
279	10x	checkmate::assert_flag(dblclicking)
280	9x	checkmate::assert_flag(hovering)
281	8x	checkmate::assert_string(graph_align)
282	8x	checkmate::assert_subset(graph_align, c("left", "right", "center", "justify"))
283
284	7x	moduleServer(id, function(input, output, session) {
285	7x	ns <- session$ns
286	7x	shinyjs::runjs(
287	7x	sprintf(
288	7x	'establishPlotResizing("%s", "%s");',
289	7x	ns("plot-out-main"), # graph parent id
290	7x	ns("flex_width") # session input$ variable name
291		)
292		)
293	7x	default_w <- function() session$clientData[[paste0("output_", ns("plot_main_width"))]]
294	7x	default_h <- function() session$clientData[[paste0("output_", ns("plot_main_height"))]]
295
296	7x	default_slider_width <- reactiveVal(width)
297	7x	delayed_flex_width <- debounce(reactive(input$flex_width), millis = 100)
298
299	7x	if (is.null(width)) {
300		# if width = NULL then set default_slider_width to be the value of the plot width on load
301	!	observeEvent(session$clientData[[paste0("output_", ns("plot_main_width"))]],
302	!	handlerExpr = {
303	!	default_slider_width(default_w() * c(1, 0.5, 2.8))
304		},
305	!	once = TRUE,
306	!	ignoreNULL = TRUE
307		)
308		}
309
310	7x	plot_type <- reactive({
311	7x	if (inherits(plot_r(), "ggplot")) {
312	1x	"gg"
313	6x	} else if (inherits(plot_r(), "trellis")) {
314	1x	"trel"
315	5x	} else if (inherits(plot_r(), "grob")) {
316	1x	"grob"
317	4x	} else if (inherits(plot_r(), c("NULL", "histogram", "list")) && !inherits(plot_r, "reactive")) {
318	3x	"base"
319		} else {
320	1x	"other"
321		}
322		})
323
324		# allow modules which use this module to turn on and off the UI
325	7x	observeEvent(show_hide_signal(), {
326	7x	if (show_hide_signal()) {
327	7x	shinyjs::show("plot-with-settings")
328		} else {
329	!	shinyjs::hide("plot-with-settings")
330		}
331		})
332
333	7x	output$slider_ui <- renderUI({
334	7x	req(default_slider_width())
335	7x	tags$div(
336	7x	optionalSliderInputValMinMax(
337	7x	inputId = ns("height"),
338	7x	label = "Plot height",
339	7x	value_min_max = round(height),
340	7x	ticks = FALSE,
341	7x	step = 1L,
342	7x	round = TRUE
343		),
344	7x	tags$b("Plot width"),
345	7x	bslib::input_switch(
346	7x	id = ns("width_resize_switch"),
347	7x	label = "Automatic",
348	7x	value = `if`(is.null(width), TRUE, FALSE)
349		),
350	7x	optionalSliderInputValMinMax(
351	7x	inputId = ns("width"),
352	7x	label = NULL,
353	7x	value_min_max = round(isolate(default_slider_width())),
354	7x	ticks = FALSE,
355	7x	step = 1L,
356	7x	round = TRUE
357		)
358		)
359		})
360
361	7x	observeEvent(input$width_resize_switch \| delayed_flex_width(), {
362	7x	if (!isFALSE(input$width_resize_switch)) {
363	7x	shinyjs::disable("width")
364	7x	updateSliderInput(session, inputId = "width", value = delayed_flex_width())
365		} else {
366	!	shinyjs::enable("width")
367		}
368		})
369
370	7x	ranges <- reactiveValues(x = NULL, y = NULL)
371
372	7x	observeEvent(input$plot_dblclick, {
373	1x	brush <- input$plot_brush
374	1x	if (!is.null(brush)) {
375	!	ranges$x <- c(brush$xmin, brush$xmax)
376	!	ranges$y <- c(brush$ymin, brush$ymax)
377		} else {
378	1x	ranges$x <- NULL
379	1x	ranges$y <- NULL
380		}
381		})
382
383	7x	p_height <- reactive(if (!is.null(input$height)) input$height else height[1])
384	7x	p_width <- reactive(
385	7x	if (!is.null(input$width)) {
386	5x	input$width
387		} else {
388	2x	if (!is.null(default_slider_width()[1])) {
389	2x	default_slider_width()[1]
390		} else {
391		# Fallback to "auto"
392	!	"auto"
393		}
394		}
395		)
396	7x	output$plot_main <- renderPlot(
397	7x	apply_plot_modifications(
398	7x	plot_obj = plot_r(),
399	7x	plot_type = plot_type(),
400	7x	dblclicking = dblclicking,
401	7x	ranges = ranges
402		),
403	7x	res = get_plot_dpi(),
404	7x	height = p_height,
405	7x	width = p_width
406		)
407
408	7x	output$plot_out_main <- renderUI({
409	7x	req(plot_r())
410	4x	tags$div(
411	4x	align = graph_align,
412	4x	plotOutput(
413	4x	ns("plot_main"),
414	4x	height = "100%",
415	4x	width = p_width(),
416	4x	brush = `if`(brushing, brushOpts(ns("plot_brush"), resetOnNew = FALSE), NULL),
417	4x	click = `if`(clicking, clickOpts(ns("plot_click")), NULL),
418	4x	dblclick = `if`(dblclicking, dblclickOpts(ns("plot_dblclick")), NULL),
419	4x	hover = `if`(hovering, hoverOpts(ns("plot_hover")), NULL)
420		)
421		)
422		})
423
424	7x	output$width_warning <- renderUI({
425	7x	grDevices::pdf(nullfile()) # reset Rplots.pdf for shiny server
426	7x	w <- grDevices::dev.size("px")[1]
427	7x	grDevices::dev.off()
428	7x	if (p_width() < w) {
429	7x	helpText(
430	7x	icon("triangle-exclamation"),
431	7x	"Plot might be cut off for small widths."
432		)
433		}
434		})
435
436	7x	type_download_srv(
437	7x	id = "downbutton",
438	7x	plot_reactive = plot_r,
439	7x	plot_type = plot_type,
440	7x	plot_w = p_width,
441	7x	default_w = default_w,
442	7x	plot_h = p_height,
443	7x	default_h = default_h
444		)
445
446	7x	list(
447	7x	brush = reactive({
448		# refresh brush data on the main plot size change
449	1x	input$height
450	1x	input$width
451	1x	input$plot_brush
452		}),
453	7x	click = reactive({
454		# refresh click data on the main plot size change
455	1x	input$height
456	1x	input$width
457	1x	input$plot_click
458		}),
459	7x	dblclick = reactive({
460		# refresh double click data on the main plot size change
461	1x	input$height
462	1x	input$width
463	1x	input$plot_dblclick
464		}),
465	7x	hover = reactive({
466		# refresh hover data on the main plot size change
467	1x	input$height
468	1x	input$width
469	1x	input$plot_hover
470		}),
471	7x	dim = reactive(c(p_width(), p_height()))
472		)
473		})
474		}
475
476		#' @keywords internal
477		type_download_ui <- function(id) {
478	2x	ns <- NS(id)
479	2x	bslib::popover(
480	2x	icon("download"),
481	2x	tags$div(
482	2x	radioButtons(ns("file_format"),
483	2x	label = "File type",
484	2x	choices = c("png" = "png", "pdf" = "pdf", "svg" = "svg"),
485		),
486	2x	textInput(ns("file_name"),
487	2x	label = "File name (without extension)",
488	2x	value = paste0("plot_", strftime(Sys.time(), format = "%Y%m%d_%H%M%S"))
489		),
490	2x	uiOutput(ns("file_name_warning")),
491	2x	conditionalPanel(
492	2x	condition = paste0("input['", ns("file_name"), "'] != ''"),
493	2x	downloadButton(ns("data_download"), label = character(0), class = "btn-sm w-full")
494		)
495		)
496		)
497		}
498
499		#' @keywords internal
500		type_download_srv <- function(id, plot_reactive, plot_type, plot_w, default_w, plot_h, default_h) {
501	12x	moduleServer(
502	12x	id,
503	12x	function(input, output, session) {
504	12x	file_name_valid <- file_name_validation_srv(input, output)
505
506	12x	output$data_download <- downloadHandler(
507	12x	filename = function() {
508	19x	paste(input$file_name, input$file_format, sep = ".")
509		},
510	12x	content = function(file) {
511	19x	width <- `if`(!is.null(plot_w()), plot_w(), default_w())
512	19x	height <- `if`(!is.null(plot_h()), plot_h(), default_h())
513
514		# svg and pdf have width in inches and 1 inch = get_plot_dpi() pixels
515	19x	switch(input$file_format,
516	11x	png = grDevices::png(file, width, height),
517	4x	pdf = grDevices::pdf(file, width / get_plot_dpi(), height / get_plot_dpi()),
518	4x	svg = grDevices::svg(file, width / get_plot_dpi(), height / get_plot_dpi())
519		)
520
521	19x	print_plot(plot_reactive, plot_type)
522
523	19x	grDevices::dev.off()
524		}
525		)
526		}
527		)
528		}
529
530		#' Clean brushed points
531		#'
532		#' @description
533		#' Cleans and organizes output to account for NAs and remove empty rows. Wrapper around `shiny::brushedPoints`.
534		#' @param data (`data.frame`)\cr
535		#' A data.frame from which to select rows.
536		#' @param brush (`list`)\cr
537		#' The data from a brush e.g. `input$plot_brush`.
538		#'
539		#' @return A `data.frame` of selected rows.
540		#'
541		#' @examples
542		#'
543		#' brush <- list(
544		#' mapping = list(
545		#' x = "AGE",
546		#' y = "BMRKR1"
547		#' ),
548		#' xmin = 30, xmax = 40,
549		#' ymin = 0.7, ymax = 10,
550		#' direction = "xy"
551		#' )
552		#'
553		#' data <- data.frame(
554		#' STUDYID = letters[1:20],
555		#' USUBJID = LETTERS[1:20],
556		#' AGE = sample(25:40, size = 20, replace = TRUE),
557		#' BMRKR1 = runif(20, min = 0, max = 12)
558		#' )
559		#' nrow(clean_brushedPoints(data, brush))
560		#' data$AGE[1:10] <- NA
561		#' nrow(clean_brushedPoints(data, brush))
562		#'
563		#' @export
564		#'
565		clean_brushedPoints <- function(data, brush) { # nolint object_name_linter.
566	6x	checkmate::assert_data_frame(data)
567	4x	checkmate::assert_list(brush, null.ok = TRUE)
568
569		# define original panelvar1 and panelvar2 before getting overwritten
570	4x	original_panelvar1 <- brush$mapping$panelvar1
571	4x	original_panelvar2 <- brush$mapping$panelvar2
572
573		# Assign NULL to `mapping$panelvar1` and `mapping$panelvar1` if `brush$panelvar1` and `brush$panelvar1` are NULL
574		# This will not evaluate the `panelMatch` step in `brushedPoints` and thus will return a non empty dataframe
575	4x	if (is.null(brush$panelvar1)) brush$mapping$panelvar1 <- NULL
576	4x	if (is.null(brush$panelvar2)) brush$mapping$panelvar2 <- NULL
577
578	4x	bp_df <- brushedPoints(data, brush)
579
580		# Keep required rows only based on the value of `brush$panelvar1`
581	3x	df <- if (is.null(brush$panelvar1) && is.character(original_panelvar1) &&
582	3x	is.null(brush$panelvar2) && is.character(original_panelvar2)) {
583	!	df_var1 <- bp_df[is.na(bp_df[[original_panelvar1]]), ]
584	!	df_var1[is.na(df_var1[[original_panelvar2]]), ]
585	3x	} else if (is.null(brush$panelvar1) && is.character(original_panelvar1)) {
586	!	bp_df[is.na(bp_df[[original_panelvar1]]), ]
587	3x	} else if (is.null(brush$panelvar2) && is.character(original_panelvar2)) {
588	!	bp_df[is.na(bp_df[[original_panelvar2]]), ]
589		} else {
590	3x	bp_df
591		}
592
593		# filter out rows that are only NAs
594	3x	df <- df[rowSums(is.na(df)) != ncol(df), ]
595	3x	df
596		}
597
598		#' @keywords internal
599		#'
600		get_plot_dpi <- function() {
601	32x	default_dpi <- 72
602	32x	dpi <- getOption("teal.plot_dpi", default_dpi)
603	32x	if (!checkmate::test_integerish(dpi, lower = 24, any.missing = FALSE, len = 1)) {
604	4x	warning(paste("Invalid value for option 'teal.plot_dpi', therefore defaulting to", default_dpi, "dpi"))
605	4x	dpi <- default_dpi
606		}
607	32x	dpi
608		}
609
610		#' Print plot for download functionality
611		#'
612		#' @param plot (`reactive`)\cr
613		#' reactive expression to draw a plot
614		#' @param plot_type (`reactive`)\cr
615		#' reactive plot type (`gg`, `trel`, `grob`, `other`)
616		#'
617		#' @return Nothing returned, the plot is printed.
618		#' @keywords internal
619		#'
620		print_plot <- function(plot, plot_type) {
621	25x	switch(plot_type(),
622	2x	"grob" = grid::grid.draw(plot()),
623		"other" = {
624	2x	graphics::plot.new()
625	2x	graphics::text(
626	2x	x = graphics::grconvertX(0.5, from = "npc"),
627	2x	y = graphics::grconvertY(0.5, from = "npc"),
628	2x	labels = "This plot graphic type is not yet supported to download"
629		)
630		},
631	17x	"base" = plot(),
632	4x	print(plot())
633		)
634		}

1		#' @keywords internal
2		#' @noRd
3		table_with_settings_deps <- function() {
4	1x	htmltools::htmlDependency(
5	1x	name = "teal-widgets-table-with-settings",
6	1x	version = utils::packageVersion("teal.widgets"),
7	1x	package = "teal.widgets",
8	1x	src = "table-with-settings",
9	1x	stylesheet = "table-with-settings.css"
10		)
11		}
12
13		render_table_to_html_rtables <- function(x, ...) {
14	6x	rtables::as_html(x)
15		}
16
17		file_download_format <- function(x, filename) {
18	35x	UseMethod("file_download_format", x)
19		}
20
21		#' @method file_download_format default
22		#' @keywords internal
23		#' @exportS3Method
24		file_download_format.default <- function(x, filename) {
25	29x	filename
26		}
27
28		#' @method file_download_format tbl_split
29		#' @keywords internal
30		#' @exportS3Method
31		file_download_format.tbl_split <- function(x, filename) {
32	6x	new_filename <- tools::file_path_sans_ext(filename)
33	6x	paste0(new_filename, ".zip")
34		}
35
36		#' Render table object to HTML
37		#'
38		#' @param x The table object to render
39		#' @param ... Additional arguments (currently unused)
40		#' @return HTML representation of the table
41		#' @keywords internal
42		#' @noRd
43		render_table_to_html <- function(x, ...) {
44	24x	UseMethod("render_table_to_html", x)
45		}
46
47		#' @method render_table_to_html default
48		#' @keywords internal
49		#' @exportS3Method
50		render_table_to_html.default <- function(x, ...) {
51	2x	stop(
52	2x	"Unsupported table type. ",
53	2x	"table_with_settings supports rtables (ElementaryTable, TableTree), ",
54	2x	"gtsummary, or gt (gt_tbl) objects."
55		)
56		}
57
58		#' @method render_table_to_html ElementaryTable
59		#' @keywords internal
60		#' @exportS3Method
61		render_table_to_html.ElementaryTable <- render_table_to_html_rtables
62
63		#' @method render_table_to_html TableTree
64		#' @keywords internal
65		#' @exportS3Method
66		render_table_to_html.TableTree <- render_table_to_html_rtables
67
68		#' @method render_table_to_html gtsummary
69		#' @keywords internal
70		#' @exportS3Method
71		render_table_to_html.gtsummary <- function(x, ...) {
72	6x	gt_obj <- gtsummary::as_gt(x)
73	6x	render_table_to_html(gt_obj)
74		}
75
76		#' @method render_table_to_html gt_tbl
77		#' @keywords internal
78		#' @exportS3Method
79		render_table_to_html.gt_tbl <- function(x, ...) {
80	8x	htmltools::HTML(gt::as_raw_html(x))
81		}
82
83		#' @method render_table_to_html tbl_split
84		#' @keywords internal
85		#' @exportS3Method
86		render_table_to_html.tbl_split <- function(x, ...) {
87	2x	tables <- lapply(seq_along(x), function(tbl) {
88	4x	label <- attr(x[[tbl]], "variable_level", exact = TRUE)
89	4x	htmltools::tags$div(
90	4x	if (checkmate::test_string(label)) htmltools::tags$h4("Variable level:", label),
91	4x	render_table_to_html(x[[tbl]])
92		)
93		})
94	2x	htmltools::tags$div(tables)
95		}
96
97		#' Export table object to file
98		#'
99		#' @param x The table object to export
100		#' @param file The file path to write to
101		#' @param format The file format (".txt", ".csv", or ".pdf")
102		#' @param paginate Logical indicating whether to paginate (for rtables)
103		#' @param lpp Lines per page for pagination (for rtables)
104		#' @param ... Additional arguments (currently unused)
105		#' @keywords internal
106		#' @noRd
107		export_table <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
108	65x	UseMethod("export_table", x)
109		}
110
111		#' @method export_table default
112		#' @keywords internal
113		#' @exportS3Method
114		export_table.default <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
115	1x	stop("Unsupported table type for download")
116		}
117
118		export_table_rtables <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
119	22x	if (format == ".txt") {
120	8x	rtables::export_as_txt(
121	8x	x = x,
122	8x	file = file,
123	8x	paginate = paginate,
124	8x	lpp = if (paginate) as.numeric(lpp)
125		)
126	14x	} else if (format == ".csv") {
127	7x	result <- rtables::matrix_form(x)$strings
128	7x	utils::write.table(
129	7x	x = result,
130	7x	file = file,
131	7x	sep = ",",
132	7x	col.names = FALSE,
133	7x	row.names = TRUE,
134	7x	append = FALSE
135		)
136		} else {
137	7x	rtables::export_as_pdf(
138	7x	x = x,
139	7x	file = file,
140	7x	paginate = paginate,
141	7x	lpp = if (paginate) as.numeric(lpp)
142		)
143		}
144		}
145
146		#' @method export_table ElementaryTable
147		#' @keywords internal
148		#' @exportS3Method
149		export_table.ElementaryTable <- export_table_rtables
150
151		#' @method export_table TableTree
152		#' @keywords internal
153		#' @exportS3Method
154		export_table.TableTree <- export_table_rtables
155
156		#' @method export_table gtsummary
157		#' @keywords internal
158		#' @exportS3Method
159		export_table.gtsummary <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
160	18x	gt_obj <- gtsummary::as_gt(x)
161	18x	export_table(gt_obj, file, format, paginate, lpp, ...)
162		}
163
164		#' @method export_table gt_tbl
165		#' @keywords internal
166		#' @exportS3Method
167		export_table.gt_tbl <- function(x, file, format, paginate = FALSE, lpp = NULL, ...) {
168	18x	if (format == ".csv") {
169	6x	utils::write.csv(export_table_raw(x), file = file, row.names = FALSE)
170	12x	} else if (format == ".pdf") {
171	6x	gt::gtsave(x, filename = file)
172		} else {
173	6x	utils::write.table(
174	6x	x = export_table_raw(x),
175	6x	file = file,
176	6x	sep = "\t",
177	6x	quote = FALSE,
178	6x	row.names = FALSE,
179	6x	col.names = TRUE
180		)
181		}
182		}
183
184		#' @method export_table tbl_split
185		#' @keywords internal
186		#' @exportS3Method
187		export_table.tbl_split <- function(x, file, format, paginate = FALSE, lpp = NULL, file_name = file, ...) {
188	6x	ext <- format # ".pdf" or ".txt"
189	6x	tmp_dir <- tempfile()
190	6x	dir.create(tmp_dir)
191	6x	on.exit(unlink(tmp_dir, recursive = TRUE))
192
193	6x	base_name <- tools::file_path_sans_ext(basename(file_name))
194
195	6x	tmp_files <- lapply(seq_along(x), function(i) {
196	12x	label <- as.vector(attr(x[[i]], "variable_level", exact = TRUE))
197	12x	if (checkmate::test_string(label)) {
198	!	base_name <- paste0(base_name, "_", gsub("[^[:alnum:]]", "_", label), "_", i)
199		} else {
200	12x	base_name <- paste0(base_name, "_", i)
201		}
202	12x	tmp_file <- file.path(tmp_dir, paste0(base_name, ext))
203	12x	export_table(x[[i]], file = tmp_file, format = format, paginate = paginate, lpp = lpp, ...)
204	12x	tmp_file
205		})
206
207	6x	utils::zip(zipfile = file, files = unlist(tmp_files), flags = "-j") # -j: junk paths
208		}
209
210		export_table_raw <- function(x) {
211	12x	html_content <- gt::as_raw_html(x)
212	12x	html_parsed <- rvest::read_html(html_content)
213
214		# xml_remove modifies the object so no need to ovewrite
215	12x	xml2::xml_remove(rvest::html_nodes(html_parsed, "caption, .gt_heading"))
216
217	12x	tbl <- rvest::html_table(html_parsed, fill = TRUE)[[1]]
218	12x	names(tbl) <- gsub("[\n\r\t]", " ", names(tbl))
219	12x	tbl
220		}
221
222		#' @name table_with_settings
223		#'
224		#' @title `table_with_settings` module
225		#'
226		#' @description
227		#' Module designed to create a `shiny` table output based on table objects.
228		#' Supports `rtables` objects (`ElementaryTable` or `TableTree`), `gtsummary` objects, or `gt` objects.
229		#' @inheritParams shiny::moduleServer
230		#' @param ... (`character`)\cr
231		#' Useful for providing additional HTML classes for the output tag.
232		#'
233		#' @note The download of [gt::gt()] and [gtsummary::tbl_summary()] tables as PDF requires the `webshot2` package
234		#' to be installed.
235		#' A once a session warning is displayed if the package is not installed when calling `table_with_settings` with
236		#' a reactive table in one of those formats.
237		#'
238		#' @rdname table_with_settings
239		#' @export
240		#'
241		table_with_settings_ui <- function(id, ...) {
242	1x	checkmate::assert_string(id)
243
244	1x	ns <- NS(id)
245
246	1x	tags$div(
247	1x	table_with_settings_deps(),
248	1x	shinyjs::useShinyjs(),
249	1x	bslib::card(
250	1x	id = ns("table-with-settings"),
251	1x	full_screen = TRUE,
252	1x	tags$div(
253	1x	class = "teal-widgets settings-buttons",
254	1x	bslib::tooltip(
255	1x	trigger = tags$div(type_download_ui_table(ns("downbutton"))),
256	1x	options = list(trigger = "hover"),
257	1x	class = "download-button",
258	1x	"Download"
259		)
260		),
261	1x	tags$div(
262	1x	class = "teal-widgets table-content",
263	1x	uiOutput(ns("table_out_main"), width = "100%", ...)
264		)
265		)
266		)
267		}
268
269		#' @inheritParams shiny::moduleServer
270		#' @param table_r (`reactive`)\cr
271		#' reactive expression that yields a table object. Supported types:
272		#' - `rtables` objects (`ElementaryTable` or `TableTree`)
273		#' - `gtsummary` objects
274		#' - `gt` objects (`gt_tbl`)
275		#' @param show_hide_signal (`reactive logical`) optional\cr
276		#' mechanism to allow modules which call this module to show/hide the table_with_settings UI.
277		#'
278		#' @rdname table_with_settings
279		#'
280		#' @return A `shiny` module.
281		#'
282		#' @export
283		#'
284		#' @examples
285		#' library(shiny)
286		#' library(rtables)
287		#' library(gtsummary)
288		#' library(gt)
289		#' library(magrittr)
290		#'
291		#' ui <- bslib::page_fluid(
292		#' table_with_settings_ui(id = "rtables_table"),
293		#' table_with_settings_ui(id = "gtsummary_table"),
294		#' table_with_settings_ui(id = "gt_table")
295		#' )
296		#'
297		#' server <- function(input, output, session) {
298		#' table_r_rtables <- reactive({
299		#' l <- basic_table() %>%
300		#' split_cols_by("ARM") %>%
301		#' analyze(c("SEX", "AGE"))
302		#' build_table(l, DM)
303		#' })
304		#'
305		#' table_r_gtsummary <- reactive({
306		#' gtsummary::tbl_summary(mtcars)
307		#' })
308		#'
309		#' table_r_gt <- reactive({
310		#' mtcars %>%
311		#' gt::gt() %>%
312		#' gt::tab_header(title = "Motor Trend Car Road Tests")
313		#' })
314		#'
315		#' table_with_settings_srv(id = "rtables_table", table_r = table_r_rtables)
316		#' table_with_settings_srv(id = "gtsummary_table", table_r = table_r_gtsummary)
317		#' table_with_settings_srv(id = "gt_table", table_r = table_r_gt)
318		#' }
319		#'
320		#' if (interactive()) {
321		#' shinyApp(ui, server)
322		#' }
323		#'
324		table_with_settings_srv <- function(id, table_r, show_hide_signal = reactive(TRUE)) {
325	9x	checkmate::assert_class(table_r, c("reactive", "function"))
326	8x	checkmate::assert_class(show_hide_signal, c("reactive", "function"))
327
328	7x	moduleServer(id, function(input, output, session) {
329	7x	ns <- session$ns
330		# Turn on and off the UI
331	7x	observeEvent(show_hide_signal(), {
332	7x	if (show_hide_signal()) {
333	6x	shinyjs::show("table-with-settings")
334		} else {
335	1x	shinyjs::hide("table-with-settings")
336		}
337		})
338
339	7x	output$table_out_main <- output$table_out_modal <- renderUI({
340	14x	.warning_gt_webshot2(table_r())
341	14x	render_table_to_html(table_r())
342		})
343
344	7x	type_download_srv_table(
345	7x	id = "downbutton",
346	7x	table_reactive = table_r
347		)
348		})
349		}
350
351		type_download_ui_table <- function(id) {
352	1x	ns <- NS(id)
353	1x	bslib::popover(
354	1x	icon("download"),
355	1x	tags$div(
356	1x	radioButtons(
357	1x	ns("file_format"),
358	1x	label = tags$span("File type", shinyjs::hidden(
359	1x	tags$div(
360	1x	id = ns("pdf_warning"),
361	1x	style = c(
362	1x	"cursor: help;", "color: var(--bs-gray-600);", "margin-bottom: 0.5rem;",
363	1x	"font-size: 0.875rem;", "padding-left: 0.1rem;"
364		),
365	1x	icon("circle-info"),
366	1x	title = "Contact app support to enable PDF download by installing the `webshot2` package.",
367	1x	"PDF download is disabled."
368		)
369		)),
370	1x	choices = c("formatted txt" = ".txt", "csv" = ".csv", "pdf" = ".pdf")
371		),
372	1x	textInput(ns("file_name"),
373	1x	label = "File name (without extension)",
374	1x	value = paste0("table_", strftime(Sys.time(), format = "%Y%m%d_%H%M%S"))
375		),
376	1x	uiOutput(ns("file_name_warning")),
377	1x	conditionalPanel(
378	1x	condition = paste0("input['", ns("file_format"), "'] != '.csv'"),
379	1x	tags$div(
380	1x	class = "lock-btn",
381	1x	title = "on / off",
382	1x	shinyWidgets::prettyToggle(
383	1x	ns("pagination_switch"),
384	1x	value = FALSE,
385	1x	label_on = NULL,
386	1x	label_off = NULL,
387	1x	status_on = "default",
388	1x	status_off = "default",
389	1x	outline = FALSE,
390	1x	plain = TRUE,
391	1x	icon_on = icon("fas fa-toggle-off"),
392	1x	icon_off = icon("fas fa-toggle-on"),
393	1x	animation = "pulse"
394		)
395		),
396	1x	tags$div(
397	1x	class = "paginate-ui",
398	1x	shinyWidgets::numericInputIcon(
399	1x	inputId = ns("lpp"),
400	1x	label = "Paginate table:",
401	1x	value = 70,
402	1x	icon = list("lines / page")
403		),
404	1x	uiOutput(ns("lpp_warning"))
405		)
406		),
407	1x	conditionalPanel(
408	1x	condition = paste0("input['", ns("file_name"), "'] != ''"),
409	1x	downloadButton(ns("data_download"), label = character(0), class = "btn-sm w-full")
410		)
411		)
412		)
413		}
414
415		type_download_srv_table <- function(id, table_reactive) {
416	19x	moduleServer(
417	19x	id,
418	19x	function(input, output, session) {
419	19x	observeEvent(table_reactive(), {
420	19x	if (
421	19x	checkmate::test_multi_class(table_reactive(), c("gt_tbl", "tbl_split", "tbl_summary")) &&
422	19x	!requireNamespace("webshot2", quietly = TRUE)
423		) {
424	!	updateRadioButtons(
425	!	inputId = "file_format",
426	!	choices = list("formatted txt" = ".txt", "csv" = ".csv")
427		)
428	!	shinyjs::show("pdf_warning")
429		}
430		})
431	19x	observeEvent(input$pagination_switch, {
432	20x	if (input$pagination_switch) {
433	7x	shinyjs::enable("lpp")
434		} else {
435	13x	shinyjs::disable("lpp")
436		}
437		})
438
439	19x	file_name_valid <- file_name_validation_srv(input, output)
440
441	19x	output$lpp_warning <- renderUI({
442	38x	table_obj <- table_reactive()
443		# Pagination warning only applies to rtables
444	19x	if (
445	38x	inherits(table_obj, c("ElementaryTable", "TableTree")) &&
446	38x	input$file_format != ".csv" &&
447	38x	input$pagination_switch
448		) {
449	9x	catch_warning <- try(rtables::paginate_table(
450	9x	tt = table_obj,
451	9x	lpp = as.numeric(input$lpp)
452	9x	), silent = TRUE)
453
454	9x	if (inherits(catch_warning, "try-error")) {
455	4x	helpText(
456	4x	class = "error",
457	4x	icon("triangle-exclamation"),
458	4x	paste0(
459	4x	"Maximum lines per page includes the reprinted header.",
460	4x	"Please enter a numeric value or increase the value."
461		)
462		)
463		}
464		}
465		})
466
467	19x	output$data_download <- downloadHandler(
468	19x	filename = function() {
469	35x	file_download_format(table_reactive(), paste0(input$file_name, input$file_format))
470		},
471	19x	content = function(file) {
472	35x	export_table(
473	35x	x = table_reactive(),
474	35x	file = file,
475	35x	format = input$file_format,
476	35x	paginate = input$pagination_switch,
477	35x	lpp = if (input$pagination_switch) as.numeric(input$lpp),
478	35x	file_name = input$file_name
479		)
480		}
481		)
482		}
483		)
484		}

1		#' Panel group widget
2		#'
3		#' @description `r lifecycle::badge("deprecated")`\cr
4		#' Designed to group [`panel_item`] elements. Used to handle `shiny` inputs in the encoding panel.
5		#' @param id optional, (`character`)\cr
6		#' @param ... (`shiny.tag`)\cr
7		#' panels created by [panel_group()]
8		#'
9		#' @return (`shiny.tag`)
10		#'
11		#' @examples
12		#'
13		#' library(shiny)
14		#' panel_group(
15		#' panel_item(
16		#' title = "Display",
17		#' collapsed = FALSE,
18		#' checkboxGroupInput(
19		#' "check",
20		#' "Tables display",
21		#' choices = LETTERS[1:3],
22		#' selected = LETTERS[1]
23		#' ),
24		#' radioButtons(
25		#' "radio",
26		#' label = "Plot type",
27		#' choices = letters[1:2],
28		#' selected = letters[1]
29		#' )
30		#' ),
31		#' panel_item(
32		#' title = "Pre-processing",
33		#' radioButtons(
34		#' "filtering",
35		#' "What to filter",
36		#' choices = LETTERS[1:4],
37		#' selected = LETTERS[1]
38		#' ),
39		#' radioButtons(
40		#' "na_action",
41		#' "NA action",
42		#' choices = letters[1:3],
43		#' selected = letters[1]
44		#' )
45		#' )
46		#' )
47		#'
48		#' @export
49		panel_group <- function(..., id = NULL) {
50	3x	lifecycle::deprecate_soft(
51	3x	when = "0.4.3",
52	3x	what = "panel_group()",
53	3x	details = paste(
54	3x	"The `panel_group()` and `panel_item()` view can be achieved by using the `bslib` package.",
55	3x	"Please use the `bslib::accordion()` and `bslib::accordion_panel()` functions instead.",
56	3x	"This function will be removed in the next release."
57		)
58		)
59	3x	checkmate::assert_string(id, null.ok = TRUE)
60
61		# panel-group
62		# div
63
64	3x	bslib::accordion(
65		...
66		)
67		}
68
69		#' @keywords internal
70		#' @noRd
71		panel_item_deps <- function() {
72	!	htmltools::htmlDependency(
73	!	name = "teal-widgets-panel-item",
74	!	version = utils::packageVersion("teal.widgets"),
75	!	package = "teal.widgets",
76	!	src = "panel-item",
77	!	script = "panel-item.js",
78	!	stylesheet = "panel-item.css"
79		)
80		}
81
82		#' Panel item widget
83		#'
84		#' @description `r lifecycle::badge("deprecated")`\cr
85		#' Designed to be grouped using [`panel_group`] element. Used to handle `shiny` inputs in the encoding panel.
86		#' @param title (`character`)\cr title of panel
87		#' @param ... content of panel
88		#' @param collapsed (`logical`) optional,\cr
89		#' whether to initially collapse panel
90		#' @param input_id (`character`) optional\cr
91		#' name of the panel item element. If supplied, this will register a shiny input variable that
92		#' indicates whether the panel item is open or collapsed and is accessed with `input$input_id`.
93		#'
94		#' @return (`shiny.tag`)
95		#'
96		#' @examples
97		#'
98		#' library(shiny)
99		#' panel_item(
100		#' title = "Display",
101		#' collapsed = FALSE,
102		#' checkboxGroupInput(
103		#' "check",
104		#' "Tables display",
105		#' choices = LETTERS[1:3],
106		#' selected = LETTERS[1]
107		#' ),
108		#' radioButtons(
109		#' "radio",
110		#' label = "Plot type",
111		#' choices = letters[1:2],
112		#' selected = letters[1]
113		#' )
114		#' )
115		#'
116		#' @export
117		panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
118	2x	lifecycle::deprecate_soft(
119	2x	when = "0.4.3",
120	2x	what = "panel_item()",
121	2x	details = paste(
122	2x	"The `panel_group()` and `panel_item()` view can be achieved by using the `bslib` package.",
123	2x	"Please use the `bslib::accordion()` and `bslib::accordion_panel()` functions instead.",
124	2x	"This function will be removed in the next release."
125		)
126		)
127	2x	stopifnot(checkmate::test_character(title, len = 1) \|\| inherits(title, c("shiny.tag", "shiny.tag.list", "html")))
128	2x	checkmate::assert_flag(collapsed)
129	2x	checkmate::assert_string(input_id, null.ok = TRUE)
130
131	2x	bslib::accordion_panel(
132	2x	id = input_id,
133	2x	title = title,
134	2x	open = !collapsed,
135		...
136		)
137		}

1		#' Builds a `basic_table_args` object
2		#'
3		#' @description
4		#' This function has to be used to build an input for a `basic_table_args` argument.
5		#' The `basic_table_args` argument should be a part of every module which contains any `rtables` object.
6		#' Arguments are validated to match their `rtables` equivalents.
7		#'
8		#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`.
9		#'
10		#' @seealso
11		#' * [resolve_basic_table_args()] to resolve multiple objects into one using pre-defined priorities.
12		#' * [parse_basic_table_args()] to parse resolved list into list of calls.
13		#'
14		#' @param ... arguments compatible with [rtables::basic_table()].
15		#'
16		#' @return (`basic_table_args`) object.
17		#' @export
18		#' @examples
19		#' basic_table_args(subtitles = "SUBTITLE")
20		basic_table_args <- function(...) {
21	118x	table_args_l <- list(...)
22	118x	checkmate::assert_character(names(table_args_l), unique = TRUE, null.ok = TRUE)
23
24	118x	basic_table_formals <- methods::formalArgs(rtables::basic_table)
25	118x	checkmate::assert_subset(names(table_args_l), choices = basic_table_formals, empty.ok = TRUE)
26
27	114x	structure(table_args_l, class = "basic_table_args")
28		}
29
30		#' Resolves and reduces multiple `basic_table_args` objects
31		#'
32		#' @description
33		#' Resolving and reducing multiple `basic_table_args` objects.
34		#' This function is intended to utilize user provided settings, defaults provided by the module creator and
35		#' also `teal` option. See `Details`, below, to understand the logic.
36		#'
37		#' @seealso [parse_basic_table_args()] to parse resolved list into list of calls.
38		#'
39		#' @param user_table (`basic_table_args`)\cr
40		#' end user setup for [rtables::basic_table()] of a specific table.
41		#' Created with the [basic_table_args()] function. The `NULL` value is supported.
42		#' @param user_default (`basic_table_args`)\cr
43		#' end user default setup for [rtables::basic_table()]
44		#' of a specific table. Created with the [basic_table_args()] function. The `NULL` value is supported.
45		#' @param module_table (`ggplot2_args`)\cr
46		#' module creator setup for [rtables::basic_table()] of a specific table.
47		#' Created with the [basic_table_args()] function. The `NULL` value is supported.
48		#' @param app_default (`basic_table_args`)\cr
49		#' Application level setting. Can be `NULL`.
50		#'
51		#' @return `basic_table_args` object.
52		#' @details
53		#' The function picks the first non `NULL` value for each argument, checking in the following order:
54		#' 1. `basic_table_args` argument provided by the end user.
55		#' Per table (`user_table`) and then default (`user_default`) setup.
56		#' 2. `app_default` global R variable, `teal.basic_table_args`.
57		#' 3. `module_table` which is a module creator setup.
58		#' @export
59		#' @examples
60		#' resolve_basic_table_args(
61		#' user_table = basic_table_args(title = "TITLE"),
62		#' user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE")
63		#' )
64		resolve_basic_table_args <- function(user_table = basic_table_args(),
65		user_default = basic_table_args(),
66		module_table = basic_table_args(),
67		app_default = getOption("teal.basic_table_args", basic_table_args())) {
68	24x	checkmate::assert_class(user_table, "basic_table_args", null.ok = TRUE)
69	23x	checkmate::assert_class(user_default, "basic_table_args", null.ok = TRUE)
70	23x	checkmate::assert_class(module_table, "basic_table_args", null.ok = TRUE)
71	23x	checkmate::assert_class(app_default, "basic_table_args", null.ok = TRUE)
72
73	23x	table_args_all <- list(
74	23x	"table" = user_table,
75	23x	"default" = user_default,
76	23x	"teal" = app_default,
77	23x	"module" = module_table
78		)
79
80	23x	table_args_f <- Reduce(`c`, table_args_all)
81
82	23x	if (length(table_args_f) == 0) {
83	9x	basic_table_args()
84		} else {
85	14x	do.call(basic_table_args, table_args_f[!duplicated(names(table_args_f))])
86		}
87		}
88
89		#' Parses `basic_table_args` object into the `basic_table` expression
90		#'
91		#' @description
92		#' A function to parse expression from the `basic_table_args` object.
93		#' @param basic_table_args (`basic_table_args`)\cr
94		#' This argument could be a result of the [`resolve_basic_table_args()`].
95		#'
96		#' @return (`language`) the `rtables::basic_table()` filled with additional arguments.
97		#' @export
98		#' @examples
99		#' parse_basic_table_args(
100		#' resolve_basic_table_args(
101		#' user_table = basic_table_args(title = "TITLE"),
102		#' user_default = basic_table_args(title = "DEFAULT_TITLE", subtitles = "SUBTITLE")
103		#' )
104		#' )
105		parse_basic_table_args <- function(basic_table_args = teal.widgets::basic_table_args()) {
106	8x	checkmate::assert_class(basic_table_args, "basic_table_args", null.ok = TRUE)
107
108	7x	if (length(basic_table_args) == 0) {
109	3x	quote(rtables::basic_table())
110		} else {
111	4x	as.call(c(list(quote(rtables::basic_table)), basic_table_args))
112		}
113		}

1		#' Nested Closeable Modal Popup
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#' Alternative to `shiny::modalDialog`. Create a nested modal popup that can be shown/hidden
5		#' using `jQuery` and modal `id`, without disturbing the parent modal.
6		#'
7		#' @param id (`character(1)`) `shiny` module id for the component.\cr
8		#' Note that this id can be used to show/hide this modal
9		#' with the appended `jQuery` methods show/hide.
10		#' @param ... (`shiny.tag`) `shiny` UI elements that will be displayed in the modal UI
11		#' @param modal_args (`list`) optional list of arguments for the `shiny::modalDialog` function
12		#' to customize the modal. Has `easyClose` set to `TRUE` as default
13		#'
14		#' @return (`shiny.tag`) returns `HTML` for `shiny` module UI which can be nested into a modal popup
15		#' @export
16		#'
17		#' @examples
18		#' library(shiny)
19		#' library(shinyjs)
20		#'
21		#' ui <- bslib::page_fluid(
22		#' useShinyjs(),
23		#' actionButton("show_1", "$(\"#modal_1\").modal(\"show\")"),
24		#' nested_closeable_modal(
25		#' "modal_1",
26		#' modal_args = list(
27		#' size = "l",
28		#' title = "First Modal",
29		#' easyClose = TRUE,
30		#' footer = NULL
31		#' ),
32		#' tags$div(
33		#' "This modal can be closed by running", tags$code("$(\"#modal_1\").modal(\"hide\")"),
34		#' "in the JS console!",
35		#' tags$br(),
36		#' "Note that the second modal is placed right within this modal",
37		#' tags$br(),
38		#' "Alternatively, calling the", tags$code("removeModal()"),
39		#' "will remove all the active modal popups",
40		#' tags$br(), tags$br(),
41		#' actionButton("show_2", "$(\"#modal_2\").modal(\"show\")"),
42		#' actionButton("hide_1", "$(\"#modal_1\").modal(\"hide\")"),
43		#' nested_closeable_modal(
44		#' id = "modal_2",
45		#' modal_args = list(
46		#' size = "m",
47		#' title = "Second Modal",
48		#' footer = NULL,
49		#' easyClose = TRUE
50		#' ),
51		#' tags$div(
52		#' "This modal can be closed by running", tags$code("$(\"#modal_1\").modal(\"hide\")"),
53		#' "in the JS console!",
54		#' "Note that removing the parent will remove the child.
55		#' But, reopening will remember the open state of child",
56		#' actionButton("hide_2", "$(\"#modal_2\").modal(\"hide\")"),
57		#' actionButton("hide_all", "$(\"#modal_1\").modal(\"hide\")")
58		#' )
59		#' )
60		#' )
61		#' )
62		#' )
63		#'
64		#' server <- function(input, output) {
65		#' observeEvent(input$show_1, {
66		#' runjs("$(\"#modal_1\").modal(\"show\")")
67		#' })
68		#' observeEvent(input$show_2, {
69		#' runjs("$(\"#modal_2\").modal(\"show\")")
70		#' })
71		#' observeEvent(c(input$hide_1, input$hide_all), {
72		#' runjs("$(\"#modal_1\").modal(\"hide\")")
73		#' })
74		#' observeEvent(input$hide_2, {
75		#' runjs("$(\"#modal_2\").modal(\"hide\")")
76		#' })
77		#' }
78		#'
79		#' if (interactive()) {
80		#' shinyApp(ui, server)
81		#' }
82		nested_closeable_modal <- function(id, ..., modal_args = list(easyClose = TRUE)) {
83	!	checkmate::assert_string(id)
84	!	checkmate::assert_list(modal_args)
85	!	lifecycle::deprecate_soft(
86	!	when = "0.5.0",
87	!	what = "nested_closeable_modal()"
88		)
89
90	!	modal_args <- append(list(...), modal_args)
91	!	tagList(
92	!	htmltools::tagQuery(do.call(modalDialog, modal_args))$
93	!	removeAttrs("id")$
94	!	addAttrs(id = id, `aria-hidden` = "true", class = "custom-modal", `data-backdrop` = "false")$
95	!	children("div")$
96	!	children("div")$
97	!	children("div")$
98	!	siblings(".modal-footer")$
99	!	find("button")$
100	!	removeAttrs(c("data-dismiss", "data-bs-dismiss"))$
101	!	addAttrs(onclick = paste0("$('#", id, "').modal('hide');"))$
102	!	allTags()
103		)
104		}

1		#' Small well class for HTML
2		#'
3		#' @description
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	2x	shiny::tagList(
20	2x	tags$div(
21	2x	class = "well well-sm",
22	2x	style = "background-color: white;",
23		...
24		)
25		)
26		}

1		#' Map `lenghtMenu` property
2		#'
3		#' @description
4		#' Maps the `lengthMenu` selected value property of `DT::datatable` to a `shiny` variable.
5		#' @param dt_name `ns()` of `inputId` of the `DT::datatable`
6		#' @param dt_rows `ns()` of `inputId` of the variable that holds the current selected value of `lengthMenu`
7		#'
8		#' @name get_dt_rows
9		#'
10		#' @return (`shiny::tagList`) A `shiny tagList`.
11		#'
12		#' @examplesIf requireNamespace("DT", quietly = TRUE)
13		#' library(shiny)
14		#' library(DT)
15		#'
16		#' ui <- function(id) {
17		#' ns <- NS(id)
18		#' tagList(
19		#' get_dt_rows(ns("data_table"), ns("dt_rows")),
20		#' textOutput(ns("rows")),
21		#' DT::DTOutput(ns("data_table"))
22		#' )
23		#' }
24		#'
25		#' # use the input$dt_rows in the Shiny Server function
26		#' server <- function(id) {
27		#' moduleServer(id, function(input, output, session) {
28		#' output$data_table <- DT::renderDataTable(iris)
29		#' # Change rows selected to see the first line on the UI change
30		#' rows <- reactive({
31		#' paste0("Selected Rows ", input$dt_rows)
32		#' })
33		#' output$rows <- renderText(rows())
34		#' })
35		#' }
36		#' if (interactive()) {
37		#' shinyApp(
38		#' ui = ui("my_table_module"),
39		#' server = function(input, output, session) server("my_table_module")
40		#' )
41		#' }
42		#' @export
43		get_dt_rows <- function(dt_name, dt_rows) {
44	1x	tags$head(
45	1x	tags$script(
46	1x	sprintf(
47	1x	"$(document).ready(function() {
48	1x	$('%s').on('length.dt', function(e, settings, len) {
49	1x	Shiny.setInputValue('%s', len);
50		});
51		});",
52	1x	paste0("#", dt_name),
53	1x	dt_rows
54		)
55		)
56		)
57		}