teal.widgets coverage - 62.17%

Files
Source

#' Hide, Show Label only or display a `pickerInput`
#'
#' @description `r lifecycle::badge("stable")`
#' 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 shinyWidgets::pickerInput
#' @param choices (`character`, `NULL`)\cr
#'   If `choices` is `NULL` no `pickerInput` widget is displayed and `input[[inputId]]`
#'   will be `""`. If `choices` is of length 1 then a label and character string will be
#'   displayed and the `pickerInput` widget will be hidden. If the length of `choices`
#'   is more than one the `pickerInput` element will be displayed.
#'   If elements of the list are named then that name rather than the value
#'   is displayed to the user.
#'
#' @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 width (`character(1)`)\cr
#'  The width of the input passed to `pickerInput`  e.g. `'auto'`, `'fit'`, `'100px'` or `'75%'`
#'
#' @export
#'
#' @examples
#' \dontrun{
#' optionalSelectInput(inputId = "xvar", label = "x variable", choices = "A", selected = "A")
#' optionalSelectInput(
#'   inputId = "xvar",
#'   label = "x variable",
#'   choices = LETTERS[1:5],
#'   selected = "A"
#' )
#' optionalSelectInput(
#'   inputId = "xvar",
#'   label = "x variable",
#'   choices = c("A - value A" = "A"),
#'   selected = "A"
#' )
#'
#' ADRS <- scda::synthetic_cdisc_data("latest")$adrs # nolint
#' optionalSelectInput(
#'   inputId = "xvar",
#'   label = "x variable",
#'   choices = teal.transform::variable_choices(data = ADRS, subset = c("AGE", "SEX", "PARAMCD")),
#'   selected = "PARAMCD"
#' )
#'
#' selected_value <- paste0(lapply(ADRS[1, c("PARAMCD", "AVISIT")], as.character), collapse = " - ")
#' optionalSelectInput(
#'   inputId = "xvar",
#'   label = "x variable",
#'   choices = teal.transform::value_choices(
#'     data = ADRS,
#'     var_choices = c("PARAMCD", "AVISIT"),
#'     var_label = c("PARAM", "AVISIT")
#'   ),
#'   selected = selected_value
#' )
#' }
optionalSelectInput <- function(inputId, # nolint
                                label = NULL,
                                choices = NULL,
                                selected = NULL,
                                multiple = FALSE,
                                sep = NULL,
                                options = list(),
                                label_help = NULL,
                                fixed = 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)
  stopifnot(is.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)

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

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

  # if called outside the fluidPage then will assume bs 3
  bs_version <- get_bs_version()
  if (isTRUE(bs_version != "3")) default_options[["style"]] <- "btn-outline-secondary"

  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
  }

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

  ui <- 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[[3]] <- append(ui[[3]], list(div(class = "label-help", label_help)), after = 1)
  }

  shiny::tagList(
    include_css_files(pattern = "picker_input"),
    if (is.null(choices)) {
      shinyjs::hidden(ui)
    } else {
      if (fixed) {
        div(
          shinyjs::hidden(ui),
          tags$label(id = paste0(inputId, "_textonly"), class = "control-label", sub(":[[:space:]]+$", "", label)),
          if (length(selected) > 0) {
            tags$code(
              id = paste0(inputId, "_valueonly"),
              paste(selected, collapse = ", ")
            )
          },
          label_help
        )
      } else {
        ui
      }
    }
  )
}

#' Update `optionalSelectInput`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams shinyWidgets::updatePickerInput
#'
#' @return `NULL`
#'
#' @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"))

  shinyWidgets::updatePickerInput(
    session = session,
    inputId = inputId,
    label = label,
    selected = as.character(raw_selected),
    choices = raw_choices,
    choicesOpt = picker_options(choices)
  )

  shinyjs::show(inputId)
  shinyjs::hide(paste0(inputId, "_textonly"))

  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
#'
#' @examples
#' teal.widgets:::variable_type_icons(c(
#'   "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt",
#'   "factor", "character", "unknown", ""
#' ))
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]]
      }
    }
  ))

  return(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
#'
#' @examples
#' teal.widgets:::picker_options_content(
#'   var_name = c("SEX", "BRMRKR1"),
#'   var_label = c("Sex", "Biomarker 1"),
#'   var_type = c("factor", "numeric")
#' )
picker_options_content <- function(var_name, var_label, var_type) {
  if (length(var_name) == 0) {
    return(character(0))
  }
  if (length(var_type) == 0 && length(var_label) == 0) {
    return(var_name)
  }
  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)
    )
  ))

  return(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"))
    return(
      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))
    return(
      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 {
    return(NULL)
  }
}

#' 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
  }
}

#' if min or max are `NA` then the slider widget will be hidden
#'
#' @description `r lifecycle::badge("stable")`
#' 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
#'  an object of class `shiny.tag`. E.g. an object returned by [shiny::helpText()]
#' @param ... optional arguments to `sliderInput`
#'
#' @export
#'
#' @examples
#' optionalSliderInput("a", "b", 0, 1, 0.2)
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(div(class = "label-help", label_help)), after = 1)
  }

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

#' For teal modules we parameterize an \code{optionalSliderInput} with one argument
#' \code{value_min_max}
#'
#' @description `r lifecycle::badge("stable")`
#' The [optionalSliderInput()] function needs three arguments to decided
#' 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.
#'
#' @export
#'
#' @examples
#'
#' optionalSliderInputValMinMax("a", "b", 1)
#' optionalSliderInputValMinMax("a", "b", c(3, 1, 5))
optionalSliderInputValMinMax <- function(inputId, label, value_min_max, label_help = NULL, ...) { # nolint

  x <- value_min_max

  if (!is.numeric(x)) stop("value_min_max is expected to be numeric")

  vals <- if (length(x) == 3) {
    if (any(diff(x[c(2, 1, 3)]) < 0)) {
      stop(paste("value_min_max is expected to be (value, min, max) where min <= value <= 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_)
  } else {
    stop(paste("value_min_max is expected to be of length 1 (value) or of length 3 (value, min, max)"))
  }

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

  if (!is.null(label_help)) {
    slider[[3]] <- append(slider[[3]], list(div(class = "label-help", label_help)), after = 1)
  }
  return(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))]
  }

  return(res)
}

#' Creates `ggplot2_args` object
#'
#' @description `r lifecycle::badge("experimental")`
#' 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(
#'   lab = 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 `r lifecycle::badge("experimental")`
#' 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
#'  teal option variable. The `NULL` value is supported.
#'
#' @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(
#'     lab = list(title = "TITLE"),
#'     theme = list(title = ggplot2::element_text(size = 20))
#'   ),
#'   user_default = ggplot2_args(
#'     lab = 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 `r lifecycle::badge("experimental")`
#' 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(
#'     lab = list(title = "TITLE"),
#'     theme = list(title = ggplot2::element_text(size = 20))
#'   ))
#' )
#'
#' parse_ggplot2_args(
#'   resolve_ggplot2_args(
#'     ggplot2_args(
#'       lab = 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)
}

#' Panel group widget
#'
#' @description `r lifecycle::badge("experimental")`
#' @param id optional, (`character`)\cr
#' @param ... (`shiny.tag`)\cr
#'  panels created by [panel_group()]
#'
#' @return (`shiny.tag`)
#'
#' @export
panel_group <- function(..., id = NULL) {
  checkmate::assert_string(id, null.ok = TRUE)

  # panel-group
  # div

  tags$div(
    id = id,
    ...,
    .renderHook = function(res_tag) {
      bs_version <- get_bs_version()
      if (bs_version == "3") {
        htmltools::tagAppendAttributes(res_tag, class = "panel-group")
      } else if (bs_version %in% c("4", "5")) {
        res_tag <- htmltools::tagAppendAttributes(res_tag, class = "my-4")
        htmltools::tagQuery(res_tag)$
          find(".card")$
          removeClass("my-2")$
          allTags()
      } else {
        stop("Bootstrap 3, 4, and 5 are supported.")
      }
    }
  )
}

#' Panel widget
#' @md
#'
#' @description `r lifecycle::badge("experimental")`
#' @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`)
#'
#' @export
panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
  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)

  div_id <- paste0(input_id, "_div")
  panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1))


  tags$div(.renderHook = function(res_tag) {
    bs_version <- get_bs_version()

    # alter tag structure
    if (bs_version == "3") {
      res_tag$children <- list(
        tags$div(
          id = div_id,
          class = "panel panel-default",
          tags$div(
            class = paste("panel-heading", ifelse(collapsed, "collapsed", "")),
            `data-toggle` = "collapse",
            href = paste0("#", panel_id),
            `aria-expanded` = ifelse(collapsed, "false", "true"),
            icon("angle-down", class = "dropdown-icon"),
            tags$label(
              class = "panel-title inline",
              title,
            )
          ),
          tags$div(
            class = paste("panel-collapse collapse", ifelse(collapsed, "", "in")),
            id = panel_id,
            tags$div(
              class = "panel-body",
              ...
            )
          )
        )
      )
    } else if (bs_version %in% c("4", "5")) {
      res_tag$children <- list(
        tags$div(
          class = "card my-2",
          tags$div(
            class = "card-header",
            tags$div(
              class = ifelse(collapsed, "collapsed", ""),
              # bs4
              `data-toggle` = "collapse",
              # bs5
              `data-bs-toggle` = "collapse",
              href = paste0("#", panel_id),
              `aria-expanded` = ifelse(collapsed, "false", "true"),
              icon("angle-down", class = "dropdown-icon"),
              tags$label(
                class = "card-title inline",
                title,
              )
            )
          ),
          tags$div(
            id = panel_id,
            class = paste("collapse", ifelse(collapsed, "", "show")),
            tags$div(
              class = "card-body",
              ...
            )
          )
        )
      )
    } else {
      stop("Bootstrap 3, 4, and 5 are supported.")
    }

    tagList(
      include_css_files(pattern = "panel.css"),
      res_tag
    )
  })
}

#' UI part of plot-with-settings module
#'
#' @description `r lifecycle::badge("stable")`
#' @export
#'
#' @param id (\code{character}) module ID
plot_with_settings_ui <- function(id) {
  checkmate::assert_string(id)

  ns <- NS(id)

  tagList(
    shiny::singleton(shiny::tags$head(
      shiny::tags$script(
        # nolint start
        sprintf(
          '$(document).on("shiny:connected", function(e) {
            Shiny.onInputChange("%s", document.getElementById("%s").clientWidth);
            Shiny.onInputChange("%s", 0.87*window.innerWidth);
            //based on modal CSS property, also accounting for margins
          });
          $(window).resize(function(e) {
            Shiny.onInputChange("%s", document.getElementById("%s").clientWidth);
            Shiny.onInputChange("%s", 0.87*window.innerWidth);
            //based on modal CSS property, also accounting for margins
          });',
          # nolint end
          ns("flex_width"), # session input$ variable name
          ns("plot_out_main"), # graph parent id
          ns("plot_modal_width"), # session input$ variable name
          ns("flex_width"), # session input$ variable name
          ns("plot_out_main"), # graph parent id
          ns("plot_modal_width") # session input$ variable name
        )
      )
    )),
    include_css_files("plot_with_settings"),
    tags$div(
      id = ns("plot-with-settings"),
      tags$div(
        class = "plot-settings-buttons",
        type_download_ui(ns("downbutton")),
        actionButton(
          ns("expand"),
          label = character(0),
          icon = icon("up-right-and-down-left-from-center"),
          class = "btn-sm"
        ),
        shinyWidgets::dropdownButton(
          circle = FALSE,
          icon = icon("maximize"),
          inline = TRUE,
          right = TRUE,
          label = "",
          inputId = ns("expbut"),
          uiOutput(ns("slider_ui")),
          uiOutput(ns("width_warning"))
        )
      ),
      uiOutput(ns("plot_out_main"), class = "plot_out_container", width = "100%")
    )
  )
}

#' Server part of plot-with-settings module
#'
#' @description `r lifecycle::badge("stable")`
#' @export
#'
#' @inheritParams shiny::moduleServer
#' @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 modal plot display. The value in the modal display is taken from the value of the
#'  slider in the main 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 modal plot display; `NULL` for default display. The value in the modal
#'  display is taken from the value of the slider in the main plot display.
#' @param show_hide_signal optional, (\code{reactive logical} a mechanism to allow modules which call this
#'     module to show/hide the plot_with_settings UI)
#' @param brushing (`logical`, optional)\cr
#'  a mechanism to enable / disable brushing on the main plot (in particular: not the one displayed
#'  in modal). 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 (in particular: not the
#'  one displayed in modal). 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
#'  a mechanism to enable / disable double-clicking on data points on the main plot (in particular:
#'  not the one displayed in modal). All the double clicking data is stored as a reactive object in
#'  the `"dblclick"` element of returned list. See the example for details.
#' @param hovering (`logical(1)`, optional)\cr
#'  a mechanism to enable / disable hovering over data points on the main plot (in particular: not
#'  the one displayed in modal). 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.
#'
#' @examples
#' \dontrun{
#' # Example using a reactive as input to plot_r
#' library(shiny)
#' shinyApp(
#'   ui = fluidPage(
#'     plot_with_settings_ui(
#'       id = "plot_with_settings"
#'     )
#'   ),
#'   server = function(input, output, session) {
#'     plot_r <- reactive({
#'       ggplot2::qplot(x = 1, y = 1)
#'     })
#'
#'     plot_with_settings_srv(
#'       id = "plot_with_settings",
#'       plot_r = plot_r,
#'       height = c(400, 100, 1200),
#'       width = c(500, 250, 750)
#'     )
#'   }
#' )
#'
#' # Example using a function as input to plot_r
#' shinyApp(
#'   ui = fluidPage(
#'     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") {
#'         ggplot2::ggplot(data.frame(n = numbers), ggplot2::aes(n)) +
#'           ggplot2::geom_bar()
#'       } else if (input$download_option == "trellis") {
#'         lattice::densityplot(numbers)
#'       } else if (input$download_option == "grob") {
#'         tr_plot <- lattice::densityplot(numbers)
#'         ggplot2::ggplotGrob(
#'           ggplot2::ggplot(data.frame(n = numbers), ggplot2::aes(n)) +
#'             ggplot2::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)
#'     )
#'   }
#' )
#'
#' # Example with brushing/hovering/clicking/double-clicking
#' shinyApp(
#'   ui = fluidPage(
#'     plot_with_settings_ui(
#'       id = "plot_with_settings"
#'     ),
#'     fluidRow(
#'       column(4, h3("Brush"), verbatimTextOutput("brushing_data")),
#'       column(4, h3("Click"), verbatimTextOutput("clicking_data")),
#'       column(4, h3("DblClick"), verbatimTextOutput("dblclicking_data")),
#'       column(4, h3("Hover"), verbatimTextOutput("hovering_data"))
#'     )
#'   ),
#'   server = function(input, output, session) {
#'     plot_r <- reactive({
#'       ggplot2::qplot(x = 1:5, y = 1:5)
#'     })
#'
#'     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())
#'   }
#' )
#'
#' # Example which allows module to be hidden/shown
#' library("shinyjs")
#'
#' shinyApp(
#'   ui = fluidPage(
#'     useShinyjs(),
#'     plot_with_settings_ui(
#'       id = "plot_with_settings"
#'     ),
#'     actionButton("button", "Show/Hide")
#'   ),
#'   server = function(input, output, session) {
#'     plot_r <- reactive(ggplot2::qplot(x = 1, y = 1))
#'
#'     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())
#'     )
#'   }
#' )
#' }
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
    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)

    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
      )

      observeEvent(input$flex_width, {
        if (input$flex_width > 0 && !isFALSE(input$width_resize_switch)) {
          default_slider_width(input$flex_width * c(1, 0.5, 2.8))
          updateSliderInput(session, inputId = "width", value = input$flex_width)
        }
      })
    }

    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({
      div(
        optionalSliderInputValMinMax(
          inputId = ns("height"),
          label = "Plot height",
          value_min_max = round(height),
          ticks = FALSE,
          step = 1L,
          round = TRUE
        ),
        tags$b("Plot width"),
        shinyWidgets::switchInput(
          inputId = ns("width_resize_switch"),
          onLabel = "ON",
          offLabel = "OFF",
          label = "Auto width",
          value = `if`(is.null(width), TRUE, FALSE),
          size = "mini",
          labelWidth = "80px"
        ),
        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 | input$flex_width, {
      if (length(input$width_resize_switch) && input$width_resize_switch) {
        shinyjs::disable("width")
        updateSliderInput(session, inputId = "width", value = input$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
      }
    })

    plot_reactive <- reactive({
      if (plot_type() == "gg" && dblclicking) {
        plot_r() +
          ggplot2::coord_cartesian(xlim = ranges$x, ylim = ranges$y, expand = FALSE)
      } else if (plot_type() == "grob") {
        # calling grid.draw on plot_r() is needed;
        # otherwise the plot will not re-render if the user triggers the zoom in or out feature of the browser.
        grid::grid.newpage()
        grid::grid.draw(plot_r())
      } else {
        plot_r()
      }
    })

    p_height <- reactive(`if`(!is.null(input$height), input$height, height[1]))
    p_width <- reactive(`if`(!is.null(input$width), input$width, default_slider_width()[1]))
    output$plot_main <- renderPlot(
      plot_reactive(),
      res = get_plot_dpi(),
      height = p_height,
      width = p_width
    )

    output$plot_modal <- renderPlot(
      plot_reactive(),
      res = get_plot_dpi(),
      height = reactive(input$height_in_modal),
      width = reactive(input$width_in_modal)
    )

    output$plot_out_main <- renderUI({
      div(
        align = graph_align,
        plotOutput(
          ns("plot_main"),
          height = p_height(),
          width = p_width(),
          brush = `if`(brushing, brushOpts(ns("plot_brush"), resetOnNew = TRUE), 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(NULL) # reset Rplots.pdf for shiny server
      w <- grDevices::dev.size("px")[1]
      grDevices::dev.off()
      if (`if`(!is.null(input$width), input$width, default_slider_width()[1]) < 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 = reactive(`if`(!is.null(input$width), input$width, default_slider_width()[1])),
      default_w = default_w,
      plot_h = reactive(`if`(!is.null(input$height), input$height, height[1])),
      default_h = default_h
    )

    output$plot_out_modal <- renderUI({
      plotOutput(ns("plot_modal"), height = input$height_in_modal, width = input$width_in_modal)
    })

    observeEvent(input$expand, {
      showModal(
        div(
          class = "plot-modal",
          modalDialog(
            easyClose = TRUE,
            div(
              class = "plot-modal-sliders",
              optionalSliderInputValMinMax(
                inputId = ns("height_in_modal"),
                label = "Plot height",
                value_min_max = round(c(`if`(!is.null(input$height), input$height, height[1]), height[2:3])),
                ticks = FALSE,
                step = 1L,
                round = TRUE
              ),
              optionalSliderInputValMinMax(
                inputId = ns("width_in_modal"),
                label = "Plot width",
                value_min_max = round(c(
                  ifelse(
                    is.null(input$width) || !isFALSE(input$width_resize_switch),
                    ifelse(
                      is.null(input$plot_modal_width) || input$plot_modal_width > default_slider_width()[3],
                      default_slider_width()[1],
                      input$plot_modal_width
                    ),
                    input$width
                  ),
                  default_slider_width()[2:3]
                )),
                ticks = FALSE,
                step = 1L,
                round = TRUE
              )
            ),
            div(
              class = "float-right",
              type_download_ui(ns("modal_downbutton"))
            ),
            div(
              align = "center",
              uiOutput(ns("plot_out_modal"), class = "plot_out_container")
            )
          )
        )
      )
    })

    type_download_srv(
      id = "modal_downbutton",
      plot_reactive = plot_r,
      plot_type = plot_type,
      plot_w = reactive(input$width_in_modal),
      default_w = default_w,
      plot_h = reactive(input$height_in_modal),
      default_h = default_h
    )

    return(
      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(input$width, input$height))
      )
    )
  })
}

#' @keywords internal
type_download_ui <- function(id) {
  ns <- NS(id)
  shinyWidgets::dropdownButton(
    circle = FALSE,
    icon = icon("download"),
    inline = TRUE,
    right = TRUE,
    label = "",
    inputId = ns("downl"),
    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"))
      ),
      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) {
      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()
        }
      )
    }
  )
}

#' Cleans and organizes output to account for NAs and remove empty rows.
#'
#' @description `r lifecycle::badge("stable")`
#' @param data (`data.frame`)\cr
#'  A dataframe from which to select rows.
#' @param brush (`list`)\cr
#'  The data from a brush e.g. input$plot_brush.
#'
#' @return A dataframe of selected rows.
#' @export
#'
clean_brushedPoints <- function(data, brush) { # nolintr
  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())
  )
}

#' @name table_with_settings
#'
#' @title table_with_settings module
#'
#' @description `r lifecycle::badge("stable")`
#' @inheritParams shiny::moduleServer
#' @param ... (`character`)\cr
#'  Useful for providing additional HTML classes for the output tag.
#'
#' @rdname table_with_settings
#' @export
#'
table_with_settings_ui <- function(id, ...) {
  checkmate::assert_string(id)

  ns <- NS(id)

  tagList(
    include_css_files("table_with_settings"),
    tags$div(
      id = ns("table-with-settings"),
      tags$div(
        class = "table-settings-buttons",
        type_download_ui_table(ns("downbutton")),
        actionButton(
          inputId = ns("expand"), label = character(0),
          icon = icon("up-right-and-down-left-from-center"), class = "btn-sm"
        ),
      ),
      tags$div(
        class = "table-settings-table",
        uiOutput(ns("table_out_main"), width = "100%", ...)
      )
    )
  )
}

#' @inheritParams shiny::moduleServer
#' @param table_r (`reactive`)\cr
#'  reactive expression that yields an `rtable` object (`ElementaryTable` or `TableTree`)
#' @param show_hide_signal (`reactive logical`, optional)\cr
#'  a mechanism to allow modules which call this module to show/hide the table_with_settings UI.
#'
#' @rdname table_with_settings
#' @export
#'
#' @examples
#' \dontrun{
#' library(shiny)
#' library(rtables)
#' library(magrittr)
#' shinyApp(
#'   ui = fluidPage(
#'     table_with_settings_ui(
#'       id = "table_with_settings"
#'     )
#'   ),
#'   server = function(input, output, session) {
#'     table_r <- reactive({
#'       l <- basic_table() %>%
#'         split_cols_by("ARM") %>%
#'         analyze(c("SEX", "AGE"))
#'
#'       tbl <- build_table(l, DM)
#'
#'       tbl
#'     })
#'
#'     table_with_settings_srv(id = "table_with_settings", table_r = table_r)
#'   }
#' )
#' }
#'
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"))

  if (!requireNamespace("rtables", quietly = TRUE)) {
    stop("package rtables is required, please install")
  }

  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({
      rtables::as_html(table_r())
    })

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

    observeEvent(input$expand, {
      showModal(
        div(
          class = "table-modal",
          modalDialog(
            easyClose = TRUE,
            div(
              class = "float-right",
              type_download_ui_table(ns("modal_downbutton"))
            ),
            uiOutput(ns("table_out_modal"), class = "table_out_container")
          )
        )
      )
    })

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

type_download_ui_table <- function(id) {
  ns <- NS(id)
  shinyWidgets::dropdownButton(
    circle = FALSE,
    icon = icon("download"),
    inline = TRUE,
    right = TRUE,
    label = "",
    inputId = ns("dwnl"),
    div(
      class = "modal-download-ui-table-container",
      radioButtons(ns("file_format"),
        label = "File type",
        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"))
      ),
      conditionalPanel(
        condition = paste0("input['", ns("file_format"), "'] != '.csv'"),
        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"
          )
        ),
        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(input$pagination_switch, {
        if (input$pagination_switch) {
          shinyjs::enable("lpp")
        } else {
          shinyjs::disable("lpp")
        }
      })

      output$lpp_warning <- renderUI({
        catch_warning <- if (input$file_format != ".csv" && input$pagination_switch) {
          try(rtables::paginate_table(
            tt = table_reactive(),
            lpp = as.numeric(input$lpp)
          ))
        }

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

      output$data_download <- downloadHandler(
        filename = function() {
          paste0(input$file_name, input$file_format)
        },
        content = function(file) {
          if (input$file_format == ".txt") {
            rtables::export_as_txt(
              x = table_reactive(),
              file = file,
              paginate = input$pagination_switch,
              lpp = if (input$pagination_switch) as.numeric(input$lpp)
            )
          } else if (input$file_format == ".csv") {
            result <- rtables::matrix_form(table_reactive())$strings
            utils::write.table(
              x = result,
              file = file,
              sep = ",",
              col.names = FALSE,
              row.names = TRUE,
              append = FALSE
            )
          } else {
            rtables::export_as_pdf(
              tt = table_reactive(),
              file = file,
              paginate = input$pagination_switch,
              lpp = if (input$pagination_switch) as.numeric(input$lpp)
            )
          }
        }
      )
    }
  )
}

#' @title Draggable Buckets
#' @description  `r lifecycle::badge("experimental")`
#' 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
#'
#' ui <- shiny::fluidPage(
#'   draggable_buckets("id", "Choices #1", c("a", "b"), c("bucket1", "bucket2")),
#'   draggable_buckets("id2", "Choices #2", letters, c("vowels", "consonants")),
#'   shiny::verbatimTextOutput("out"),
#'   shiny::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()
#'
#'   shiny::observeEvent(list(input$id, input$id2), {
#'     print(isolate(input$id))
#'     print(isolate(input$id2))
#'   })
#'   output$out <- shiny::renderPrint({
#'     iv$is_valid()
#'     input$id
#'   })
#'   output$out2 <- shiny::renderPrint(input$id2)
#' }
#' if (interactive()) shiny::shinyApp(ui, server)
#'
#' # With default elements in the bucket
#' ui <- shiny::fluidPage(
#'   draggable_buckets("id", "Choices #1", c("a", "b"), list(bucket1 = character(), bucket2 = c("c"))),
#'   shiny::verbatimTextOutput("out")
#' )
#' server <- function(input, output) {
#'   shiny::observeEvent(input$id, {
#'     print(shiny::isolate(input$id))
#'   })
#'   output$out <- shiny::renderPrint(input$id)
#' }
#' if (interactive()) shiny::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(
    shiny::singleton(shiny::tags$head(
      shiny::includeScript(system.file("widgets/draggable_buckets.js", package = "teal.widgets"))
    )),
    include_css_files("draggable_buckets.css"),
    shiny::div(
      shiny::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) {
  shiny::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) {
  shiny::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) {
  shiny::tags$div(
    shiny::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
  )
}

#' Create a standard UI layout with output on the right and an encoding panel on
#' the left
#'
#' @description `r lifecycle::badge("stable")`
#' This is the layout used for the teal modules in the `beam` package
#'
#' @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 \code{shiny.tag} with the UI code.
#'
#' @export
standard_layout <- function(output,
                            encoding = NULL,
                            forms = NULL,
                            pre_output = NULL,
                            post_output = NULL) {
  # checking arguments
  if (!inherits(output, c("shiny.tag", "shiny.tag.list", "html"))) {
    stop("output is supposed to be of class shiny.tag or shiny.tag.list")
  }
  for (name in names(l <- list(
    "encoding" = encoding,
    "pre_output" = pre_output,
    "post_output" = post_output
  ))) {
    if (!is.null(l[[name]]) && !inherits(l[[name]], c("shiny.tag", "shiny.tag.list", "html"))) {
      stop(paste(name, "is supposed to be NULL, shiny.tag or shiny.tag.list."))
    }
  }

  # if encoding=NULL then forms is placed below output

  tag_output <- div(
    class = "well",
    div(class = "pre-output", pre_output),
    div(class = "output", output),
    div(class = "post-output", post_output)
  )

  tag_enc_out <- if (!is.null(encoding)) {
    tagList(
      div(
        class = "col-md-3",
        div(class = "well", encoding),
        if (is.null(forms)) {
          NULL
        } else {
          div(class = "form-group", forms)
        }
      ),
      div(class = "col-md-9", tag_output)
    )
  } else {
    div(
      class = "col-md-12",
      tag_output,
      if (is.null(forms)) {
        NULL
      } else {
        div(class = "form-group", forms)
      }
    )
  }

  fluidRow(tag_enc_out)
}

#' Builds a `basic_table_args` object
#'
#' @description `r lifecycle::badge("experimental")`
#' 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 `r lifecycle::badge("experimental")`
#' 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
#'  teal option variable. The `NULL` value is supported.
#'
#' @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 `r lifecycle::badge("experimental")`
#' 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))
  }
}

#' Include `CSS` files from `/inst/css/` package directory to application header
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`. Therefore, we redefine this method in each package
#' as needed. Thus, we do not export this method
#'
#' @param pattern (`character`) pattern of files to be included
#'
#' @return HTML code that includes `CSS` files
#' @keywords internal
include_css_files <- function(pattern = "*") {
  css_files <- list.files(
    system.file("css", package = "teal.widgets", mustWork = TRUE),
    pattern = pattern, full.names = TRUE
  )
  if (length(css_files) == 0) {
    return(NULL)
  }
  return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))
}

#' Adds Class Small Well and overflow-x property to HTML output element
#'
#' @description `r lifecycle::badge("stable")`
#' @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(
    include_css_files(pattern = "custom"),
    tags$div(
      class = "well well-sm bg-white",
      ...
    )
  )
}

#' Maps the `lengthMenu`selected value property of `DT::datatable` to a Shiny variable.
#'
#' @description `r lifecycle::badge("stable")`
#' @param dt_name \code{ns()} of `inputId` of the `DT::datatable`
#' @param dt_rows \code{ns()} of `inputId` of the variable that holds the current selected value of `lengthMenu`
#'
#' @name get_dt_rows
#'
#' @examples
#' \dontrun{
#' library(shiny)
#' # in Shiny UI function
#' tagList(
#'   get_dt_rows(ns("data_table"), ns("dt_rows")),
#'   ...
#' )
#'
#' # use the input$dt_rows in the Shiny Server function
#' if (!is.null(input$dt_rows)) {
#'   dt_args$options$pageLength <- input$dt_rows
#' } # nolint
#' do.call(DT::datatable, dt_args)
#' }
#'
#' @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.onInputChange('%s', len);
        });
        });",
        paste0("#", dt_name),
        dt_rows
      )
    )
  )
}

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

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

1		#' Create a standard UI layout with output on the right and an encoding panel on
2		#' the left
3		#'
4		#' @description `r lifecycle::badge("stable")`
5		#' This is the layout used for the teal modules in the `beam` package
6		#'
7		#' @param output (`shiny.tag`)\cr
8		#' object with the output element (table, plot, listing) such as for example returned
9		#' by [shiny::plotOutput()].
10		#' @param encoding (`shiny.tag`)\cr
11		#' object containing the encoding elements. If this element is `NULL` then no encoding side
12		#' panel on the right is created.
13		#' @param forms (`tagList`)\cr
14		#' for example [shiny::actionButton()] that are placed below the encodings panel
15		#' @param pre_output (`shiny.tag`, optional)\cr
16		#' with text placed before the output to put the output into context. For example a title.
17		#' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output
18		#' into context. For example the [shiny::helpText()] elements are useful.
19		#'
20		#' @return an object of class \code{shiny.tag} with the UI code.
21		#'
22		#' @export
23		standard_layout <- function(output,
24		encoding = NULL,
25		forms = NULL,
26		pre_output = NULL,
27		post_output = NULL) {
28		# checking arguments
29	11x	if (!inherits(output, c("shiny.tag", "shiny.tag.list", "html"))) {
30	2x	stop("output is supposed to be of class shiny.tag or shiny.tag.list")
31		}
32	9x	for (name in names(l <- list(
33	9x	"encoding" = encoding,
34	9x	"pre_output" = pre_output,
35	9x	"post_output" = post_output
36		))) {
37	24x	if (!is.null(l[[name]]) && !inherits(l[[name]], c("shiny.tag", "shiny.tag.list", "html"))) {
38	3x	stop(paste(name, "is supposed to be NULL, shiny.tag or shiny.tag.list."))
39		}
40		}
41
42		# if encoding=NULL then forms is placed below output
43
44	6x	tag_output <- div(
45	6x	class = "well",
46	6x	div(class = "pre-output", pre_output),
47	6x	div(class = "output", output),
48	6x	div(class = "post-output", post_output)
49		)
50
51	6x	tag_enc_out <- if (!is.null(encoding)) {
52	2x	tagList(
53	2x	div(
54	2x	class = "col-md-3",
55	2x	div(class = "well", encoding),
56	2x	if (is.null(forms)) {
57	1x	NULL
58		} else {
59	1x	div(class = "form-group", forms)
60		}
61		),
62	2x	div(class = "col-md-9", tag_output)
63		)
64		} else {
65	4x	div(
66	4x	class = "col-md-12",
67	4x	tag_output,
68	4x	if (is.null(forms)) {
69	3x	NULL
70		} else {
71	1x	div(class = "form-group", forms)
72		}
73		)
74		}
75
76	6x	fluidRow(tag_enc_out)
77		}

1		#' Get bootstrap current version
2		#' @note will work properly mainly inside a tag `.renderHook`
3		#' @keywords internal
4		get_bs_version <- function() {
5	1x	theme <- bslib::bs_current_theme()
6	1x	if (bslib::is_bs_theme(theme)) {
7	!	bslib::theme_version(theme)
8		} else {
9	1x	"3"
10		}
11		}

1		#' Hide, Show Label only or display a `pickerInput`
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' Hidden input widgets are useful to have the `input[[inputId]]` variable
5		#' on available in the server function but no corresponding visual clutter from
6		#' input widgets that provide only a single choice.
7		#'
8		#' @inheritParams shinyWidgets::pickerInput
9		#' @param choices (`character`, `NULL`)\cr
10		#' If `choices` is `NULL` no `pickerInput` widget is displayed and `input[[inputId]]`
11		#' will be `""`. If `choices` is of length 1 then a label and character string will be
12		#' displayed and the `pickerInput` widget will be hidden. If the length of `choices`
13		#' is more than one the `pickerInput` element will be displayed.
14		#' If elements of the list are named then that name rather than the value
15		#' is displayed to the user.
16		#'
17		#' @param sep (`character(1)`)\cr
18		#' A separator string to split the `choices` or `selected` inputs into the values of the different
19		#' columns.
20		#'
21		#' @param label_help (`shiny.tag` optional)\cr
22		#' e.g. an object returned by [shiny::helpText()].
23		#'
24		#' @param fixed (`logical(1)` optional)\cr
25		#' whether to block user to select choices.
26		#'
27		#' @param width (`character(1)`)\cr
28		#' The width of the input passed to `pickerInput` e.g. `'auto'`, `'fit'`, `'100px'` or `'75%'`
29		#'
30		#' @export
31		#'
32		#' @examples
33		#' \dontrun{
34		#' optionalSelectInput(inputId = "xvar", label = "x variable", choices = "A", selected = "A")
35		#' optionalSelectInput(
36		#' inputId = "xvar",
37		#' label = "x variable",
38		#' choices = LETTERS[1:5],
39		#' selected = "A"
40		#' )
41		#' optionalSelectInput(
42		#' inputId = "xvar",
43		#' label = "x variable",
44		#' choices = c("A - value A" = "A"),
45		#' selected = "A"
46		#' )
47		#'
48		#' ADRS <- scda::synthetic_cdisc_data("latest")$adrs # nolint
49		#' optionalSelectInput(
50		#' inputId = "xvar",
51		#' label = "x variable",
52		#' choices = teal.transform::variable_choices(data = ADRS, subset = c("AGE", "SEX", "PARAMCD")),
53		#' selected = "PARAMCD"
54		#' )
55		#'
56		#' selected_value <- paste0(lapply(ADRS[1, c("PARAMCD", "AVISIT")], as.character), collapse = " - ")
57		#' optionalSelectInput(
58		#' inputId = "xvar",
59		#' label = "x variable",
60		#' choices = teal.transform::value_choices(
61		#' data = ADRS,
62		#' var_choices = c("PARAMCD", "AVISIT"),
63		#' var_label = c("PARAM", "AVISIT")
64		#' ),
65		#' selected = selected_value
66		#' )
67		#' }
68		optionalSelectInput <- function(inputId, # nolint
69		label = NULL,
70		choices = NULL,
71		selected = NULL,
72		multiple = FALSE,
73		sep = NULL,
74		options = list(),
75		label_help = NULL,
76		fixed = FALSE,
77		width = NULL) {
78	!	checkmate::assert_string(inputId)
79
80	!	checkmate::assert(
81	!	checkmate::check_string(label, null.ok = TRUE),
82	!	checkmate::check_class(label, "shiny.tag"),
83	!	checkmate::check_class(label, "shiny.tag.list"),
84	!	checkmate::check_class(label, "html")
85		)
86	!	stopifnot(is.null(choices) \|\| length(choices) >= 1)
87	!	stopifnot(
88	!	is.null(selected) \|\|
89	!	length(selected) == 0 \|\|
90	!	all(selected %in% choices) \|\|
91	!	all(selected %in% unlist(choices, recursive = FALSE))
92		)
93	!	checkmate::assert_flag(multiple)
94	!	checkmate::assert_string(sep, null.ok = TRUE)
95	!	stopifnot(is.list(options))
96	!	checkmate::assert(
97	!	checkmate::check_string(label_help, null.ok = TRUE),
98	!	checkmate::check_class(label_help, "shiny.tag"),
99	!	checkmate::check_class(label_help, "shiny.tag.list"),
100	!	checkmate::check_class(label_help, "html")
101		)
102	!	checkmate::assert_flag(fixed)
103
104	!	if (!is.null(width)) {
105	!	validateCssUnit(width)
106		}
107
108	!	default_options <- list(
109	!	"actions-box" = multiple,
110	!	"none-selected-text" = "- Nothing selected -",
111	!	"max-options" = ifelse(multiple, Inf, 1),
112	!	"show-subtext" = TRUE,
113	!	"live-search" = ifelse(length(choices) > 10, TRUE, FALSE)
114		)
115
116		# if called outside the fluidPage then will assume bs 3
117	!	bs_version <- get_bs_version()
118	!	if (isTRUE(bs_version != "3")) default_options[["style"]] <- "btn-outline-secondary"
119
120	!	options <- if (!identical(options, list())) {
121	!	c(options, default_options[setdiff(names(default_options), names(options))])
122		} else {
123	!	default_options
124		}
125
126	!	if (is.null(choices)) {
127	!	choices <- ""
128	!	selected <- NULL
129		}
130
131	!	raw_choices <- extract_raw_choices(choices, attr(choices, "sep"))
132	!	raw_selected <- extract_raw_choices(selected, attr(choices, "sep"))
133
134	!	ui <- shinyWidgets::pickerInput(
135	!	inputId = inputId,
136	!	label = label,
137	!	choices = raw_choices,
138	!	selected = raw_selected,
139	!	multiple = TRUE,
140	!	width = width,
141	!	options = options,
142	!	choicesOpt = picker_options(choices)
143		)
144
145	!	if (!is.null(label_help)) {
146	!	ui[[3]] <- append(ui[[3]], list(div(class = "label-help", label_help)), after = 1)
147		}
148
149	!	shiny::tagList(
150	!	include_css_files(pattern = "picker_input"),
151	!	if (is.null(choices)) {
152	!	shinyjs::hidden(ui)
153		} else {
154	!	if (fixed) {
155	!	div(
156	!	shinyjs::hidden(ui),
157	!	tags$label(id = paste0(inputId, "_textonly"), class = "control-label", sub(":[[:space:]]+$", "", label)),
158	!	if (length(selected) > 0) {
159	!	tags$code(
160	!	id = paste0(inputId, "_valueonly"),
161	!	paste(selected, collapse = ", ")
162		)
163		},
164	!	label_help
165		)
166		} else {
167	!	ui
168		}
169		}
170		)
171		}
172
173		#' Update `optionalSelectInput`
174		#'
175		#' @description `r lifecycle::badge("stable")`
176		#'
177		#' @inheritParams shinyWidgets::updatePickerInput
178		#'
179		#' @return `NULL`
180		#'
181		#' @export
182		#'
183		updateOptionalSelectInput <- function(session, # nolint
184		inputId, # nolint
185		label = NULL,
186		selected = NULL,
187		choices = NULL) {
188	!	raw_choices <- extract_raw_choices(choices, attr(choices, "sep"))
189	!	raw_selected <- extract_raw_choices(selected, attr(choices, "sep"))
190
191	!	shinyWidgets::updatePickerInput(
192	!	session = session,
193	!	inputId = inputId,
194	!	label = label,
195	!	selected = as.character(raw_selected),
196	!	choices = raw_choices,
197	!	choicesOpt = picker_options(choices)
198		)
199
200	!	shinyjs::show(inputId)
201	!	shinyjs::hide(paste0(inputId, "_textonly"))
202
203	!	invisible(NULL)
204		}
205
206		#' Get icons to represent variable types in dataset
207		#'
208		#' @param var_type (`character`)\cr
209		#' of R internal types (classes).
210		#'
211		#' @return (`character`)\cr
212		#' vector of HTML icons corresponding to data type in each column.
213		#' @keywords internal
214		#'
215		#' @examples
216		#' teal.widgets:::variable_type_icons(c(
217		#' "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt",
218		#' "factor", "character", "unknown", ""
219		#' ))
220		variable_type_icons <- function(var_type) {
221	!	checkmate::assert_character(var_type, any.missing = FALSE)
222
223	!	class_to_icon <- list(
224	!	numeric = "arrow-up-1-9",
225	!	integer = "arrow-up-1-9",
226	!	logical = "pause",
227	!	Date = "calendar",
228	!	POSIXct = "calendar",
229	!	POSIXlt = "calendar",
230	!	factor = "chart-bar",
231	!	character = "keyboard",
232	!	primary_key = "key",
233	!	unknown = "circle-question"
234		)
235	!	class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
236
237	!	res <- unname(vapply(
238	!	var_type,
239	!	FUN.VALUE = character(1),
240	!	FUN = function(class) {
241	!	if (class == "") {
242	!	class
243	!	} else if (is.null(class_to_icon[[class]])) {
244	!	class_to_icon[["unknown"]]
245		} else {
246	!	class_to_icon[[class]]
247		}
248		}
249		))
250
251	!	return(res)
252		}
253
254		#' Optional content for `optionalSelectInput`
255		#'
256		#' Prepares content to be displayed in `optionalSelectInput` with icons and labels
257		#'
258		#' @param var_name (`character`)\cr
259		#' variable name
260		#' @param var_label (`character`)\cr
261		#' variable alternative name - for example variable label
262		#' @param var_type (`character`)
263		#' class of the variable.
264		#'
265		#' @return (`character`) HTML contents with all elements combined
266		#' @keywords internal
267		#'
268		#' @examples
269		#' teal.widgets:::picker_options_content(
270		#' var_name = c("SEX", "BRMRKR1"),
271		#' var_label = c("Sex", "Biomarker 1"),
272		#' var_type = c("factor", "numeric")
273		#' )
274		picker_options_content <- function(var_name, var_label, var_type) {
275	!	if (length(var_name) == 0) {
276	!	return(character(0))
277		}
278	!	if (length(var_type) == 0 && length(var_label) == 0) {
279	!	return(var_name)
280		}
281	!	checkmate::assert_character(var_name, min.len = 1, any.missing = FALSE)
282	!	stopifnot(
283	!	identical(var_type, character(0)) \|\| length(var_type) == length(var_name),
284	!	identical(var_label, character(0)) \|\| length(var_label) == length(var_name)
285		)
286
287	!	var_icon <- variable_type_icons(var_type)
288
289	!	res <- trimws(paste(
290	!	var_icon,
291	!	var_name,
292	!	vapply(
293	!	var_label,
294	!	function(x) {
295	!	ifelse(x == "", "", toString(tags$small(x, class = "text-muted")))
296		},
297	!	character(1)
298		)
299		))
300
301	!	return(res)
302		}
303
304		#' Create `choicesOpt` for `pickerInput`
305		#'
306		#' @param choices (`choices_labeled` or `character`)\cr
307		#' choices vector
308		#'
309		#' @return (`list`)\cr
310		#' to be passed as `choicesOpt` argument.
311		#' @keywords internal
312		picker_options <- function(choices) {
313	!	if (inherits(choices, "choices_labeled")) {
314	!	raw_choices <- extract_raw_choices(choices, sep = attr(choices, "sep"))
315	!	return(
316	!	list(
317	!	content = picker_options_content(
318	!	var_name = raw_choices,
319	!	var_label = extract_choices_labels(choices),
320	!	var_type = if (is.null(attr(choices, "types"))) character(0) else attr(choices, "types")
321		)
322		)
323		)
324	!	} else if (all(vapply(choices, inherits, logical(1), "choices_labeled"))) {
325	!	choices <- unlist(unname(choices))
326	!	return(
327	!	list(content = picker_options_content(
328	!	var_name = choices,
329	!	var_label = extract_choices_labels(choices),
330	!	var_type = if (is.null(attr(choices, "types"))) character(0) else attr(choices, "types")
331		))
332		)
333		} else {
334	!	return(NULL)
335		}
336		}
337
338		#' Extract raw values from choices
339		#'
340		#' @param choices (`choices_labeled`, `list` or `character`)\cr
341		#' object containing choices
342		#' @param sep (`character(1)`)\cr
343		#' A separator string to split the `choices` or `selected` inputs into the values of
344		#' the different columns.
345		#' @return choices simplified
346		#' @keywords internal
347		extract_raw_choices <- function(choices, sep) {
348	!	if (!is.null(sep)) {
349	!	vapply(choices, paste, collapse = sep, character(1))
350	!	} else if (inherits(choices, "choices_labeled")) {
351	!	unname(unlist(choices))
352		} else {
353	!	choices
354		}
355		}
356
357		#' if min or max are `NA` then the slider widget will be hidden
358		#'
359		#' @description `r lifecycle::badge("stable")`
360		#' Hidden input widgets are useful to have the `input[[inputId]]` variable
361		#' on available in the server function but no corresponding visual clutter from
362		#' input widgets that provide only a single choice.
363		#'
364		#' @inheritParams shiny::sliderInput
365		#' @param label_help (`shiny.tag`, optional)\cr
366		#' an object of class `shiny.tag`. E.g. an object returned by [shiny::helpText()]
367		#' @param ... optional arguments to `sliderInput`
368		#'
369		#' @export
370		#'
371		#' @examples
372		#' optionalSliderInput("a", "b", 0, 1, 0.2)
373		optionalSliderInput <- function(inputId, label, min, max, value, label_help = NULL, ...) { # nolint
374	25x	checkmate::assert_number(min, na.ok = TRUE)
375	25x	checkmate::assert_number(max, na.ok = TRUE)
376	25x	checkmate::assert_numeric(value, min.len = 1, max.len = 2, any.missing = FALSE)
377
378	25x	is_na_min <- is.na(min)
379	25x	is_na_max <- is.na(max)
380
381	25x	hide <- is_na_min \|\| is_na_max
382
383	25x	if (length(value) == 2) {
384	2x	value1 <- value[1]
385	2x	value2 <- value[2]
386		} else {
387	23x	value1 <- value
388	23x	value2 <- value
389		}
390
391	25x	if (is_na_min) {
392	2x	min <- value1 - 1
393		}
394	25x	if (is_na_max) {
395	1x	max <- value2 + 1
396		}
397
398	25x	if (min > value1 \|\| max < value2) {
399	2x	stop("arguments inconsistent: min <= value <= max expected")
400		}
401
402	23x	slider <- sliderInput(inputId, label, min, max, value, ...)
403
404	23x	if (!is.null(label_help)) {
405	!	slider[[3]] <- append(slider[[3]], list(div(class = "label-help", label_help)), after = 1)
406		}
407
408	23x	if (hide) {
409	2x	shinyjs::hidden(slider)
410		} else {
411	21x	slider
412		}
413		}
414
415		#' For teal modules we parameterize an \code{optionalSliderInput} with one argument
416		#' \code{value_min_max}
417		#'
418		#' @description `r lifecycle::badge("stable")`
419		#' The [optionalSliderInput()] function needs three arguments to decided
420		#' whether to hide the `sliderInput` widget or not. For teal modules we specify an
421		#' optional slider input with one argument here called `value_min_max`.
422		#'
423		#' @inheritParams optionalSliderInput
424		#'
425		#' @param value_min_max (`numeric(1)` or `numeric(3)`)\cr
426		#' If of length 1 then the value gets set to that number and the `sliderInput` will be hidden.
427		#' Otherwise, if it is of length three the three elements will map to `value`, `min` and `max` of
428		#' the [optionalSliderInput()] function.
429		#'
430		#' @export
431		#'
432		#' @examples
433		#'
434		#' optionalSliderInputValMinMax("a", "b", 1)
435		#' optionalSliderInputValMinMax("a", "b", c(3, 1, 5))
436		optionalSliderInputValMinMax <- function(inputId, label, value_min_max, label_help = NULL, ...) { # nolint
437
438	18x	x <- value_min_max
439
440	!	if (!is.numeric(x)) stop("value_min_max is expected to be numeric")
441
442	18x	vals <- if (length(x) == 3) {
443	18x	if (any(diff(x[c(2, 1, 3)]) < 0)) {
444	!	stop(paste("value_min_max is expected to be (value, min, max) where min <= value <= max"))
445		}
446	18x	list(value = x[1], min = x[2], max = x[3])
447	18x	} else if (length(x) == 1) {
448	!	list(value = x, min = NA_real_, max = NA_real_)
449		} else {
450	!	stop(paste("value_min_max is expected to be of length 1 (value) or of length 3 (value, min, max)"))
451		}
452
453	18x	slider <- optionalSliderInput(inputId, label, vals$min, vals$max, vals$value, ...)
454
455	18x	if (!is.null(label_help)) {
456	!	slider[[3]] <- append(slider[[3]], list(div(class = "label-help", label_help)), after = 1)
457		}
458	18x	return(slider)
459		}
460
461		#' Extract labels from choices basing on attributes and names
462		#'
463		#' @param choices (`list` or `vector`)\cr
464		#' select choices
465		#' @param values (optional)\cr
466		#' choices subset for which labels should be extracted, `NULL` for all choices.
467		#'
468		#' @return (`character`) vector with labels
469		#' @keywords internal
470		extract_choices_labels <- function(choices, values = NULL) {
471	!	res <- if (inherits(choices, "choices_labeled")) {
472	!	attr(choices, "raw_labels")
473	!	} else if (!is.null(names(choices)) && !setequal(names(choices), unlist(unname(choices)))) {
474	!	names(choices)
475		} else {
476	!	NULL
477		}
478
479	!	if (!is.null(values) && !is.null(res)) {
480	!	stopifnot(all(values %in% choices))
481	!	res <- res[vapply(values, function(val) which(val == choices), numeric(1))]
482		}
483
484	!	return(res)
485		}

1		#' Panel group widget
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#' @param id optional, (`character`)\cr
5		#' @param ... (`shiny.tag`)\cr
6		#' panels created by [panel_group()]
7		#'
8		#' @return (`shiny.tag`)
9		#'
10		#' @export
11		panel_group <- function(..., id = NULL) {
12	!	checkmate::assert_string(id, null.ok = TRUE)
13
14		# panel-group
15		# div
16
17	!	tags$div(
18	!	id = id,
19		...,
20	!	.renderHook = function(res_tag) {
21	!	bs_version <- get_bs_version()
22	!	if (bs_version == "3") {
23	!	htmltools::tagAppendAttributes(res_tag, class = "panel-group")
24	!	} else if (bs_version %in% c("4", "5")) {
25	!	res_tag <- htmltools::tagAppendAttributes(res_tag, class = "my-4")
26	!	htmltools::tagQuery(res_tag)$
27	!	find(".card")$
28	!	removeClass("my-2")$
29	!	allTags()
30		} else {
31	!	stop("Bootstrap 3, 4, and 5 are supported.")
32		}
33		}
34		)
35		}
36
37		#' Panel widget
38		#' @md
39		#'
40		#' @description `r lifecycle::badge("experimental")`
41		#' @param title (`character`)\cr title of panel
42		#' @param ... content of panel
43		#' @param collapsed (`logical`, optional)\cr
44		#' whether to initially collapse panel
45		#' @param input_id (`character`, optional)\cr
46		#' name of the panel item element. If supplied, this will register a shiny input variable that
47		#' indicates whether the panel item is open or collapsed and is accessed with `input$input_id`.
48		#'
49		#' @return (`shiny.tag`)
50		#'
51		#' @export
52		panel_item <- function(title, ..., collapsed = TRUE, input_id = NULL) {
53	!	stopifnot(checkmate::test_character(title, len = 1) \|\| inherits(title, c("shiny.tag", "shiny.tag.list", "html")))
54	!	checkmate::assert_flag(collapsed)
55	!	checkmate::assert_string(input_id, null.ok = TRUE)
56
57	!	div_id <- paste0(input_id, "_div")
58	!	panel_id <- paste0(input_id, "_panel_body_", sample(1:10000, 1))
59
60
61	!	tags$div(.renderHook = function(res_tag) {
62	!	bs_version <- get_bs_version()
63
64		# alter tag structure
65	!	if (bs_version == "3") {
66	!	res_tag$children <- list(
67	!	tags$div(
68	!	id = div_id,
69	!	class = "panel panel-default",
70	!	tags$div(
71	!	class = paste("panel-heading", ifelse(collapsed, "collapsed", "")),
72	!	`data-toggle` = "collapse",
73	!	href = paste0("#", panel_id),
74	!	`aria-expanded` = ifelse(collapsed, "false", "true"),
75	!	icon("angle-down", class = "dropdown-icon"),
76	!	tags$label(
77	!	class = "panel-title inline",
78	!	title,
79		)
80		),
81	!	tags$div(
82	!	class = paste("panel-collapse collapse", ifelse(collapsed, "", "in")),
83	!	id = panel_id,
84	!	tags$div(
85	!	class = "panel-body",
86		...
87		)
88		)
89		)
90		)
91	!	} else if (bs_version %in% c("4", "5")) {
92	!	res_tag$children <- list(
93	!	tags$div(
94	!	class = "card my-2",
95	!	tags$div(
96	!	class = "card-header",
97	!	tags$div(
98	!	class = ifelse(collapsed, "collapsed", ""),
99		# bs4
100	!	`data-toggle` = "collapse",
101		# bs5
102	!	`data-bs-toggle` = "collapse",
103	!	href = paste0("#", panel_id),
104	!	`aria-expanded` = ifelse(collapsed, "false", "true"),
105	!	icon("angle-down", class = "dropdown-icon"),
106	!	tags$label(
107	!	class = "card-title inline",
108	!	title,
109		)
110		)
111		),
112	!	tags$div(
113	!	id = panel_id,
114	!	class = paste("collapse", ifelse(collapsed, "", "show")),
115	!	tags$div(
116	!	class = "card-body",
117		...
118		)
119		)
120		)
121		)
122		} else {
123	!	stop("Bootstrap 3, 4, and 5 are supported.")
124		}
125
126	!	tagList(
127	!	include_css_files(pattern = "panel.css"),
128	!	res_tag
129		)
130		})
131		}

1		#' @name table_with_settings
2		#'
3		#' @title table_with_settings module
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#' @inheritParams shiny::moduleServer
7		#' @param ... (`character`)\cr
8		#' Useful for providing additional HTML classes for the output tag.
9		#'
10		#' @rdname table_with_settings
11		#' @export
12		#'
13		table_with_settings_ui <- function(id, ...) {
14	1x	checkmate::assert_string(id)
15
16	1x	ns <- NS(id)
17
18	1x	tagList(
19	1x	include_css_files("table_with_settings"),
20	1x	tags$div(
21	1x	id = ns("table-with-settings"),
22	1x	tags$div(
23	1x	class = "table-settings-buttons",
24	1x	type_download_ui_table(ns("downbutton")),
25	1x	actionButton(
26	1x	inputId = ns("expand"), label = character(0),
27	1x	icon = icon("up-right-and-down-left-from-center"), class = "btn-sm"
28		),
29		),
30	1x	tags$div(
31	1x	class = "table-settings-table",
32	1x	uiOutput(ns("table_out_main"), width = "100%", ...)
33		)
34		)
35		)
36		}
37
38		#' @inheritParams shiny::moduleServer
39		#' @param table_r (`reactive`)\cr
40		#' reactive expression that yields an `rtable` object (`ElementaryTable` or `TableTree`)
41		#' @param show_hide_signal (`reactive logical`, optional)\cr
42		#' a mechanism to allow modules which call this module to show/hide the table_with_settings UI.
43		#'
44		#' @rdname table_with_settings
45		#' @export
46		#'
47		#' @examples
48		#' \dontrun{
49		#' library(shiny)
50		#' library(rtables)
51		#' library(magrittr)
52		#' shinyApp(
53		#' ui = fluidPage(
54		#' table_with_settings_ui(
55		#' id = "table_with_settings"
56		#' )
57		#' ),
58		#' server = function(input, output, session) {
59		#' table_r <- reactive({
60		#' l <- basic_table() %>%
61		#' split_cols_by("ARM") %>%
62		#' analyze(c("SEX", "AGE"))
63		#'
64		#' tbl <- build_table(l, DM)
65		#'
66		#' tbl
67		#' })
68		#'
69		#' table_with_settings_srv(id = "table_with_settings", table_r = table_r)
70		#' }
71		#' )
72		#' }
73		#'
74		table_with_settings_srv <- function(id, table_r, show_hide_signal = reactive(TRUE)) {
75	6x	checkmate::assert_class(table_r, c("reactive", "function"))
76	5x	checkmate::assert_class(show_hide_signal, c("reactive", "function"))
77
78	4x	if (!requireNamespace("rtables", quietly = TRUE)) {
79	!	stop("package rtables is required, please install")
80		}
81
82	4x	moduleServer(id, function(input, output, session) {
83	4x	ns <- session$ns
84		# Turn on and off the UI
85	4x	observeEvent(show_hide_signal(), {
86	4x	if (show_hide_signal()) {
87	3x	shinyjs::show("table-with-settings")
88		} else {
89	1x	shinyjs::hide("table-with-settings")
90		}
91		})
92
93	4x	output$table_out_main <- output$table_out_modal <- renderUI({
94	8x	rtables::as_html(table_r())
95		})
96
97	4x	type_download_srv_table(
98	4x	id = "downbutton",
99	4x	table_reactive = table_r
100		)
101
102	4x	observeEvent(input$expand, {
103	2x	showModal(
104	2x	div(
105	2x	class = "table-modal",
106	2x	modalDialog(
107	2x	easyClose = TRUE,
108	2x	div(
109	2x	class = "float-right",
110	2x	type_download_ui_table(ns("modal_downbutton"))
111		),
112	2x	uiOutput(ns("table_out_modal"), class = "table_out_container")
113		)
114		)
115		)
116		})
117
118	4x	type_download_srv_table(
119	4x	id = "modal_downbutton",
120	4x	table_reactive = table_r
121		)
122		})
123		}
124
125		type_download_ui_table <- function(id) {
126	3x	ns <- NS(id)
127	3x	shinyWidgets::dropdownButton(
128	3x	circle = FALSE,
129	3x	icon = icon("download"),
130	3x	inline = TRUE,
131	3x	right = TRUE,
132	3x	label = "",
133	3x	inputId = ns("dwnl"),
134	3x	div(
135	3x	class = "modal-download-ui-table-container",
136	3x	radioButtons(ns("file_format"),
137	3x	label = "File type",
138	3x	choices = c("formatted txt" = ".txt", "csv" = ".csv", "pdf" = ".pdf"),
139		),
140	3x	textInput(ns("file_name"),
141	3x	label = "File name (without extension)",
142	3x	value = paste0("table_", strftime(Sys.time(), format = "%Y%m%d_%H%M%S"))
143		),
144	3x	conditionalPanel(
145	3x	condition = paste0("input['", ns("file_format"), "'] != '.csv'"),
146	3x	div(
147	3x	class = "lock-btn",
148	3x	title = "on / off",
149	3x	shinyWidgets::prettyToggle(
150	3x	ns("pagination_switch"),
151	3x	value = FALSE,
152	3x	label_on = NULL,
153	3x	label_off = NULL,
154	3x	status_on = "default",
155	3x	status_off = "default",
156	3x	outline = FALSE,
157	3x	plain = TRUE,
158	3x	icon_on = icon("fas fa-toggle-off"),
159	3x	icon_off = icon("fas fa-toggle-on"),
160	3x	animation = "pulse"
161		)
162		),
163	3x	div(
164	3x	class = "paginate-ui",
165	3x	shinyWidgets::numericInputIcon(
166	3x	inputId = ns("lpp"),
167	3x	label = "Paginate table:",
168	3x	value = 70,
169	3x	icon = list("lines / page")
170		),
171	3x	uiOutput(ns("lpp_warning"))
172		)
173		),
174	3x	conditionalPanel(
175	3x	condition = paste0("input['", ns("file_name"), "'] != ''"),
176	3x	downloadButton(ns("data_download"), label = character(0), class = "btn-sm w-full")
177		)
178		)
179		)
180		}
181
182		type_download_srv_table <- function(id, table_reactive) {
183	14x	moduleServer(
184	14x	id,
185	14x	function(input, output, session) {
186	14x	observeEvent(input$pagination_switch, {
187	14x	if (input$pagination_switch) {
188	6x	shinyjs::enable("lpp")
189		} else {
190	8x	shinyjs::disable("lpp")
191		}
192		})
193
194	14x	output$lpp_warning <- renderUI({
195	30x	catch_warning <- if (input$file_format != ".csv" && input$pagination_switch) {
196	6x	try(rtables::paginate_table(
197	6x	tt = table_reactive(),
198	6x	lpp = as.numeric(input$lpp)
199		))
200		}
201
202	20x	if (inherits(catch_warning, "try-error")) {
203	1x	helpText(
204	1x	class = "error",
205	1x	icon("triangle-exclamation"),
206	1x	"Maximum lines per page includes the reprinted header. Please enter a numeric value or increase the value."
207		)
208		}
209		})
210
211	14x	output$data_download <- downloadHandler(
212	14x	filename = function() {
213	21x	paste0(input$file_name, input$file_format)
214		},
215	14x	content = function(file) {
216	21x	if (input$file_format == ".txt") {
217	8x	rtables::export_as_txt(
218	8x	x = table_reactive(),
219	8x	file = file,
220	8x	paginate = input$pagination_switch,
221	8x	lpp = if (input$pagination_switch) as.numeric(input$lpp)
222		)
223	13x	} else if (input$file_format == ".csv") {
224	7x	result <- rtables::matrix_form(table_reactive())$strings
225	7x	utils::write.table(
226	7x	x = result,
227	7x	file = file,
228	7x	sep = ",",
229	7x	col.names = FALSE,
230	7x	row.names = TRUE,
231	7x	append = FALSE
232		)
233		} else {
234	6x	rtables::export_as_pdf(
235	6x	tt = table_reactive(),
236	6x	file = file,
237	6x	paginate = input$pagination_switch,
238	6x	lpp = if (input$pagination_switch) as.numeric(input$lpp)
239		)
240		}
241		}
242		)
243		}
244		)
245		}

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

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

1		#' Include `CSS` files from `/inst/css/` package directory to application header
2		#'
3		#' `system.file` should not be used to access files in other packages, it does
4		#' not work with `devtools`. Therefore, we redefine this method in each package
5		#' as needed. Thus, we do not export this method
6		#'
7		#' @param pattern (`character`) pattern of files to be included
8		#'
9		#' @return HTML code that includes `CSS` files
10		#' @keywords internal
11		include_css_files <- function(pattern = "*") {
12	3x	css_files <- list.files(
13	3x	system.file("css", package = "teal.widgets", mustWork = TRUE),
14	3x	pattern = pattern, full.names = TRUE
15		)
16	3x	if (length(css_files) == 0) {
17	!	return(NULL)
18		}
19	3x	return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))
20		}

1		#' Adds Class Small Well and overflow-x property to HTML output element
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' @param ... other arguments to pass to tag object's div attributes.
5		#'
6		#' @details `white_small_well` is intended to be used with [shiny::uiOutput()].
7		#' The overflow-x property is set to auto so that a scroll bar is added
8		#' when the content overflows at the left and right edges of the output window.
9		#' For example, this is useful for displaying wide tables.
10		#'
11		#' @return An HTML output element with class Small Well and overflow-x property
12		#' @export
13		#'
14		#' @examples
15		#'
16		#' white_small_well(shiny::htmlOutput("summary"))
17		white_small_well <- function(...) {
18	!	shiny::tagList(
19	!	include_css_files(pattern = "custom"),
20	!	tags$div(
21	!	class = "well well-sm bg-white",
22		...
23		)
24		)
25		}

1		#' Maps the `lengthMenu`selected value property of `DT::datatable` to a Shiny variable.
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' @param dt_name \code{ns()} of `inputId` of the `DT::datatable`
5		#' @param dt_rows \code{ns()} of `inputId` of the variable that holds the current selected value of `lengthMenu`
6		#'
7		#' @name get_dt_rows
8		#'
9		#' @examples
10		#' \dontrun{
11		#' library(shiny)
12		#' # in Shiny UI function
13		#' tagList(
14		#' get_dt_rows(ns("data_table"), ns("dt_rows")),
15		#' ...
16		#' )
17		#'
18		#' # use the input$dt_rows in the Shiny Server function
19		#' if (!is.null(input$dt_rows)) {
20		#' dt_args$options$pageLength <- input$dt_rows
21		#' } # nolint
22		#' do.call(DT::datatable, dt_args)
23		#' }
24		#'
25		#' @export
26		get_dt_rows <- function(dt_name, dt_rows) {
27	!	tags$head(
28	!	tags$script(
29	!	sprintf(
30	!	"$(document).ready(function() {
31	!	$('%s').on('length.dt', function(e, settings, len) {
32	!	Shiny.onInputChange('%s', len);
33		});
34		});",
35	!	paste0("#", dt_name),
36	!	dt_rows
37		)
38		)
39		)
40		}