teal coverage - 59.42%

Files
Source

#' Create a `teal` module for previewing a report
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' This function wraps [teal.reporter::reporter_previewer_ui()] and
#' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be
#' used in `teal` applications.
#'
#' If you are creating a `teal` application using [init()] then this
#' module will be added to your application automatically if any of your `teal_modules`
#' support report generation.
#'
#' @inheritParams teal_modules
#' @param server_args (named `list`)
#'  Arguments passed to [teal.reporter::reporter_previewer_srv()].
#'
#' @return
#' `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer functionality.
#'
#' @export
#'
reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
  checkmate::assert_string(label)
  checkmate::assert_list(server_args, names = "named")
  checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))

  message("Initializing reporter_previewer_module")

  srv <- function(id, reporter, ...) {
    teal.reporter::reporter_previewer_srv(id, reporter, ...)
  }

  ui <- function(id, ...) {
    teal.reporter::reporter_previewer_ui(id, ...)
  }

  module <- module(
    label = "temporary label",
    server = srv, ui = ui,
    server_args = server_args, ui_args = list(), datanames = NULL
  )
  # Module is created with a placeholder label and the label is changed later.
  # This is to prevent another module being labeled "Report previewer".
  class(module) <- c(class(module), "teal_module_previewer")
  module$label <- label
  attr(module, "teal_bookmarkable") <- TRUE
  module
}

#' Get client timezone
#'
#' User timezone in the browser may be different to the one on the server.
#' This script can be run to register a `shiny` input which contains information about the timezone in the browser.
#'
#' @param ns (`function`) namespace function passed from the `session` object in the `shiny` server.
#'  For `shiny` modules this will allow for proper name spacing of the registered input.
#'
#' @return `NULL`, invisibly.
#'
#' @keywords internal
#'
get_client_timezone <- function(ns) {
  script <- sprintf(
    "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",
    ns("timezone")
  )
  shinyjs::runjs(script) # function does not return anything
  invisible(NULL)
}

#' Resolve the expected bootstrap theme
#' @noRd
#' @keywords internal
get_teal_bs_theme <- function() {
  bs_theme <- getOption("teal.bs_theme")

  if (is.null(bs_theme)) {
    return(NULL)
  }

  if (!checkmate::test_class(bs_theme, "bs_theme")) {
    warning(
      "Assertion on 'teal.bs_theme' option value failed: ",
      checkmate::check_class(bs_theme, "bs_theme"),
      ". The default Shiny Bootstrap theme will be used."
    )
    return(NULL)
  }

  bs_theme
}

#' Return parentnames along with datanames.
#' @noRd
#' @keywords internal
.include_parent_datanames <- function(datanames, join_keys) {
  ordered_datanames <- datanames
  for (i in datanames) {
    parents <- character(0)
    while (length(i) > 0) {
      parent_i <- teal.data::parent(join_keys, i)
      parents <- c(parent_i, parents)
      i <- parent_i
    }
    ordered_datanames <- c(parents, ordered_datanames)
  }
  unique(ordered_datanames)
}

#' Return topologicaly sorted datanames
#' @noRd
#' @keywords internal
.topologically_sort_datanames <- function(datanames, join_keys) {
  datanames_with_parents <- .include_parent_datanames(datanames, join_keys)
  intersect(datanames, datanames_with_parents)
}

#' Create a `FilteredData`
#'
#' Create a `FilteredData` object from a `teal_data` object.
#'
#' @param x (`teal_data`) object
#' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)`
#' @return A `FilteredData` object.
#' @keywords internal
teal_data_to_filtered_data <- function(x, datanames = ls(teal.code::get_env(x))) {
  checkmate::assert_class(x, "teal_data")
  checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)
  # Otherwise, FilteredData will be created in the modules' scope later
  teal.slice::init_filtered_data(
    x = Filter(
      length,
      sapply(datanames, function(dn) x[[dn]], simplify = FALSE)
    ),
    join_keys = teal.data::join_keys(x)
  )
}


#' Template function for `TealReportCard` creation and customization
#'
#' This function generates a report card with a title,
#' an optional description, and the option to append the filter state list.
#'
#' @param title (`character(1)`) title of the card (unless overwritten by label)
#' @param label (`character(1)`) label provided by the user when adding the card
#' @param description (`character(1)`) optional, additional description
#' @param with_filter (`logical(1)`) flag indicating to add filter state
#' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation
#' of the filter state in the report
#'
#' @return (`TealReportCard`) populated with a title, description and filter state.
#'
#' @export
report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
  checkmate::assert_string(title)
  checkmate::assert_string(label)
  checkmate::assert_string(description, null.ok = TRUE)
  checkmate::assert_flag(with_filter)
  checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")

  card <- teal::TealReportCard$new()
  title <- if (label == "") title else label
  card$set_name(title)
  card$append_text(title, "header2")
  if (!is.null(description)) card$append_text(description, "header3")
  if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
  card
}


#' Check `datanames` in modules
#'
#' These functions check if specified `datanames` in modules match those in the data object,
#' returning error messages or `TRUE` for successful validation. Two functions return error message
#' in different forms:
#' - `check_modules_datanames` returns `character(1)` for basic assertion usage
#' - `check_modules_datanames_html` returns `shiny.tag.list` to display it in the app.
#'
#' @param modules (`teal_modules`) object
#' @param datanames (`character`) names of datasets available in the `data` object
#'
#' @return `TRUE` if validation passes, otherwise `character(1)` or `shiny.tag.list`
#' @keywords internal
check_modules_datanames <- function(modules, datanames) {
  out <- check_modules_datanames_html(modules, datanames)
  if (inherits(out, "shiny.tag.list")) {
    out_with_ticks <- gsub("<code>|</code>", "`", toString(out))
    out_text <- gsub("<[^<>]+>", "", toString(out_with_ticks))
    trimws(gsub("[[:space:]]+", " ", out_text))
  } else {
    out
  }
}

#' @rdname check_modules_datanames
check_modules_datanames_html <- function(modules,
                                         datanames) {
  check_datanames <- check_modules_datanames_recursive(modules, datanames)
  show_module_info <- inherits(modules, "teal_modules") # used in two contexts - module and app
  if (!length(check_datanames)) {
    return(TRUE)
  }
  shiny::tagList(
    lapply(
      check_datanames,
      function(mod) {
        tagList(
          tags$span(
            tags$span(if (length(mod$missing_datanames) == 1) "Dataset" else "Datasets"),
            to_html_code_list(mod$missing_datanames),
            tags$span(
              paste0(
                if (length(mod$missing_datanames) > 1) "are missing" else "is missing",
                if (show_module_info) sprintf(" for module '%s'.", mod$label) else "."
              )
            )
          ),
          if (length(datanames) >= 1) {
            tagList(
              tags$span(if (length(datanames) == 1) "Dataset" else "Datasets"),
              tags$span("available in data:"),
              tagList(
                tags$span(
                  to_html_code_list(datanames),
                  tags$span(".", .noWS = "outside"),
                  .noWS = c("outside")
                )
              )
            )
          } else {
            tags$span("No datasets are available in data.")
          },
          tags$br(.noWS = "before")
        )
      }
    )
  )
}

#' Recursively checks modules and returns list for every datanames mismatch between module and data
#' @noRd
check_modules_datanames_recursive <- function(modules, datanames) { # nolint: object_name_length
  checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
  checkmate::assert_character(datanames)
  if (inherits(modules, "teal_modules")) {
    unlist(
      lapply(modules$children, check_modules_datanames_recursive, datanames = datanames),
      recursive = FALSE
    )
  } else {
    missing_datanames <- setdiff(modules$datanames, c("all", datanames))
    if (length(missing_datanames)) {
      list(list(
        label = modules$label,
        missing_datanames = missing_datanames
      ))
    }
  }
}

#' Convert character vector to html code separated with commas and "and"
#' @noRd
to_html_code_list <- function(x) {
  checkmate::assert_character(x)
  do.call(
    tagList,
    lapply(seq_along(x), function(.ix) {
      tagList(
        tags$code(x[.ix]),
        if (.ix != length(x)) {
          if (.ix == length(x) - 1) tags$span(" and ") else tags$span(", ", .noWS = "before")
        }
      )
    })
  )
}


#' Check `datanames` in filters
#'
#' This function checks whether `datanames` in filters correspond to those in `data`,
#' returning character vector with error messages or `TRUE` if all checks pass.
#'
#' @param filters (`teal_slices`) object
#' @param datanames (`character`) names of datasets available in the `data` object
#'
#' @return A `character(1)` containing error message or TRUE if validation passes.
#' @keywords internal
check_filter_datanames <- function(filters, datanames) {
  checkmate::assert_class(filters, "teal_slices")
  checkmate::assert_character(datanames)

  # check teal_slices against datanames
  out <- unlist(sapply(
    filters, function(filter) {
      dataname <- shiny::isolate(filter$dataname)
      if (!dataname %in% datanames) {
        sprintf(
          "- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)",
          shiny::isolate(filter$id),
          dQuote(dataname, q = FALSE),
          toString(dQuote(datanames, q = FALSE))
        )
      }
    }
  ))


  if (length(out)) {
    paste(out, collapse = "\n")
  } else {
    TRUE
  }
}

#' Function for validating the title parameter of `teal::init`
#'
#' Checks if the input of the title from `teal::init` will create a valid title and favicon tag.
#' @param shiny_tag (`shiny.tag`) Object to validate for a valid title.
#' @keywords internal
validate_app_title_tag <- function(shiny_tag) {
  checkmate::assert_class(shiny_tag, "shiny.tag")
  checkmate::assert_true(shiny_tag$name == "head")
  child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name")
  checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags")
  rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel
  checkmate::assert_subset(
    rel_attr,
    c("icon", "shortcut icon"),
    .var.name = "Link tag's rel attribute",
    empty.ok = FALSE
  )
}

#' Build app title with favicon
#'
#' A helper function to create the browser title along with a logo.
#'
#' @param title (`character`) The browser title for the `teal` app.
#' @param favicon (`character`) The path for the icon for the title.
#' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/`
#'
#' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app.
#' @export
build_app_title <- function(
    title = "teal app",
    favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
  checkmate::assert_string(title, null.ok = TRUE)
  checkmate::assert_string(favicon, null.ok = TRUE)
  tags$head(
    tags$title(title),
    tags$link(
      rel = "icon",
      href = favicon,
      sizes = "any"
    )
  )
}

#' Application ID
#'
#' Creates App ID used to match filter snapshots to application.
#'
#' Calculate app ID that will be used to stamp filter state snapshots.
#' App ID is a hash of the app's data and modules.
#' See "transferring snapshots" section in ?snapshot.
#'
#' @param data (`teal_data` or `teal_data_module`) as accepted by `init`
#' @param modules (`teal_modules`) object as accepted by `init`
#'
#' @return A single character string.
#'
#' @keywords internal
create_app_id <- function(data, modules) {
  checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
  checkmate::assert_class(modules, "teal_modules")

  data <- if (inherits(data, "teal_data")) {
    as.list(teal.code::get_env(data))
  } else if (inherits(data, "teal_data_module")) {
    deparse1(body(data$server))
  }
  modules <- lapply(modules, defunction)

  rlang::hash(list(data = data, modules = modules))
}

#' Go through list and extract bodies of encountered functions as string, recursively.
#' @keywords internal
#' @noRd
defunction <- function(x) {
  if (is.list(x)) {
    lapply(x, defunction)
  } else if (is.function(x)) {
    deparse1(body(x))
  } else {
    x
  }
}

#' Get unique labels
#'
#' Get unique labels for the modules to avoid namespace conflicts.
#'
#' @param labels (`character`) vector of labels
#'
#' @return (`character`) vector of unique labels
#'
#' @keywords internal
get_unique_labels <- function(labels) {
  make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
}

#' Remove ANSI escape sequences from a string
#' @noRd
strip_style <- function(string) {
  checkmate::assert_string(string)

  gsub(
    "(?:(?:\\x{001b}\\[)|\\x{009b})(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])|\\x{001b}[A-M]",
    "",
    string,
    perl = TRUE,
    useBytes = TRUE
  )
}

setOldClass("teal_module")
setOldClass("teal_modules")

#' Create `teal_module` and `teal_modules` objects
#'
#' @description
#' `r lifecycle::badge("stable")`
#' Create a nested tab structure to embed modules in a `teal` application.
#'
#' @details
#' `module()` creates an instance of a `teal_module` that can be placed in a `teal` application.
#' `modules()` shapes the structure of a the application by organizing `teal_module` within the navigation panel.
#' It wraps `teal_module` and `teal_modules` objects in a `teal_modules` object,
#' which results in a nested structure corresponding to the nested tabs in the final application.
#'
#' Note that for `modules()` `label` comes after `...`, so it must be passed as a named argument,
#' otherwise it will be captured by `...`.
#'
#' The labels `"global_filters"` and `"Report previewer"` are reserved
#' because they are used by the `mapping` argument of [teal_slices()]
#' and the report previewer module [reporter_previewer_module()], respectively.
#'
#' # Restricting datasets used by `teal_module`:
#' The `datanames` argument controls which datasets are used by the module’s server. These datasets,
#' passed via server's `data` argument, are the only ones shown in the module's tab.
#'
#' When `datanames` is set to `"all"`, all datasets in the data object are treated as relevant.
#' However, this may include unnecessary datasets, such as:
#' -	Proxy variables for column modifications
#' -	Temporary datasets used to create final versions
#' -	Connection objects
#'
#' To exclude irrelevant datasets, use the [set_datanames()] function to change `datanames` from
#' `"all"` to specific names. Trying to modify non-`"all"` values with [set_datanames()] will result
#' in a warning. Datasets with names starting with . are ignored globally unless explicitly listed
#' in `datanames`.
#'
#' # `datanames` with `transformers`
#' When transformers are specified, their `datanames` are added to the module’s `datanames`, which
#' changes the behavior as follows:
#' - If `module(datanames)` is `NULL` and the `transformers` have defined `datanames`, the sidebar
#'   will appear showing the `transformers`' datasets, instead of being hidden.
#' - If `module(datanames)` is set to specific values and any `transformer` has `datanames = "all"`,
#'   the module may receive extra datasets that could be unnecessary
#'
#' @param label (`character(1)`) Label shown in the navigation item for the module or module group.
#'   For `modules()` defaults to `"root"`. See `Details`.
#' @param server (`function`) `shiny` module with following arguments:
#'  - `id` - `teal` will set proper `shiny` namespace for this module (see [shiny::moduleServer()]).
#'  - `input`, `output`, `session` - (optional; not recommended) When provided, then [shiny::callModule()]
#'    will be used to call a module. From `shiny` 1.5.0, the recommended way is to use
#'    [shiny::moduleServer()] instead which doesn't require these arguments.
#'  - `data` (optional) When provided, the module will be called with `teal_data` object (i.e. a list of
#'    reactive (filtered) data specified in the `filters` argument) as the value of this argument.
#'  - `datasets` (optional) When provided, the module will be called with `FilteredData` object as the
#'    value of this argument. (See [`teal.slice::FilteredData`]).
#'  - `reporter` (optional) When provided, the module will be called with `Reporter` object as the value
#'    of this argument. (See [`teal.reporter::Reporter`]).
#'  - `filter_panel_api` (optional) When provided, the module will be called with `FilterPanelAPI` object
#'    as the value of this argument. (See [`teal.slice::FilterPanelAPI`]).
#'  - `...` (optional) When provided, `server_args` elements will be passed to the module named argument
#'    or to the `...`.
#' @param ui (`function`) `shiny` UI module function with following arguments:
#'  - `id` - `teal` will set proper `shiny` namespace for this module.
#'  - `...` (optional) When provided, `ui_args` elements will be passed to the module named argument
#'    or to the `...`.
#' @param filters (`character`) Deprecated. Use `datanames` instead.
#' @param datanames (`character`) Names of the datasets relevant to the item.
#' There are 2 reserved values that have specific behaviors:
#' - The keyword `"all"` includes all datasets available in the data passed to the teal application.
#' - `NULL` hides the sidebar panel completely.
#' - If `transformers` are specified, their `datanames` are automatically added to this `datanames`
#'   argument.
#' @param server_args (named `list`) with additional arguments passed on to the server function.
#' @param ui_args (named `list`) with additional arguments passed on to the UI function.
#' @param x (`teal_module` or `teal_modules`) Object to format/print.
#' @param indent (`integer(1)`) Indention level; each nested element is indented one level more.
#' @param transformers (`list` of `teal_data_module`) that will be applied to transform the data.
#' Each transform module UI will appear in the `teal`'s sidebar panel.
#' Transformers' `datanames` are added to the `datanames`. See [teal_transform_module()].
#'
#' @param ...
#' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab.
#' - For `format()` and `print()`: Arguments passed to other methods.
#'
#' @return
#' `module()` returns an object of class `teal_module`.
#'
#' `modules()` returns a `teal_modules` object which contains following fields:
#' - `label`: taken from the `label` argument.
#' - `children`: a list containing objects passed in `...`. List elements are named after
#' their `label` attribute converted to a valid `shiny` id.
#'
#' @name teal_modules
#' @aliases teal_module
#'
#' @examples
#' library(shiny)
#'
#' module_1 <- module(
#'   label = "a module",
#'   server = function(id, data) {
#'     moduleServer(
#'       id,
#'       module = function(input, output, session) {
#'         output$data <- renderDataTable(data()[["iris"]])
#'       }
#'     )
#'   },
#'   ui = function(id) {
#'     ns <- NS(id)
#'     tagList(dataTableOutput(ns("data")))
#'   },
#'   datanames = "all"
#' )
#'
#' module_2 <- module(
#'   label = "another module",
#'   server = function(id) {
#'     moduleServer(
#'       id,
#'       module = function(input, output, session) {
#'         output$text <- renderText("Another Module")
#'       }
#'     )
#'   },
#'   ui = function(id) {
#'     ns <- NS(id)
#'     tagList(textOutput(ns("text")))
#'   },
#'   datanames = NULL
#' )
#'
#' modules <- modules(
#'   label = "modules",
#'   modules(
#'     label = "nested modules",
#'     module_1
#'   ),
#'   module_2
#' )
#'
#' app <- init(
#'   data = teal_data(iris = iris),
#'   modules = modules
#' )
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#' @rdname teal_modules
#' @export
#'
module <- function(label = "module",
                   server = function(id, data, ...) moduleServer(id, function(input, output, session) NULL),
                   ui = function(id, ...) tags$p(paste0("This module has no UI (id: ", id, " )")),
                   filters,
                   datanames = "all",
                   server_args = NULL,
                   ui_args = NULL,
                   transformers = list()) {
  # argument checking (independent)
  ## `label`
  checkmate::assert_string(label)
  if (label == "global_filters") {
    stop(
      sprintf("module(label = \"%s\", ...\n  ", label),
      "Label 'global_filters' is reserved in teal. Please change to something else.",
      call. = FALSE
    )
  }
  if (label == "Report previewer") {
    stop(
      sprintf("module(label = \"%s\", ...\n  ", label),
      "Label 'Report previewer' is reserved in teal. Please change to something else.",
      call. = FALSE
    )
  }

  ## server
  checkmate::assert_function(server)
  server_formals <- names(formals(server))
  if (!(
    "id" %in% server_formals ||
      all(c("input", "output", "session") %in% server_formals)
  )) {
    stop(
      "\nmodule() `server` argument requires a function with following arguments:",
      "\n - id - `teal` will set proper `shiny` namespace for this module.",
      "\n - input, output, session (not recommended) - then `shiny::callModule` will be used to call a module.",
      "\n\nFollowing arguments can be used optionaly:",
      "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",
      "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",
      "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",
      "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",
      "\n - `...` server_args elements will be passed to the module named argument or to the `...`"
    )
  }
  if ("datasets" %in% server_formals) {
    warning(
      sprintf("Called from module(label = \"%s\", ...)\n  ", label),
      "`datasets` argument in the server is deprecated and will be removed in the next release. ",
      "Please use `data` instead.",
      call. = FALSE
    )
  }


  ## UI
  checkmate::assert_function(ui)
  ui_formals <- names(formals(ui))
  if (!"id" %in% ui_formals) {
    stop(
      "\nmodule() `ui` argument requires a function with following arguments:",
      "\n - id - `teal` will set proper `shiny` namespace for this module.",
      "\n\nFollowing arguments can be used optionally:",
      "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"
    )
  }
  if (any(c("data", "datasets") %in% ui_formals)) {
    stop(
      sprintf("Called from module(label = \"%s\", ...)\n  ", label),
      "UI with `data` or `datasets` argument is no longer accepted.\n  ",
      "If some UI inputs depend on data, please move the logic to your server instead.\n  ",
      "Possible solutions are renderUI() or updateXyzInput() functions."
    )
  }


  ## `filters`
  if (!missing(filters)) {
    datanames <- filters
    msg <-
      "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."
    warning(msg)
  }

  ## `datanames` (also including deprecated `filters`)
  # please note a race condition between datanames set when filters is not missing and data arg in server function
  if (!is.element("data", server_formals) && !is.null(datanames)) {
    message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
    datanames <- NULL
  }
  checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)

  ## `server_args`
  checkmate::assert_list(server_args, null.ok = TRUE, names = "named")
  srv_extra_args <- setdiff(names(server_args), server_formals)
  if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
    stop(
      "\nFollowing `server_args` elements have no equivalent in the formals of the server:\n",
      paste(paste(" -", srv_extra_args), collapse = "\n"),
      "\n\nUpdate the server arguments by including above or add `...`"
    )
  }

  ## `ui_args`
  checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")
  ui_extra_args <- setdiff(names(ui_args), ui_formals)
  if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
    stop(
      "\nFollowing `ui_args` elements have no equivalent in the formals of UI:\n",
      paste(paste(" -", ui_extra_args), collapse = "\n"),
      "\n\nUpdate the UI arguments by including above or add `...`"
    )
  }

  ## `transformers`
  if (inherits(transformers, "teal_transform_module")) {
    transformers <- list(transformers)
  }
  checkmate::assert_list(transformers, types = "teal_transform_module")
  transformer_datanames <- unlist(lapply(transformers, attr, "datanames"))
  combined_datanames <- if (identical(datanames, "all")) {
    "all"
  } else {
    union(datanames, transformer_datanames)
  }

  structure(
    list(
      label = label,
      server = server,
      ui = ui,
      datanames = combined_datanames,
      server_args = server_args,
      ui_args = ui_args,
      transformers = transformers
    ),
    class = "teal_module"
  )
}

#' @rdname teal_modules
#' @export
#'
modules <- function(..., label = "root") {
  checkmate::assert_string(label)
  submodules <- list(...)
  if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
    stop(
      "The only character argument to modules() must be 'label' and it must be named, ",
      "change modules('lab', ...) to modules(label = 'lab', ...)"
    )
  }

  checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
  # name them so we can more easily access the children
  # beware however that the label of the submodules should not be changed as it must be kept synced
  labels <- vapply(submodules, function(submodule) submodule$label, character(1))
  names(submodules) <- get_unique_labels(labels)
  structure(
    list(
      label = label,
      children = submodules
    ),
    class = "teal_modules"
  )
}

# printing methods ----

#' @rdname teal_modules
#' @export
format.teal_module <- function(x, indent = 0, ...) {
  paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, "\n", collapse = "")
}


#' @rdname teal_modules
#' @export
print.teal_module <- function(x, ...) {
  cat(format(x, ...))
  invisible(x)
}


#' @rdname teal_modules
#' @export
format.teal_modules <- function(x, indent = 0, ...) {
  paste(
    c(
      paste0(rep(" ", indent), "+ ", x$label, "\n"),
      unlist(lapply(x$children, format, indent = indent + 1, ...))
    ),
    collapse = ""
  )
}

#' @param modules (`teal_module` or `teal_modules`)
#' @rdname teal_modules
#' @examples
#' # change the module's datanames
#' set_datanames(module(datanames = "all"), "a")
#'
#' # change modules' datanames
#' set_datanames(
#'   modules(
#'     module(datanames = "all"),
#'     module(datanames = "a")
#'   ),
#'   "b"
#' )
#' @export
set_datanames <- function(modules, datanames) {
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  if (inherits(modules, "teal_modules")) {
    modules$children <- lapply(modules$children, set_datanames, datanames)
  } else {
    if (identical(modules$datanames, "all")) {
      modules$datanames <- datanames
    } else {
      warning(
        "Not possible to modify datanames of the module ", modules$label,
        ". set_datanames() can only change datanames if it was set to \"all\".",
        call. = FALSE
      )
    }
  }
  modules
}

#' @rdname teal_modules
#' @export
print.teal_modules <- print.teal_module


# utilities ----
## subset or modify modules ----

#' Append a `teal_module` to `children` of a `teal_modules` object
#' @keywords internal
#' @param modules (`teal_modules`)
#' @param module (`teal_module`) object to be appended onto the children of `modules`
#' @return A `teal_modules` object with `module` appended.
append_module <- function(modules, module) {
  checkmate::assert_class(modules, "teal_modules")
  checkmate::assert_class(module, "teal_module")
  modules$children <- c(modules$children, list(module))
  labels <- vapply(modules$children, function(submodule) submodule$label, character(1))
  names(modules$children) <- get_unique_labels(labels)
  modules
}

#' Extract/Remove module(s) of specific class
#'
#' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`.
#'
#' @param modules (`teal_modules`)
#' @param class The class name of `teal_module` to be extracted or dropped.
#' @keywords internal
#' @return
#' - For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`.
#' - For `drop_module`, the opposite, which is all `teal_modules` of  class other than `class`.
#' @rdname module_management
extract_module <- function(modules, class) {
  if (inherits(modules, class)) {
    modules
  } else if (inherits(modules, "teal_module")) {
    NULL
  } else if (inherits(modules, "teal_modules")) {
    Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class))
  }
}

#' @keywords internal
#' @return `teal_modules`
#' @rdname module_management
drop_module <- function(modules, class) {
  if (inherits(modules, class)) {
    NULL
  } else if (inherits(modules, "teal_module")) {
    modules
  } else if (inherits(modules, "teal_modules")) {
    do.call(
      "modules",
      c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label)
    )
  }
}

## read modules ----

#' Does the object make use of the `arg`
#'
#' @param modules (`teal_module` or `teal_modules`) object
#' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.
#' @return `logical` whether the object makes use of `arg`.
#' @rdname is_arg_used
#' @keywords internal
is_arg_used <- function(modules, arg) {
  checkmate::assert_string(arg)
  if (inherits(modules, "teal_modules")) {
    any(unlist(lapply(modules$children, is_arg_used, arg)))
  } else if (inherits(modules, "teal_module")) {
    is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg)
  } else if (is.function(modules)) {
    isTRUE(arg %in% names(formals(modules)))
  } else {
    stop("is_arg_used function not implemented for this object")
  }
}


#' Get module depth
#'
#' Depth starts at 0, so a single `teal.module` has depth 0.
#' Nesting it increases overall depth by 1.
#'
#' @inheritParams init
#' @param depth optional integer determining current depth level
#'
#' @return Depth level for given module.
#' @keywords internal
modules_depth <- function(modules, depth = 0L) {
  checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
  checkmate::assert_int(depth, lower = 0)
  if (inherits(modules, "teal_modules")) {
    max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))
  } else {
    depth
  }
}

#' Retrieve labels from `teal_modules`
#'
#' @param modules (`teal_modules`)
#' @return A `list` containing the labels of the modules. If the modules are nested,
#' the function returns a nested `list` of labels.
#' @keywords internal
module_labels <- function(modules) {
  if (inherits(modules, "teal_modules")) {
    lapply(modules$children, module_labels)
  } else {
    modules$label
  }
}

#' Retrieve `teal_bookmarkable` attribute from `teal_modules`
#'
#' @param modules (`teal_modules` or `teal_module`) object
#' @return named list of the same structure as `modules` with `TRUE` or `FALSE` values indicating
#' whether the module is bookmarkable.
#' @keywords internal
modules_bookmarkable <- function(modules) {
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  if (inherits(modules, "teal_modules")) {
    setNames(
      lapply(modules$children, modules_bookmarkable),
      vapply(modules$children, `[[`, "label", FUN.VALUE = character(1))
    )
  } else {
    attr(modules, "teal_bookmarkable", exact = TRUE)
  }
}

#' Validate that dataset has a minimum number of observations
#'
#' `r lifecycle::badge("stable")`
#'
#' This function is a wrapper for `shiny::validate`.
#'
#' @param x (`data.frame`)
#' @param min_nrow (`numeric(1)`) Minimum allowed number of rows in `x`.
#' @param complete (`logical(1)`) Flag specifying whether to check only complete cases. Defaults to `FALSE`.
#' @param allow_inf (`logical(1)`) Flag specifying whether to allow infinite values. Defaults to `TRUE`.
#' @param msg (`character(1)`) Additional message to display alongside the default message.
#'
#' @export
#'
#' @examples
#' library(teal)
#' ui <- fluidPage(
#'   sliderInput("len", "Max Length of Sepal",
#'     min = 4.3, max = 7.9, value = 5
#'   ),
#'   plotOutput("plot")
#' )
#'
#' server <- function(input, output) {
#'   output$plot <- renderPlot({
#'     iris_df <- iris[iris$Sepal.Length <= input$len, ]
#'     validate_has_data(
#'       iris_df,
#'       min_nrow = 10,
#'       complete = FALSE,
#'       msg = "Please adjust Max Length of Sepal"
#'     )
#'
#'     hist(iris_df$Sepal.Length, breaks = 5)
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
validate_has_data <- function(x,
                              min_nrow = NULL,
                              complete = FALSE,
                              allow_inf = TRUE,
                              msg = NULL) {
  checkmate::assert_string(msg, null.ok = TRUE)
  checkmate::assert_data_frame(x)
  if (!is.null(min_nrow)) {
    if (complete) {
      complete_index <- stats::complete.cases(x)
      validate(need(
        sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,
        paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
      ))
    } else {
      validate(need(
        nrow(x) >= min_nrow,
        paste(
          c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
          collapse = "\n"
        )
      ))
    }

    if (!allow_inf) {
      validate(need(
        all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))),
        "Dataframe contains Inf values which is not allowed."
      ))
    }
  }
}

#' Validate that dataset has unique rows for key variables
#'
#' `r lifecycle::badge("stable")`
#'
#' This function is a wrapper for `shiny::validate`.
#'
#' @param x (`data.frame`)
#' @param key (`character`) Vector of ID variables from `x` that identify unique records.
#'
#' @export
#'
#' @examples
#' iris$id <- rep(1:50, times = 3)
#' ui <- fluidPage(
#'   selectInput(
#'     inputId = "species",
#'     label = "Select species",
#'     choices = c("setosa", "versicolor", "virginica"),
#'     selected = "setosa",
#'     multiple = TRUE
#'   ),
#'   plotOutput("plot")
#' )
#' server <- function(input, output) {
#'   output$plot <- renderPlot({
#'     iris_f <- iris[iris$Species %in% input$species, ]
#'     validate_one_row_per_id(iris_f, key = c("id"))
#'
#'     hist(iris_f$Sepal.Length, breaks = 5)
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
  validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
}

#' Validates that vector includes all expected values
#'
#' `r lifecycle::badge("stable")`
#'
#' This function is a wrapper for `shiny::validate`.
#'
#' @param x Vector of values to test.
#' @param choices Vector to test against.
#' @param msg (`character(1)`) Error message to display if some elements of `x` are not elements of `choices`.
#'
#' @export
#'
#' @examples
#' ui <- fluidPage(
#'   selectInput(
#'     "species",
#'     "Select species",
#'     choices = c("setosa", "versicolor", "virginica", "unknown species"),
#'     selected = "setosa",
#'     multiple = FALSE
#'   ),
#'   verbatimTextOutput("summary")
#' )
#'
#' server <- function(input, output) {
#'   output$summary <- renderPrint({
#'     validate_in(input$species, iris$Species, "Species does not exist.")
#'     nrow(iris[iris$Species == input$species, ])
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
validate_in <- function(x, choices, msg) {
  validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg))
}

#' Validates that vector has length greater than 0
#'
#' `r lifecycle::badge("stable")`
#'
#' This function is a wrapper for `shiny::validate`.
#'
#' @param x vector
#' @param msg message to display
#'
#' @export
#'
#' @examples
#' data <- data.frame(
#'   id = c(1:10, 11:20, 1:10),
#'   strata = rep(c("A", "B"), each = 15)
#' )
#' ui <- fluidPage(
#'   selectInput("ref1", "Select strata1 to compare",
#'     choices = c("A", "B", "C"), selected = "A"
#'   ),
#'   selectInput("ref2", "Select strata2 to compare",
#'     choices = c("A", "B", "C"), selected = "B"
#'   ),
#'   verbatimTextOutput("arm_summary")
#' )
#'
#' server <- function(input, output) {
#'   output$arm_summary <- renderText({
#'     sample_1 <- data$id[data$strata == input$ref1]
#'     sample_2 <- data$id[data$strata == input$ref2]
#'
#'     validate_has_elements(sample_1, "No subjects in strata1.")
#'     validate_has_elements(sample_2, "No subjects in strata2.")
#'
#'     paste0(
#'       "Number of samples in: strata1=", length(sample_1),
#'       " comparions strata2=", length(sample_2)
#'     )
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
validate_has_elements <- function(x, msg) {
  validate(need(length(x) > 0, msg))
}

#' Validates no intersection between two vectors
#'
#' `r lifecycle::badge("stable")`
#'
#' This function is a wrapper for `shiny::validate`.
#'
#' @param x vector
#' @param y vector
#' @param msg (`character(1)`) message to display if `x` and `y` intersect
#'
#' @export
#'
#' @examples
#' data <- data.frame(
#'   id = c(1:10, 11:20, 1:10),
#'   strata = rep(c("A", "B", "C"), each = 10)
#' )
#'
#' ui <- fluidPage(
#'   selectInput("ref1", "Select strata1 to compare",
#'     choices = c("A", "B", "C"),
#'     selected = "A"
#'   ),
#'   selectInput("ref2", "Select strata2 to compare",
#'     choices = c("A", "B", "C"),
#'     selected = "B"
#'   ),
#'   verbatimTextOutput("summary")
#' )
#'
#' server <- function(input, output) {
#'   output$summary <- renderText({
#'     sample_1 <- data$id[data$strata == input$ref1]
#'     sample_2 <- data$id[data$strata == input$ref2]
#'
#'     validate_no_intersection(
#'       sample_1, sample_2,
#'       "subjects within strata1 and strata2 cannot overlap"
#'     )
#'     paste0(
#'       "Number of subject in: reference treatment=", length(sample_1),
#'       " comparions treatment=", length(sample_2)
#'     )
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
validate_no_intersection <- function(x, y, msg) {
  validate(need(length(intersect(x, y)) == 0, msg))
}


#' Validates that dataset contains specific variable
#'
#' `r lifecycle::badge("stable")`
#'
#' This function is a wrapper for `shiny::validate`.
#'
#' @param data (`data.frame`)
#' @param varname (`character(1)`) name of variable to check for in `data`
#' @param msg (`character(1)`) message to display if `data` does not include `varname`
#'
#' @export
#'
#' @examples
#' data <- data.frame(
#'   one = rep("a", length.out = 20),
#'   two = rep(c("a", "b"), length.out = 20)
#' )
#' ui <- fluidPage(
#'   selectInput(
#'     "var",
#'     "Select variable",
#'     choices = c("one", "two", "three", "four"),
#'     selected = "one"
#'   ),
#'   verbatimTextOutput("summary")
#' )
#'
#' server <- function(input, output) {
#'   output$summary <- renderText({
#'     validate_has_variable(data, input$var)
#'     paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
validate_has_variable <- function(data, varname, msg) {
  if (length(varname) != 0) {
    has_vars <- varname %in% names(data)

    if (!all(has_vars)) {
      if (missing(msg)) {
        msg <- sprintf(
          "%s does not have the required variables: %s.",
          deparse(substitute(data)),
          toString(varname[!has_vars])
        )
      }
      validate(need(FALSE, msg))
    }
  }
}

#' Validate that variables has expected number of levels
#'
#' `r lifecycle::badge("stable")`
#'
#' If the number of levels of `x` is less than `min_levels`
#' or greater than `max_levels` the validation will fail.
#' This function is a wrapper for `shiny::validate`.
#'
#' @param x variable name. If `x` is not a factor, the unique values
#'   are treated as levels.
#' @param min_levels cutoff for minimum number of levels of `x`
#' @param max_levels cutoff for maximum number of levels of `x`
#' @param var_name name of variable being validated for use in
#'   validation message
#'
#' @export
#' @examples
#' data <- data.frame(
#'   one = rep("a", length.out = 20),
#'   two = rep(c("a", "b"), length.out = 20),
#'   three = rep(c("a", "b", "c"), length.out = 20),
#'   four = rep(c("a", "b", "c", "d"), length.out = 20),
#'   stringsAsFactors = TRUE
#' )
#' ui <- fluidPage(
#'   selectInput(
#'     "var",
#'     "Select variable",
#'     choices = c("one", "two", "three", "four"),
#'     selected = "one"
#'   ),
#'   verbatimTextOutput("summary")
#' )
#'
#' server <- function(input, output) {
#'   output$summary <- renderText({
#'     validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var)
#'     paste0(
#'       "Levels of selected treatment variable: ",
#'       paste(levels(data[[input$var]]),
#'         collapse = ", "
#'       )
#'     )
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
  x_levels <- if (is.factor(x)) {
    levels(x)
  } else {
    unique(x)
  }

  if (!is.null(min_levels) && !(is.null(max_levels))) {
    validate(need(
      length(x_levels) >= min_levels && length(x_levels) <= max_levels,
      sprintf(
        "%s variable needs minimum %s level(s) and maximum %s level(s).",
        var_name, min_levels, max_levels
      )
    ))
  } else if (!is.null(min_levels)) {
    validate(need(
      length(x_levels) >= min_levels,
      sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
    ))
  } else if (!is.null(max_levels)) {
    validate(need(
      length(x_levels) <= max_levels,
      sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
    ))
  }
}

#' Module to transform `reactive` `teal_data`
#'
#' Module calls multiple [`module_teal_data`] in sequence so that `reactive teal_data` output
#' from one module is handed over to the following module's input.
#'
#' @inheritParams module_teal_data
#' @inheritParams teal_modules
#' @return `reactive` `teal_data`
#'
#'
#' @name module_transform_data
#' @keywords internal
NULL

#' @rdname module_transform_data
ui_transform_data <- function(id, transformers = list(), class = "well") {
  checkmate::assert_string(id)
  checkmate::assert_list(transformers, "teal_transform_module")

  ns <- NS(id)
  labels <- lapply(transformers, function(x) attr(x, "label"))
  ids <- get_unique_labels(labels)
  names(transformers) <- ids

  lapply(
    names(transformers),
    function(name) {
      data_mod <- transformers[[name]]
      wrapper_id <- ns(sprintf("wrapper_%s", name))
      div( # todo: accordion?
        # class .teal_validated changes the color of the boarder on error in ui_validate_reactive_teal_data
        #   For details see tealValidate.js file.
        class = c(class, "teal_validated"),
        title = attr(data_mod, "label"),
        tags$span(
          class = "text-primary mb-4",
          icon("fas fa-square-pen"),
          attr(data_mod, "label")
        ),
        tags$i(
          class = "remove pull-right fa fa-angle-down",
          style = "cursor: pointer;",
          title = "fold/expand transform panel",
          onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", wrapper_id)
        ),
        div(
          id = wrapper_id,
          ui_teal_data(id = ns(name), data_module = transformers[[name]]$ui)
        )
      )
    }
  )
}

#' @rdname module_transform_data
srv_transform_data <- function(id, data, transformers = list(), modules, is_transformer_failed = reactiveValues()) {
  checkmate::assert_string(id)
  assert_reactive(data)
  checkmate::assert_list(transformers, "teal_transform_module")
  checkmate::assert_class(modules, "teal_module")
  labels <- lapply(transformers, function(x) attr(x, "label"))
  ids <- get_unique_labels(labels)
  names(transformers) <- ids
  moduleServer(id, function(input, output, session) {
    logger::log_debug("srv_teal_data_modules initializing.")
    Reduce(
      function(previous_result, name) {
        srv_teal_data(
          id = name,
          data_module = function(id) transformers[[name]]$server(id, previous_result),
          modules = modules,
          is_transformer_failed = is_transformer_failed
        )
      },
      x = names(transformers),
      init = data
    )
  })
}

#' Manage multiple `FilteredData` objects
#'
#' @description
#' Oversee filter states across the entire application.
#'
#' @section Slices global:
#' The key role in maintaining the module-specific filter states is played by the `.slicesGlobal`
#' object. It is a reference class that holds the following fields:
#' - `all_slices` (`reactiveVal`) - reactive value containing all filters registered in an app.
#' - `module_slices_api` (`reactiveValues`) - reactive field containing references to each modules'
#' `FilteredData` object methods. At this moment it is used only in `srv_filter_manager` to display
#' the filter states in a table combining informations from `all_slices` and from
#' `FilteredData$get_available_teal_slices()`.
#'
#' During a session only new filters are added to `all_slices` unless [`module_snapshot_manager`] is
#' used to restore previous state. Filters from `all_slices` can be activated or deactivated in a
#' module which is linked (both ways) by `attr(, "mapping")` so that:
#' - If module's filter is added or removed in its `FilteredData` object, this information is passed
#'   to `SlicesGlobal` which updates `attr(, "mapping")` accordingly.
#' - When mapping changes in a `SlicesGlobal`, filters are set or removed from module's
#'  `FilteredData`.
#'
#' @section Filter manager:
#' Filter-manager is split into two parts:
#' 1. `ui/srv_filter_manager_panel` - Called once for the whole app. This module observes changes in
#' the filters in `slices_global` and displays them in a table utilizing information from `mapping`:
#'   - (`TRUE`) - filter is active in the module
#'   - (`FALSE`) - filter is inactive in the module
#'   - (`NA`) - filter is not available in the module
#' 2. `ui/srv_module_filter_manager` - Called once for each `teal_module`. Handling filter states
#' for of single module and keeping module `FilteredData` consistent with `slices_global`, so that
#' local filters are always reflected in the `slices_global` and its mapping and vice versa.
#'
#'
#' @param id (`character(1)`)
#'  `shiny` module instance id.
#'
#' @param slices_global (`reactiveVal`)
#'  containing `teal_slices`.
#'
#' @param module_fd (`FilteredData`)
#'   Object containing the data to be filtered in a single `teal` module.
#'
#' @return
#' Module returns a `slices_global` (`reactiveVal`) containing a `teal_slices` object with mapping.
#'
#' @encoding UTF-8
#'
#' @name module_filter_manager
#' @rdname module_filter_manager
#'
NULL

#' @rdname module_filter_manager
ui_filter_manager_panel <- function(id) {
  ns <- NS(id)
  tags$button(
    id = ns("show_filter_manager"),
    class = "btn action-button wunder_bar_button",
    title = "View filter mapping",
    suppressMessages(icon("fas fa-grip"))
  )
}

#' @rdname module_filter_manager
#' @keywords internal
srv_filter_manager_panel <- function(id, slices_global) {
  checkmate::assert_string(id)
  checkmate::assert_class(slices_global, ".slicesGlobal")
  moduleServer(id, function(input, output, session) {
    setBookmarkExclude(c("show_filter_manager"))
    observeEvent(input$show_filter_manager, {
      logger::log_debug("srv_filter_manager_panel@1 show_filter_manager button has been clicked.")
      showModal(
        modalDialog(
          ui_filter_manager(session$ns("filter_manager")),
          class = "filter_manager_modal",
          size = "l",
          footer = NULL,
          easyClose = TRUE
        )
      )
    })
    srv_filter_manager("filter_manager", slices_global = slices_global)
  })
}

#' @rdname module_filter_manager
ui_filter_manager <- function(id) {
  ns <- NS(id)
  actionButton(ns("filter_manager"), NULL, icon = icon("fas fa-filter"))
  tags$div(
    class = "filter_manager_content",
    tableOutput(ns("slices_table"))
  )
}

#' @rdname module_filter_manager
srv_filter_manager <- function(id, slices_global) {
  checkmate::assert_string(id)
  checkmate::assert_class(slices_global, ".slicesGlobal")

  moduleServer(id, function(input, output, session) {
    logger::log_debug("filter_manager_srv initializing.")

    # Bookmark slices global with mapping.
    session$onBookmark(function(state) {
      logger::log_debug("filter_manager_srv@onBookmark: storing filter state")
      state$values$filter_state_on_bookmark <- as.list(
        slices_global$all_slices(),
        recursive = TRUE
      )
    })

    bookmarked_slices <- restoreValue(session$ns("filter_state_on_bookmark"), NULL)
    if (!is.null(bookmarked_slices)) {
      logger::log_debug("filter_manager_srv: restoring filter state from bookmark.")
      slices_global$slices_set(bookmarked_slices)
    }

    mapping_table <- reactive({
      # We want this to be reactive on slices_global$all_slices() only as get_available_teal_slices()
      #   is dependent on slices_global$all_slices().
      module_labels <- setdiff(
        names(attr(slices_global$all_slices(), "mapping")),
        "Report previewer"
      )
      isolate({
        mm <- as.data.frame(
          sapply(
            module_labels,
            simplify = FALSE,
            function(module_label) {
              available_slices <- slices_global$module_slices_api[[module_label]]$get_available_teal_slices()
              global_ids <- sapply(slices_global$all_slices(), `[[`, "id", simplify = FALSE)
              module_ids <- sapply(slices_global$slices_get(module_label), `[[`, "id", simplify = FALSE)
              allowed_ids <- vapply(available_slices, `[[`, character(1L), "id")
              active_ids <- global_ids %in% module_ids
              setNames(nm = global_ids, ifelse(global_ids %in% allowed_ids, active_ids, NA))
            }
          ),
          check.names = FALSE
        )
        colnames(mm)[colnames(mm) == "global_filters"] <- "Global filters"

        mm
      })
    })

    output$slices_table <- renderTable(
      expr = {
        logger::log_debug("filter_manager_srv@1 rendering slices_table.")
        mm <- mapping_table()

        # Display logical values as UTF characters.
        mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))
        mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))

        # Display placeholder if no filters defined.
        if (nrow(mm) == 0L) {
          mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)
          rownames(mm) <- ""
        }
        mm
      },
      rownames = TRUE
    )

    mapping_table # for testing purpose
  })
}

#' @rdname module_filter_manager
srv_module_filter_manager <- function(id, module_fd, slices_global) {
  checkmate::assert_string(id)
  assert_reactive(module_fd)
  checkmate::assert_class(slices_global, ".slicesGlobal")

  moduleServer(id, function(input, output, session) {
    logger::log_debug("srv_module_filter_manager initializing for module: { id }.")
    # Track filter global and local states.
    slices_global_module <- reactive({
      slices_global$slices_get(module_label = id)
    })
    slices_module <- reactive(req(module_fd())$get_filter_state())

    module_fd_previous <- reactiveVal(NULL)

    # Set (reactively) available filters for the module.
    obs1 <- observeEvent(module_fd(), priority = 1, {
      logger::log_debug("srv_module_filter_manager@1 setting initial slices for module: { id }.")
      # Filters relevant for the module in module-specific app.
      slices <- slices_global_module()

      # Clean up previous filter states and refresh cache of previous module_fd with current
      if (!is.null(module_fd_previous())) module_fd_previous()$finalize()
      module_fd_previous(module_fd())

      # Setting filter states from slices_global:
      # 1. when app initializes slices_global set to initial filters (specified by app developer)
      # 2. when data reinitializes slices_global reflects latest filter states

      module_fd()$set_filter_state(slices)

      # irrelevant filters are discarded in FilteredData$set_available_teal_slices
      # it means we don't need to subset slices_global$all_slices() from filters refering to irrelevant datasets
      module_fd()$set_available_teal_slices(slices_global$all_slices)

      # this needed in filter_manager_srv
      slices_global$module_slices_api_set(
        id,
        list(
          get_available_teal_slices = module_fd()$get_available_teal_slices(),
          set_filter_state = module_fd()$set_filter_state, # for testing purpose
          get_filter_state = module_fd()$get_filter_state # for testing purpose
        )
      )
    })

    # Update global state and mapping matrix when module filters change.
    obs2 <- observeEvent(slices_module(), priority = 0, {
      this_slices <- slices_module()
      slices_global$slices_append(this_slices) # append new slices to the all_slices list
      mapping_elem <- setNames(nm = id, list(vapply(this_slices, `[[`, character(1L), "id")))
      slices_global$slices_active(mapping_elem)
    })

    obs3 <- observeEvent(slices_global_module(), {
      global_vs_module <- setdiff_teal_slices(slices_global_module(), slices_module())
      module_vs_global <- setdiff_teal_slices(slices_module(), slices_global_module())
      if (length(global_vs_module) || length(module_vs_global)) {
        # Comment: (Nota Bene) Normally new filters for a module are added through module-filter-panel, and slices
        # global are updated automatically so slices_module -> slices_global_module are equal.
        # this if is valid only when a change is made on the global level so the change needs to be propagated down
        # to the module (for example through snapshot manager). If it happens both slices are different
        logger::log_debug("srv_module_filter_manager@3 (N.B.) global state has changed for a module:{ id }.")
        module_fd()$clear_filter_states()
        module_fd()$set_filter_state(slices_global_module())
      }
    })

    slices_module # returned for testing purpose
  })
}

#' @importFrom shiny reactiveVal reactiveValues
methods::setOldClass("reactiveVal")
methods::setOldClass("reactivevalues")

#' @importFrom methods new
#' @rdname module_filter_manager
.slicesGlobal <- methods::setRefClass(".slicesGlobal", # nolint: object_name.
  fields = list(
    all_slices = "reactiveVal",
    module_slices_api = "reactivevalues"
  ),
  methods = list(
    initialize = function(slices = teal_slices(), module_labels) {
      shiny::isolate({
        checkmate::assert_class(slices, "teal_slices")
        # needed on init to not mix "global_filters" with module-specific-slots
        if (isTRUE(attr(slices, "module_specific"))) {
          old_mapping <- attr(slices, "mapping")
          new_mapping <- sapply(module_labels, simplify = FALSE, function(module_label) {
            unique(unlist(old_mapping[c(module_label, "global_filters")]))
          })
          attr(slices, "mapping") <- new_mapping
        }
        .self$all_slices <<- shiny::reactiveVal(slices)
        .self$module_slices_api <<- shiny::reactiveValues()
        .self$slices_append(slices)
        .self$slices_active(attr(slices, "mapping"))
        invisible(.self)
      })
    },
    is_module_specific = function() {
      isTRUE(attr(.self$all_slices(), "module_specific"))
    },
    module_slices_api_set = function(module_label, functions_list) {
      shiny::isolate({
        if (!.self$is_module_specific()) {
          module_label <- "global_filters"
        }
        if (!identical(.self$module_slices_api[[module_label]], functions_list)) {
          .self$module_slices_api[[module_label]] <- functions_list
        }
        invisible(.self)
      })
    },
    slices_deactivate_all = function(module_label) {
      shiny::isolate({
        new_slices <- .self$all_slices()
        old_mapping <- attr(new_slices, "mapping")

        new_mapping <- if (.self$is_module_specific()) {
          new_module_mapping <- setNames(nm = module_label, list(character(0)))
          modifyList(old_mapping, new_module_mapping)
        } else if (missing(module_label)) {
          lapply(
            attr(.self$all_slices(), "mapping"),
            function(x) character(0)
          )
        } else {
          old_mapping[[module_label]] <- character(0)
          old_mapping
        }

        if (!identical(new_mapping, old_mapping)) {
          logger::log_debug(".slicesGlobal@slices_deactivate_all: deactivating all slices.")
          attr(new_slices, "mapping") <- new_mapping
          .self$all_slices(new_slices)
        }
        invisible(.self)
      })
    },
    slices_active = function(mapping_elem) {
      shiny::isolate({
        if (.self$is_module_specific()) {
          new_mapping <- modifyList(attr(.self$all_slices(), "mapping"), mapping_elem)
        } else {
          new_mapping <- setNames(nm = "global_filters", list(unique(unlist(mapping_elem))))
        }

        if (!identical(new_mapping, attr(.self$all_slices(), "mapping"))) {
          mapping_modules <- toString(names(new_mapping))
          logger::log_debug(".slicesGlobal@slices_active: changing mapping for module(s): { mapping_modules }.")
          new_slices <- .self$all_slices()
          attr(new_slices, "mapping") <- new_mapping
          .self$all_slices(new_slices)
        }

        invisible(.self)
      })
    },
    # - only new filters are appended to the $all_slices
    # - mapping is not updated here
    slices_append = function(slices, activate = FALSE) {
      shiny::isolate({
        if (!is.teal_slices(slices)) {
          slices <- as.teal_slices(slices)
        }

        # to make sure that we don't unnecessary trigger $all_slices <reactiveVal>
        new_slices <- setdiff_teal_slices(slices, .self$all_slices())
        old_mapping <- attr(.self$all_slices(), "mapping")
        if (length(new_slices)) {
          new_ids <- vapply(new_slices, `[[`, character(1L), "id")
          logger::log_debug(".slicesGlobal@slices_append: appending new slice(s): { new_ids }.")
          slices_ids <- vapply(.self$all_slices(), `[[`, character(1L), "id")
          lapply(new_slices, function(slice) {
            # In case the new state has the same id as an existing one, add a suffix
            if (slice$id %in% slices_ids) {
              slice$id <- utils::tail(make.unique(c(slices_ids, slice$id), sep = "_"), 1)
            }
          })

          new_slices_all <- c(.self$all_slices(), new_slices)
          attr(new_slices_all, "mapping") <- old_mapping
          .self$all_slices(new_slices_all)
        }

        invisible(.self)
      })
    },
    slices_get = function(module_label) {
      if (missing(module_label)) {
        .self$all_slices()
      } else {
        module_ids <- unlist(attr(.self$all_slices(), "mapping")[c(module_label, "global_filters")])
        Filter(
          function(slice) slice$id %in% module_ids,
          .self$all_slices()
        )
      }
    },
    slices_set = function(slices) {
      shiny::isolate({
        if (!is.teal_slices(slices)) {
          slices <- as.teal_slices(slices)
        }
        .self$all_slices(slices)
        invisible(.self)
      })
    },
    show = function() {
      shiny::isolate(print(.self$all_slices()))
      invisible(.self)
    }
  )
)
# todo: prevent any teal_slices attribute except mapping

#' Calls all `modules`
#'
#' On the UI side each `teal_modules` is translated to a `tabsetPanel` and each `teal_module` is a
#' `tabPanel`. Both, UI and server are called recursively so that each tab is a separate module and
#' reflect nested structure of `modules` argument.
#'
#' @name module_teal_module
#'
#' @inheritParams module_teal
#'
#' @param data_rv (`reactive` returning `teal_data`)
#'
#' @param slices_global (`reactiveVal` returning `modules_teal_slices`)
#'   see [`module_filter_manager`]
#'
#' @param depth (`integer(1)`)
#'  number which helps to determine depth of the modules nesting.
#'
#' @param datasets (`reactive` returning `FilteredData` or `NULL`)
#'  When `datasets` is passed from the parent module (`srv_teal`) then `dataset` is a singleton
#'  which implies in filter-panel to be "global". When `NULL` then filter-panel is "module-specific".
#'
#' @param data_load_status (`reactive` returning `character`)
#'  Determines action dependent on a data loading status:
#'  - `"ok"` when `teal_data` is returned from the data loading.
#'  - `"teal_data_module failed"` when [teal_data_module()] didn't return  `teal_data`. Disables tabs buttons.
#'  - `"external failed"` when a `reactive` passed to `srv_teal(data)` didn't return `teal_data`. Hides the whole tab
#'    panel.
#'
#' @return
#' output of currently active module.
#' - `srv_teal_module.teal_module` returns `reactiveVal` containing output of the called module.
#' - `srv_teal_module.teal_modules` returns output of module selected by `input$active_tab`.
#'
#' @keywords internal
NULL

#' @rdname module_teal_module
ui_teal_module <- function(id, modules, depth = 0L) {
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module", "shiny.tag"))
  checkmate::assert_count(depth)
  UseMethod("ui_teal_module", modules)
}

#' @rdname module_teal_module
#' @export
ui_teal_module.default <- function(id, modules, depth = 0L) {
  stop("Modules class not supported: ", paste(class(modules), collapse = " "))
}

#' @rdname module_teal_module
#' @export
ui_teal_module.teal_modules <- function(id, modules, depth = 0L) {
  ns <- NS(id)
  tags$div(
    id = ns("wrapper"),
    do.call(
      tabsetPanel,
      c(
        # by giving an id, we can reactively respond to tab changes
        list(
          id = ns("active_tab"),
          type = if (modules$label == "root") "pills" else "tabs"
        ),
        lapply(
          names(modules$children),
          function(module_id) {
            module_label <- modules$children[[module_id]]$label
            if (is.null(module_label)) {
              module_label <- icon("fas fa-database")
            }
            tabPanel(
              title = module_label,
              value = module_id, # when clicked this tab value changes input$<tabset panel id>
              ui_teal_module(
                id = ns(module_id),
                modules = modules$children[[module_id]],
                depth = depth + 1L
              )
            )
          }
        )
      )
    )
  )
}

#' @rdname module_teal_module
#' @export
ui_teal_module.teal_module <- function(id, modules, depth = 0L) {
  ns <- NS(id)
  args <- c(list(id = ns("module")), modules$ui_args)

  ui_teal <- tagList(
    div(
      id = ns("validate_datanames"),
      ui_validate_reactive_teal_data(ns("validate_datanames"))
    ),
    shinyjs::hidden(
      tags$div(
        id = ns("transformer_failure_info"),
        class = "teal_validated",
        div(
          class = "teal-output-warning",
          "One of transformers failed. Please fix and continue."
        )
      )
    ),
    tags$div(
      id = ns("teal_module_ui"),
      do.call(modules$ui, args)
    )
  )

  div(
    id = id,
    class = "teal_module",
    uiOutput(ns("data_reactive"), inline = TRUE),
    tagList(
      if (depth >= 2L) tags$div(style = "mt-6"),
      if (!is.null(modules$datanames)) {
        fluidRow(
          column(width = 9, ui_teal, class = "teal_primary_col"),
          column(
            width = 3,
            ui_data_summary(ns("data_summary")),
            ui_filter_data(ns("filter_panel")),
            ui_transform_data(ns("data_transform"), transformers = modules$transformers, class = "well"),
            class = "teal_secondary_col"
          )
        )
      } else {
        div(
          div(
            class = "teal_validated",
            uiOutput(ns("data_input_error"))
          ),
          ui_teal
        )
      }
    )
  )
}

#' @rdname module_teal_module
srv_teal_module <- function(id,
                            data_rv,
                            modules,
                            datasets = NULL,
                            slices_global,
                            reporter = teal.reporter::Reporter$new(),
                            data_load_status = reactive("ok"),
                            is_active = reactive(TRUE)) {
  checkmate::assert_string(id)
  assert_reactive(data_rv)
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  assert_reactive(datasets, null.ok = TRUE)
  checkmate::assert_class(slices_global, ".slicesGlobal")
  checkmate::assert_class(reporter, "Reporter")
  assert_reactive(data_load_status)
  UseMethod("srv_teal_module", modules)
}

#' @rdname module_teal_module
#' @export
srv_teal_module.default <- function(id,
                                    data_rv,
                                    modules,
                                    datasets = NULL,
                                    slices_global,
                                    reporter = teal.reporter::Reporter$new(),
                                    data_load_status = reactive("ok"),
                                    is_active = reactive(TRUE)) {
  stop("Modules class not supported: ", paste(class(modules), collapse = " "))
}

#' @rdname module_teal_module
#' @export
srv_teal_module.teal_modules <- function(id,
                                         data_rv,
                                         modules,
                                         datasets = NULL,
                                         slices_global,
                                         reporter = teal.reporter::Reporter$new(),
                                         data_load_status = reactive("ok"),
                                         is_active = reactive(TRUE)) {
  moduleServer(id = id, module = function(input, output, session) {
    logger::log_debug("srv_teal_module.teal_modules initializing the module { deparse1(modules$label) }.")

    observeEvent(data_load_status(), {
      tabs_selector <- sprintf("#%s li a", session$ns("active_tab"))
      if (identical(data_load_status(), "ok")) {
        logger::log_debug("srv_teal_module@1 enabling modules tabs.")
        shinyjs::show("wrapper")
        shinyjs::enable(selector = tabs_selector)
      } else if (identical(data_load_status(), "teal_data_module failed")) {
        logger::log_debug("srv_teal_module@1 disabling modules tabs.")
        shinyjs::disable(selector = tabs_selector)
      } else if (identical(data_load_status(), "external failed")) {
        logger::log_debug("srv_teal_module@1 hiding modules tabs.")
        shinyjs::hide("wrapper")
      }
    })

    modules_output <- sapply(
      names(modules$children),
      function(module_id) {
        srv_teal_module(
          id = module_id,
          data_rv = data_rv,
          modules = modules$children[[module_id]],
          datasets = datasets,
          slices_global = slices_global,
          reporter = reporter,
          is_active = reactive(
            is_active() &&
              input$active_tab == module_id &&
              identical(data_load_status(), "ok")
          )
        )
      },
      simplify = FALSE
    )

    modules_output
  })
}

#' @rdname module_teal_module
#' @export
srv_teal_module.teal_module <- function(id,
                                        data_rv,
                                        modules,
                                        datasets = NULL,
                                        slices_global,
                                        reporter = teal.reporter::Reporter$new(),
                                        data_load_status = reactive("ok"),
                                        is_active = reactive(TRUE)) {
  logger::log_debug("srv_teal_module.teal_module initializing the module: { deparse1(modules$label) }.")
  moduleServer(id = id, module = function(input, output, session) {
    module_out <- reactiveVal()

    active_datanames <- reactive({
      .resolve_module_datanames(data = data_rv(), modules = modules)
    })
    if (is.null(datasets)) {
      datasets <- eventReactive(data_rv(), {
        req(inherits(data_rv(), "teal_data"))
        logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
        teal_data_to_filtered_data(data_rv(), datanames = active_datanames())
      })
    }

    # manage module filters on the module level
    # important:
    #   filter_manager_module_srv needs to be called before filter_panel_srv
    #   Because available_teal_slices is used in FilteredData$srv_available_slices (via srv_filter_panel)
    #   and if it is not set, then it won't be available in the srv_filter_panel
    srv_module_filter_manager(modules$label, module_fd = datasets, slices_global = slices_global)

    call_once_when(is_active(), {
      filtered_teal_data <- srv_filter_data(
        "filter_panel",
        datasets = datasets,
        active_datanames = active_datanames,
        data_rv = data_rv,
        is_active = is_active
      )
      is_transformer_failed <- reactiveValues()
      transformed_teal_data <- srv_transform_data(
        "data_transform",
        data = filtered_teal_data,
        transformers = modules$transformers,
        modules = modules,
        is_transformer_failed = is_transformer_failed
      )
      any_transformer_failed <- reactive({
        any(unlist(reactiveValuesToList(is_transformer_failed)))
      })

      observeEvent(any_transformer_failed(), {
        if (isTRUE(any_transformer_failed())) {
          shinyjs::hide("teal_module_ui")
          shinyjs::hide("validate_datanames")
          shinyjs::show("transformer_failure_info")
        } else {
          shinyjs::show("teal_module_ui")
          shinyjs::show("validate_datanames")
          shinyjs::hide("transformer_failure_info")
        }
      })

      module_teal_data <- reactive({
        req(inherits(transformed_teal_data(), "teal_data"))
        all_teal_data <- transformed_teal_data()
        module_datanames <- .resolve_module_datanames(data = all_teal_data, modules = modules)
        .subset_teal_data(all_teal_data, module_datanames)
      })

      srv_validate_reactive_teal_data(
        "validate_datanames",
        data = module_teal_data,
        modules = modules
      )

      summary_table <- srv_data_summary("data_summary", module_teal_data)

      # Call modules.
      if (!inherits(modules, "teal_module_previewer")) {
        obs_module <- call_once_when(
          !is.null(module_teal_data()),
          ignoreNULL = TRUE,
          handlerExpr = {
            module_out(.call_teal_module(modules, datasets, module_teal_data, reporter))
          }
        )
      } else {
        # Report previewer must be initiated on app start for report cards to be included in bookmarks.
        # When previewer is delayed, cards are bookmarked only if previewer has been initiated (visited).
        module_out(.call_teal_module(modules, datasets, module_teal_data, reporter))
      }

      # todo: (feature request) add a ReporterCard to the reporter as an output from the teal_module
      #       how to determine if module returns a ReporterCard so that reportPreviewer is needed?
      #       Should we insertUI of the ReportPreviewer then?
      #       What about attr(module, "reportable") - similar to attr(module, "bookmarkable")
      if ("report" %in% names(module_out)) {
        # (reactively) add card to the reporter
      }
    })

    module_out
  })
}

# This function calls a module server function.
.call_teal_module <- function(modules, datasets, filtered_teal_data, reporter) {
  # collect arguments to run teal_module
  args <- c(list(id = "module"), modules$server_args)
  if (is_arg_used(modules$server, "reporter")) {
    args <- c(args, list(reporter = reporter))
  }

  if (is_arg_used(modules$server, "datasets")) {
    args <- c(args, datasets = datasets())
    warning("datasets argument is not reactive and therefore it won't be updated when data is refreshed.")
  }

  if (is_arg_used(modules$server, "data")) {
    args <- c(args, data = list(filtered_teal_data))
  }

  if (is_arg_used(modules$server, "filter_panel_api")) {
    args <- c(args, filter_panel_api = teal.slice::FilterPanelAPI$new(datasets()))
  }

  if (is_arg_used(modules$server, "id")) {
    do.call(modules$server, args)
  } else {
    do.call(callModule, c(args, list(module = modules$server)))
  }
}

.resolve_module_datanames <- function(data, modules) {
  stopifnot("data_rv must be teal_data object." = inherits(data, "teal_data"))
  if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
    .topologically_sort_datanames(ls(teal.code::get_env(data)), teal.data::join_keys(data))
  } else {
    intersect(
      .include_parent_datanames(modules$datanames, teal.data::join_keys(data)),
      ls(teal.code::get_env(data))
    )
  }
}

#' Calls expression when condition is met
#'
#' Function postpones `handlerExpr` to the moment when `eventExpr` (condition) returns `TRUE`,
#' otherwise nothing happens.
#' @param eventExpr A (quoted or unquoted) logical expression that represents the event;
#' this can be a simple reactive value like input$click, a call to a reactive expression
#' like dataset(), or even a complex expression inside curly braces.
#' @param ... additional arguments passed to `observeEvent` with the exception of `eventExpr` that is not allowed.
#' @inheritParams shiny::observeEvent
#'
#' @return An observer.
#'
#' @keywords internal
call_once_when <- function(eventExpr, # nolint: object_name.
                           handlerExpr, # nolint: object_name.
                           event.env = parent.frame(), # nolint: object_name.
                           handler.env = parent.frame(), # nolint: object_name.
                           ...) {
  event_quo <- rlang::new_quosure(substitute(eventExpr), env = event.env)
  handler_quo <- rlang::new_quosure(substitute(handlerExpr), env = handler.env)

  # When `condExpr` is TRUE, then `handlerExpr` is evaluated once.
  activator <- reactive({
    if (isTRUE(rlang::eval_tidy(event_quo))) {
      TRUE
    }
  })

  observeEvent(
    eventExpr = activator(),
    once = TRUE,
    handlerExpr = rlang::eval_tidy(handler_quo),
    ...
  )
}

#' Send input validation messages to output
#'
#' Captures messages from `InputValidator` objects and collates them
#' into one message passed to `validate`.
#'
#' `shiny::validate` is used to withhold rendering of an output element until
#' certain conditions are met and to print a validation message in place
#' of the output element.
#' `shinyvalidate::InputValidator` allows to validate input elements
#' and to display specific messages in their respective input widgets.
#' `validate_inputs` provides a hybrid solution.
#' Given an `InputValidator` object, messages corresponding to inputs that fail validation
#' are extracted and placed in one validation message that is passed to a `validate`/`need` call.
#' This way the input `validator` messages are repeated in the output.
#'
#' The `...` argument accepts any number of `InputValidator` objects
#' or a nested list of such objects.
#' If `validators` are passed directly, all their messages are printed together
#' under one (optional) header message specified by `header`. If a list is passed,
#' messages are grouped by `validator`. The list's names are used as headers
#' for their respective message groups.
#' If neither of the nested list elements is named, a header message is taken from `header`.
#'
#' @param ... either any number of `InputValidator` objects
#'            or an optionally named, possibly nested `list` of `InputValidator`
#'            objects, see `Details`
#' @param header (`character(1)`) generic validation message; set to NULL to omit
#'
#' @return
#' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails.
#'
#' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`]
#'
#' @examplesIf require("shinyvalidate")
#' library(shiny)
#' library(shinyvalidate)
#'
#' ui <- fluidPage(
#'   selectInput("method", "validation method", c("sequential", "combined", "grouped")),
#'   sidebarLayout(
#'     sidebarPanel(
#'       selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
#'       selectInput("number", "select a number:", 1:6),
#'       tags$br(),
#'       selectInput("color", "select a color:",
#'         c("black", "indianred2", "springgreen2", "cornflowerblue"),
#'         multiple = TRUE
#'       ),
#'       sliderInput("size", "select point size:",
#'         min = 0.1, max = 4, value = 0.25
#'       )
#'     ),
#'     mainPanel(plotOutput("plot"))
#'   )
#' )
#'
#' server <- function(input, output) {
#'   # set up input validation
#'   iv <- InputValidator$new()
#'   iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
#'   iv$add_rule("number", function(x) {
#'     if (as.integer(x) %% 2L == 1L) "choose an even number"
#'   })
#'   iv$enable()
#'   # more input validation
#'   iv_par <- InputValidator$new()
#'   iv_par$add_rule("color", sv_required(message = "choose a color"))
#'   iv_par$add_rule("color", function(x) {
#'     if (length(x) > 1L) "choose only one color"
#'   })
#'   iv_par$add_rule(
#'     "size",
#'     sv_between(
#'       left = 0.5, right = 3,
#'       message_fmt = "choose a value between {left} and {right}"
#'     )
#'   )
#'   iv_par$enable()
#'
#'   output$plot <- renderPlot({
#'     # validate output
#'     switch(input[["method"]],
#'       "sequential" = {
#'         validate_inputs(iv)
#'         validate_inputs(iv_par, header = "Set proper graphical parameters")
#'       },
#'       "combined" = validate_inputs(iv, iv_par),
#'       "grouped" = validate_inputs(list(
#'         "Some inputs require attention" = iv,
#'         "Set proper graphical parameters" = iv_par
#'       ))
#'     )
#'
#'     plot(faithful$eruptions ~ faithful$waiting,
#'       las = 1, pch = 16,
#'       col = input[["color"]], cex = input[["size"]]
#'     )
#'   })
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @export
#'
validate_inputs <- function(..., header = "Some inputs require attention") {
  dots <- list(...)
  if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")

  messages <- extract_validator(dots, header)
  failings <- if (!any_names(dots)) {
    add_header(messages, header)
  } else {
    unlist(messages)
  }

  shiny::validate(shiny::need(is.null(failings), failings))
}

### internal functions

#' @noRd
#' @keywords internal
# recursive object type test
# returns logical of length 1
is_validators <- function(x) {
  all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))
}

#' @noRd
#' @keywords internal
# test if an InputValidator object is enabled
# returns logical of length 1
# official method requested at https://github.com/rstudio/shinyvalidate/issues/64
validator_enabled <- function(x) {
  x$.__enclos_env__$private$enabled
}

#' Recursively extract messages from validator list
#' @return A character vector or a list of character vectors, possibly nested and named.
#' @noRd
#' @keywords internal
extract_validator <- function(iv, header) {
  if (inherits(iv, "InputValidator")) {
    add_header(gather_messages(iv), header)
  } else {
    if (is.null(names(iv))) names(iv) <- rep("", length(iv))
    mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)
  }
}

#' Collate failing messages from validator.
#' @return `list`
#' @noRd
#' @keywords internal
gather_messages <- function(iv) {
  if (validator_enabled(iv)) {
    status <- iv$validate()
    failing_inputs <- Filter(Negate(is.null), status)
    unique(lapply(failing_inputs, function(x) x[["message"]]))
  } else {
    warning("Validator is disabled and will be omitted.")
    list()
  }
}

#' Add optional header to failing messages
#' @noRd
#' @keywords internal
add_header <- function(messages, header = "") {
  ans <- unlist(messages)
  if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
    ans <- c(paste0(header, "\n"), ans, "\n")
  }
  ans
}

#' Recursively check if the object contains a named list
#' @noRd
#' @keywords internal
any_names <- function(x) {
  any(
    if (is.list(x)) {
      if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))
    } else {
      FALSE
    }
  )
}

#' `teal` main module
#'
#' @description
#' `r lifecycle::badge("stable")`
#' Module to create a `teal` app. This module can be called directly instead of [init()] and
#' included in your custom application. Please note that [init()] adds `reporter_previewer_module`
#' automatically, which is not a case when calling `ui/srv_teal` directly.
#'
#' @details
#'
#' Module is responsible for creating the main `shiny` app layout and initializing all the necessary
#' components. This module establishes reactive connection between the input `data` and every other
#' component in the app. Reactive change of the `data` passed as an argument, reloads the app and
#' possibly keeps all input settings the same so the user can continue where one left off.
#'
#' ## data flow in `teal` application
#'
#' This module supports multiple data inputs but eventually, they are all converted to `reactive`
#' returning `teal_data` in this module. On this `reactive teal_data` object several actions are
#' performed:
#' - data loading in [`module_init_data`]
#' - data filtering in [`module_filter_data`]
#' - data transformation in [`module_transform_data`]
#'
#' ## Fallback on failure
#'
#' `teal` is designed in such way that app will never crash if the error is introduced in any
#' custom `shiny` module provided by app developer (e.g. [teal_data_module()], [teal_transform_module()]).
#' If any module returns a failing object, the app will halt the evaluation and display a warning message.
#' App user should always have a chance to fix the improper input and continue without restarting the session.
#'
#' @rdname module_teal
#' @name module_teal
#'
#' @inheritParams module_init_data
#' @inheritParams init
#'
#' @return `NULL` invisibly
NULL

#' @rdname module_teal
#' @export
ui_teal <- function(id,
                    modules,
                    title = build_app_title(),
                    header = tags$p(),
                    footer = tags$p()) {
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
  checkmate::assert(
    .var.name = "title",
    checkmate::check_string(title),
    checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert(
    .var.name = "header",
    checkmate::check_string(header),
    checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert(
    .var.name = "footer",
    checkmate::check_string(footer),
    checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
  )

  if (is.character(title)) {
    title <- build_app_title(title)
  } else {
    validate_app_title_tag(title)
  }

  if (checkmate::test_string(header)) {
    header <- tags$p(header)
  }

  if (checkmate::test_string(footer)) {
    footer <- tags$p(footer)
  }

  ns <- NS(id)

  # show busy icon when `shiny` session is busy computing stuff
  # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length.
  shiny_busy_message_panel <- conditionalPanel(
    condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
    tags$div(
      icon("arrows-rotate", class = "fa-spin", prefer_type = "solid"),
      "Computing ...",
      # CSS defined in `custom.css`
      class = "shinybusymessage"
    )
  )

  fluidPage(
    id = id,
    title = title,
    theme = get_teal_bs_theme(),
    include_teal_css_js(),
    tags$header(header),
    tags$hr(class = "my-2"),
    shiny_busy_message_panel,
    tags$div(
      id = ns("tabpanel_wrapper"),
      class = "teal-body",
      ui_teal_module(id = ns("teal_modules"), modules = modules)
    ),
    tags$div(
      id = ns("options_buttons"),
      style = "position: absolute; right: 10px;",
      ui_bookmark_panel(ns("bookmark_manager"), modules),
      tags$button(
        class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger
        href = "javascript:void(0)",
        onclick = sprintf("toggleFilterPanel('%s');", ns("tabpanel_wrapper")),
        title = "Toggle filter panel",
        icon("fas fa-bars")
      ),
      ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
      ui_filter_manager_panel(ns("filter_manager_panel"))
    ),
    tags$script(
      HTML(
        sprintf(
          "
            $(document).ready(function() {
              $('#%s').appendTo('#%s');
            });
          ",
          ns("options_buttons"),
          ns("teal_modules-active_tab")
        )
      )
    ),
    tags$hr(),
    tags$footer(
      tags$div(
        footer,
        teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
        br(),
        ui_teal_lockfile(ns("lockfile")),
        textOutput(ns("identifier"))
      )
    )
  )
}

#' @rdname module_teal
#' @export
srv_teal <- function(id, data, modules, filter = teal_slices()) {
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
  checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
  checkmate::assert_class(modules, "teal_modules")
  checkmate::assert_class(filter, "teal_slices")

  moduleServer(id, function(input, output, session) {
    logger::log_debug("srv_teal initializing.")

    if (getOption("teal.show_js_log", default = FALSE)) {
      shinyjs::showLog()
    }

    srv_teal_lockfile("lockfile")

    output$identifier <- renderText(
      paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
    )

    teal.widgets::verbatim_popup_srv(
      "sessionInfo",
      verbatim_content = utils::capture.output(utils::sessionInfo()),
      title = "SessionInfo"
    )

    # `JavaScript` code
    run_js_files(files = "init.js")

    # set timezone in shiny app
    # timezone is set in the early beginning so it will be available also
    # for `DDL` and all shiny modules
    get_client_timezone(session$ns)
    observeEvent(
      eventExpr = input$timezone,
      once = TRUE,
      handlerExpr = {
        session$userData$timezone <- input$timezone
        logger::log_debug("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
      }
    )

    data_pulled <- srv_init_data("data", data = data)
    data_validated <- srv_validate_reactive_teal_data(
      "validate",
      data = data_pulled,
      modules = modules,
      validate_shiny_silent_error = FALSE
    )
    data_rv <- reactive({
      req(inherits(data_validated(), "teal_data"))
      is_filter_ok <- check_filter_datanames(filter, ls(teal.code::get_env(data_validated())))
      if (!isTRUE(is_filter_ok)) {
        showNotification(
          "Some filters were not applied because of incompatibility with data. Contact app developer.",
          type = "warning",
          duration = 10
        )
        warning(is_filter_ok)
      }
      .add_signature_to_data(data_validated())
    })

    data_load_status <- reactive({
      if (inherits(data_pulled(), "teal_data")) {
        "ok"
        # todo: should we hide warnings on top for a data?
      } else if (inherits(data, "teal_data_module")) {
        "teal_data_module failed"
      } else {
        "external failed"
      }
    })

    datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
      eventReactive(data_rv(), {
        req(inherits(data_rv(), "teal_data"))
        logger::log_debug("srv_teal@1 initializing FilteredData")
        teal_data_to_filtered_data(data_rv())
      })
    }

    if (inherits(data, "teal_data_module")) {
      setBookmarkExclude(c("teal_modules-active_tab"))
      shiny::insertTab(
        inputId = "teal_modules-active_tab",
        position = "before",
        select = TRUE,
        tabPanel(
          title = icon("fas fa-database"),
          value = "teal_data_module",
          tags$div(
            ui_init_data(session$ns("data")),
            ui_validate_reactive_teal_data(session$ns("validate"))
          )
        )
      )

      if (attr(data, "once")) {
        observeEvent(data_rv(), once = TRUE, {
          logger::log_debug("srv_teal@2 removing data tab.")
          # when once = TRUE we pull data once and then remove data tab
          removeTab("teal_modules-active_tab", target = "teal_data_module")
        })
      }
    } else {
      # when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)
      insertUI(
        selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
        where = "beforeBegin",
        ui = tags$div(ui_validate_reactive_teal_data(session$ns("validate")), tags$br())
      )
    }

    module_labels <- unlist(module_labels(modules), use.names = FALSE)
    slices_global <- methods::new(".slicesGlobal", filter, module_labels)
    modules_output <- srv_teal_module(
      id = "teal_modules",
      data_rv = data_rv,
      datasets = datasets_rv,
      modules = modules,
      slices_global = slices_global,
      data_load_status = data_load_status
    )
    mapping_table <- srv_filter_manager_panel("filter_manager_panel", slices_global = slices_global)
    snapshots <- srv_snapshot_manager_panel("snapshot_manager_panel", slices_global = slices_global)
    srv_bookmark_panel("bookmark_manager", modules)
  })

  invisible(NULL)
}

#' Filter state snapshot management
#'
#' Capture and restore snapshots of the global (app) filter state.
#'
#' This module introduces snapshots: stored descriptions of the filter state of the entire application.
#' Snapshots allow the user to save the current filter state of the application for later use in the session,
#' as well as to save it to file in order to share it with an app developer or other users,
#' who in turn can upload it to their own session.
#'
#' The snapshot manager is accessed with the camera icon in the tabset bar.
#' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow.
#' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file
#' and applies the filter states therein, and clicking the arrow resets initial application state.
#' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.
#'
#' @section Server logic:
#' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance
#' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`
#' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation
#' (attributes are maintained).
#'
#' Snapshots are stored in a `reactiveVal` as a named list.
#' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.
#'
#' For every snapshot except the initial one, a piece of UI is generated that contains
#' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.
#' The initial snapshot is restored by a separate "reset" button.
#' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.
#'
#' @section Snapshot mechanics:
#' When a snapshot is captured, the user is prompted to name it.
#' Names are displayed as is but since they are used to create button ids,
#' under the hood they are converted to syntactically valid strings.
#' New snapshot names are validated so that their valid versions are unique.
#' Leading and trailing white space is trimmed.
#'
#' The module can read the global state of the application from `slices_global` and `mapping_matrix`.
#' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.
#' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.
#' The snapshot contains the `mapping` attribute of the initial application state
#' (or one that has been restored), which may not reflect the current one,
#' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,
#' when passed to the `mapping` argument of [teal_slices()], would result in the current mapping.
#' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.
#'
#' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.
#' Then state of all `FilteredData` objects (provided in `datasets`) is cleared
#' and set anew according to the `mapping` attribute of the snapshot.
#' The snapshot is then set as the current content of `slices_global`.
#'
#' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,
#' and then saved to file with [slices_store()].
#'
#' When a snapshot is uploaded, it will first be added to storage just like a newly created one,
#' and then used to restore app state much like a snapshot taken from storage.
#' Upon clicking the upload icon the user will be prompted for a file to upload
#' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped)
#' and normal naming rules apply. Loading the file yields a `teal_slices` object,
#' which is disassembled for storage and used directly for restoring app state.
#'
#' @section Transferring snapshots:
#' Snapshots uploaded from disk should only be used in the same application they come from,
#' _i.e._ an application that uses the same data and the same modules.
#' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of
#' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that
#' of the current app state and only if the match is the snapshot admitted to the session.
#'
#' @section Bookmarks:
#' An `onBookmark` callback creates a snapshot of the current filter state.
#' This is done on the app session, not the module session.
#' (The snapshot will be retrieved by `module_teal` in order to set initial app state in a restored app.)
#' Then that snapshot, and the previous snapshot history are dumped into the `values.rds` file in `<bookmark_dir>`.
#'
#' @param id (`character(1)`) `shiny` module instance id.
#' @param slices_global (`reactiveVal`) that contains a `teal_slices` object
#'                      containing all `teal_slice`s existing in the app, both active and inactive.
#'
#' @return `list` containing the snapshot history, where each element is an unlisted `teal_slices` object.
#'
#' @name module_snapshot_manager
#' @rdname module_snapshot_manager
#'
#' @author Aleksander Chlebowski
#' @keywords internal
NULL

#' @rdname module_snapshot_manager
ui_snapshot_manager_panel <- function(id) {
  ns <- NS(id)
  tags$button(
    id = ns("show_snapshot_manager"),
    class = "btn action-button wunder_bar_button",
    title = "View filter mapping",
    suppressMessages(icon("fas fa-camera"))
  )
}

#' @rdname module_snapshot_manager
srv_snapshot_manager_panel <- function(id, slices_global) {
  moduleServer(id, function(input, output, session) {
    logger::log_debug("srv_snapshot_manager_panel initializing")
    setBookmarkExclude(c("show_snapshot_manager"))
    observeEvent(input$show_snapshot_manager, {
      logger::log_debug("srv_snapshot_manager_panel@1 show_snapshot_manager button has been clicked.")
      showModal(
        modalDialog(
          ui_snapshot_manager(session$ns("module")),
          class = "snapshot_manager_modal",
          size = "m",
          footer = NULL,
          easyClose = TRUE
        )
      )
    })
    srv_snapshot_manager("module", slices_global = slices_global)
  })
}

#' @rdname module_snapshot_manager
ui_snapshot_manager <- function(id) {
  ns <- NS(id)
  tags$div(
    class = "manager_content",
    tags$div(
      class = "manager_table_row",
      tags$span(tags$b("Snapshot manager")),
      actionLink(ns("snapshot_add"), label = NULL, icon = icon("fas fa-camera"), title = "add snapshot"),
      actionLink(ns("snapshot_load"), label = NULL, icon = icon("fas fa-upload"), title = "upload snapshot"),
      actionLink(ns("snapshot_reset"), label = NULL, icon = icon("fas fa-undo"), title = "reset initial state"),
      NULL
    ),
    uiOutput(ns("snapshot_list"))
  )
}

#' @rdname module_snapshot_manager
srv_snapshot_manager <- function(id, slices_global) {
  checkmate::assert_character(id)

  moduleServer(id, function(input, output, session) {
    logger::log_debug("srv_snapshot_manager initializing")

    # Set up bookmarking callbacks ----
    # Register bookmark exclusions (all buttons and text fields).
    setBookmarkExclude(c(
      "snapshot_add", "snapshot_load", "snapshot_reset",
      "snapshot_name_accept", "snaphot_file_accept",
      "snapshot_name", "snapshot_file"
    ))
    # Add snapshot history to bookmark.
    session$onBookmark(function(state) {
      logger::log_debug("srv_snapshot_manager@onBookmark: storing snapshot and bookmark history")
      state$values$snapshot_history <- snapshot_history() # isolate this?
    })

    ns <- session$ns

    # Track global filter states ----
    snapshot_history <- reactiveVal({
      # Restore directly from bookmarked state, if applicable.
      restoreValue(
        ns("snapshot_history"),
        list("Initial application state" = shiny::isolate(as.list(slices_global$all_slices(), recursive = TRUE)))
      )
    })

    # Snapshot current application state ----
    # Name snaphsot.
    observeEvent(input$snapshot_add, {
      logger::log_debug("srv_snapshot_manager: snapshot_add button clicked")
      showModal(
        modalDialog(
          textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
          footer = tagList(
            actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("far fa-thumbs-up")),
            modalButton(label = "Cancel", icon = icon("far fa-thumbs-down"))
          ),
          size = "s"
        )
      )
    })
    # Store snaphsot.
    observeEvent(input$snapshot_name_accept, {
      logger::log_debug("srv_snapshot_manager: snapshot_name_accept button clicked")
      snapshot_name <- trimws(input$snapshot_name)
      if (identical(snapshot_name, "")) {
        logger::log_debug("srv_snapshot_manager: snapshot name rejected")
        showNotification(
          "Please name the snapshot.",
          type = "message"
        )
        updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
      } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
        logger::log_debug("srv_snapshot_manager: snapshot name rejected")
        showNotification(
          "This name is in conflict with other snapshot names. Please choose a different one.",
          type = "message"
        )
        updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
      } else {
        logger::log_debug("srv_snapshot_manager: snapshot name accepted, adding snapshot")
        snapshot <- as.list(slices_global$all_slices(), recursive = TRUE)
        snapshot_update <- c(snapshot_history(), list(snapshot))
        names(snapshot_update)[length(snapshot_update)] <- snapshot_name
        snapshot_history(snapshot_update)
        removeModal()
        # Reopen filter manager modal by clicking button in the main application.
        shinyjs::click(id = "teal-wunder_bar-show_snapshot_manager", asis = TRUE)
      }
    })

    # Upload a snapshot file ----
    # Select file.
    observeEvent(input$snapshot_load, {
      logger::log_debug("srv_snapshot_manager: snapshot_load button clicked")
      showModal(
        modalDialog(
          fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
          textInput(
            ns("snapshot_name"),
            "Name the snapshot (optional)",
            width = "100%",
            placeholder = "Meaningful, unique name"
          ),
          footer = tagList(
            actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("far fa-thumbs-up")),
            modalButton(label = "Cancel", icon = icon("far fa-thumbs-down"))
          )
        )
      )
    })
    # Store new snapshot to list and restore filter states.
    observeEvent(input$snaphot_file_accept, {
      logger::log_debug("srv_snapshot_manager: snapshot_file_accept button clicked")
      snapshot_name <- trimws(input$snapshot_name)
      if (identical(snapshot_name, "")) {
        logger::log_debug("srv_snapshot_manager: no snapshot name provided, naming after file")
        snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)
      }
      if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
        logger::log_debug("srv_snapshot_manager: snapshot name rejected")
        showNotification(
          "This name is in conflict with other snapshot names. Please choose a different one.",
          type = "message"
        )
        updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
      } else {
        # Restore snapshot and verify app compatibility.
        logger::log_debug("srv_snapshot_manager: snapshot name accepted, loading snapshot")
        snapshot_state <- try(slices_restore(input$snapshot_file$datapath))
        if (!inherits(snapshot_state, "modules_teal_slices")) {
          logger::log_debug("srv_snapshot_manager: snapshot file corrupt")
          showNotification(
            "File appears to be corrupt.",
            type = "error"
          )
        } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global$all_slices(), "app_id"))) {
          logger::log_debug("srv_snapshot_manager: snapshot not compatible with app")
          showNotification(
            "This snapshot file is not compatible with the app and cannot be loaded.",
            type = "warning"
          )
        } else {
          # Add to snapshot history.
          logger::log_debug("srv_snapshot_manager: snapshot loaded, adding to history")
          snapshot <- as.list(slices_global$all_slices(), recursive = TRUE)
          snapshot_update <- c(snapshot_history(), list(snapshot))
          names(snapshot_update)[length(snapshot_update)] <- snapshot_name
          snapshot_history(snapshot_update)
          ### Begin simplified restore procedure. ###
          logger::log_debug("srv_snapshot_manager: restoring snapshot")
          slices_global$slices_set(snapshot_state)
          removeModal()
          ### End  simplified restore procedure. ###
        }
      }
    })
    # Apply newly added snapshot.

    # Restore initial state ----
    observeEvent(input$snapshot_reset, {
      logger::log_debug("srv_snapshot_manager: snapshot_reset button clicked, restoring snapshot")
      s <- "Initial application state"
      ### Begin restore procedure. ###
      snapshot <- snapshot_history()[[s]]
      # todo: as.teal_slices looses module-mapping if is not global
      snapshot_state <- as.teal_slices(snapshot)
      slices_global$slices_set(snapshot_state)
      removeModal()
      ### End restore procedure. ###
    })

    # Build snapshot table ----
    # Create UI elements and server logic for the snapshot table.
    # Observers must be tracked to avoid duplication and excess reactivity.
    # Remaining elements are tracked likewise for consistency and a slight speed margin.
    observers <- reactiveValues()
    handlers <- reactiveValues()
    divs <- reactiveValues()

    observeEvent(snapshot_history(), {
      logger::log_debug("srv_snapshot_manager: snapshot history modified, updating snapshot list")
      lapply(names(snapshot_history())[-1L], function(s) {
        id_pickme <- sprintf("pickme_%s", make.names(s))
        id_saveme <- sprintf("saveme_%s", make.names(s))
        id_rowme <- sprintf("rowme_%s", make.names(s))

        # Observer for restoring snapshot.
        if (!is.element(id_pickme, names(observers))) {
          observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
            ### Begin restore procedure. ###
            snapshot <- snapshot_history()[[s]]
            snapshot_state <- as.teal_slices(snapshot)

            slices_global$slices_set(snapshot_state)
            removeModal()
            ### End restore procedure. ###
          })
        }
        # Create handler for downloading snapshot.
        if (!is.element(id_saveme, names(handlers))) {
          output[[id_saveme]] <- downloadHandler(
            filename = function() {
              sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
            },
            content = function(file) {
              snapshot <- snapshot_history()[[s]]
              snapshot_state <- as.teal_slices(snapshot)
              slices_store(tss = snapshot_state, file = file)
            }
          )
          handlers[[id_saveme]] <- id_saveme
        }
        # Create a row for the snapshot table.
        if (!is.element(id_rowme, names(divs))) {
          divs[[id_rowme]] <- tags$div(
            class = "manager_table_row",
            tags$span(tags$h5(s)),
            actionLink(inputId = ns(id_pickme), label = icon("far fa-circle-check"), title = "select"),
            downloadLink(outputId = ns(id_saveme), label = icon("far fa-save"), title = "save to file")
          )
        }
      })
    })

    # Create table to display list of snapshots and their actions.
    output$snapshot_list <- renderUI({
      rows <- rev(reactiveValuesToList(divs))
      if (length(rows) == 0L) {
        tags$div(
          class = "manager_placeholder",
          "Snapshots will appear here."
        )
      } else {
        rows
      }
    })

    snapshot_history
  })
}

#' App state management.
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Capture and restore the global (app) input state.
#'
#' @details
#' This module introduces bookmarks into `teal` apps: the `shiny` bookmarking mechanism becomes enabled
#' and server-side bookmarks can be created.
#'
#' The bookmark manager presents a button with the bookmark icon and is placed in the tab-bar.
#' When clicked, the button creates a bookmark and opens a modal which displays the bookmark URL.
#'
#' `teal` does not guarantee that all modules (`teal_module` objects) are bookmarkable.
#' Those that are, have a `teal_bookmarkable` attribute set to `TRUE`. If any modules are not bookmarkable,
#' the bookmark manager modal displays a warning and the bookmark button displays a flag.
#' In order to communicate that a external module is bookmarkable, the module developer
#' should set the `teal_bookmarkable` attribute to `TRUE`.
#'
#' @section Server logic:
#' A bookmark is a URL that contains the app address with a `/?_state_id_=<bookmark_dir>` suffix.
#' `<bookmark_dir>` is a directory created on the server, where the state of the application is saved.
#' Accessing the bookmark URL opens a new session of the app that starts in the previously saved state.
#'
#' @section Note:
#' To enable bookmarking use either:
#' - `shiny` app by using `shinyApp(..., enableBookmarking = "server")` (not supported in `shinytest2`)
#' - set `options(shiny.bookmarkStore = "server")` before running the app
#'
#'
#' @inheritParams init
#'
#' @return Invisible `NULL`.
#'
#' @aliases bookmark bookmark_manager bookmark_manager_module
#'
#' @name module_bookmark_manager
#' @rdname module_bookmark_manager
#'
#' @keywords internal
#'
NULL

#' @rdname module_bookmark_manager
ui_bookmark_panel <- function(id, modules) {
  ns <- NS(id)

  bookmark_option <- get_bookmarking_option()
  is_unbookmarkable <- need_bookmarking(modules)
  shinyOptions(bookmarkStore = bookmark_option)

  # Render bookmark warnings count
  if (!all(is_unbookmarkable) && identical(bookmark_option, "server")) {
    tags$button(
      id = ns("do_bookmark"),
      class = "btn action-button wunder_bar_button bookmark_manager_button",
      title = "Add bookmark",
      tags$span(
        suppressMessages(icon("fas fa-bookmark")),
        if (any(is_unbookmarkable)) {
          tags$span(
            sum(is_unbookmarkable),
            class = "badge-warning badge-count text-white bg-danger"
          )
        }
      )
    )
  }
}

#' @rdname module_bookmark_manager
srv_bookmark_panel <- function(id, modules) {
  checkmate::assert_character(id)
  checkmate::assert_class(modules, "teal_modules")
  moduleServer(id, function(input, output, session) {
    logger::log_debug("bookmark_manager_srv initializing")
    ns <- session$ns
    bookmark_option <- get_bookmarking_option()
    is_unbookmarkable <- need_bookmarking(modules)

    # Set up bookmarking callbacks ----
    # Register bookmark exclusions: do_bookmark button to avoid re-bookmarking
    setBookmarkExclude(c("do_bookmark"))
    # This bookmark can only be used on the app session.
    app_session <- .subset2(session, "parent")
    app_session$onBookmarked(function(url) {
      logger::log_debug("bookmark_manager_srv@onBookmarked: bookmark button clicked, registering bookmark")
      modal_content <- if (bookmark_option != "server") {
        msg <- sprintf(
          "Bookmarking has been set to \"%s\".\n%s\n%s",
          bookmark_option,
          "Only server-side bookmarking is supported.",
          "Please contact your app developer."
        )
        tags$div(
          tags$p(msg, class = "text-warning")
        )
      } else {
        tags$div(
          tags$span(
            tags$pre(url)
          ),
          if (any(is_unbookmarkable)) {
            bkmb_summary <- rapply2(
              modules_bookmarkable(modules),
              function(x) {
                if (isTRUE(x)) {
                  "\u2705" # check mark
                } else if (isFALSE(x)) {
                  "\u274C" # cross mark
                } else {
                  "\u2753" # question mark
                }
              }
            )
            tags$div(
              tags$p(
                icon("fas fa-exclamation-triangle"),
                "Some modules will not be restored when using this bookmark.",
                tags$br(),
                "Check the list below to see which modules are not bookmarkable.",
                class = "text-warning"
              ),
              tags$pre(yaml::as.yaml(bkmb_summary))
            )
          }
        )
      }

      showModal(
        modalDialog(
          id = ns("bookmark_modal"),
          title = "Bookmarked teal app url",
          modal_content,
          easyClose = TRUE
        )
      )
    })

    # manually trigger bookmarking because of the problems reported on windows with bookmarkButton in teal
    observeEvent(input$do_bookmark, {
      logger::log_debug("bookmark_manager_srv@1 do_bookmark module clicked.")
      session$doBookmark()
    })

    invisible(NULL)
  })
}


#' @rdname module_bookmark_manager
get_bookmarking_option <- function() {
  bookmark_option <- getShinyOption("bookmarkStore")
  if (is.null(bookmark_option) && identical(getOption("shiny.bookmarkStore"), "server")) {
    bookmark_option <- getOption("shiny.bookmarkStore")
  }
  bookmark_option
}

#' @rdname module_bookmark_manager
need_bookmarking <- function(modules) {
  unlist(rapply2(
    modules_bookmarkable(modules),
    Negate(isTRUE)
  ))
}


# utilities ----

#' Restore value from bookmark.
#'
#' Get value from bookmark or return default.
#'
#' Bookmarks can store not only inputs but also arbitrary values.
#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks,
#' and they are placed in the `values` environment in the `session$restoreContext` field.
#' Using `teal_data_module` makes it impossible to run the callbacks
#' because the app becomes ready before modules execute and callbacks are registered.
#' In those cases the stored values can still be recovered from the `session` object directly.
#'
#' Note that variable names in the `values` environment are prefixed with module name space names,
#' therefore, when using this function in modules, `value` must be run through the name space function.
#'
#' @param value (`character(1)`) name of value to restore
#' @param default fallback value
#'
#' @return
#' In an application restored from a server-side bookmark,
#' the variable specified by `value` from the `values` environment.
#' Otherwise `default`.
#'
#' @keywords internal
#'
restoreValue <- function(value, default) { # nolint: object_name.
  checkmate::assert_character("value")
  session_default <- shiny::getDefaultReactiveDomain()
  session_parent <- .subset2(session_default, "parent")
  session <- if (is.null(session_parent)) session_default else session_parent

  if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
    session$restoreContext$values[[value]]
  } else {
    default
  }
}

#' Compare bookmarks.
#'
#' Test if two bookmarks store identical state.
#'
#' `input` environments are compared one variable at a time and if not identical,
#' values in both bookmarks are reported. States of `datatable`s are stripped
#' of the `time` element before comparing because the time stamp is always different.
#' The contents themselves are not printed as they are large and the contents are not informative.
#' Elements present in one bookmark and absent in the other are also reported.
#' Differences are printed as messages.
#'
#' `values` environments are compared with `all.equal`.
#'
#' @section How to use:
#' Open an application, change relevant inputs (typically, all of them), and create a bookmark.
#' Then open that bookmark and immediately create a bookmark of that.
#' If restoring bookmarks occurred properly, the two bookmarks should store the same state.
#'
#'
#' @param book1,book2 bookmark directories stored in `shiny_bookmarks/`;
#'                    default to the two most recently modified directories
#'
#' @return
#' Invisible `NULL` if bookmarks are identical or if there are no bookmarks to test.
#' `FALSE` if inconsistencies are detected.
#'
#' @keywords internal
#'
bookmarks_identical <- function(book1, book2) {
  if (!dir.exists("shiny_bookmarks")) {
    message("no bookmark directory")
    return(invisible(NULL))
  }

  ans <- TRUE

  if (missing(book1) && missing(book2)) {
    dirs <- list.dirs("shiny_bookmarks", recursive = FALSE)
    bookmarks_sorted <- basename(rev(dirs[order(file.mtime(dirs))]))
    if (length(bookmarks_sorted) < 2L) {
      message("no bookmarks to compare")
      return(invisible(NULL))
    }
    book1 <- bookmarks_sorted[2L]
    book2 <- bookmarks_sorted[1L]
  } else {
    if (!dir.exists(file.path("shiny_bookmarks", book1))) stop(book1, " not found")
    if (!dir.exists(file.path("shiny_bookmarks", book2))) stop(book2, " not found")
  }

  book1_input <- readRDS(file.path("shiny_bookmarks", book1, "input.rds"))
  book2_input <- readRDS(file.path("shiny_bookmarks", book2, "input.rds"))

  elements_common <- intersect(names(book1_input), names(book2_input))
  dt_states <- grepl("_state$", elements_common)
  if (any(dt_states)) {
    for (el in elements_common[dt_states]) {
      book1_input[[el]][["time"]] <- NULL
      book2_input[[el]][["time"]] <- NULL
    }
  }

  identicals <- mapply(identical, book1_input[elements_common], book2_input[elements_common])
  non_identicals <- names(identicals[!identicals])
  compares <- sprintf("$ %s:\t%s --- %s", non_identicals, book1_input[non_identicals], book2_input[non_identicals])
  if (length(compares) != 0L) {
    message("common elements not identical: \n", paste(compares, collapse = "\n"))
    ans <- FALSE
  }

  elements_boook1 <- setdiff(names(book1_input), names(book2_input))
  if (length(elements_boook1) != 0L) {
    dt_states <- grepl("_state$", elements_boook1)
    if (any(dt_states)) {
      for (el in elements_boook1[dt_states]) {
        if (is.list(book1_input[[el]])) book1_input[[el]] <- "--- data table state ---"
      }
    }
    excess1 <- sprintf("$ %s:\t%s", elements_boook1, book1_input[elements_boook1])
    message("elements only in book1: \n", paste(excess1, collapse = "\n"))
    ans <- FALSE
  }

  elements_boook2 <- setdiff(names(book2_input), names(book1_input))
  if (length(elements_boook2) != 0L) {
    dt_states <- grepl("_state$", elements_boook1)
    if (any(dt_states)) {
      for (el in elements_boook1[dt_states]) {
        if (is.list(book2_input[[el]])) book2_input[[el]] <- "--- data table state ---"
      }
    }
    excess2 <- sprintf("$ %s:\t%s", elements_boook2, book2_input[elements_boook2])
    message("elements only in book2: \n", paste(excess2, collapse = "\n"))
    ans <- FALSE
  }

  book1_values <- readRDS(file.path("shiny_bookmarks", book1, "values.rds"))
  book2_values <- readRDS(file.path("shiny_bookmarks", book2, "values.rds"))

  if (!isTRUE(all.equal(book1_values, book2_values))) {
    message("different values detected")
    message("choices for numeric filters MAY be different, see RangeFilterState$set_choices")
    ans <- FALSE
  }

  if (ans) message("perfect!")
  invisible(NULL)
}


# Replacement for [base::rapply] which doesn't handle NULL values - skips the evaluation
# of the function and returns NULL for given element.
rapply2 <- function(x, f) {
  if (inherits(x, "list")) {
    lapply(x, rapply2, f = f)
  } else {
    f(x)
  }
}

#' Execute and validate `teal_data_module`
#'
#' This is a low level module to handle `teal_data_module` execution and validation.
#' [teal_transform_module()] inherits from [teal_data_module()] so it is handled by this module too.
#' [srv_teal()] accepts various `data` objects and eventually they are all transformed to `reactive`
#' [teal_data()] which is a standard data class in whole `teal` framework.
#'
#' @section data validation:
#'
#' Executed [teal_data_module()] is validated and output is validated for consistency.
#' Output `data` is invalid if:
#' 1. [teal_data_module()] is invalid if server doesn't return `reactive`. **Immediately crashes an app!**
#' 2. `reactive` throws a `shiny.error` - happens when module creating [teal_data()] fails.
#' 3. `reactive` returns `qenv.error` - happens when [teal_data()] evaluates a failing code.
#' 4. `reactive` object doesn't return [teal_data()].
#' 5. [teal_data()] object lacks any `datanames` specified in the `modules` argument.
#'
#' `teal` (observers in `srv_teal`) always waits to render an app until `reactive` `teal_data` is
#' returned. If error 2-4 occurs, relevant error message is displayed to the app user. Once the issue is
#' resolved, the app will continue to run. `teal` guarantees that errors in data don't crash the app
#' (except error 1).
#'
#' @param id (`character(1)`) Module id
#' @param data (`reactive teal_data`)
#' @param data_module (`teal_data_module`)
#' @param modules (`teal_modules` or `teal_module`) For `datanames` validation purpose
#' @param validate_shiny_silent_error (`logical`) If `TRUE`, then `shiny.silent.error` is validated and
#' @param is_transformer_failed (`reactiveValues`) contains `logical` flags named after each transformer.
#' Help to determine if any previous transformer failed, so that following transformers can be disabled
#' and display a generic failure message.
#'
#' @return `reactive` `teal_data`
#'
#' @rdname module_teal_data
#' @name module_teal_data
#' @keywords internal
NULL

#' @rdname module_teal_data
ui_teal_data <- function(id, data_module = function(id) NULL) {
  checkmate::assert_string(id)
  checkmate::assert_function(data_module, args = "id")
  ns <- NS(id)

  shiny::tagList(
    tags$div(id = ns("wrapper"), data_module(id = ns("data"))),
    ui_validate_reactive_teal_data(ns("validate"))
  )
}

#' @rdname module_teal_data
srv_teal_data <- function(id,
                          data_module = function(id) NULL,
                          modules = NULL,
                          validate_shiny_silent_error = TRUE,
                          is_transformer_failed = reactiveValues()) {
  checkmate::assert_string(id)
  checkmate::assert_function(data_module, args = "id")
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
  checkmate::assert_class(is_transformer_failed, "reactivevalues")

  moduleServer(id, function(input, output, session) {
    logger::log_debug("srv_teal_data initializing.")
    is_transformer_failed[[id]] <- FALSE
    data_out <- data_module(id = "data")
    data_handled <- reactive(tryCatch(data_out(), error = function(e) e))
    observeEvent(data_handled(), {
      if (!inherits(data_handled(), "teal_data")) {
        is_transformer_failed[[id]] <- TRUE
      } else {
        is_transformer_failed[[id]] <- FALSE
      }
    })

    is_previous_failed <- reactive({
      idx_this <- which(names(is_transformer_failed) == id)
      is_transformer_failed_list <- reactiveValuesToList(is_transformer_failed)
      idx_failures <- which(unlist(is_transformer_failed_list))
      any(idx_failures < idx_this)
    })

    observeEvent(is_previous_failed(), {
      if (is_previous_failed()) {
        shinyjs::disable("wrapper")
      } else {
        shinyjs::enable("wrapper")
      }
    })

    srv_validate_reactive_teal_data(
      "validate",
      data = data_handled,
      modules = modules,
      validate_shiny_silent_error = validate_shiny_silent_error,
      hide_validation_error = is_previous_failed
    )
  })
}

#' @rdname module_teal_data
ui_validate_reactive_teal_data <- function(id) {
  ns <- NS(id)
  tagList(
    div(
      id = ns("validate_messages"),
      class = "teal_validated",
      ui_validate_error(ns("silent_error")),
      ui_check_class_teal_data(ns("class_teal_data")),
      ui_check_shiny_warnings(ns("shiny_warnings"))
    ),
    div(
      class = "teal_validated",
      uiOutput(ns("previous_failed"))
    )
  )
}

#' @rdname module_teal_data
srv_validate_reactive_teal_data <- function(id, # nolint: object_length
                                            data,
                                            modules = NULL,
                                            validate_shiny_silent_error = FALSE,
                                            hide_validation_error = reactive(FALSE)) {
  checkmate::assert_string(id)
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
  checkmate::assert_flag(validate_shiny_silent_error)

  moduleServer(id, function(input, output, session) {
    # there is an empty reactive cycle on `init` and `data_rv` has `shiny.silent.error` class
    srv_validate_error("silent_error", data, validate_shiny_silent_error)
    srv_check_class_teal_data("class_teal_data", data)
    srv_check_shiny_warnings("shiny_warnings", data, modules)
    output$previous_failed <- renderUI({
      if (hide_validation_error()) {
        shinyjs::hide("validate_messages")
        tags$div("One of previous transformers failed. Please fix and continue.", class = "teal-output-warning")
      } else {
        shinyjs::show("validate_messages")
        NULL
      }
    })

    .trigger_on_success(data)
  })
}

#' @keywords internal
ui_validate_error <- function(id) {
  ns <- NS(id)
  uiOutput(ns("message"))
}

#' @keywords internal
srv_validate_error <- function(id, data, validate_shiny_silent_error) {
  checkmate::assert_string(id)
  checkmate::assert_flag(validate_shiny_silent_error)
  moduleServer(id, function(input, output, session) {
    output$message <- renderUI({
      is_shiny_silent_error <- inherits(data(), "shiny.silent.error") && identical(data()$message, "")
      if (inherits(data(), "qenv.error")) {
        validate(
          need(
            FALSE,
            paste(
              "Error when executing the `data` module:",
              strip_style(paste(data()$message, collapse = "\n")),
              "\nCheck your inputs or contact app developer if error persists.",
              collapse = "\n"
            )
          )
        )
      } else if (inherits(data(), "error")) {
        if (is_shiny_silent_error && !validate_shiny_silent_error) {
          return(NULL)
        }
        validate(
          need(
            FALSE,
            sprintf(
              "Shiny error when executing the `data` module.\n%s\n%s",
              data()$message,
              "Check your inputs or contact app developer if error persists."
            )
          )
        )
      }
    })
  })
}


#' @keywords internal
ui_check_class_teal_data <- function(id) {
  ns <- NS(id)
  uiOutput(ns("message"))
}

#' @keywords internal
srv_check_class_teal_data <- function(id, data) {
  checkmate::assert_string(id)
  moduleServer(id, function(input, output, session) {
    output$message <- renderUI({
      validate(
        need(
          inherits(data(), c("teal_data", "error")),
          "Did not receive `teal_data` object. Cannot proceed further."
        )
      )
    })
  })
}

#' @keywords internal
ui_check_shiny_warnings <- function(id) {
  ns <- NS(id)
  uiOutput(NS(id, "message"))
}

#' @keywords internal
srv_check_shiny_warnings <- function(id, data, modules) {
  checkmate::assert_string(id)
  moduleServer(id, function(input, output, session) {
    output$message <- renderUI({
      if (inherits(data(), "teal_data")) {
        is_modules_ok <- check_modules_datanames_html(
          modules = modules, datanames = ls(teal.code::get_env(data()))
        )
        if (!isTRUE(is_modules_ok)) {
          tags$div(is_modules_ok, class = "teal-output-warning")
        }
      }
    })
  })
}

.trigger_on_success <- function(data) {
  out <- reactiveVal(NULL)
  observeEvent(data(), {
    if (inherits(data(), "teal_data")) {
      if (!identical(data(), out())) {
        out(data())
      }
    }
  })

  out
}

#' Generate lockfile for application's environment reproducibility
#'
#' @param lockfile_path (`character`) path to the lockfile.
#'
#' @section Different ways of creating lockfile:
#' `teal` leverages [renv::snapshot()], which offers multiple methods for lockfile creation.
#'
#' - **Working directory lockfile**: `teal`, by default, will create an `implicit` type lockfile that uses
#' `renv::dependencies()` to detect all R packages in the current project's working directory.
#' - **`DESCRIPTION`-based lockfile**: To generate a lockfile based on a `DESCRIPTION` file in your working
#' directory, set `renv::settings$snapshot.type("explicit")`. The naming convention for `type` follows
#' `renv::snapshot()`. For the `"explicit"` type, refer to `renv::settings$package.dependency.fields()` for the
#' `DESCRIPTION` fields included in the lockfile.
#' - **Custom files-based lockfile**: To specify custom files as the basis for the lockfile, set
#' `renv::settings$snapshot.type("custom")` and configure the `renv.snapshot.filter` option.
#'
#' @section lockfile usage:
#' After creating the lockfile, you can restore the application's environment using `renv::restore()`.
#'
#' @seealso [renv::snapshot()], [renv::restore()].
#'
#' @return `NULL`
#'
#' @name module_teal_lockfile
#' @rdname module_teal_lockfile
#'
#' @keywords internal
NULL

#' @rdname module_teal_lockfile
ui_teal_lockfile <- function(id) {
  ns <- NS(id)
  shiny::tagList(
    tags$span("", id = ns("lockFileStatus")),
    shinyjs::disabled(downloadLink(ns("lockFileLink"), "Download lockfile"))
  )
}

#' @rdname module_teal_lockfile
srv_teal_lockfile <- function(id) {
  moduleServer(id, function(input, output, session) {
    logger::log_debug("Initialize srv_teal_lockfile.")
    enable_lockfile_download <- function() {
      shinyjs::html("lockFileStatus", "Application lockfile ready.")
      shinyjs::hide("lockFileStatus", anim = TRUE)
      shinyjs::enable("lockFileLink")
      output$lockFileLink <- shiny::downloadHandler(
        filename = function() {
          "renv.lock"
        },
        content = function(file) {
          file.copy(lockfile_path, file)
          file
        },
        contentType = "application/json"
      )
    }
    disable_lockfile_download <- function() {
      warning("Lockfile creation failed.", call. = FALSE)
      shinyjs::html("lockFileStatus", "Lockfile creation failed.")
      shinyjs::hide("lockFileLink")
    }

    shiny::onStop(function() {
      if (file.exists(lockfile_path) && !shiny::isRunning()) {
        logger::log_debug("Removing lockfile after shutting down the app")
        file.remove(lockfile_path)
      }
    })

    lockfile_path <- "teal_app.lock"
    mode <- getOption("teal.lockfile.mode", default = "")

    if (!(mode %in% c("auto", "enabled", "disabled"))) {
      stop("'teal.lockfile.mode' option can only be one of \"auto\", \"disabled\" or \"disabled\". ")
    }

    if (mode == "disabled") {
      logger::log_debug("'teal.lockfile.mode' option is set to 'disabled'. Hiding lockfile download button.")
      shinyjs::hide("lockFileLink")
      return(NULL)
    }

    if (file.exists(lockfile_path)) {
      logger::log_debug("Lockfile has already been created for this app - skipping automatic creation.")
      enable_lockfile_download()
      return(NULL)
    }

    if (mode == "auto" && .is_disabled_lockfile_scenario()) {
      logger::log_debug(
        "Automatic lockfile creation disabled. Execution scenario satisfies teal:::.is_disabled_lockfile_scenario()."
      )
      shinyjs::hide("lockFileLink")
      return(NULL)
    }

    if (!.is_lockfile_deps_installed()) {
      warning("Automatic lockfile creation disabled. `mirai` and `renv` packages must be installed.")
      shinyjs::hide("lockFileLink")
      return(NULL)
    }

    # - Will be run only if the lockfile doesn't exist (see the if-s above)
    # - We render to the tempfile because the process might last after session is closed and we don't
    #   want to make a "teal_app.renv" then. This is why we copy only during active session.
    process <- .teal_lockfile_process_invoke(lockfile_path)
    observeEvent(process$status(), {
      if (process$status() %in% c("initial", "running")) {
        shinyjs::html("lockFileStatus", "Creating lockfile...")
      } else if (process$status() == "success") {
        result <- process$result()
        if (any(grepl("Lockfile written to", result$out))) {
          logger::log_debug("Lockfile containing { length(result$res$Packages) } packages created.")
          if (any(grepl("(WARNING|ERROR):", result$out))) {
            warning("Lockfile created with warning(s) or error(s):", call. = FALSE)
            for (i in result$out) {
              warning(i, call. = FALSE)
            }
          }
          enable_lockfile_download()
        } else {
          disable_lockfile_download()
        }
      } else if (process$status() == "error") {
        disable_lockfile_download()
      }
    })

    NULL
  })
}

utils::globalVariables(c("opts", "sysenv", "libpaths", "wd", "lockfilepath", "run")) # needed for mirai call
#' @rdname module_teal_lockfile
.teal_lockfile_process_invoke <- function(lockfile_path) {
  mirai_obj <- NULL
  process <- shiny::ExtendedTask$new(function() {
    m <- mirai::mirai(
      {
        options(opts)
        do.call(Sys.setenv, sysenv)
        .libPaths(libpaths)
        setwd(wd)
        run(lockfile_path = lockfile_path)
      },
      run = .renv_snapshot,
      lockfile_path = lockfile_path,
      opts = options(),
      libpaths = .libPaths(),
      sysenv = as.list(Sys.getenv()),
      wd = getwd()
    )
    mirai_obj <<- m
    m
  })

  shiny::onStop(function() {
    if (mirai::unresolved(mirai_obj)) {
      logger::log_debug("Terminating a running lockfile process...")
      mirai::stop_mirai(mirai_obj) # this doesn't stop running - renv will be created even if session is closed
    }
  })

  suppressWarnings({ # 'package:stats' may not be available when loading
    process$invoke()
  })

  logger::log_debug("Lockfile creation started based on { getwd() }.")

  process
}

#' @rdname module_teal_lockfile
.renv_snapshot <- function(lockfile_path) {
  out <- utils::capture.output(
    res <- renv::snapshot(
      lockfile = lockfile_path,
      prompt = FALSE,
      force = TRUE,
      type = renv::settings$snapshot.type() # see the section "Different ways of creating lockfile" above here
    )
  )

  list(out = out, res = res)
}

#' @rdname module_teal_lockfile
.is_lockfile_deps_installed <- function() {
  requireNamespace("mirai", quietly = TRUE) && requireNamespace("renv", quietly = TRUE)
}

#' @rdname module_teal_lockfile
.is_disabled_lockfile_scenario <- function() {
  identical(Sys.getenv("CALLR_IS_RUNNING"), "true") || # inside callr process
    identical(Sys.getenv("TESTTHAT"), "true") || # inside devtools::test
    !identical(Sys.getenv("QUARTO_PROJECT_ROOT"), "") || # inside Quarto process
    (
      ("CheckExEnv" %in% search()) || any(c("_R_CHECK_TIMINGS_", "_R_CHECK_LICENSE_") %in% names(Sys.getenv()))
    ) # inside R CMD CHECK
}

#' @title `TealReportCard`
#' @description `r lifecycle::badge("experimental")`
#' Child class of [`ReportCard`] that is used for `teal` specific applications.
#' In addition to the parent methods, it supports rendering `teal` specific elements such as
#' the source code, the encodings panel content and the filter panel content as part of the
#' meta data.
#' @export
#'
TealReportCard <- R6::R6Class( # nolint: object_name.
  classname = "TealReportCard",
  inherit = teal.reporter::ReportCard,
  public = list(
    #' @description Appends the source code to the `content` meta data of this `TealReportCard`.
    #'
    #' @param src (`character(1)`) code as text.
    #' @param ... any `rmarkdown` `R` chunk parameter and its value.
    #' But `eval` parameter is always set to `FALSE`.
    #' @return Object of class `TealReportCard`, invisibly.
    #' @examples
    #' card <- TealReportCard$new()$append_src(
    #'   "plot(iris)"
    #' )
    #' card$get_content()[[1]]$get_content()
    append_src = function(src, ...) {
      checkmate::assert_character(src, min.len = 0, max.len = 1)
      params <- list(...)
      params$eval <- FALSE
      rblock <- RcodeBlock$new(src)
      rblock$set_params(params)
      self$append_content(rblock)
      self$append_metadata("SRC", src)
      invisible(self)
    },
    #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.
    #'  If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses
    #'  the default `yaml::as.yaml` to format the list.
    #'  If the filter state list is empty, nothing is appended to the `content`.
    #'
    #' @param fs (`teal_slices`) object returned from [teal_slices()] function.
    #' @return `self`, invisibly.
    append_fs = function(fs) {
      checkmate::assert_class(fs, "teal_slices")
      self$append_text("Filter State", "header3")
      if (length(fs)) {
        self$append_content(TealSlicesBlock$new(fs))
      } else {
        self$append_text("No filters specified.")
      }
      invisible(self)
    },
    #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.
    #'
    #' @param encodings (`list`) list of encodings selections of the `teal` app.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))
    #' card$get_content()[[1]]$get_content()
    #'
    append_encodings = function(encodings) {
      checkmate::assert_list(encodings)
      self$append_text("Selected Options", "header3")
      if (requireNamespace("yaml", quietly = TRUE)) {
        self$append_text(yaml::as.yaml(encodings, handlers = list(
          POSIXct = function(x) format(x, "%Y-%m-%d"),
          POSIXlt = function(x) format(x, "%Y-%m-%d"),
          Date = function(x) format(x, "%Y-%m-%d")
        )), "verbatim")
      } else {
        stop("yaml package is required to format the encodings list")
      }
      self$append_metadata("Encodings", encodings)
      invisible(self)
    }
  ),
  private = list(
    dispatch_block = function(block_class) {
      eval(str2lang(block_class))
    }
  )
)

#' @title `TealSlicesBlock`
#' @docType class
#' @description
#' Specialized `TealSlicesBlock` block for managing filter panel content in reports.
#' @keywords internal
TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter.
  classname = "TealSlicesBlock",
  inherit = teal.reporter:::TextBlock,
  public = list(
    #' @description Returns a `TealSlicesBlock` object.
    #'
    #' @details Returns a `TealSlicesBlock` object with no content and no parameters.
    #'
    #' @param content (`teal_slices`) object returned from [teal_slices()] function.
    #' @param style (`character(1)`) string specifying style to apply.
    #'
    #' @return Object of class `TealSlicesBlock`, invisibly.
    #'
    initialize = function(content = teal_slices(), style = "verbatim") {
      self$set_content(content)
      self$set_style(style)
      invisible(self)
    },

    #' @description Sets content of this `TealSlicesBlock`.
    #' Sets content as `YAML` text which represents a list generated from `teal_slices`.
    #' The list displays limited number of fields from `teal_slice` objects, but this list is
    #' sufficient to conclude which filters were applied.
    #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"
    #'
    #'
    #' @param content (`teal_slices`) object returned from [teal_slices()] function.
    #' @return `self`, invisibly.
    set_content = function(content) {
      checkmate::assert_class(content, "teal_slices")
      if (length(content) != 0) {
        states_list <- lapply(content, function(x) {
          x_list <- shiny::isolate(as.list(x))
          if (
            inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
              length(x_list$choices) == 2 &&
              length(x_list$selected) == 2
          ) {
            x_list$range <- paste(x_list$selected, collapse = " - ")
            x_list["selected"] <- NULL
          }
          if (!is.null(x_list$arg)) {
            x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"
          }

          x_list <- x_list[
            c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
          ]
          names(x_list) <- c(
            "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",
            "Selected Values", "Selected range", "Include NA values", "Include Inf values"
          )

          Filter(Negate(is.null), x_list)
        })

        if (requireNamespace("yaml", quietly = TRUE)) {
          super$set_content(yaml::as.yaml(states_list))
        } else {
          stop("yaml package is required to format the filter state list")
        }
      }
      private$teal_slices <- content
      invisible(self)
    },
    #' @description Create the `TealSlicesBlock` from a list.
    #'
    #' @param x (`named list`) with two fields `text` and `style`.
    #' Use the `get_available_styles` method to get all possible styles.
    #'
    #' @return `self`, invisibly.
    #' @examples
    #' TealSlicesBlock <- getFromNamespace("TealSlicesBlock", "teal")
    #' block <- TealSlicesBlock$new()
    #' block$from_list(list(text = "sth", style = "default"))
    #'
    from_list = function(x) {
      checkmate::assert_list(x)
      checkmate::assert_names(names(x), must.include = c("text", "style"))
      super$set_content(x$text)
      super$set_style(x$style)
      invisible(self)
    },
    #' @description Convert the `TealSlicesBlock` to a list.
    #'
    #' @return `named list` with a text and style.
    #' @examples
    #' TealSlicesBlock <- getFromNamespace("TealSlicesBlock", "teal")
    #' block <- TealSlicesBlock$new()
    #' block$to_list()
    #'
    to_list = function() {
      content <- self$get_content()
      list(
        text = if (length(content)) content else "",
        style = self$get_style()
      )
    }
  ),
  private = list(
    style = "verbatim",
    teal_slices = NULL # teal_slices
  )
)

#' Filter panel module in teal
#'
#' Creates filter panel module from `teal_data` object and returns `teal_data`. It is build in a way
#' that filter panel changes and anything what happens before (e.g. [`module_init_data`]) is triggering
#' further reactive events only if something has changed and if the module is visible. Thanks to
#' this special implementation all modules' data are recalculated only for those modules which are
#' currently displayed.
#'
#' @return A `eventReactive` containing `teal_data` containing filtered objects and filter code.
#' `eventReactive` triggers only if all conditions are met:
#'  - tab is selected (`is_active`)
#'  - when filters are changed (`get_filter_expr` is different than previous)
#'
#' @inheritParams module_teal_module
#' @param active_datanames (`reactive` returning `character`) this module's data names
#' @name module_filter_data
#' @keywords internal
NULL

#' @rdname module_filter_data
ui_filter_data <- function(id) {
  ns <- shiny::NS(id)
  uiOutput(ns("panel"))
}

#' @rdname module_filter_data
srv_filter_data <- function(id, datasets, active_datanames, data_rv, is_active) {
  assert_reactive(datasets)
  moduleServer(id, function(input, output, session) {
    active_corrected <- reactive(intersect(active_datanames(), datasets()$datanames()))

    output$panel <- renderUI({
      req(inherits(datasets(), "FilteredData"))
      isolate({
        # render will be triggered only when FilteredData object changes (not when filters change)
        # technically it means that teal_data_module needs to be refreshed
        logger::log_debug("srv_filter_panel rendering filter panel.")
        if (length(active_corrected())) {
          datasets()$srv_active("filters", active_datanames = active_corrected)
          datasets()$ui_active(session$ns("filters"), active_datanames = active_corrected)
        }
      })
    })

    trigger_data <- .observe_active_filter_changed(datasets, is_active, active_corrected, data_rv)

    eventReactive(trigger_data(), {
      .make_filtered_teal_data(modules, data = data_rv(), datasets = datasets(), datanames = active_corrected())
    })
  })
}

#' @rdname module_filter_data
.make_filtered_teal_data <- function(modules, data, datasets = NULL, datanames) {
  data <- eval_code(
    data,
    paste0(
      ".raw_data <- list2env(list(",
      toString(sprintf("%1$s = %1$s", sapply(datanames, as.name))),
      "))\n",
      "lockEnvironment(.raw_data) # @linksto .raw_data" # this is environment and it is shared by qenvs. CAN'T MODIFY!
    )
  )
  filtered_code <- .get_filter_expr(datasets = datasets, datanames = datanames)
  filtered_teal_data <- .append_evaluated_code(data, filtered_code)
  filtered_datasets <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)
  filtered_teal_data <- .append_modified_data(filtered_teal_data, filtered_datasets)
  filtered_teal_data
}

#' @rdname module_filter_data
.observe_active_filter_changed <- function(datasets, is_active, active_datanames, data_rv) {
  previous_signature <- reactiveVal(NULL)
  filter_changed <- reactive({
    req(inherits(datasets(), "FilteredData"))
    new_signature <- c(
      teal.code::get_code(data_rv()),
      .get_filter_expr(datasets = datasets(), datanames = active_datanames())
    )
    if (!identical(previous_signature(), new_signature)) {
      previous_signature(new_signature)
      TRUE
    } else {
      FALSE
    }
  })

  trigger_data <- reactiveVal(NULL)
  observe({
    if (isTRUE(is_active() && filter_changed())) {
      isolate({
        if (is.null(trigger_data())) {
          trigger_data(0)
        } else {
          trigger_data(trigger_data() + 1)
        }
      })
    }
  })

  trigger_data
}

#' @rdname module_filter_data
.get_filter_expr <- function(datasets, datanames) {
  if (length(datanames)) {
    teal.slice::get_filter_expr(datasets = datasets, datanames = datanames)
  } else {
    NULL
  }
}

# This is the main function from teal to be used by the end-users. Although it delegates
# directly to `module_teal_with_splash.R`, we keep it in a separate file because its documentation is quite large
# and it is very end-user oriented. It may also perform more argument checking with more informative
# error messages.

#' Create the server and UI function for the `shiny` app
#'
#' @description `r lifecycle::badge("stable")`
#'
#' End-users: This is the most important function for you to start a
#' `teal` app that is composed of `teal` modules.
#'
#' @param data (`teal_data` or `teal_data_module`)
#'   For constructing the data object, refer to [teal_data()] and [teal_data_module()].
#'   If `datanames` are not set for the `teal_data` object, defaults from the `teal_data` environment will be used.
#' @param modules (`list` or `teal_modules` or `teal_module`)
#'   Nested list of `teal_modules` or `teal_module` objects or a single
#'   `teal_modules` or `teal_module` object. These are the specific output modules which
#'   will be displayed in the `teal` application. See [modules()] and [module()] for
#'   more details.
#' @param filter (`teal_slices`) Optionally,
#'   specifies the initial filter using [teal_slices()].
#' @param title (`shiny.tag` or `character(1)`) Optionally,
#'   the browser window title. Defaults to a title "teal app" with the icon of NEST.
#'   Can be created using the `build_app_title()` or
#'   by passing a valid `shiny.tag` which is a head tag with title and link tag.
#' @param header (`shiny.tag` or `character(1)`) Optionally,
#'   the header of the app.
#' @param footer (`shiny.tag` or `character(1)`) Optionally,
#'   the footer of the app.
#' @param id (`character`) Optionally,
#'   a string specifying the `shiny` module id in cases it is used as a `shiny` module
#'   rather than a standalone `shiny` app. This is a legacy feature.
#' @param landing_popup (`teal_module_landing`) Optionally,
#'   a `landing_popup_module` to show up as soon as the teal app is initialized.
#'
#' @return Named list containing server and UI functions.
#'
#' @export
#'
#' @include modules.R
#'
#' @examples
#' app <- init(
#'   data = within(
#'     teal_data(),
#'     {
#'       new_iris <- transform(iris, id = seq_len(nrow(iris)))
#'       new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
#'     }
#'   ),
#'   modules = modules(
#'     module(
#'       label = "data source",
#'       server = function(input, output, session, data) {},
#'       ui = function(id, ...) tags$div(p("information about data source")),
#'       datanames = "all"
#'     ),
#'     example_module(label = "example teal module"),
#'     module(
#'       "Iris Sepal.Length histogram",
#'       server = function(input, output, session, data) {
#'         output$hist <- renderPlot(
#'           hist(data()[["new_iris"]]$Sepal.Length)
#'         )
#'       },
#'       ui = function(id, ...) {
#'         ns <- NS(id)
#'         plotOutput(ns("hist"))
#'       },
#'       datanames = "new_iris"
#'     )
#'   ),
#'   filter = teal_slices(
#'     teal_slice(dataname = "new_iris", varname = "Species"),
#'     teal_slice(dataname = "new_iris", varname = "Sepal.Length"),
#'     teal_slice(dataname = "new_mtcars", varname = "cyl"),
#'     exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
#'     module_specific = TRUE,
#'     mapping = list(
#'       `example teal module` = "new_iris Species",
#'       `Iris Sepal.Length histogram` = "new_iris Species",
#'       global_filters = "new_mtcars cyl"
#'     )
#'   ),
#'   title = "App title",
#'   header = tags$h1("Sample App"),
#'   footer = tags$p("Sample footer")
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
init <- function(data,
                 modules,
                 filter = teal_slices(),
                 title = build_app_title(),
                 header = tags$p(),
                 footer = tags$p(),
                 id = character(0),
                 landing_popup = NULL) {
  logger::log_debug("init initializing teal app with: data ('{ class(data) }').")

  # argument checking (independent)
  ## `data`
  if (inherits(data, "TealData")) {
    lifecycle::deprecate_stop(
      when = "0.15.0",
      what = "init(data)",
      paste(
        "TealData is no longer supported. Use teal_data() instead.",
        "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/988."
      )
    )
  }
  checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
  checkmate::assert_class(landing_popup, "teal_module_landing", null.ok = TRUE)

  ## `modules`
  checkmate::assert(
    .var.name = "modules",
    checkmate::check_multi_class(modules, c("teal_modules", "teal_module")),
    checkmate::check_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
  )
  if (inherits(modules, "teal_module")) {
    modules <- list(modules)
  }
  if (checkmate::test_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))) {
    modules <- do.call(teal::modules, modules)
  }

  ## `filter`
  checkmate::assert_class(filter, "teal_slices")

  ## all other arguments
  checkmate::assert(
    .var.name = "title",
    checkmate::check_string(title),
    checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert(
    .var.name = "header",
    checkmate::check_string(header),
    checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert(
    .var.name = "footer",
    checkmate::check_string(footer),
    checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)

  # log
  teal.logger::log_system_info()

  # argument transformations
  ## `modules` - landing module
  landing <- extract_module(modules, "teal_module_landing")
  if (length(landing) == 1L) {
    landing_popup <- landing[[1L]]
    modules <- drop_module(modules, "teal_module_landing")
    lifecycle::deprecate_soft(
      when = "0.15.3",
      what = "landing_popup_module()",
      details = paste(
        "Pass `landing_popup_module` to the `landing_popup` argument of the `init` ",
        "instead of wrapping it into `modules()` and passing to the `modules` argument"
      )
    )
  } else if (length(landing) > 1L) {
    stop("Only one `landing_popup_module` can be used.")
  }

  ## `filter` - set app_id attribute unless present (when restoring bookmark)
  if (is.null(attr(filter, "app_id", exact = TRUE))) attr(filter, "app_id") <- create_app_id(data, modules)

  ## `filter` - convert teal.slice::teal_slices to teal::teal_slices
  filter <- as.teal_slices(as.list(filter))

  # argument checking (interdependent)
  ## `filter` - `modules`
  if (isTRUE(attr(filter, "module_specific"))) {
    module_names <- unlist(c(module_labels(modules), "global_filters"))
    failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)
    if (length(failed_mod_names)) {
      stop(
        sprintf(
          "Some module names in the mapping arguments don't match module labels.\n %s not in %s",
          toString(failed_mod_names),
          toString(unique(module_names))
        )
      )
    }

    if (anyDuplicated(module_names)) {
      # In teal we are able to set nested modules with duplicated label.
      # Because mapping argument bases on the relationship between module-label and filter-id,
      # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)
      stop(
        sprintf(
          "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",
          toString(module_names[duplicated(module_names)])
        )
      )
    }
  }

  ## `data` - `modules`
  if (inherits(data, "teal_data")) {
    if (length(ls(teal.code::get_env(data))) == 0) {
      stop("The environment of `data` is empty.")
    }

    is_modules_ok <- check_modules_datanames(modules, ls(teal.code::get_env(data)))
    if (!isTRUE(is_modules_ok) && length(unlist(extract_transformers(modules))) == 0) {
      warning(is_modules_ok, call. = FALSE)
    }

    is_filter_ok <- check_filter_datanames(filter, ls(teal.code::get_env(data)))
    if (!isTRUE(is_filter_ok)) {
      warning(is_filter_ok)
      # we allow app to continue if applied filters are outside
      # of possible data range
    }
  }

  reporter <- teal.reporter::Reporter$new()$set_id(attr(filter, "app_id"))
  if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
    modules <- append_module(
      modules,
      reporter_previewer_module(server_args = list(previewer_buttons = c("download", "reset")))
    )
  }

  ns <- NS(id)
  # Note: UI must be a function to support bookmarking.
  res <- list(
    ui = function(request) {
      ui_teal(
        id = ns("teal"),
        modules = modules,
        title = title,
        header = header,
        footer = footer
      )
    },
    server = function(input, output, session) {
      if (!is.null(landing_popup)) {
        do.call(landing_popup$server, c(list(id = "landing_module_shiny_id"), landing_popup$server_args))
      }
      srv_teal(id = ns("teal"), data = data, modules = modules, filter = deep_copy_filter(filter))
    }
  )

  logger::log_debug("init teal app has been initialized.")

  res
}

#' Data module for `teal` applications
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Create a `teal_data_module` object and evaluate code on it with history tracking.
#'
#' @details
#' `teal_data_module` creates a `shiny` module to interactively supply or modify data in a `teal` application.
#' The module allows for running any code (creation _and_ some modification) after the app starts or reloads.
#' The body of the server function will be run in the app rather than in the global environment.
#' This means it will be run every time the app starts, so use sparingly.
#'
#' Pass this module instead of a `teal_data` object in a call to [init()].
#' Note that the server function must always return a `teal_data` object wrapped in a reactive expression.
#'
#' See vignette `vignette("data-as-shiny-module", package = "teal")` for more details.
#'
#' @param ui (`function(id)`)
#'  `shiny` module UI function; must only take `id` argument
#' @param server (`function(id)`)
#'  `shiny` module server function; must only take `id` argument;
#'  must return reactive expression containing `teal_data` object
#' @param label (`character(1)`) Label of the module.
#' @param once (`logical(1)`)
#'  If `TRUE`, the data module will be shown only once and will disappear after successful data loading.
#'  App user will no longer be able to interact with this module anymore.
#'  If `FALSE`, the data module can be reused multiple times.
#'  App user will be able to interact and change the data output from the module multiple times.
#'
#' @return
#' `teal_data_module` returns a list of class `teal_data_module` containing two elements, `ui` and
#' `server` provided via arguments.
#'
#' @examples
#' tdm <- teal_data_module(
#'   ui = function(id) {
#'     ns <- NS(id)
#'     actionButton(ns("submit"), label = "Load data")
#'   },
#'   server = function(id) {
#'     moduleServer(id, function(input, output, session) {
#'       eventReactive(input$submit, {
#'         data <- within(
#'           teal_data(),
#'           {
#'             dataset1 <- iris
#'             dataset2 <- mtcars
#'           }
#'         )
#'         datanames(data) <- c("dataset1", "dataset2")
#'
#'         data
#'       })
#'     })
#'   }
#' )
#'
#' @name teal_data_module
#' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]
#'
#' @export
teal_data_module <- function(ui, server, label = "data module", once = TRUE) {
  checkmate::assert_function(ui, args = "id", nargs = 1)
  checkmate::assert_function(server, args = "id", nargs = 1)
  checkmate::assert_string(label)
  checkmate::assert_flag(once)
  structure(
    list(
      ui = ui,
      server = function(id) {
        data_out <- server(id)
        decorate_err_msg(
          assert_reactive(data_out),
          pre = sprintf("From: 'teal_data_module()':\nA 'teal_data_module' with \"%s\" label:", label),
          post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
        )
      }
    ),
    label = label,
    class = "teal_data_module",
    once = once
  )
}

#' Data module for `teal` transformers.
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Create a `teal_data_module` object for custom transformation of data for pre-processing
#' before passing the data into the module.
#'
#' @details
#' `teal_transform_module` creates a [`teal_data_module`] object to transform data in a `teal`
#' application. This transformation happens after the data has passed through the filtering activity
#' in teal. The transformed data is then sent to the server of the [teal_module()].
#'
#' See vignette `vignette("data-transform-as-shiny-module", package = "teal")` for more details.
#'
#'
#' @inheritParams teal_data_module
#' @param server (`function(id, data)`)
#' `shiny` module server function; that takes `id` and `data` argument,
#' where the `id` is the module id and `data` is the reactive `teal_data` input.
#' The server function must return reactive expression containing `teal_data` object.
#'
#' The server function definition should not use `eventReactive` as it may lead to
#' unexpected behavior.
#' See `vignettes("data-transform-as-shiny-module")` for more information.
#' @param datanames (`character`)
#'  Names of the datasets that are relevant for this module to evaluate. If set to `character(0)`
#'  then module would receive [modules()] `datanames`.
#' @examples
#' my_transformers <- list(
#'   teal_transform_module(
#'     label = "Custom transform for iris",
#'     datanames = "iris",
#'     ui = function(id) {
#'       ns <- NS(id)
#'       tags$div(
#'         numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
#'       )
#'     },
#'     server = function(id, data) {
#'       moduleServer(id, function(input, output, session) {
#'         reactive({
#'           within(data(),
#'             {
#'               iris <- head(iris, num_rows)
#'             },
#'             num_rows = input$n_rows
#'           )
#'         })
#'       })
#'     }
#'   )
#' )
#'
#' @name teal_transform_module
#'
#' @export
teal_transform_module <- function(ui = function(id) NULL,
                                  server = function(id, data) data,
                                  label = "transform module",
                                  datanames = character(0)) {
  checkmate::assert_function(ui, args = "id", nargs = 1)
  checkmate::assert_function(server, args = c("id", "data"), nargs = 2)
  checkmate::assert_string(label)
  checkmate::assert_character(datanames)
  if (identical(datanames, "all")) {
    stop(
      "teal_transform_module can't have datanames property equal to 'all'. Set `datanames = character(0)` instead.",
      call. = FALSE
    )
  }
  structure(
    list(
      ui = ui,
      server = function(id, data) {
        data_out <- server(id, data)

        if (inherits(data_out, "reactive.event")) {
          # This warning message partially detects when `eventReactive` is used in `data_module`.
          warning(
            "teal_transform_module() ",
            "Using eventReactive in teal_transform module server code should be avoided as it ",
            "may lead to unexpected behavior. See the vignettes for more information  ",
            "(`vignette(\"data-transform-as-shiny-module\", package = \"teal\")`).",
            call. = FALSE
          )
        }

        decorate_err_msg(
          assert_reactive(data_out),
          pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
          post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
        )
      }
    ),
    label = label,
    datanames = datanames,
    class = c("teal_transform_module", "teal_data_module")
  )
}


#' Extract all `transformers` from `modules`.
#'
#' @param modules `teal_modules` or `teal_module`
#' @return A list of `teal_transform_module` nested in the same way as input `modules`.
#' @keywords internal
extract_transformers <- function(modules) {
  if (inherits(modules, "teal_module")) {
    modules$transformers
  } else if (inherits(modules, "teal_modules")) {
    lapply(modules$children, extract_transformers)
  }
}

#' An example `teal` module
#'
#' `r lifecycle::badge("experimental")`
#'
#' @inheritParams teal_modules
#' @return A `teal` module which can be included in the `modules` argument to [init()].
#' @examples
#' app <- init(
#'   data = teal_data(IRIS = iris, MTCARS = mtcars),
#'   modules = example_module()
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#' @export
example_module <- function(label = "example teal module", datanames = "all", transformers = list()) {
  checkmate::assert_string(label)
  ans <- module(
    label,
    server = function(id, data) {
      checkmate::assert_class(isolate(data()), "teal_data")
      moduleServer(id, function(input, output, session) {
        datanames_rv <- reactive(ls(teal.code::get_env((req(data())))))
        observeEvent(datanames_rv(), {
          selected <- input$dataname
          if (identical(selected, "")) {
            selected <- restoreInput(session$ns("dataname"), NULL)
          } else if (isFALSE(selected %in% datanames_rv())) {
            selected <- datanames_rv()[1]
          }
          updateSelectInput(
            session = session,
            inputId = "dataname",
            choices = datanames_rv(),
            selected = selected
          )
        })

        output$text <- renderPrint({
          req(input$dataname)
          data()[[input$dataname]]
        })

        teal.widgets::verbatim_popup_srv(
          id = "rcode",
          verbatim_content = reactive(teal.code::get_code(data())),
          title = "Example Code"
        )
      })
    },
    ui = function(id) {
      ns <- NS(id)
      teal.widgets::standard_layout(
        output = verbatimTextOutput(ns("text")),
        encoding = tags$div(
          selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
          teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
        )
      )
    },
    datanames = datanames,
    transformers = transformers
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

setOldClass("teal_data_module")

#' Evaluate code on `teal_data_module`
#'
#' @details
#' `eval_code` evaluates given code in the environment of the `teal_data` object created by the `teal_data_module`.
#' The code is added to the `@code` slot of the `teal_data`.
#'
#' @param object (`teal_data_module`)
#' @inheritParams teal.code::eval_code
#'
#' @return
#' `eval_code` returns a `teal_data_module` object with a delayed evaluation of `code` when the module is run.
#'
#' @examples
#' eval_code(tdm, "dataset1 <- subset(dataset1, Species == 'virginica')")
#'
#' @include teal_data_module.R
#' @name eval_code
#' @rdname teal_data_module
#' @aliases eval_code,teal_data_module,character-method
#' @aliases eval_code,teal_data_module,language-method
#' @aliases eval_code,teal_data_module,expression-method
#'
#' @importFrom methods setMethod
#' @importMethodsFrom teal.code eval_code
#'
setMethod("eval_code", signature = c("teal_data_module", "character"), function(object, code) {
  teal_data_module(
    ui = function(id) {
      ns <- NS(id)
      object$ui(ns("mutate_inner"))
    },
    server = function(id) {
      moduleServer(id, function(input, output, session) {
        teal_data_rv <- object$server("mutate_inner")
        td <- eventReactive(teal_data_rv(),
          {
            if (inherits(teal_data_rv(), c("teal_data", "qenv.error"))) {
              eval_code(teal_data_rv(), code)
            } else {
              teal_data_rv()
            }
          },
          ignoreNULL = FALSE
        )
        td
      })
    }
  )
})

setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
})

setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
})

#' 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", mustWork = TRUE),
    pattern = pattern, full.names = TRUE
  )

  singleton(
    tags$head(lapply(css_files, includeCSS))
  )
}

#' Include `JS` files from `/inst/js/` 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, passed to `system.file`
#' @param except (`character`) vector of basename filenames to be excluded
#'
#' @return HTML code that includes `JS` files.
#' @keywords internal
include_js_files <- function(pattern = NULL, except = NULL) {
  checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)
  js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
  js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL

  singleton(lapply(js_files, includeScript))
}

#' Run `JS` file from `/inst/js/` package directory
#'
#' This is triggered from the server to execute on the client
#' rather than triggered directly on the client.
#' Unlike `include_js_files` which includes `JavaScript` functions,
#' the `run_js` actually executes `JavaScript` functions.
#'
#' `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 files (`character`) vector of filenames.
#'
#' @return `NULL`, invisibly.
#' @keywords internal
run_js_files <- function(files) {
  checkmate::assert_character(files, min.len = 1, any.missing = FALSE)
  lapply(files, function(file) {
    shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
  })
  invisible(NULL)
}

#' Code to include `teal` `CSS` and `JavaScript` files
#'
#' This is useful when you want to use the same `JavaScript` and `CSS` files that are
#' used with the `teal` application.
#' This is also useful for running standalone modules in `teal` with the correct
#' styles.
#' Also initializes `shinyjs` so you can use it.
#'
#' Simply add `include_teal_css_js()` as one of the UI elements.
#' @return A `shiny.tag.list`.
#' @keywords internal
include_teal_css_js <- function() {
  tagList(
    shinyjs::useShinyjs(),
    include_css_files(),
    # init.js is executed from the server
    include_js_files(except = "init.js"),
    shinyjs::hidden(icon("fas fa-gear")), # add hidden icon to load font-awesome css for icons
  )
}

#' `teal_data` utils
#'
#' In `teal` we need to recreate the `teal_data` object due to two operations:
#' - we need to append filter-data code and objects which have been evaluated in `FilteredData` and
#' we want to avoid double-evaluation.
#' - we need to subset `teal_data` to `datanames` used by the module, to shorten obtainable R-code
#'
#' Due to above recreation of `teal_data` object can't be done simply by using public
#' `teal.code` and `teal.data` methods.
#'
#' @param data (`teal_data`)
#' @param code (`character`) code to append to `data@code`
#' @param objects (`list`) objects to append to `data@env`
#' @param datanames (`character`) names of the datasets
#' @return modified `teal_data`
#' @keywords internal
#' @name teal_data_utilities
NULL

#' @rdname teal_data_utilities
.append_evaluated_code <- function(data, code) {
  checkmate::assert_class(data, "teal_data")
  data@code <- c(data@code, code)
  data@id <- c(data@id, max(data@id) + 1L + seq_along(code))
  data@messages <- c(data@messages, rep("", length(code)))
  data@warnings <- c(data@warnings, rep("", length(code)))
  methods::validObject(data)
  data
}

#' @rdname teal_data_utilities
.append_modified_data <- function(data, objects) {
  checkmate::assert_class(data, "teal_data")
  checkmate::assert_class(objects, "list")
  new_env <- list2env(objects, parent = .GlobalEnv)
  rlang::env_coalesce(new_env, teal.code::get_env(data))
  data@env <- new_env
  data
}

#' @rdname teal_data_utilities
.subset_teal_data <- function(data, datanames) {
  checkmate::assert_class(data, "teal_data")
  checkmate::assert_class(datanames, "character")
  datanames_corrected <- intersect(datanames, ls(teal.code::get_env(data)))
  datanames_corrected_with_raw <- c(datanames_corrected, ".raw_data")
  if (!length(datanames_corrected)) {
    return(teal_data())
  }

  new_data <- do.call(
    teal.data::teal_data,
    args = c(
      mget(x = datanames_corrected_with_raw, envir = teal.code::get_env(data)),
      list(
        code = teal.code::get_code(data, names = datanames_corrected_with_raw),
        join_keys = teal.data::join_keys(data)[datanames_corrected]
      )
    )
  )
  new_data@verified <- data@verified
  teal.data::datanames(new_data) <- datanames_corrected
  new_data
}

#' Filter settings for `teal` applications
#'
#' Specify initial filter states and filtering settings for a `teal` app.
#'
#' Produces a `teal_slices` object.
#' The `teal_slice` components will specify filter states that will be active when the app starts.
#' Attributes (created with the named arguments) will configure the way the app applies filters.
#' See argument descriptions for details.
#'
#' @inheritParams teal.slice::teal_slices
#'
#' @param module_specific (`logical(1)`) optional,
#'  - `FALSE` (default) when one filter panel applied to all modules.
#'  All filters will be shared by all modules.
#'  - `TRUE` when filter panel module-specific.
#'  Modules can have different set of filters specified - see `mapping` argument.
#' @param mapping `r lifecycle::badge("experimental")`
#' _This is a new feature. Do kindly share your opinions on
#' [`teal`'s GitHub repository](https://github.com/insightsengineering/teal/)._
#'
#'  (named `list`) specifies which filters will be active in which modules on app start.
#'  Elements should contain character vector of `teal_slice` `id`s (see [`teal.slice::teal_slice`]).
#'  Names of the list should correspond to `teal_module` `label` set in [module()] function.
#'  - `id`s listed under `"global_filters` will be active in all modules.
#'  - If missing, all filters will be applied to all modules.
#'  - If empty list, all filters will be available to all modules but will start inactive.
#'  - If `module_specific` is `FALSE`, only `global_filters` will be active on start.
#' @param app_id (`character(1)`)
#'  For internal use only, do not set manually.
#'  Added by `init` so that a `teal_slices` can be matched to the app in which it was used.
#'  Used for verifying snapshots uploaded from file. See `snapshot`.
#'
#' @param x (`list`) of lists to convert to `teal_slices`
#'
#' @return
#' A `teal_slices` object.
#'
#' @seealso [`teal.slice::teal_slices`], [`teal.slice::teal_slice`], [slices_store()]
#'
#' @examples
#' filter <- teal_slices(
#'   teal_slice(dataname = "iris", varname = "Species", id = "species"),
#'   teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),
#'   teal_slice(
#'     dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"
#'   ),
#'   teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),
#'   mapping = list(
#'     module1 = c("species", "sepal_length"),
#'     module2 = c("mtcars_mpg"),
#'     global_filters = "long_petals"
#'   )
#' )
#'
#' app <- init(
#'   data = teal_data(iris = iris, mtcars = mtcars),
#'   modules = list(
#'     module("module1"),
#'     module("module2")
#'   ),
#'   filter = filter
#' )
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
teal_slices <- function(...,
                        exclude_varnames = NULL,
                        include_varnames = NULL,
                        count_type = NULL,
                        allow_add = TRUE,
                        module_specific = FALSE,
                        mapping,
                        app_id = NULL) {
  shiny::isolate({
    checkmate::assert_flag(allow_add)
    checkmate::assert_flag(module_specific)
    if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
    checkmate::assert_string(app_id, null.ok = TRUE)

    slices <- list(...)
    all_slice_id <- vapply(slices, `[[`, character(1L), "id")

    if (missing(mapping)) {
      mapping <- if (length(all_slice_id)) {
        list(global_filters = all_slice_id)
      } else {
        list()
      }
    }

    if (!module_specific) {
      mapping[setdiff(names(mapping), "global_filters")] <- NULL
    }

    failed_slice_id <- setdiff(unlist(mapping), all_slice_id)
    if (length(failed_slice_id)) {
      stop(sprintf(
        "Filters in mapping don't match any available filter.\n %s not in %s",
        toString(failed_slice_id),
        toString(all_slice_id)
      ))
    }

    tss <- teal.slice::teal_slices(
      ...,
      exclude_varnames = exclude_varnames,
      include_varnames = include_varnames,
      count_type = count_type,
      allow_add = allow_add
    )
    attr(tss, "mapping") <- mapping
    attr(tss, "module_specific") <- module_specific
    attr(tss, "app_id") <- app_id
    class(tss) <- c("modules_teal_slices", class(tss))
    tss
  })
}


#' @rdname teal_slices
#' @export
#' @keywords internal
#'
as.teal_slices <- function(x) { # nolint: object_name.
  checkmate::assert_list(x)
  lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")

  attrs <- attributes(unclass(x))
  ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))
  do.call(teal_slices, c(ans, attrs))
}


#' @rdname teal_slices
#' @export
#' @keywords internal
#'
c.teal_slices <- function(...) {
  x <- list(...)
  checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")

  all_attributes <- lapply(x, attributes)
  all_attributes <- coalesce_r(all_attributes)
  all_attributes <- all_attributes[names(all_attributes) != "class"]

  do.call(
    teal_slices,
    c(
      unique(unlist(x, recursive = FALSE)),
      all_attributes
    )
  )
}


#' Deep copy `teal_slices`
#'
#' it's important to create a new copy of `teal_slices` when
#' starting a new `shiny` session. Otherwise, object will be shared
#' by multiple users as it is created in global environment before
#' `shiny` session starts.
#' @param filter (`teal_slices`)
#' @return `teal_slices`
#' @keywords internal
deep_copy_filter <- function(filter) {
  checkmate::assert_class(filter, "teal_slices")
  shiny::isolate({
    filter_copy <- lapply(filter, function(slice) {
      teal.slice::as.teal_slice(as.list(slice))
    })
    attributes(filter_copy) <- attributes(filter)
    filter_copy
  })
}

#' Data summary
#' @description
#' Module and its utils to display the number of rows and subjects in the filtered and unfiltered data.
#'
#' @details Handling different data classes:
#' `get_object_filter_overview()` is a pseudo S3 method which has variants for:
#' - `array` (`data.frame`, `DataFrame`, `array`, `Matrix` and `SummarizedExperiment`): Method variant
#' can be applied to any two-dimensional objects on which [ncol()] can be used.
#' - `MultiAssayExperiment`: for which summary contains counts for `colData` and all `experiments`.
#'
#' @param id (`character(1)`)
#'  `shiny` module instance id.
#' @param teal_data (`reactive` returning `teal_data`)
#'
#'
#' @name module_data_summary
#' @rdname module_data_summary
#' @keywords internal
#' @return `NULL`.
NULL

#' @rdname module_data_summary
ui_data_summary <- function(id) {
  ns <- NS(id)
  content_id <- ns("filters_overview_contents")
  tags$div(
    id = id,
    class = "well",
    tags$div(
      class = "row",
      tags$div(
        class = "col-sm-9",
        tags$label("Active Filter Summary", class = "text-primary mb-4")
      ),
      tags$div(
        class = "col-sm-3",
        tags$i(
          class = "remove pull-right fa fa-angle-down",
          style = "cursor: pointer;",
          title = "fold/expand data summary panel",
          onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", content_id)
        )
      )
    ),
    tags$div(
      id = content_id,
      tags$div(
        class = "teal_active_summary_filter_panel",
        tableOutput(ns("table"))
      )
    )
  )
}

#' @rdname module_data_summary
srv_data_summary <- function(id, teal_data) {
  assert_reactive(teal_data)
  moduleServer(
    id = id,
    function(input, output, session) {
      logger::log_debug("srv_data_summary initializing")

      summary_table <- reactive({
        req(inherits(teal_data(), "teal_data"))
        if (!length(ls(teal.code::get_env(teal_data())))) {
          return(NULL)
        }

        filter_overview <- get_filter_overview(teal_data)
        names(filter_overview)[[1]] <- "Data Name"

        filter_overview$Obs <- ifelse(
          !is.na(filter_overview$obs),
          sprintf("%s/%s", filter_overview$obs_filtered, filter_overview$obs),
          ifelse(!is.na(filter_overview$obs_filtered), sprintf("%s", filter_overview$obs_filtered), "")
        )

        filter_overview$Subjects <- ifelse(
          !is.na(filter_overview$subjects),
          sprintf("%s/%s", filter_overview$subjects_filtered, filter_overview$subjects),
          ""
        )

        filter_overview <- filter_overview[, colnames(filter_overview) %in% c("Data Name", "Obs", "Subjects")]
        Filter(function(col) !all(col == ""), filter_overview)
      })

      output$table <- renderUI({
        summary_table_out <- try(summary_table(), silent = TRUE)
        if (inherits(summary_table_out, "try-error")) {
          # Ignore silent shiny error
          if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
            stop("Error occurred during data processing. See details in the main panel.")
          }
        } else if (is.null(summary_table_out)) {
          "no datasets to show"
        } else {
          body_html <- apply(
            summary_table_out,
            1,
            function(x) {
              tags$tr(
                tagList(
                  tags$td(
                    if (all(x[-1] == "")) {
                      icon(
                        name = "fas fa-exclamation-triangle",
                        title = "Unsupported dataset",
                        `data-container` = "body",
                        `data-toggle` = "popover",
                        `data-content` = "object not supported by the data_summary module"
                      )
                    },
                    x[1]
                  ),
                  lapply(x[-1], tags$td)
                )
              )
            }
          )

          header_labels <- names(summary_table())
          header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))

          table_html <- tags$table(
            class = "table custom-table",
            tags$thead(header_html),
            tags$tbody(body_html)
          )
          table_html
        }
      })

      summary_table # testing purpose
    }
  )
}

#' @rdname module_data_summary
get_filter_overview <- function(teal_data) {
  datanames <- teal.data::datanames(teal_data())
  joinkeys <- teal.data::join_keys(teal_data())

  filtered_data_objs <- sapply(
    datanames,
    function(name) teal.code::get_var(teal_data(), name),
    simplify = FALSE
  )
  unfiltered_data_objs <- teal.code::get_var(teal_data(), ".raw_data")

  rows <- lapply(
    datanames,
    function(dataname) {
      parent <- teal.data::parent(joinkeys, dataname)
      # todo: what should we display for a parent dataset?
      #     - Obs and Subjects
      #     - Obs only
      #     - Subjects only
      # todo (for later): summary table should be displayed in a way that child datasets
      #       are indented under their parent dataset to form a tree structure
      subject_keys <- if (length(parent) > 0) {
        names(joinkeys[dataname, parent])
      } else {
        joinkeys[dataname, dataname]
      }
      get_object_filter_overview(
        filtered_data = filtered_data_objs[[dataname]],
        unfiltered_data = unfiltered_data_objs[[dataname]],
        dataname = dataname,
        subject_keys = subject_keys
      )
    }
  )

  unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1)) # this is mainly for vectors
  do.call(rbind, c(rows[!unssuported_idx], rows[unssuported_idx]))
}

#' @rdname module_data_summary
#' @param filtered_data (`list`) of filtered objects
#' @param unfiltered_data (`list`) of unfiltered objects
#' @param dataname (`character(1)`)
get_object_filter_overview <- function(filtered_data, unfiltered_data, dataname, subject_keys) {
  if (inherits(filtered_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
    get_object_filter_overview_array(filtered_data, unfiltered_data, dataname, subject_keys)
  } else if (inherits(filtered_data, "MultiAssayExperiment")) {
    get_object_filter_overview_MultiAssayExperiment(filtered_data, unfiltered_data, dataname)
  } else {
    data.frame(
      dataname = dataname,
      obs = NA,
      obs_filtered = NA,
      subjects = NA,
      subjects_filtered = NA
    )
  }
}

#' @rdname module_data_summary
get_object_filter_overview_array <- function(filtered_data, # nolint: object_length.
                                             unfiltered_data,
                                             dataname,
                                             subject_keys) {
  if (length(subject_keys) == 0) {
    data.frame(
      dataname = dataname,
      obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
      obs_filtered = nrow(filtered_data),
      subjects = NA,
      subjects_filtered = NA
    )
  } else {
    data.frame(
      dataname = dataname,
      obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
      obs_filtered = nrow(filtered_data),
      subjects = nrow(unique(unfiltered_data[subject_keys])),
      subjects_filtered = nrow(unique(filtered_data[subject_keys]))
    )
  }
}

#' @rdname module_data_summary
get_object_filter_overview_MultiAssayExperiment <- function(filtered_data, # nolint: object_length, object_name.
                                                            unfiltered_data,
                                                            dataname) {
  experiment_names <- names(unfiltered_data)
  mae_info <- data.frame(
    dataname = dataname,
    obs = NA,
    obs_filtered = NA,
    subjects = nrow(unfiltered_data@colData),
    subjects_filtered = nrow(filtered_data@colData)
  )

  experiment_obs_info <- do.call("rbind", lapply(
    experiment_names,
    function(experiment_name) {
      transform(
        get_object_filter_overview(
          filtered_data[[experiment_name]],
          unfiltered_data[[experiment_name]],
          dataname = experiment_name,
          subject_keys = join_keys() # empty join keys
        ),
        dataname = paste0(" - ", experiment_name)
      )
    }
  ))

  get_experiment_keys <- function(mae, experiment) {
    sample_subset <- mae@sampleMap[mae@sampleMap$colname %in% colnames(experiment), ]
    length(unique(sample_subset$primary))
  }

  experiment_subjects_info <- do.call("rbind", lapply(
    experiment_names,
    function(experiment_name) {
      data.frame(
        subjects = get_experiment_keys(filtered_data, unfiltered_data[[experiment_name]]),
        subjects_filtered = get_experiment_keys(filtered_data, filtered_data[[experiment_name]])
      )
    }
  ))

  experiment_info <- cbind(experiment_obs_info[, c("dataname", "obs", "obs_filtered")], experiment_subjects_info)
  rbind(mae_info, experiment_info)
}

#' UI and server modules of `teal`
#'
#' @description `r lifecycle::badge("deprecated")`
#' Please use [`module_teal`] instead.
#'
#' @inheritParams ui_teal
#' @inheritParams srv_teal
#'
#' @return
#' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not.
#' @name module_teal_with_splash
#'
NULL

#' @export
#' @rdname module_teal_with_splash
ui_teal_with_splash <- function(id,
                                data,
                                title = build_app_title(),
                                header = tags$p(),
                                footer = tags$p()) {
  lifecycle::deprecate_soft(
    when = "0.16",
    what = "ui_teal_with_splash()",
    details = "Deprecated, please use `ui_teal` instead"
  )
  ui_teal(id = id, title = title, header = header, footer = footer)
}

#' @export
#' @rdname module_teal_with_splash
srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
  lifecycle::deprecate_soft(
    when = "0.16",
    what = "srv_teal_with_splash()",
    details = "Deprecated, please use `srv_teal` instead"
  )
  srv_teal(id = id, data = data, modules = modules, filter = filter)
}

#' Data Module for teal
#'
#' This module manages the `data` argument for `srv_teal`. The `teal` framework uses [teal_data()],
#' which can be provided in various ways:
#' 1. Directly as a [teal.data::teal_data()] object. This will automatically convert it into a `reactive` `teal_data`.
#' 2. As a `reactive` object that returns a [teal.data::teal_data()] object.
#'
#' @details
#' ## Reactive `teal_data`:
#'
#' The data in the application can be reactively updated, prompting [srv_teal()] to rebuild the
#' content accordingly. There are two methods for creating interactive `teal_data`:
#' 1. Using a `reactive` object provided from outside the `teal` application. In this scenario,
#' reactivity is controlled by an external module, and `srv_teal` responds to changes.
#' 2. Using [teal_data_module()], which is embedded within the `teal` application, allowing data to
#' be resubmitted by the user as needed.
#'
#' Since the server of [teal_data_module()] must return a `reactive` `teal_data` object, both
#' methods (1 and 2) produce the same reactive behavior within a `teal` application. The distinction
#' lies in data control: the first method involves external control, while the second method
#' involves control from a custom module within the app.
#'
#' For more details, see [`module_teal_data`].
#'
#' @inheritParams init
#'
#' @param data (`teal_data`, `teal_data_module`, or `reactive` returning `teal_data`)
#' The data which application will depend on.
#'
#' @return A `reactive` object that returns:
#' Output of the `data`. If `data` fails then returned error is handled (after [tryCatch()]) so that
#' rest of the application can respond to this respectively.
#'
#' @rdname module_init_data
#' @name module_init_data
#' @keywords internal
NULL

#' @rdname module_init_data
ui_init_data <- function(id) {
  ns <- shiny::NS(id)
  shiny::div(
    id = ns("content"),
    style = "display: inline-block; width: 100%;",
    uiOutput(ns("data"))
  )
}

#' @rdname module_init_data
srv_init_data <- function(id, data) {
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
  checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))

  moduleServer(id, function(input, output, session) {
    logger::log_debug("srv_data initializing.")
    # data_rv contains teal_data object
    # either passed to teal::init or returned from teal_data_module
    data_out <- if (inherits(data, "teal_data_module")) {
      output$data <- renderUI(data$ui(id = session$ns("teal_data_module")))
      data$server("teal_data_module")
    } else if (inherits(data, "teal_data")) {
      reactiveVal(data)
    } else if (test_reactive(data)) {
      data
    }

    data_handled <- reactive({
      tryCatch(data_out(), error = function(e) e)
    })

    # We want to exclude teal_data_module elements from bookmarking as they might have some secrets
    observeEvent(data_handled(), {
      if (inherits(data_handled(), "teal_data")) {
        app_session <- .subset2(shiny::getDefaultReactiveDomain(), "parent")
        setBookmarkExclude(
          session$ns(
            grep(
              pattern = "teal_data_module-",
              x = names(reactiveValuesToList(input)),
              value = TRUE
            )
          ),
          session = app_session
        )
      }
    })

    data_handled
  })
}

#' Adds signature protection to the `datanames` in the data
#' @param data (`teal_data`)
#' @return `teal_data` with additional code that has signature of the `datanames`
#' @keywords internal
.add_signature_to_data <- function(data) {
  hashes <- .get_hashes_code(data)

  tdata <- do.call(
    teal.data::teal_data,
    c(
      list(code = trimws(c(teal.code::get_code(data), hashes), which = "right")),
      list(join_keys = teal.data::join_keys(data)),
      sapply(
        ls(teal.code::get_env(data)),
        teal.code::get_var,
        object = data,
        simplify = FALSE
      )
    )
  )

  tdata@verified <- data@verified
  tdata
}

#' Get code that tests the integrity of the reproducible data
#'
#' @param data (`teal_data`) object holding the data
#' @param datanames (`character`) names of `datasets`
#'
#' @return A character vector with the code lines.
#' @keywords internal
#'
.get_hashes_code <- function(data, datanames = ls(teal.code::get_env(data))) {
  vapply(
    datanames,
    function(dataname, datasets) {
      x <- data[[dataname]]

      code <- if (is.function(x) && !is.primitive(x)) {
        x <- deparse1(x)
        bquote(rlang::hash(deparse1(.(as.name(dataname)))))
      } else {
        bquote(rlang::hash(.(as.name(dataname))))
      }
      sprintf(
        "stopifnot(%s == %s) # @linksto %s",
        deparse1(code),
        deparse1(rlang::hash(x)),
        dataname
      )
    },
    character(1L),
    USE.NAMES = TRUE
  )
}

#' Store and restore `teal_slices` object
#'
#' Functions that write a `teal_slices` object to a file in the `JSON` format,
#' and also restore the object from disk.
#'
#' Date and date time objects are stored in the following formats:
#'
#' - `Date` class is converted to the `"ISO8601"` standard (`YYYY-MM-DD`).
#' - `POSIX*t` classes are converted to character by using
#' `format.POSIX*t(usetz = TRUE, tz = "UTC")` (`YYYY-MM-DD HH:MM:SS UTC`, where
#' `UTC` is the `Coordinated Universal Time` timezone short-code).
#'
#' This format is assumed during `slices_restore`. All `POSIX*t` objects in
#' `selected` or `choices` fields of `teal_slice` objects are always printed in
#' `UTC` timezone as well.
#'
#' @param tss (`teal_slices`) object to be stored.
#' @param file (`character(1)`) file path where `teal_slices` object will be
#' saved and restored. The file extension should be `".json"`.
#'
#' @return `slices_store` returns `NULL`, invisibly.
#'
#' @seealso [teal_slices()]
#'
#' @keywords internal
#'
slices_store <- function(tss, file) {
  checkmate::assert_class(tss, "teal_slices")
  checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json")

  cat(format(tss, trim_lines = FALSE), "\n", file = file)
}

#' @rdname slices_store
#' @return `slices_restore` returns a `teal_slices` object restored from the file.
#' @keywords internal
slices_restore <- function(file) {
  checkmate::assert_file_exists(file, access = "r", extension = "json")

  tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE)
  tss_json$slices <-
    lapply(tss_json$slices, function(slice) {
      for (field in c("selected", "choices")) {
        if (!is.null(slice[[field]])) {
          if (length(slice[[field]]) > 0) {
            date_partial_regex <- "^[0-9]{4}-[0-9]{2}-[0-9]{2}"
            time_stamp_regex <- paste0(date_partial_regex, "\\s[0-9]{2}:[0-9]{2}:[0-9]{2}\\sUTC$")

            slice[[field]] <-
              if (all(grepl(paste0(date_partial_regex, "$"), slice[[field]]))) {
                as.Date(slice[[field]])
              } else if (all(grepl(time_stamp_regex, slice[[field]]))) {
                as.POSIXct(slice[[field]], tz = "UTC")
              } else {
                slice[[field]]
              }
          } else {
            slice[[field]] <- character(0)
          }
        }
      }
      slice
    })

  tss_elements <- lapply(tss_json$slices, as.teal_slice)

  do.call(teal_slices, c(tss_elements, tss_json$attributes))
}

#' Generates library calls from current session info
#'
#' Function to create multiple library calls out of current session info to ensure reproducible code works.
#'
#' @return Character vector of `library(<package>)` calls.
#' @keywords internal
get_rcode_libraries <- function() {
  libraries <- vapply(
    utils::sessionInfo()$otherPkgs,
    function(x) {
      paste0("library(", x$Package, ")")
    },
    character(1)
  )
  paste0(paste0(rev(libraries), sep = "\n"), collapse = "")
}


#' @noRd
#' @keywords internal
get_rcode_str_install <- function() {
  code_string <- getOption("teal.load_nest_code")
  if (is.character(code_string)) {
    code_string
  } else {
    "# Add any code to install/load your NEST environment here\n"
  }
}

#' Create a `tdata` object
#'
#' @description `r lifecycle::badge("superseded")`
#'
#' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object
#' to be passed to the `data` argument but instead they receive a `teal_data` object,
#' which is additionally wrapped in a reactive expression in the server functions.
#' In order to easily adapt such modules without a proper refactor,
#' use this function to downgrade the `data` argument.
#'
#' @name tdata
#' @param ... ignored
#' @return nothing
NULL

#' @rdname tdata
#' @export
new_tdata <- function(...) {
  .deprecate_tdata_msg()
}

#' @rdname tdata
#' @export
tdata2env <- function(...) {
  .deprecate_tdata_msg()
}

#' @rdname tdata
#' @export
get_code_tdata <- function(...) {
  .deprecate_tdata_msg()
}

#' @rdname tdata
#' @export
join_keys.tdata <- function(...) {
  .deprecate_tdata_msg()
}

#' @rdname tdata
#' @export
get_metadata <- function(...) {
  .deprecate_tdata_msg()
}

#' @rdname tdata
#' @export
as_tdata <- function(...) {
  .deprecate_tdata_msg()
}


.deprecate_tdata_msg <- function() {
  lifecycle::deprecate_stop(
    when = "0.16",
    what = "tdata()",
    details = paste(
      "tdata has been removed in favour of `teal_data`.\n",
      "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."
    )
  )
}

.onLoad <- function(libname, pkgname) {
  # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R

  teal_default_options <- list(
    teal.show_js_log = FALSE,
    teal.lockfile.mode = "auto",
    shiny.sanitize.errors = FALSE
  )

  op <- options()
  toset <- !(names(teal_default_options) %in% names(op))
  if (any(toset)) options(teal_default_options[toset])

  # Set up the teal logger instance
  teal.logger::register_logger("teal")
  teal.logger::register_handlers("teal")

  invisible()
}

.onAttach <- function(libname, pkgname) {
  packageStartupMessage(
    "\nYou are using teal version ",
    # `system.file` uses the `shim` of `system.file` by `teal`
    # we avoid `desc` dependency here to get the version
    read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
  )
}

# This one is here because setdiff_teal_slice should not be exported from teal.slice.
setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
# This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice.
coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
# all *Block objects are private in teal.reporter
RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint: object_name.

# Use non-exported function(s) from teal.code
# This one is here because lang2calls should not be exported from teal.code
lang2calls <- getFromNamespace("lang2calls", "teal.code")

#' Evaluate expression on `teal_data_module`
#'
#' @details
#' `within` is a convenience function for evaluating inline code inside the environment of a `teal_data_module`.
#' It accepts only inline expressions (both simple and compound) and allows for injecting values into `expr` through
#' the `...` argument: as `name:value` pairs are passed to `...`, `name` in `expr` will be replaced with `value.`
#'
#' @param data (`teal_data_module`) object
#' @param expr (`expression`) to evaluate. Must be inline code. See
#' @param ... See `Details`.
#'
#' @return
#' `within` returns a `teal_data_module` object with a delayed evaluation of `expr` when the module is run.
#'
#' @examples
#' within(tdm, dataset1 <- subset(dataset1, Species == "virginica"))
#'
#' # use additional parameter for expression value substitution.
#' valid_species <- "versicolor"
#' within(tdm, dataset1 <- subset(dataset1, Species %in% species), species = valid_species)
#' @include teal_data_module.R
#' @name within
#' @rdname teal_data_module
#'
#' @export
#'
within.teal_data_module <- function(data, expr, ...) {
  expr <- substitute(expr)
  extras <- list(...)

  # Add braces for consistency.
  if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
    expr <- call("{", expr)
  }

  calls <- as.list(expr)[-1]

  # Inject extra values into expressions.
  calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))

  eval_code(object = data, code = as.expression(calls))
}

#' Check that argument is reactive.
#'
#' @inherit checkmate::check_class params return
#'
#' @keywords internal
check_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
  if (!isTRUE(checkmate::test_class(x, classes = "reactive", null.ok = null.ok))) {
    cl <- class(x)
    return(sprintf(
      "Must be a reactive (i.e. inherit from 'reactive' class) but has class%s '%s'",
      if (length(cl) > 1L) "es" else "",
      paste0(cl, collapse = "','")
    ))
  }
  return(TRUE)
}
#' @rdname check_reactive
test_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
  isTRUE(check_reactive(x, null.ok = null.ok))
}
#' @rdname check_reactive
assert_reactive <- checkmate::makeAssertionFunction(check_reactive)

#' Capture error and decorate error message.
#'
#' @param x object to evaluate
#' @param pre (`character(1)`) A string to prepend to error message
#' @param post (`character(1)`) A string to append to error message
#'
#' @return `x` if no error, otherwise throws error with decorated message
#'
#' @keywords internal
decorate_err_msg <- function(x, pre = character(0), post = character(0)) {
  tryCatch(
    x,
    error = function(e) {
      stop(
        "\n",
        pre,
        "\n",
        e$message,
        "\n",
        post,
        call. = FALSE
      )
    }
  )
  x
}

1		#' Landing popup module
2		#'
3		#' @description Creates a landing welcome popup for `teal` applications.
4		#'
5		#' This module is used to display a popup dialog when the application starts.
6		#' The dialog blocks access to the application and must be closed with a button before the application can be viewed.
7		#'
8		#' @param label (`character(1)`) Label of the module.
9		#' @param title (`character(1)`) Text to be displayed as popup title.
10		#' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup.
11		#' Passed to `...` of `shiny::modalDialog`. See examples.
12		#' @param buttons (`shiny.tag` or `shiny.tag.list`) Typically a `modalButton` or `actionButton`. See examples.
13		#'
14		#' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications.
15		#'
16		#' @examples
17		#' app1 <- init(
18		#' data = teal_data(iris = iris),
19		#' modules = modules(
20		#' example_module()
21		#' ),
22		#' landing_popup = landing_popup_module(
23		#' content = "A place for the welcome message or a disclaimer statement.",
24		#' buttons = modalButton("Proceed")
25		#' )
26		#' )
27		#' if (interactive()) {
28		#' shinyApp(app1$ui, app1$server)
29		#' }
30		#'
31		#' app2 <- init(
32		#' data = teal_data(iris = iris),
33		#' modules = modules(
34		#' example_module()
35		#' ),
36		#' landing_popup = landing_popup_module(
37		#' title = "Welcome",
38		#' content = tags$b(
39		#' "A place for the welcome message or a disclaimer statement.",
40		#' style = "color: red;"
41		#' ),
42		#' buttons = tagList(
43		#' modalButton("Proceed"),
44		#' actionButton("read", "Read more",
45		#' onclick = "window.open('http://google.com', '_blank')"
46		#' ),
47		#' actionButton("close", "Reject", onclick = "window.close()")
48		#' )
49		#' )
50		#' )
51		#'
52		#' if (interactive()) {
53		#' shinyApp(app2$ui, app2$server)
54		#' }
55		#'
56		#' @export
57		landing_popup_module <- function(label = "Landing Popup",
58		title = NULL,
59		content = NULL,
60		buttons = modalButton("Accept")) {
61	!	checkmate::assert_string(label)
62	!	checkmate::assert_string(title, null.ok = TRUE)
63	!	checkmate::assert_multi_class(
64	!	content,
65	!	classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
66		)
67	!	checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
68
69	!	message("Initializing landing_popup_module")
70
71	!	module <- module(
72	!	label = label,
73	!	server = function(id) {
74	!	moduleServer(id, function(input, output, session) {
75	!	showModal(
76	!	modalDialog(
77	!	id = "landingpopup",
78	!	title = title,
79	!	content,
80	!	footer = buttons
81		)
82		)
83		})
84		}
85		)
86	!	class(module) <- c("teal_module_landing", class(module))
87	!	module
88		}

1		#' Show `R` code modal
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#'
5		#' Use the [shiny::showModal()] function to show the `R` code inside.
6		#'
7		#' @param title (`character(1)`)
8		#' Title of the modal, displayed in the first comment of the `R` code.
9		#' @param rcode (`character`)
10		#' vector with `R` code to show inside the modal.
11		#' @param session (`ShinySession`) optional
12		#' `shiny` session object, defaults to [shiny::getDefaultReactiveDomain()].
13		#'
14		#' @references [shiny::showModal()]
15		#' @export
16		show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) {
17	!	lifecycle::deprecate_soft(
18	!	when = "0.16",
19	!	what = "show_rcode_modal()",
20	!	details = "This function will be removed in the next release."
21		)
22
23	!	rcode <- paste(rcode, collapse = "\n")
24
25	!	ns <- session$ns
26	!	showModal(modalDialog(
27	!	tagList(
28	!	tags$div(
29	!	actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
30	!	modalButton("Dismiss"),
31	!	style = "mb-4"
32		),
33	!	tags$div(tags$pre(id = ns("r_code"), rcode)),
34		),
35	!	title = title,
36	!	footer = tagList(
37	!	actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
38	!	modalButton("Dismiss")
39		),
40	!	size = "l",
41	!	easyClose = TRUE
42		))
43		}

1		#' Create a `teal` module for previewing a report
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' This function wraps [teal.reporter::reporter_previewer_ui()] and
6		#' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be
7		#' used in `teal` applications.
8		#'
9		#' If you are creating a `teal` application using [init()] then this
10		#' module will be added to your application automatically if any of your `teal_modules`
11		#' support report generation.
12		#'
13		#' @inheritParams teal_modules
14		#' @param server_args (named `list`)
15		#' Arguments passed to [teal.reporter::reporter_previewer_srv()].
16		#'
17		#' @return
18		#' `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer functionality.
19		#'
20		#' @export
21		#'
22		reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
23	7x	checkmate::assert_string(label)
24	5x	checkmate::assert_list(server_args, names = "named")
25	5x	checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))
26
27	3x	message("Initializing reporter_previewer_module")
28
29	3x	srv <- function(id, reporter, ...) {
30	!	teal.reporter::reporter_previewer_srv(id, reporter, ...)
31		}
32
33	3x	ui <- function(id, ...) {
34	!	teal.reporter::reporter_previewer_ui(id, ...)
35		}
36
37	3x	module <- module(
38	3x	label = "temporary label",
39	3x	server = srv, ui = ui,
40	3x	server_args = server_args, ui_args = list(), datanames = NULL
41		)
42		# Module is created with a placeholder label and the label is changed later.
43		# This is to prevent another module being labeled "Report previewer".
44	3x	class(module) <- c(class(module), "teal_module_previewer")
45	3x	module$label <- label
46	3x	attr(module, "teal_bookmarkable") <- TRUE
47	3x	module
48		}

1		#' Get client timezone
2		#'
3		#' User timezone in the browser may be different to the one on the server.
4		#' This script can be run to register a `shiny` input which contains information about the timezone in the browser.
5		#'
6		#' @param ns (`function`) namespace function passed from the `session` object in the `shiny` server.
7		#' For `shiny` modules this will allow for proper name spacing of the registered input.
8		#'
9		#' @return `NULL`, invisibly.
10		#'
11		#' @keywords internal
12		#'
13		get_client_timezone <- function(ns) {
14	81x	script <- sprintf(
15	81x	"Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",
16	81x	ns("timezone")
17		)
18	81x	shinyjs::runjs(script) # function does not return anything
19	81x	invisible(NULL)
20		}
21
22		#' Resolve the expected bootstrap theme
23		#' @noRd
24		#' @keywords internal
25		get_teal_bs_theme <- function() {
26	4x	bs_theme <- getOption("teal.bs_theme")
27
28	4x	if (is.null(bs_theme)) {
29	1x	return(NULL)
30		}
31
32	3x	if (!checkmate::test_class(bs_theme, "bs_theme")) {
33	2x	warning(
34	2x	"Assertion on 'teal.bs_theme' option value failed: ",
35	2x	checkmate::check_class(bs_theme, "bs_theme"),
36	2x	". The default Shiny Bootstrap theme will be used."
37		)
38	2x	return(NULL)
39		}
40
41	1x	bs_theme
42		}
43
44		#' Return parentnames along with datanames.
45		#' @noRd
46		#' @keywords internal
47		.include_parent_datanames <- function(datanames, join_keys) {
48	163x	ordered_datanames <- datanames
49	163x	for (i in datanames) {
50	293x	parents <- character(0)
51	293x	while (length(i) > 0) {
52	306x	parent_i <- teal.data::parent(join_keys, i)
53	306x	parents <- c(parent_i, parents)
54	306x	i <- parent_i
55		}
56	293x	ordered_datanames <- c(parents, ordered_datanames)
57		}
58	163x	unique(ordered_datanames)
59		}
60
61		#' Return topologicaly sorted datanames
62		#' @noRd
63		#' @keywords internal
64		.topologically_sort_datanames <- function(datanames, join_keys) {
65	131x	datanames_with_parents <- .include_parent_datanames(datanames, join_keys)
66	131x	intersect(datanames, datanames_with_parents)
67		}
68
69		#' Create a `FilteredData`
70		#'
71		#' Create a `FilteredData` object from a `teal_data` object.
72		#'
73		#' @param x (`teal_data`) object
74		#' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)`
75		#' @return A `FilteredData` object.
76		#' @keywords internal
77		teal_data_to_filtered_data <- function(x, datanames = ls(teal.code::get_env(x))) {
78	76x	checkmate::assert_class(x, "teal_data")
79	76x	checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)
80		# Otherwise, FilteredData will be created in the modules' scope later
81	76x	teal.slice::init_filtered_data(
82	76x	x = Filter(
83	76x	length,
84	76x	sapply(datanames, function(dn) x[[dn]], simplify = FALSE)
85		),
86	76x	join_keys = teal.data::join_keys(x)
87		)
88		}
89
90
91		#' Template function for `TealReportCard` creation and customization
92		#'
93		#' This function generates a report card with a title,
94		#' an optional description, and the option to append the filter state list.
95		#'
96		#' @param title (`character(1)`) title of the card (unless overwritten by label)
97		#' @param label (`character(1)`) label provided by the user when adding the card
98		#' @param description (`character(1)`) optional, additional description
99		#' @param with_filter (`logical(1)`) flag indicating to add filter state
100		#' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation
101		#' of the filter state in the report
102		#'
103		#' @return (`TealReportCard`) populated with a title, description and filter state.
104		#'
105		#' @export
106		report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
107	2x	checkmate::assert_string(title)
108	2x	checkmate::assert_string(label)
109	2x	checkmate::assert_string(description, null.ok = TRUE)
110	2x	checkmate::assert_flag(with_filter)
111	2x	checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")
112
113	2x	card <- teal::TealReportCard$new()
114	2x	title <- if (label == "") title else label
115	2x	card$set_name(title)
116	2x	card$append_text(title, "header2")
117	1x	if (!is.null(description)) card$append_text(description, "header3")
118	1x	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
119	2x	card
120		}
121
122
123		#' Check `datanames` in modules
124		#'
125		#' These functions check if specified `datanames` in modules match those in the data object,
126		#' returning error messages or `TRUE` for successful validation. Two functions return error message
127		#' in different forms:
128		#' - `check_modules_datanames` returns `character(1)` for basic assertion usage
129		#' - `check_modules_datanames_html` returns `shiny.tag.list` to display it in the app.
130		#'
131		#' @param modules (`teal_modules`) object
132		#' @param datanames (`character`) names of datasets available in the `data` object
133		#'
134		#' @return `TRUE` if validation passes, otherwise `character(1)` or `shiny.tag.list`
135		#' @keywords internal
136		check_modules_datanames <- function(modules, datanames) {
137	9x	out <- check_modules_datanames_html(modules, datanames)
138	9x	if (inherits(out, "shiny.tag.list")) {
139	3x	out_with_ticks <- gsub("<code>\|</code>", "`", toString(out))
140	3x	out_text <- gsub("<[^<>]+>", "", toString(out_with_ticks))
141	3x	trimws(gsub("[[:space:]]+", " ", out_text))
142		} else {
143	6x	out
144		}
145		}
146
147		#' @rdname check_modules_datanames
148		check_modules_datanames_html <- function(modules,
149		datanames) {
150	173x	check_datanames <- check_modules_datanames_recursive(modules, datanames)
151	173x	show_module_info <- inherits(modules, "teal_modules") # used in two contexts - module and app
152	173x	if (!length(check_datanames)) {
153	155x	return(TRUE)
154		}
155	18x	shiny::tagList(
156	18x	lapply(
157	18x	check_datanames,
158	18x	function(mod) {
159	18x	tagList(
160	18x	tags$span(
161	18x	tags$span(if (length(mod$missing_datanames) == 1) "Dataset" else "Datasets"),
162	18x	to_html_code_list(mod$missing_datanames),
163	18x	tags$span(
164	18x	paste0(
165	18x	if (length(mod$missing_datanames) > 1) "are missing" else "is missing",
166	18x	if (show_module_info) sprintf(" for module '%s'.", mod$label) else "."
167		)
168		)
169		),
170	18x	if (length(datanames) >= 1) {
171	16x	tagList(
172	16x	tags$span(if (length(datanames) == 1) "Dataset" else "Datasets"),
173	16x	tags$span("available in data:"),
174	16x	tagList(
175	16x	tags$span(
176	16x	to_html_code_list(datanames),
177	16x	tags$span(".", .noWS = "outside"),
178	16x	.noWS = c("outside")
179		)
180		)
181		)
182		} else {
183	2x	tags$span("No datasets are available in data.")
184		},
185	18x	tags$br(.noWS = "before")
186		)
187		}
188		)
189		)
190		}
191
192		#' Recursively checks modules and returns list for every datanames mismatch between module and data
193		#' @noRd
194		check_modules_datanames_recursive <- function(modules, datanames) { # nolint: object_name_length
195	270x	checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
196	270x	checkmate::assert_character(datanames)
197	270x	if (inherits(modules, "teal_modules")) {
198	77x	unlist(
199	77x	lapply(modules$children, check_modules_datanames_recursive, datanames = datanames),
200	77x	recursive = FALSE
201		)
202		} else {
203	193x	missing_datanames <- setdiff(modules$datanames, c("all", datanames))
204	193x	if (length(missing_datanames)) {
205	18x	list(list(
206	18x	label = modules$label,
207	18x	missing_datanames = missing_datanames
208		))
209		}
210		}
211		}
212
213		#' Convert character vector to html code separated with commas and "and"
214		#' @noRd
215		to_html_code_list <- function(x) {
216	34x	checkmate::assert_character(x)
217	34x	do.call(
218	34x	tagList,
219	34x	lapply(seq_along(x), function(.ix) {
220	47x	tagList(
221	47x	tags$code(x[.ix]),
222	47x	if (.ix != length(x)) {
223	1x	if (.ix == length(x) - 1) tags$span(" and ") else tags$span(", ", .noWS = "before")
224		}
225		)
226		})
227		)
228		}
229
230
231		#' Check `datanames` in filters
232		#'
233		#' This function checks whether `datanames` in filters correspond to those in `data`,
234		#' returning character vector with error messages or `TRUE` if all checks pass.
235		#'
236		#' @param filters (`teal_slices`) object
237		#' @param datanames (`character`) names of datasets available in the `data` object
238		#'
239		#' @return A `character(1)` containing error message or TRUE if validation passes.
240		#' @keywords internal
241		check_filter_datanames <- function(filters, datanames) {
242	77x	checkmate::assert_class(filters, "teal_slices")
243	77x	checkmate::assert_character(datanames)
244
245		# check teal_slices against datanames
246	77x	out <- unlist(sapply(
247	77x	filters, function(filter) {
248	24x	dataname <- shiny::isolate(filter$dataname)
249	24x	if (!dataname %in% datanames) {
250	3x	sprintf(
251	3x	"- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)",
252	3x	shiny::isolate(filter$id),
253	3x	dQuote(dataname, q = FALSE),
254	3x	toString(dQuote(datanames, q = FALSE))
255		)
256		}
257		}
258		))
259
260
261	77x	if (length(out)) {
262	3x	paste(out, collapse = "\n")
263		} else {
264	74x	TRUE
265		}
266		}
267
268		#' Function for validating the title parameter of `teal::init`
269		#'
270		#' Checks if the input of the title from `teal::init` will create a valid title and favicon tag.
271		#' @param shiny_tag (`shiny.tag`) Object to validate for a valid title.
272		#' @keywords internal
273		validate_app_title_tag <- function(shiny_tag) {
274	7x	checkmate::assert_class(shiny_tag, "shiny.tag")
275	7x	checkmate::assert_true(shiny_tag$name == "head")
276	6x	child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name")
277	6x	checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags")
278	4x	rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel
279	4x	checkmate::assert_subset(
280	4x	rel_attr,
281	4x	c("icon", "shortcut icon"),
282	4x	.var.name = "Link tag's rel attribute",
283	4x	empty.ok = FALSE
284		)
285		}
286
287		#' Build app title with favicon
288		#'
289		#' A helper function to create the browser title along with a logo.
290		#'
291		#' @param title (`character`) The browser title for the `teal` app.
292		#' @param favicon (`character`) The path for the icon for the title.
293		#' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/`
294		#'
295		#' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app.
296		#' @export
297		build_app_title <- function(
298		title = "teal app",
299		favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
300	13x	checkmate::assert_string(title, null.ok = TRUE)
301	13x	checkmate::assert_string(favicon, null.ok = TRUE)
302	13x	tags$head(
303	13x	tags$title(title),
304	13x	tags$link(
305	13x	rel = "icon",
306	13x	href = favicon,
307	13x	sizes = "any"
308		)
309		)
310		}
311
312		#' Application ID
313		#'
314		#' Creates App ID used to match filter snapshots to application.
315		#'
316		#' Calculate app ID that will be used to stamp filter state snapshots.
317		#' App ID is a hash of the app's data and modules.
318		#' See "transferring snapshots" section in ?snapshot.
319		#'
320		#' @param data (`teal_data` or `teal_data_module`) as accepted by `init`
321		#' @param modules (`teal_modules`) object as accepted by `init`
322		#'
323		#' @return A single character string.
324		#'
325		#' @keywords internal
326		create_app_id <- function(data, modules) {
327	21x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
328	20x	checkmate::assert_class(modules, "teal_modules")
329
330	19x	data <- if (inherits(data, "teal_data")) {
331	17x	as.list(teal.code::get_env(data))
332	19x	} else if (inherits(data, "teal_data_module")) {
333	2x	deparse1(body(data$server))
334		}
335	19x	modules <- lapply(modules, defunction)
336
337	19x	rlang::hash(list(data = data, modules = modules))
338		}
339
340		#' Go through list and extract bodies of encountered functions as string, recursively.
341		#' @keywords internal
342		#' @noRd
343		defunction <- function(x) {
344	229x	if (is.list(x)) {
345	67x	lapply(x, defunction)
346	162x	} else if (is.function(x)) {
347	50x	deparse1(body(x))
348		} else {
349	112x	x
350		}
351		}
352
353		#' Get unique labels
354		#'
355		#' Get unique labels for the modules to avoid namespace conflicts.
356		#'
357		#' @param labels (`character`) vector of labels
358		#'
359		#' @return (`character`) vector of unique labels
360		#'
361		#' @keywords internal
362		get_unique_labels <- function(labels) {
363	211x	make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
364		}
365
366		#' Remove ANSI escape sequences from a string
367		#' @noRd
368		strip_style <- function(string) {
369	2x	checkmate::assert_string(string)
370
371	2x	gsub(
372	2x	"(?:(?:\\x{001b}\\[)\|\\x{009b})(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M\|f-m])\|\\x{001b}[A-M]",
373		"",
374	2x	string,
375	2x	perl = TRUE,
376	2x	useBytes = TRUE
377		)
378		}

1		setOldClass("teal_module")
2		setOldClass("teal_modules")
3
4		#' Create `teal_module` and `teal_modules` objects
5		#'
6		#' @description
7		#' `r lifecycle::badge("stable")`
8		#' Create a nested tab structure to embed modules in a `teal` application.
9		#'
10		#' @details
11		#' `module()` creates an instance of a `teal_module` that can be placed in a `teal` application.
12		#' `modules()` shapes the structure of a the application by organizing `teal_module` within the navigation panel.
13		#' It wraps `teal_module` and `teal_modules` objects in a `teal_modules` object,
14		#' which results in a nested structure corresponding to the nested tabs in the final application.
15		#'
16		#' Note that for `modules()` `label` comes after `...`, so it must be passed as a named argument,
17		#' otherwise it will be captured by `...`.
18		#'
19		#' The labels `"global_filters"` and `"Report previewer"` are reserved
20		#' because they are used by the `mapping` argument of [teal_slices()]
21		#' and the report previewer module [reporter_previewer_module()], respectively.
22		#'
23		#' # Restricting datasets used by `teal_module`:
24		#' The `datanames` argument controls which datasets are used by the module’s server. These datasets,
25		#' passed via server's `data` argument, are the only ones shown in the module's tab.
26		#'
27		#' When `datanames` is set to `"all"`, all datasets in the data object are treated as relevant.
28		#' However, this may include unnecessary datasets, such as:
29		#' - Proxy variables for column modifications
30		#' - Temporary datasets used to create final versions
31		#' - Connection objects
32		#'
33		#' To exclude irrelevant datasets, use the [set_datanames()] function to change `datanames` from
34		#' `"all"` to specific names. Trying to modify non-`"all"` values with [set_datanames()] will result
35		#' in a warning. Datasets with names starting with . are ignored globally unless explicitly listed
36		#' in `datanames`.
37		#'
38		#' # `datanames` with `transformers`
39		#' When transformers are specified, their `datanames` are added to the module’s `datanames`, which
40		#' changes the behavior as follows:
41		#' - If `module(datanames)` is `NULL` and the `transformers` have defined `datanames`, the sidebar
42		#' will appear showing the `transformers`' datasets, instead of being hidden.
43		#' - If `module(datanames)` is set to specific values and any `transformer` has `datanames = "all"`,
44		#' the module may receive extra datasets that could be unnecessary
45		#'
46		#' @param label (`character(1)`) Label shown in the navigation item for the module or module group.
47		#' For `modules()` defaults to `"root"`. See `Details`.
48		#' @param server (`function`) `shiny` module with following arguments:
49		#' - `id` - `teal` will set proper `shiny` namespace for this module (see [shiny::moduleServer()]).
50		#' - `input`, `output`, `session` - (optional; not recommended) When provided, then [shiny::callModule()]
51		#' will be used to call a module. From `shiny` 1.5.0, the recommended way is to use
52		#' [shiny::moduleServer()] instead which doesn't require these arguments.
53		#' - `data` (optional) When provided, the module will be called with `teal_data` object (i.e. a list of
54		#' reactive (filtered) data specified in the `filters` argument) as the value of this argument.
55		#' - `datasets` (optional) When provided, the module will be called with `FilteredData` object as the
56		#' value of this argument. (See [`teal.slice::FilteredData`]).
57		#' - `reporter` (optional) When provided, the module will be called with `Reporter` object as the value
58		#' of this argument. (See [`teal.reporter::Reporter`]).
59		#' - `filter_panel_api` (optional) When provided, the module will be called with `FilterPanelAPI` object
60		#' as the value of this argument. (See [`teal.slice::FilterPanelAPI`]).
61		#' - `...` (optional) When provided, `server_args` elements will be passed to the module named argument
62		#' or to the `...`.
63		#' @param ui (`function`) `shiny` UI module function with following arguments:
64		#' - `id` - `teal` will set proper `shiny` namespace for this module.
65		#' - `...` (optional) When provided, `ui_args` elements will be passed to the module named argument
66		#' or to the `...`.
67		#' @param filters (`character`) Deprecated. Use `datanames` instead.
68		#' @param datanames (`character`) Names of the datasets relevant to the item.
69		#' There are 2 reserved values that have specific behaviors:
70		#' - The keyword `"all"` includes all datasets available in the data passed to the teal application.
71		#' - `NULL` hides the sidebar panel completely.
72		#' - If `transformers` are specified, their `datanames` are automatically added to this `datanames`
73		#' argument.
74		#' @param server_args (named `list`) with additional arguments passed on to the server function.
75		#' @param ui_args (named `list`) with additional arguments passed on to the UI function.
76		#' @param x (`teal_module` or `teal_modules`) Object to format/print.
77		#' @param indent (`integer(1)`) Indention level; each nested element is indented one level more.
78		#' @param transformers (`list` of `teal_data_module`) that will be applied to transform the data.
79		#' Each transform module UI will appear in the `teal`'s sidebar panel.
80		#' Transformers' `datanames` are added to the `datanames`. See [teal_transform_module()].
81		#'
82		#' @param ...
83		#' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab.
84		#' - For `format()` and `print()`: Arguments passed to other methods.
85		#'
86		#' @return
87		#' `module()` returns an object of class `teal_module`.
88		#'
89		#' `modules()` returns a `teal_modules` object which contains following fields:
90		#' - `label`: taken from the `label` argument.
91		#' - `children`: a list containing objects passed in `...`. List elements are named after
92		#' their `label` attribute converted to a valid `shiny` id.
93		#'
94		#' @name teal_modules
95		#' @aliases teal_module
96		#'
97		#' @examples
98		#' library(shiny)
99		#'
100		#' module_1 <- module(
101		#' label = "a module",
102		#' server = function(id, data) {
103		#' moduleServer(
104		#' id,
105		#' module = function(input, output, session) {
106		#' output$data <- renderDataTable(data()[["iris"]])
107		#' }
108		#' )
109		#' },
110		#' ui = function(id) {
111		#' ns <- NS(id)
112		#' tagList(dataTableOutput(ns("data")))
113		#' },
114		#' datanames = "all"
115		#' )
116		#'
117		#' module_2 <- module(
118		#' label = "another module",
119		#' server = function(id) {
120		#' moduleServer(
121		#' id,
122		#' module = function(input, output, session) {
123		#' output$text <- renderText("Another Module")
124		#' }
125		#' )
126		#' },
127		#' ui = function(id) {
128		#' ns <- NS(id)
129		#' tagList(textOutput(ns("text")))
130		#' },
131		#' datanames = NULL
132		#' )
133		#'
134		#' modules <- modules(
135		#' label = "modules",
136		#' modules(
137		#' label = "nested modules",
138		#' module_1
139		#' ),
140		#' module_2
141		#' )
142		#'
143		#' app <- init(
144		#' data = teal_data(iris = iris),
145		#' modules = modules
146		#' )
147		#'
148		#' if (interactive()) {
149		#' shinyApp(app$ui, app$server)
150		#' }
151		#' @rdname teal_modules
152		#' @export
153		#'
154		module <- function(label = "module",
155		server = function(id, data, ...) moduleServer(id, function(input, output, session) NULL),
156		ui = function(id, ...) tags$p(paste0("This module has no UI (id: ", id, " )")),
157		filters,
158		datanames = "all",
159		server_args = NULL,
160		ui_args = NULL,
161		transformers = list()) {
162		# argument checking (independent)
163		## `label`
164	211x	checkmate::assert_string(label)
165	208x	if (label == "global_filters") {
166	1x	stop(
167	1x	sprintf("module(label = \"%s\", ...\n ", label),
168	1x	"Label 'global_filters' is reserved in teal. Please change to something else.",
169	1x	call. = FALSE
170		)
171		}
172	207x	if (label == "Report previewer") {
173	!	stop(
174	!	sprintf("module(label = \"%s\", ...\n ", label),
175	!	"Label 'Report previewer' is reserved in teal. Please change to something else.",
176	!	call. = FALSE
177		)
178		}
179
180		## server
181	207x	checkmate::assert_function(server)
182	207x	server_formals <- names(formals(server))
183	207x	if (!(
184	207x	"id" %in% server_formals \|\|
185	207x	all(c("input", "output", "session") %in% server_formals)
186		)) {
187	2x	stop(
188	2x	"\nmodule() `server` argument requires a function with following arguments:",
189	2x	"\n - id - `teal` will set proper `shiny` namespace for this module.",
190	2x	"\n - input, output, session (not recommended) - then `shiny::callModule` will be used to call a module.",
191	2x	"\n\nFollowing arguments can be used optionaly:",
192	2x	"\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",
193	2x	"\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",
194	2x	"\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",
195	2x	"\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",
196	2x	"\n - `...` server_args elements will be passed to the module named argument or to the `...`"
197		)
198		}
199	205x	if ("datasets" %in% server_formals) {
200	2x	warning(
201	2x	sprintf("Called from module(label = \"%s\", ...)\n ", label),
202	2x	"`datasets` argument in the server is deprecated and will be removed in the next release. ",
203	2x	"Please use `data` instead.",
204	2x	call. = FALSE
205		)
206		}
207
208
209		## UI
210	205x	checkmate::assert_function(ui)
211	205x	ui_formals <- names(formals(ui))
212	205x	if (!"id" %in% ui_formals) {
213	1x	stop(
214	1x	"\nmodule() `ui` argument requires a function with following arguments:",
215	1x	"\n - id - `teal` will set proper `shiny` namespace for this module.",
216	1x	"\n\nFollowing arguments can be used optionally:",
217	1x	"\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"
218		)
219		}
220	204x	if (any(c("data", "datasets") %in% ui_formals)) {
221	2x	stop(
222	2x	sprintf("Called from module(label = \"%s\", ...)\n ", label),
223	2x	"UI with `data` or `datasets` argument is no longer accepted.\n ",
224	2x	"If some UI inputs depend on data, please move the logic to your server instead.\n ",
225	2x	"Possible solutions are renderUI() or updateXyzInput() functions."
226		)
227		}
228
229
230		## `filters`
231	202x	if (!missing(filters)) {
232	!	datanames <- filters
233	!	msg <-
234	!	"The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."
235	!	warning(msg)
236		}
237
238		## `datanames` (also including deprecated `filters`)
239		# please note a race condition between datanames set when filters is not missing and data arg in server function
240	202x	if (!is.element("data", server_formals) && !is.null(datanames)) {
241	12x	message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
242	12x	datanames <- NULL
243		}
244	202x	checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)
245
246		## `server_args`
247	201x	checkmate::assert_list(server_args, null.ok = TRUE, names = "named")
248	199x	srv_extra_args <- setdiff(names(server_args), server_formals)
249	199x	if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
250	1x	stop(
251	1x	"\nFollowing `server_args` elements have no equivalent in the formals of the server:\n",
252	1x	paste(paste(" -", srv_extra_args), collapse = "\n"),
253	1x	"\n\nUpdate the server arguments by including above or add `...`"
254		)
255		}
256
257		## `ui_args`
258	198x	checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")
259	196x	ui_extra_args <- setdiff(names(ui_args), ui_formals)
260	196x	if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
261	1x	stop(
262	1x	"\nFollowing `ui_args` elements have no equivalent in the formals of UI:\n",
263	1x	paste(paste(" -", ui_extra_args), collapse = "\n"),
264	1x	"\n\nUpdate the UI arguments by including above or add `...`"
265		)
266		}
267
268		## `transformers`
269	195x	if (inherits(transformers, "teal_transform_module")) {
270	1x	transformers <- list(transformers)
271		}
272	195x	checkmate::assert_list(transformers, types = "teal_transform_module")
273	195x	transformer_datanames <- unlist(lapply(transformers, attr, "datanames"))
274	195x	combined_datanames <- if (identical(datanames, "all")) {
275	142x	"all"
276		} else {
277	53x	union(datanames, transformer_datanames)
278		}
279
280	195x	structure(
281	195x	list(
282	195x	label = label,
283	195x	server = server,
284	195x	ui = ui,
285	195x	datanames = combined_datanames,
286	195x	server_args = server_args,
287	195x	ui_args = ui_args,
288	195x	transformers = transformers
289		),
290	195x	class = "teal_module"
291		)
292		}
293
294		#' @rdname teal_modules
295		#' @export
296		#'
297		modules <- function(..., label = "root") {
298	135x	checkmate::assert_string(label)
299	133x	submodules <- list(...)
300	133x	if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
301	2x	stop(
302	2x	"The only character argument to modules() must be 'label' and it must be named, ",
303	2x	"change modules('lab', ...) to modules(label = 'lab', ...)"
304		)
305		}
306
307	131x	checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
308		# name them so we can more easily access the children
309		# beware however that the label of the submodules should not be changed as it must be kept synced
310	128x	labels <- vapply(submodules, function(submodule) submodule$label, character(1))
311	128x	names(submodules) <- get_unique_labels(labels)
312	128x	structure(
313	128x	list(
314	128x	label = label,
315	128x	children = submodules
316		),
317	128x	class = "teal_modules"
318		)
319		}
320
321		# printing methods ----
322
323		#' @rdname teal_modules
324		#' @export
325		format.teal_module <- function(x, indent = 0, ...) {
326	3x	paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, "\n", collapse = "")
327		}
328
329
330		#' @rdname teal_modules
331		#' @export
332		print.teal_module <- function(x, ...) {
333	!	cat(format(x, ...))
334	!	invisible(x)
335		}
336
337
338		#' @rdname teal_modules
339		#' @export
340		format.teal_modules <- function(x, indent = 0, ...) {
341	1x	paste(
342	1x	c(
343	1x	paste0(rep(" ", indent), "+ ", x$label, "\n"),
344	1x	unlist(lapply(x$children, format, indent = indent + 1, ...))
345		),
346	1x	collapse = ""
347		)
348		}
349
350		#' @param modules (`teal_module` or `teal_modules`)
351		#' @rdname teal_modules
352		#' @examples
353		#' # change the module's datanames
354		#' set_datanames(module(datanames = "all"), "a")
355		#'
356		#' # change modules' datanames
357		#' set_datanames(
358		#' modules(
359		#' module(datanames = "all"),
360		#' module(datanames = "a")
361		#' ),
362		#' "b"
363		#' )
364		#' @export
365		set_datanames <- function(modules, datanames) {
366	!	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
367	!	if (inherits(modules, "teal_modules")) {
368	!	modules$children <- lapply(modules$children, set_datanames, datanames)
369		} else {
370	!	if (identical(modules$datanames, "all")) {
371	!	modules$datanames <- datanames
372		} else {
373	!	warning(
374	!	"Not possible to modify datanames of the module ", modules$label,
375	!	". set_datanames() can only change datanames if it was set to \"all\".",
376	!	call. = FALSE
377		)
378		}
379		}
380	!	modules
381		}
382
383		#' @rdname teal_modules
384		#' @export
385		print.teal_modules <- print.teal_module
386
387
388		# utilities ----
389		## subset or modify modules ----
390
391		#' Append a `teal_module` to `children` of a `teal_modules` object
392		#' @keywords internal
393		#' @param modules (`teal_modules`)
394		#' @param module (`teal_module`) object to be appended onto the children of `modules`
395		#' @return A `teal_modules` object with `module` appended.
396		append_module <- function(modules, module) {
397	8x	checkmate::assert_class(modules, "teal_modules")
398	6x	checkmate::assert_class(module, "teal_module")
399	4x	modules$children <- c(modules$children, list(module))
400	4x	labels <- vapply(modules$children, function(submodule) submodule$label, character(1))
401	4x	names(modules$children) <- get_unique_labels(labels)
402	4x	modules
403		}
404
405		#' Extract/Remove module(s) of specific class
406		#'
407		#' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`.
408		#'
409		#' @param modules (`teal_modules`)
410		#' @param class The class name of `teal_module` to be extracted or dropped.
411		#' @keywords internal
412		#' @return
413		#' - For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`.
414		#' - For `drop_module`, the opposite, which is all `teal_modules` of class other than `class`.
415		#' @rdname module_management
416		extract_module <- function(modules, class) {
417	24x	if (inherits(modules, class)) {
418	!	modules
419	24x	} else if (inherits(modules, "teal_module")) {
420	13x	NULL
421	11x	} else if (inherits(modules, "teal_modules")) {
422	11x	Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class))
423		}
424		}
425
426		#' @keywords internal
427		#' @return `teal_modules`
428		#' @rdname module_management
429		drop_module <- function(modules, class) {
430	!	if (inherits(modules, class)) {
431	!	NULL
432	!	} else if (inherits(modules, "teal_module")) {
433	!	modules
434	!	} else if (inherits(modules, "teal_modules")) {
435	!	do.call(
436	!	"modules",
437	!	c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label)
438		)
439		}
440		}
441
442		## read modules ----
443
444		#' Does the object make use of the `arg`
445		#'
446		#' @param modules (`teal_module` or `teal_modules`) object
447		#' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.
448		#' @return `logical` whether the object makes use of `arg`.
449		#' @rdname is_arg_used
450		#' @keywords internal
451		is_arg_used <- function(modules, arg) {
452	476x	checkmate::assert_string(arg)
453	473x	if (inherits(modules, "teal_modules")) {
454	18x	any(unlist(lapply(modules$children, is_arg_used, arg)))
455	455x	} else if (inherits(modules, "teal_module")) {
456	30x	is_arg_used(modules$server, arg) \|\| is_arg_used(modules$ui, arg)
457	425x	} else if (is.function(modules)) {
458	423x	isTRUE(arg %in% names(formals(modules)))
459		} else {
460	2x	stop("is_arg_used function not implemented for this object")
461		}
462		}
463
464
465		#' Get module depth
466		#'
467		#' Depth starts at 0, so a single `teal.module` has depth 0.
468		#' Nesting it increases overall depth by 1.
469		#'
470		#' @inheritParams init
471		#' @param depth optional integer determining current depth level
472		#'
473		#' @return Depth level for given module.
474		#' @keywords internal
475		modules_depth <- function(modules, depth = 0L) {
476	12x	checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
477	12x	checkmate::assert_int(depth, lower = 0)
478	11x	if (inherits(modules, "teal_modules")) {
479	4x	max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))
480		} else {
481	7x	depth
482		}
483		}
484
485		#' Retrieve labels from `teal_modules`
486		#'
487		#' @param modules (`teal_modules`)
488		#' @return A `list` containing the labels of the modules. If the modules are nested,
489		#' the function returns a nested `list` of labels.
490		#' @keywords internal
491		module_labels <- function(modules) {
492	185x	if (inherits(modules, "teal_modules")) {
493	80x	lapply(modules$children, module_labels)
494		} else {
495	105x	modules$label
496		}
497		}
498
499		#' Retrieve `teal_bookmarkable` attribute from `teal_modules`
500		#'
501		#' @param modules (`teal_modules` or `teal_module`) object
502		#' @return named list of the same structure as `modules` with `TRUE` or `FALSE` values indicating
503		#' whether the module is bookmarkable.
504		#' @keywords internal
505		modules_bookmarkable <- function(modules) {
506	185x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
507	185x	if (inherits(modules, "teal_modules")) {
508	80x	setNames(
509	80x	lapply(modules$children, modules_bookmarkable),
510	80x	vapply(modules$children, `[[`, "label", FUN.VALUE = character(1))
511		)
512		} else {
513	105x	attr(modules, "teal_bookmarkable", exact = TRUE)
514		}
515		}

1		#' Validate that dataset has a minimum number of observations
2		#'
3		#' `r lifecycle::badge("stable")`
4		#'
5		#' This function is a wrapper for `shiny::validate`.
6		#'
7		#' @param x (`data.frame`)
8		#' @param min_nrow (`numeric(1)`) Minimum allowed number of rows in `x`.
9		#' @param complete (`logical(1)`) Flag specifying whether to check only complete cases. Defaults to `FALSE`.
10		#' @param allow_inf (`logical(1)`) Flag specifying whether to allow infinite values. Defaults to `TRUE`.
11		#' @param msg (`character(1)`) Additional message to display alongside the default message.
12		#'
13		#' @export
14		#'
15		#' @examples
16		#' library(teal)
17		#' ui <- fluidPage(
18		#' sliderInput("len", "Max Length of Sepal",
19		#' min = 4.3, max = 7.9, value = 5
20		#' ),
21		#' plotOutput("plot")
22		#' )
23		#'
24		#' server <- function(input, output) {
25		#' output$plot <- renderPlot({
26		#' iris_df <- iris[iris$Sepal.Length <= input$len, ]
27		#' validate_has_data(
28		#' iris_df,
29		#' min_nrow = 10,
30		#' complete = FALSE,
31		#' msg = "Please adjust Max Length of Sepal"
32		#' )
33		#'
34		#' hist(iris_df$Sepal.Length, breaks = 5)
35		#' })
36		#' }
37		#' if (interactive()) {
38		#' shinyApp(ui, server)
39		#' }
40		#'
41		validate_has_data <- function(x,
42		min_nrow = NULL,
43		complete = FALSE,
44		allow_inf = TRUE,
45		msg = NULL) {
46	17x	checkmate::assert_string(msg, null.ok = TRUE)
47	15x	checkmate::assert_data_frame(x)
48	15x	if (!is.null(min_nrow)) {
49	15x	if (complete) {
50	5x	complete_index <- stats::complete.cases(x)
51	5x	validate(need(
52	5x	sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,
53	5x	paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
54		))
55		} else {
56	10x	validate(need(
57	10x	nrow(x) >= min_nrow,
58	10x	paste(
59	10x	c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
60	10x	collapse = "\n"
61		)
62		))
63		}
64
65	10x	if (!allow_inf) {
66	6x	validate(need(
67	6x	all(vapply(x, function(col) !is.numeric(col) \|\| !any(is.infinite(col)), logical(1))),
68	6x	"Dataframe contains Inf values which is not allowed."
69		))
70		}
71		}
72		}
73
74		#' Validate that dataset has unique rows for key variables
75		#'
76		#' `r lifecycle::badge("stable")`
77		#'
78		#' This function is a wrapper for `shiny::validate`.
79		#'
80		#' @param x (`data.frame`)
81		#' @param key (`character`) Vector of ID variables from `x` that identify unique records.
82		#'
83		#' @export
84		#'
85		#' @examples
86		#' iris$id <- rep(1:50, times = 3)
87		#' ui <- fluidPage(
88		#' selectInput(
89		#' inputId = "species",
90		#' label = "Select species",
91		#' choices = c("setosa", "versicolor", "virginica"),
92		#' selected = "setosa",
93		#' multiple = TRUE
94		#' ),
95		#' plotOutput("plot")
96		#' )
97		#' server <- function(input, output) {
98		#' output$plot <- renderPlot({
99		#' iris_f <- iris[iris$Species %in% input$species, ]
100		#' validate_one_row_per_id(iris_f, key = c("id"))
101		#'
102		#' hist(iris_f$Sepal.Length, breaks = 5)
103		#' })
104		#' }
105		#' if (interactive()) {
106		#' shinyApp(ui, server)
107		#' }
108		#'
109		validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
110	!	validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
111		}
112
113		#' Validates that vector includes all expected values
114		#'
115		#' `r lifecycle::badge("stable")`
116		#'
117		#' This function is a wrapper for `shiny::validate`.
118		#'
119		#' @param x Vector of values to test.
120		#' @param choices Vector to test against.
121		#' @param msg (`character(1)`) Error message to display if some elements of `x` are not elements of `choices`.
122		#'
123		#' @export
124		#'
125		#' @examples
126		#' ui <- fluidPage(
127		#' selectInput(
128		#' "species",
129		#' "Select species",
130		#' choices = c("setosa", "versicolor", "virginica", "unknown species"),
131		#' selected = "setosa",
132		#' multiple = FALSE
133		#' ),
134		#' verbatimTextOutput("summary")
135		#' )
136		#'
137		#' server <- function(input, output) {
138		#' output$summary <- renderPrint({
139		#' validate_in(input$species, iris$Species, "Species does not exist.")
140		#' nrow(iris[iris$Species == input$species, ])
141		#' })
142		#' }
143		#' if (interactive()) {
144		#' shinyApp(ui, server)
145		#' }
146		#'
147		validate_in <- function(x, choices, msg) {
148	!	validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg))
149		}
150
151		#' Validates that vector has length greater than 0
152		#'
153		#' `r lifecycle::badge("stable")`
154		#'
155		#' This function is a wrapper for `shiny::validate`.
156		#'
157		#' @param x vector
158		#' @param msg message to display
159		#'
160		#' @export
161		#'
162		#' @examples
163		#' data <- data.frame(
164		#' id = c(1:10, 11:20, 1:10),
165		#' strata = rep(c("A", "B"), each = 15)
166		#' )
167		#' ui <- fluidPage(
168		#' selectInput("ref1", "Select strata1 to compare",
169		#' choices = c("A", "B", "C"), selected = "A"
170		#' ),
171		#' selectInput("ref2", "Select strata2 to compare",
172		#' choices = c("A", "B", "C"), selected = "B"
173		#' ),
174		#' verbatimTextOutput("arm_summary")
175		#' )
176		#'
177		#' server <- function(input, output) {
178		#' output$arm_summary <- renderText({
179		#' sample_1 <- data$id[data$strata == input$ref1]
180		#' sample_2 <- data$id[data$strata == input$ref2]
181		#'
182		#' validate_has_elements(sample_1, "No subjects in strata1.")
183		#' validate_has_elements(sample_2, "No subjects in strata2.")
184		#'
185		#' paste0(
186		#' "Number of samples in: strata1=", length(sample_1),
187		#' " comparions strata2=", length(sample_2)
188		#' )
189		#' })
190		#' }
191		#' if (interactive()) {
192		#' shinyApp(ui, server)
193		#' }
194		validate_has_elements <- function(x, msg) {
195	!	validate(need(length(x) > 0, msg))
196		}
197
198		#' Validates no intersection between two vectors
199		#'
200		#' `r lifecycle::badge("stable")`
201		#'
202		#' This function is a wrapper for `shiny::validate`.
203		#'
204		#' @param x vector
205		#' @param y vector
206		#' @param msg (`character(1)`) message to display if `x` and `y` intersect
207		#'
208		#' @export
209		#'
210		#' @examples
211		#' data <- data.frame(
212		#' id = c(1:10, 11:20, 1:10),
213		#' strata = rep(c("A", "B", "C"), each = 10)
214		#' )
215		#'
216		#' ui <- fluidPage(
217		#' selectInput("ref1", "Select strata1 to compare",
218		#' choices = c("A", "B", "C"),
219		#' selected = "A"
220		#' ),
221		#' selectInput("ref2", "Select strata2 to compare",
222		#' choices = c("A", "B", "C"),
223		#' selected = "B"
224		#' ),
225		#' verbatimTextOutput("summary")
226		#' )
227		#'
228		#' server <- function(input, output) {
229		#' output$summary <- renderText({
230		#' sample_1 <- data$id[data$strata == input$ref1]
231		#' sample_2 <- data$id[data$strata == input$ref2]
232		#'
233		#' validate_no_intersection(
234		#' sample_1, sample_2,
235		#' "subjects within strata1 and strata2 cannot overlap"
236		#' )
237		#' paste0(
238		#' "Number of subject in: reference treatment=", length(sample_1),
239		#' " comparions treatment=", length(sample_2)
240		#' )
241		#' })
242		#' }
243		#' if (interactive()) {
244		#' shinyApp(ui, server)
245		#' }
246		#'
247		validate_no_intersection <- function(x, y, msg) {
248	!	validate(need(length(intersect(x, y)) == 0, msg))
249		}
250
251
252		#' Validates that dataset contains specific variable
253		#'
254		#' `r lifecycle::badge("stable")`
255		#'
256		#' This function is a wrapper for `shiny::validate`.
257		#'
258		#' @param data (`data.frame`)
259		#' @param varname (`character(1)`) name of variable to check for in `data`
260		#' @param msg (`character(1)`) message to display if `data` does not include `varname`
261		#'
262		#' @export
263		#'
264		#' @examples
265		#' data <- data.frame(
266		#' one = rep("a", length.out = 20),
267		#' two = rep(c("a", "b"), length.out = 20)
268		#' )
269		#' ui <- fluidPage(
270		#' selectInput(
271		#' "var",
272		#' "Select variable",
273		#' choices = c("one", "two", "three", "four"),
274		#' selected = "one"
275		#' ),
276		#' verbatimTextOutput("summary")
277		#' )
278		#'
279		#' server <- function(input, output) {
280		#' output$summary <- renderText({
281		#' validate_has_variable(data, input$var)
282		#' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
283		#' })
284		#' }
285		#' if (interactive()) {
286		#' shinyApp(ui, server)
287		#' }
288		validate_has_variable <- function(data, varname, msg) {
289	!	if (length(varname) != 0) {
290	!	has_vars <- varname %in% names(data)
291
292	!	if (!all(has_vars)) {
293	!	if (missing(msg)) {
294	!	msg <- sprintf(
295	!	"%s does not have the required variables: %s.",
296	!	deparse(substitute(data)),
297	!	toString(varname[!has_vars])
298		)
299		}
300	!	validate(need(FALSE, msg))
301		}
302		}
303		}
304
305		#' Validate that variables has expected number of levels
306		#'
307		#' `r lifecycle::badge("stable")`
308		#'
309		#' If the number of levels of `x` is less than `min_levels`
310		#' or greater than `max_levels` the validation will fail.
311		#' This function is a wrapper for `shiny::validate`.
312		#'
313		#' @param x variable name. If `x` is not a factor, the unique values
314		#' are treated as levels.
315		#' @param min_levels cutoff for minimum number of levels of `x`
316		#' @param max_levels cutoff for maximum number of levels of `x`
317		#' @param var_name name of variable being validated for use in
318		#' validation message
319		#'
320		#' @export
321		#' @examples
322		#' data <- data.frame(
323		#' one = rep("a", length.out = 20),
324		#' two = rep(c("a", "b"), length.out = 20),
325		#' three = rep(c("a", "b", "c"), length.out = 20),
326		#' four = rep(c("a", "b", "c", "d"), length.out = 20),
327		#' stringsAsFactors = TRUE
328		#' )
329		#' ui <- fluidPage(
330		#' selectInput(
331		#' "var",
332		#' "Select variable",
333		#' choices = c("one", "two", "three", "four"),
334		#' selected = "one"
335		#' ),
336		#' verbatimTextOutput("summary")
337		#' )
338		#'
339		#' server <- function(input, output) {
340		#' output$summary <- renderText({
341		#' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var)
342		#' paste0(
343		#' "Levels of selected treatment variable: ",
344		#' paste(levels(data[[input$var]]),
345		#' collapse = ", "
346		#' )
347		#' )
348		#' })
349		#' }
350		#' if (interactive()) {
351		#' shinyApp(ui, server)
352		#' }
353		validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
354	!	x_levels <- if (is.factor(x)) {
355	!	levels(x)
356		} else {
357	!	unique(x)
358		}
359
360	!	if (!is.null(min_levels) && !(is.null(max_levels))) {
361	!	validate(need(
362	!	length(x_levels) >= min_levels && length(x_levels) <= max_levels,
363	!	sprintf(
364	!	"%s variable needs minimum %s level(s) and maximum %s level(s).",
365	!	var_name, min_levels, max_levels
366		)
367		))
368	!	} else if (!is.null(min_levels)) {
369	!	validate(need(
370	!	length(x_levels) >= min_levels,
371	!	sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
372		))
373	!	} else if (!is.null(max_levels)) {
374	!	validate(need(
375	!	length(x_levels) <= max_levels,
376	!	sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
377		))
378		}
379		}

1		#' Module to transform `reactive` `teal_data`
2		#'
3		#' Module calls multiple [`module_teal_data`] in sequence so that `reactive teal_data` output
4		#' from one module is handed over to the following module's input.
5		#'
6		#' @inheritParams module_teal_data
7		#' @inheritParams teal_modules
8		#' @return `reactive` `teal_data`
9		#'
10		#'
11		#' @name module_transform_data
12		#' @keywords internal
13		NULL
14
15		#' @rdname module_transform_data
16		ui_transform_data <- function(id, transformers = list(), class = "well") {
17	!	checkmate::assert_string(id)
18	!	checkmate::assert_list(transformers, "teal_transform_module")
19
20	!	ns <- NS(id)
21	!	labels <- lapply(transformers, function(x) attr(x, "label"))
22	!	ids <- get_unique_labels(labels)
23	!	names(transformers) <- ids
24
25	!	lapply(
26	!	names(transformers),
27	!	function(name) {
28	!	data_mod <- transformers[[name]]
29	!	wrapper_id <- ns(sprintf("wrapper_%s", name))
30	!	div( # todo: accordion?
31		# class .teal_validated changes the color of the boarder on error in ui_validate_reactive_teal_data
32		# For details see tealValidate.js file.
33	!	class = c(class, "teal_validated"),
34	!	title = attr(data_mod, "label"),
35	!	tags$span(
36	!	class = "text-primary mb-4",
37	!	icon("fas fa-square-pen"),
38	!	attr(data_mod, "label")
39		),
40	!	tags$i(
41	!	class = "remove pull-right fa fa-angle-down",
42	!	style = "cursor: pointer;",
43	!	title = "fold/expand transform panel",
44	!	onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", wrapper_id)
45		),
46	!	div(
47	!	id = wrapper_id,
48	!	ui_teal_data(id = ns(name), data_module = transformers[[name]]$ui)
49		)
50		)
51		}
52		)
53		}
54
55		#' @rdname module_transform_data
56		srv_transform_data <- function(id, data, transformers = list(), modules, is_transformer_failed = reactiveValues()) {
57	79x	checkmate::assert_string(id)
58	79x	assert_reactive(data)
59	79x	checkmate::assert_list(transformers, "teal_transform_module")
60	79x	checkmate::assert_class(modules, "teal_module")
61	79x	labels <- lapply(transformers, function(x) attr(x, "label"))
62	79x	ids <- get_unique_labels(labels)
63	79x	names(transformers) <- ids
64	79x	moduleServer(id, function(input, output, session) {
65	79x	logger::log_debug("srv_teal_data_modules initializing.")
66	79x	Reduce(
67	79x	function(previous_result, name) {
68	19x	srv_teal_data(
69	19x	id = name,
70	19x	data_module = function(id) transformers[[name]]$server(id, previous_result),
71	19x	modules = modules,
72	19x	is_transformer_failed = is_transformer_failed
73		)
74		},
75	79x	x = names(transformers),
76	79x	init = data
77		)
78		})
79		}

1		#' Manage multiple `FilteredData` objects
2		#'
3		#' @description
4		#' Oversee filter states across the entire application.
5		#'
6		#' @section Slices global:
7		#' The key role in maintaining the module-specific filter states is played by the `.slicesGlobal`
8		#' object. It is a reference class that holds the following fields:
9		#' - `all_slices` (`reactiveVal`) - reactive value containing all filters registered in an app.
10		#' - `module_slices_api` (`reactiveValues`) - reactive field containing references to each modules'
11		#' `FilteredData` object methods. At this moment it is used only in `srv_filter_manager` to display
12		#' the filter states in a table combining informations from `all_slices` and from
13		#' `FilteredData$get_available_teal_slices()`.
14		#'
15		#' During a session only new filters are added to `all_slices` unless [`module_snapshot_manager`] is
16		#' used to restore previous state. Filters from `all_slices` can be activated or deactivated in a
17		#' module which is linked (both ways) by `attr(, "mapping")` so that:
18		#' - If module's filter is added or removed in its `FilteredData` object, this information is passed
19		#' to `SlicesGlobal` which updates `attr(, "mapping")` accordingly.
20		#' - When mapping changes in a `SlicesGlobal`, filters are set or removed from module's
21		#' `FilteredData`.
22		#'
23		#' @section Filter manager:
24		#' Filter-manager is split into two parts:
25		#' 1. `ui/srv_filter_manager_panel` - Called once for the whole app. This module observes changes in
26		#' the filters in `slices_global` and displays them in a table utilizing information from `mapping`:
27		#' - (`TRUE`) - filter is active in the module
28		#' - (`FALSE`) - filter is inactive in the module
29		#' - (`NA`) - filter is not available in the module
30		#' 2. `ui/srv_module_filter_manager` - Called once for each `teal_module`. Handling filter states
31		#' for of single module and keeping module `FilteredData` consistent with `slices_global`, so that
32		#' local filters are always reflected in the `slices_global` and its mapping and vice versa.
33		#'
34		#'
35		#' @param id (`character(1)`)
36		#' `shiny` module instance id.
37		#'
38		#' @param slices_global (`reactiveVal`)
39		#' containing `teal_slices`.
40		#'
41		#' @param module_fd (`FilteredData`)
42		#' Object containing the data to be filtered in a single `teal` module.
43		#'
44		#' @return
45		#' Module returns a `slices_global` (`reactiveVal`) containing a `teal_slices` object with mapping.
46		#'
47		#' @encoding UTF-8
48		#'
49		#' @name module_filter_manager
50		#' @rdname module_filter_manager
51		#'
52		NULL
53
54		#' @rdname module_filter_manager
55		ui_filter_manager_panel <- function(id) {
56	!	ns <- NS(id)
57	!	tags$button(
58	!	id = ns("show_filter_manager"),
59	!	class = "btn action-button wunder_bar_button",
60	!	title = "View filter mapping",
61	!	suppressMessages(icon("fas fa-grip"))
62		)
63		}
64
65		#' @rdname module_filter_manager
66		#' @keywords internal
67		srv_filter_manager_panel <- function(id, slices_global) {
68	80x	checkmate::assert_string(id)
69	80x	checkmate::assert_class(slices_global, ".slicesGlobal")
70	80x	moduleServer(id, function(input, output, session) {
71	80x	setBookmarkExclude(c("show_filter_manager"))
72	80x	observeEvent(input$show_filter_manager, {
73	!	logger::log_debug("srv_filter_manager_panel@1 show_filter_manager button has been clicked.")
74	!	showModal(
75	!	modalDialog(
76	!	ui_filter_manager(session$ns("filter_manager")),
77	!	class = "filter_manager_modal",
78	!	size = "l",
79	!	footer = NULL,
80	!	easyClose = TRUE
81		)
82		)
83		})
84	80x	srv_filter_manager("filter_manager", slices_global = slices_global)
85		})
86		}
87
88		#' @rdname module_filter_manager
89		ui_filter_manager <- function(id) {
90	!	ns <- NS(id)
91	!	actionButton(ns("filter_manager"), NULL, icon = icon("fas fa-filter"))
92	!	tags$div(
93	!	class = "filter_manager_content",
94	!	tableOutput(ns("slices_table"))
95		)
96		}
97
98		#' @rdname module_filter_manager
99		srv_filter_manager <- function(id, slices_global) {
100	80x	checkmate::assert_string(id)
101	80x	checkmate::assert_class(slices_global, ".slicesGlobal")
102
103	80x	moduleServer(id, function(input, output, session) {
104	80x	logger::log_debug("filter_manager_srv initializing.")
105
106		# Bookmark slices global with mapping.
107	80x	session$onBookmark(function(state) {
108	!	logger::log_debug("filter_manager_srv@onBookmark: storing filter state")
109	!	state$values$filter_state_on_bookmark <- as.list(
110	!	slices_global$all_slices(),
111	!	recursive = TRUE
112		)
113		})
114
115	80x	bookmarked_slices <- restoreValue(session$ns("filter_state_on_bookmark"), NULL)
116	80x	if (!is.null(bookmarked_slices)) {
117	!	logger::log_debug("filter_manager_srv: restoring filter state from bookmark.")
118	!	slices_global$slices_set(bookmarked_slices)
119		}
120
121	80x	mapping_table <- reactive({
122		# We want this to be reactive on slices_global$all_slices() only as get_available_teal_slices()
123		# is dependent on slices_global$all_slices().
124	89x	module_labels <- setdiff(
125	89x	names(attr(slices_global$all_slices(), "mapping")),
126	89x	"Report previewer"
127		)
128	89x	isolate({
129	89x	mm <- as.data.frame(
130	89x	sapply(
131	89x	module_labels,
132	89x	simplify = FALSE,
133	89x	function(module_label) {
134	102x	available_slices <- slices_global$module_slices_api[[module_label]]$get_available_teal_slices()
135	94x	global_ids <- sapply(slices_global$all_slices(), `[[`, "id", simplify = FALSE)
136	94x	module_ids <- sapply(slices_global$slices_get(module_label), `[[`, "id", simplify = FALSE)
137	94x	allowed_ids <- vapply(available_slices, `[[`, character(1L), "id")
138	94x	active_ids <- global_ids %in% module_ids
139	94x	setNames(nm = global_ids, ifelse(global_ids %in% allowed_ids, active_ids, NA))
140		}
141		),
142	89x	check.names = FALSE
143		)
144	81x	colnames(mm)[colnames(mm) == "global_filters"] <- "Global filters"
145
146	81x	mm
147		})
148		})
149
150	80x	output$slices_table <- renderTable(
151	80x	expr = {
152	89x	logger::log_debug("filter_manager_srv@1 rendering slices_table.")
153	89x	mm <- mapping_table()
154
155		# Display logical values as UTF characters.
156	81x	mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))
157	81x	mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))
158
159		# Display placeholder if no filters defined.
160	81x	if (nrow(mm) == 0L) {
161	57x	mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)
162	57x	rownames(mm) <- ""
163		}
164	81x	mm
165		},
166	80x	rownames = TRUE
167		)
168
169	80x	mapping_table # for testing purpose
170		})
171		}
172
173		#' @rdname module_filter_manager
174		srv_module_filter_manager <- function(id, module_fd, slices_global) {
175	105x	checkmate::assert_string(id)
176	105x	assert_reactive(module_fd)
177	105x	checkmate::assert_class(slices_global, ".slicesGlobal")
178
179	105x	moduleServer(id, function(input, output, session) {
180	105x	logger::log_debug("srv_module_filter_manager initializing for module: { id }.")
181		# Track filter global and local states.
182	105x	slices_global_module <- reactive({
183	189x	slices_global$slices_get(module_label = id)
184		})
185	105x	slices_module <- reactive(req(module_fd())$get_filter_state())
186
187	105x	module_fd_previous <- reactiveVal(NULL)
188
189		# Set (reactively) available filters for the module.
190	105x	obs1 <- observeEvent(module_fd(), priority = 1, {
191	86x	logger::log_debug("srv_module_filter_manager@1 setting initial slices for module: { id }.")
192		# Filters relevant for the module in module-specific app.
193	86x	slices <- slices_global_module()
194
195		# Clean up previous filter states and refresh cache of previous module_fd with current
196	3x	if (!is.null(module_fd_previous())) module_fd_previous()$finalize()
197	86x	module_fd_previous(module_fd())
198
199		# Setting filter states from slices_global:
200		# 1. when app initializes slices_global set to initial filters (specified by app developer)
201		# 2. when data reinitializes slices_global reflects latest filter states
202
203	86x	module_fd()$set_filter_state(slices)
204
205		# irrelevant filters are discarded in FilteredData$set_available_teal_slices
206		# it means we don't need to subset slices_global$all_slices() from filters refering to irrelevant datasets
207	86x	module_fd()$set_available_teal_slices(slices_global$all_slices)
208
209		# this needed in filter_manager_srv
210	86x	slices_global$module_slices_api_set(
211	86x	id,
212	86x	list(
213	86x	get_available_teal_slices = module_fd()$get_available_teal_slices(),
214	86x	set_filter_state = module_fd()$set_filter_state, # for testing purpose
215	86x	get_filter_state = module_fd()$get_filter_state # for testing purpose
216		)
217		)
218		})
219
220		# Update global state and mapping matrix when module filters change.
221	105x	obs2 <- observeEvent(slices_module(), priority = 0, {
222	108x	this_slices <- slices_module()
223	108x	slices_global$slices_append(this_slices) # append new slices to the all_slices list
224	108x	mapping_elem <- setNames(nm = id, list(vapply(this_slices, `[[`, character(1L), "id")))
225	108x	slices_global$slices_active(mapping_elem)
226		})
227
228	105x	obs3 <- observeEvent(slices_global_module(), {
229	128x	global_vs_module <- setdiff_teal_slices(slices_global_module(), slices_module())
230	128x	module_vs_global <- setdiff_teal_slices(slices_module(), slices_global_module())
231	119x	if (length(global_vs_module) \|\| length(module_vs_global)) {
232		# Comment: (Nota Bene) Normally new filters for a module are added through module-filter-panel, and slices
233		# global are updated automatically so slices_module -> slices_global_module are equal.
234		# this if is valid only when a change is made on the global level so the change needs to be propagated down
235		# to the module (for example through snapshot manager). If it happens both slices are different
236	13x	logger::log_debug("srv_module_filter_manager@3 (N.B.) global state has changed for a module:{ id }.")
237	13x	module_fd()$clear_filter_states()
238	13x	module_fd()$set_filter_state(slices_global_module())
239		}
240		})
241
242	105x	slices_module # returned for testing purpose
243		})
244		}
245
246		#' @importFrom shiny reactiveVal reactiveValues
247		methods::setOldClass("reactiveVal")
248		methods::setOldClass("reactivevalues")
249
250		#' @importFrom methods new
251		#' @rdname module_filter_manager
252		.slicesGlobal <- methods::setRefClass(".slicesGlobal", # nolint: object_name.
253		fields = list(
254		all_slices = "reactiveVal",
255		module_slices_api = "reactivevalues"
256		),
257		methods = list(
258		initialize = function(slices = teal_slices(), module_labels) {
259	80x	shiny::isolate({
260	80x	checkmate::assert_class(slices, "teal_slices")
261		# needed on init to not mix "global_filters" with module-specific-slots
262	80x	if (isTRUE(attr(slices, "module_specific"))) {
263	11x	old_mapping <- attr(slices, "mapping")
264	11x	new_mapping <- sapply(module_labels, simplify = FALSE, function(module_label) {
265	20x	unique(unlist(old_mapping[c(module_label, "global_filters")]))
266		})
267	11x	attr(slices, "mapping") <- new_mapping
268		}
269	80x	.self$all_slices <<- shiny::reactiveVal(slices)
270	80x	.self$module_slices_api <<- shiny::reactiveValues()
271	80x	.self$slices_append(slices)
272	80x	.self$slices_active(attr(slices, "mapping"))
273	80x	invisible(.self)
274		})
275		},
276		is_module_specific = function() {
277	277x	isTRUE(attr(.self$all_slices(), "module_specific"))
278		},
279		module_slices_api_set = function(module_label, functions_list) {
280	86x	shiny::isolate({
281	86x	if (!.self$is_module_specific()) {
282	70x	module_label <- "global_filters"
283		}
284	86x	if (!identical(.self$module_slices_api[[module_label]], functions_list)) {
285	86x	.self$module_slices_api[[module_label]] <- functions_list
286		}
287	86x	invisible(.self)
288		})
289		},
290		slices_deactivate_all = function(module_label) {
291	!	shiny::isolate({
292	!	new_slices <- .self$all_slices()
293	!	old_mapping <- attr(new_slices, "mapping")
294
295	!	new_mapping <- if (.self$is_module_specific()) {
296	!	new_module_mapping <- setNames(nm = module_label, list(character(0)))
297	!	modifyList(old_mapping, new_module_mapping)
298	!	} else if (missing(module_label)) {
299	!	lapply(
300	!	attr(.self$all_slices(), "mapping"),
301	!	function(x) character(0)
302		)
303		} else {
304	!	old_mapping[[module_label]] <- character(0)
305	!	old_mapping
306		}
307
308	!	if (!identical(new_mapping, old_mapping)) {
309	!	logger::log_debug(".slicesGlobal@slices_deactivate_all: deactivating all slices.")
310	!	attr(new_slices, "mapping") <- new_mapping
311	!	.self$all_slices(new_slices)
312		}
313	!	invisible(.self)
314		})
315		},
316		slices_active = function(mapping_elem) {
317	191x	shiny::isolate({
318	191x	if (.self$is_module_specific()) {
319	36x	new_mapping <- modifyList(attr(.self$all_slices(), "mapping"), mapping_elem)
320		} else {
321	155x	new_mapping <- setNames(nm = "global_filters", list(unique(unlist(mapping_elem))))
322		}
323
324	191x	if (!identical(new_mapping, attr(.self$all_slices(), "mapping"))) {
325	134x	mapping_modules <- toString(names(new_mapping))
326	134x	logger::log_debug(".slicesGlobal@slices_active: changing mapping for module(s): { mapping_modules }.")
327	134x	new_slices <- .self$all_slices()
328	134x	attr(new_slices, "mapping") <- new_mapping
329	134x	.self$all_slices(new_slices)
330		}
331
332	191x	invisible(.self)
333		})
334		},
335		# - only new filters are appended to the $all_slices
336		# - mapping is not updated here
337		slices_append = function(slices, activate = FALSE) {
338	191x	shiny::isolate({
339	191x	if (!is.teal_slices(slices)) {
340	!	slices <- as.teal_slices(slices)
341		}
342
343		# to make sure that we don't unnecessary trigger $all_slices <reactiveVal>
344	191x	new_slices <- setdiff_teal_slices(slices, .self$all_slices())
345	191x	old_mapping <- attr(.self$all_slices(), "mapping")
346	191x	if (length(new_slices)) {
347	6x	new_ids <- vapply(new_slices, `[[`, character(1L), "id")
348	6x	logger::log_debug(".slicesGlobal@slices_append: appending new slice(s): { new_ids }.")
349	6x	slices_ids <- vapply(.self$all_slices(), `[[`, character(1L), "id")
350	6x	lapply(new_slices, function(slice) {
351		# In case the new state has the same id as an existing one, add a suffix
352	6x	if (slice$id %in% slices_ids) {
353	1x	slice$id <- utils::tail(make.unique(c(slices_ids, slice$id), sep = "_"), 1)
354		}
355		})
356
357	6x	new_slices_all <- c(.self$all_slices(), new_slices)
358	6x	attr(new_slices_all, "mapping") <- old_mapping
359	6x	.self$all_slices(new_slices_all)
360		}
361
362	191x	invisible(.self)
363		})
364		},
365		slices_get = function(module_label) {
366	283x	if (missing(module_label)) {
367	!	.self$all_slices()
368		} else {
369	283x	module_ids <- unlist(attr(.self$all_slices(), "mapping")[c(module_label, "global_filters")])
370	283x	Filter(
371	283x	function(slice) slice$id %in% module_ids,
372	283x	.self$all_slices()
373		)
374		}
375		},
376		slices_set = function(slices) {
377	7x	shiny::isolate({
378	7x	if (!is.teal_slices(slices)) {
379	!	slices <- as.teal_slices(slices)
380		}
381	7x	.self$all_slices(slices)
382	7x	invisible(.self)
383		})
384		},
385		show = function() {
386	!	shiny::isolate(print(.self$all_slices()))
387	!	invisible(.self)
388		}
389		)
390		)
391		# todo: prevent any teal_slices attribute except mapping

1		#' Calls all `modules`
2		#'
3		#' On the UI side each `teal_modules` is translated to a `tabsetPanel` and each `teal_module` is a
4		#' `tabPanel`. Both, UI and server are called recursively so that each tab is a separate module and
5		#' reflect nested structure of `modules` argument.
6		#'
7		#' @name module_teal_module
8		#'
9		#' @inheritParams module_teal
10		#'
11		#' @param data_rv (`reactive` returning `teal_data`)
12		#'
13		#' @param slices_global (`reactiveVal` returning `modules_teal_slices`)
14		#' see [`module_filter_manager`]
15		#'
16		#' @param depth (`integer(1)`)
17		#' number which helps to determine depth of the modules nesting.
18		#'
19		#' @param datasets (`reactive` returning `FilteredData` or `NULL`)
20		#' When `datasets` is passed from the parent module (`srv_teal`) then `dataset` is a singleton
21		#' which implies in filter-panel to be "global". When `NULL` then filter-panel is "module-specific".
22		#'
23		#' @param data_load_status (`reactive` returning `character`)
24		#' Determines action dependent on a data loading status:
25		#' - `"ok"` when `teal_data` is returned from the data loading.
26		#' - `"teal_data_module failed"` when [teal_data_module()] didn't return `teal_data`. Disables tabs buttons.
27		#' - `"external failed"` when a `reactive` passed to `srv_teal(data)` didn't return `teal_data`. Hides the whole tab
28		#' panel.
29		#'
30		#' @return
31		#' output of currently active module.
32		#' - `srv_teal_module.teal_module` returns `reactiveVal` containing output of the called module.
33		#' - `srv_teal_module.teal_modules` returns output of module selected by `input$active_tab`.
34		#'
35		#' @keywords internal
36		NULL
37
38		#' @rdname module_teal_module
39		ui_teal_module <- function(id, modules, depth = 0L) {
40	!	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module", "shiny.tag"))
41	!	checkmate::assert_count(depth)
42	!	UseMethod("ui_teal_module", modules)
43		}
44
45		#' @rdname module_teal_module
46		#' @export
47		ui_teal_module.default <- function(id, modules, depth = 0L) {
48	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
49		}
50
51		#' @rdname module_teal_module
52		#' @export
53		ui_teal_module.teal_modules <- function(id, modules, depth = 0L) {
54	!	ns <- NS(id)
55	!	tags$div(
56	!	id = ns("wrapper"),
57	!	do.call(
58	!	tabsetPanel,
59	!	c(
60		# by giving an id, we can reactively respond to tab changes
61	!	list(
62	!	id = ns("active_tab"),
63	!	type = if (modules$label == "root") "pills" else "tabs"
64		),
65	!	lapply(
66	!	names(modules$children),
67	!	function(module_id) {
68	!	module_label <- modules$children[[module_id]]$label
69	!	if (is.null(module_label)) {
70	!	module_label <- icon("fas fa-database")
71		}
72	!	tabPanel(
73	!	title = module_label,
74	!	value = module_id, # when clicked this tab value changes input$<tabset panel id>
75	!	ui_teal_module(
76	!	id = ns(module_id),
77	!	modules = modules$children[[module_id]],
78	!	depth = depth + 1L
79		)
80		)
81		}
82		)
83		)
84		)
85		)
86		}
87
88		#' @rdname module_teal_module
89		#' @export
90		ui_teal_module.teal_module <- function(id, modules, depth = 0L) {
91	!	ns <- NS(id)
92	!	args <- c(list(id = ns("module")), modules$ui_args)
93
94	!	ui_teal <- tagList(
95	!	div(
96	!	id = ns("validate_datanames"),
97	!	ui_validate_reactive_teal_data(ns("validate_datanames"))
98		),
99	!	shinyjs::hidden(
100	!	tags$div(
101	!	id = ns("transformer_failure_info"),
102	!	class = "teal_validated",
103	!	div(
104	!	class = "teal-output-warning",
105	!	"One of transformers failed. Please fix and continue."
106		)
107		)
108		),
109	!	tags$div(
110	!	id = ns("teal_module_ui"),
111	!	do.call(modules$ui, args)
112		)
113		)
114
115	!	div(
116	!	id = id,
117	!	class = "teal_module",
118	!	uiOutput(ns("data_reactive"), inline = TRUE),
119	!	tagList(
120	!	if (depth >= 2L) tags$div(style = "mt-6"),
121	!	if (!is.null(modules$datanames)) {
122	!	fluidRow(
123	!	column(width = 9, ui_teal, class = "teal_primary_col"),
124	!	column(
125	!	width = 3,
126	!	ui_data_summary(ns("data_summary")),
127	!	ui_filter_data(ns("filter_panel")),
128	!	ui_transform_data(ns("data_transform"), transformers = modules$transformers, class = "well"),
129	!	class = "teal_secondary_col"
130		)
131		)
132		} else {
133	!	div(
134	!	div(
135	!	class = "teal_validated",
136	!	uiOutput(ns("data_input_error"))
137		),
138	!	ui_teal
139		)
140		}
141		)
142		)
143		}
144
145		#' @rdname module_teal_module
146		srv_teal_module <- function(id,
147		data_rv,
148		modules,
149		datasets = NULL,
150		slices_global,
151		reporter = teal.reporter::Reporter$new(),
152		data_load_status = reactive("ok"),
153		is_active = reactive(TRUE)) {
154	185x	checkmate::assert_string(id)
155	185x	assert_reactive(data_rv)
156	185x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
157	185x	assert_reactive(datasets, null.ok = TRUE)
158	185x	checkmate::assert_class(slices_global, ".slicesGlobal")
159	185x	checkmate::assert_class(reporter, "Reporter")
160	185x	assert_reactive(data_load_status)
161	185x	UseMethod("srv_teal_module", modules)
162		}
163
164		#' @rdname module_teal_module
165		#' @export
166		srv_teal_module.default <- function(id,
167		data_rv,
168		modules,
169		datasets = NULL,
170		slices_global,
171		reporter = teal.reporter::Reporter$new(),
172		data_load_status = reactive("ok"),
173		is_active = reactive(TRUE)) {
174	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
175		}
176
177		#' @rdname module_teal_module
178		#' @export
179		srv_teal_module.teal_modules <- function(id,
180		data_rv,
181		modules,
182		datasets = NULL,
183		slices_global,
184		reporter = teal.reporter::Reporter$new(),
185		data_load_status = reactive("ok"),
186		is_active = reactive(TRUE)) {
187	80x	moduleServer(id = id, module = function(input, output, session) {
188	80x	logger::log_debug("srv_teal_module.teal_modules initializing the module { deparse1(modules$label) }.")
189
190	80x	observeEvent(data_load_status(), {
191	73x	tabs_selector <- sprintf("#%s li a", session$ns("active_tab"))
192	73x	if (identical(data_load_status(), "ok")) {
193	68x	logger::log_debug("srv_teal_module@1 enabling modules tabs.")
194	68x	shinyjs::show("wrapper")
195	68x	shinyjs::enable(selector = tabs_selector)
196	5x	} else if (identical(data_load_status(), "teal_data_module failed")) {
197	5x	logger::log_debug("srv_teal_module@1 disabling modules tabs.")
198	5x	shinyjs::disable(selector = tabs_selector)
199	!	} else if (identical(data_load_status(), "external failed")) {
200	!	logger::log_debug("srv_teal_module@1 hiding modules tabs.")
201	!	shinyjs::hide("wrapper")
202		}
203		})
204
205	80x	modules_output <- sapply(
206	80x	names(modules$children),
207	80x	function(module_id) {
208	105x	srv_teal_module(
209	105x	id = module_id,
210	105x	data_rv = data_rv,
211	105x	modules = modules$children[[module_id]],
212	105x	datasets = datasets,
213	105x	slices_global = slices_global,
214	105x	reporter = reporter,
215	105x	is_active = reactive(
216	105x	is_active() &&
217	105x	input$active_tab == module_id &&
218	105x	identical(data_load_status(), "ok")
219		)
220		)
221		},
222	80x	simplify = FALSE
223		)
224
225	80x	modules_output
226		})
227		}
228
229		#' @rdname module_teal_module
230		#' @export
231		srv_teal_module.teal_module <- function(id,
232		data_rv,
233		modules,
234		datasets = NULL,
235		slices_global,
236		reporter = teal.reporter::Reporter$new(),
237		data_load_status = reactive("ok"),
238		is_active = reactive(TRUE)) {
239	105x	logger::log_debug("srv_teal_module.teal_module initializing the module: { deparse1(modules$label) }.")
240	105x	moduleServer(id = id, module = function(input, output, session) {
241	105x	module_out <- reactiveVal()
242
243	105x	active_datanames <- reactive({
244	82x	.resolve_module_datanames(data = data_rv(), modules = modules)
245		})
246	105x	if (is.null(datasets)) {
247	20x	datasets <- eventReactive(data_rv(), {
248	16x	req(inherits(data_rv(), "teal_data"))
249	16x	logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
250	16x	teal_data_to_filtered_data(data_rv(), datanames = active_datanames())
251		})
252		}
253
254		# manage module filters on the module level
255		# important:
256		# filter_manager_module_srv needs to be called before filter_panel_srv
257		# Because available_teal_slices is used in FilteredData$srv_available_slices (via srv_filter_panel)
258		# and if it is not set, then it won't be available in the srv_filter_panel
259	105x	srv_module_filter_manager(modules$label, module_fd = datasets, slices_global = slices_global)
260
261	105x	call_once_when(is_active(), {
262	79x	filtered_teal_data <- srv_filter_data(
263	79x	"filter_panel",
264	79x	datasets = datasets,
265	79x	active_datanames = active_datanames,
266	79x	data_rv = data_rv,
267	79x	is_active = is_active
268		)
269	79x	is_transformer_failed <- reactiveValues()
270	79x	transformed_teal_data <- srv_transform_data(
271	79x	"data_transform",
272	79x	data = filtered_teal_data,
273	79x	transformers = modules$transformers,
274	79x	modules = modules,
275	79x	is_transformer_failed = is_transformer_failed
276		)
277	79x	any_transformer_failed <- reactive({
278	79x	any(unlist(reactiveValuesToList(is_transformer_failed)))
279		})
280
281	79x	observeEvent(any_transformer_failed(), {
282	79x	if (isTRUE(any_transformer_failed())) {
283	6x	shinyjs::hide("teal_module_ui")
284	6x	shinyjs::hide("validate_datanames")
285	6x	shinyjs::show("transformer_failure_info")
286		} else {
287	73x	shinyjs::show("teal_module_ui")
288	73x	shinyjs::show("validate_datanames")
289	73x	shinyjs::hide("transformer_failure_info")
290		}
291		})
292
293	79x	module_teal_data <- reactive({
294	87x	req(inherits(transformed_teal_data(), "teal_data"))
295	81x	all_teal_data <- transformed_teal_data()
296	81x	module_datanames <- .resolve_module_datanames(data = all_teal_data, modules = modules)
297	81x	.subset_teal_data(all_teal_data, module_datanames)
298		})
299
300	79x	srv_validate_reactive_teal_data(
301	79x	"validate_datanames",
302	79x	data = module_teal_data,
303	79x	modules = modules
304		)
305
306	79x	summary_table <- srv_data_summary("data_summary", module_teal_data)
307
308		# Call modules.
309	79x	if (!inherits(modules, "teal_module_previewer")) {
310	79x	obs_module <- call_once_when(
311	79x	!is.null(module_teal_data()),
312	79x	ignoreNULL = TRUE,
313	79x	handlerExpr = {
314	73x	module_out(.call_teal_module(modules, datasets, module_teal_data, reporter))
315		}
316		)
317		} else {
318		# Report previewer must be initiated on app start for report cards to be included in bookmarks.
319		# When previewer is delayed, cards are bookmarked only if previewer has been initiated (visited).
320	!	module_out(.call_teal_module(modules, datasets, module_teal_data, reporter))
321		}
322
323		# todo: (feature request) add a ReporterCard to the reporter as an output from the teal_module
324		# how to determine if module returns a ReporterCard so that reportPreviewer is needed?
325		# Should we insertUI of the ReportPreviewer then?
326		# What about attr(module, "reportable") - similar to attr(module, "bookmarkable")
327	79x	if ("report" %in% names(module_out)) {
328		# (reactively) add card to the reporter
329		}
330		})
331
332	105x	module_out
333		})
334		}
335
336		# This function calls a module server function.
337		.call_teal_module <- function(modules, datasets, filtered_teal_data, reporter) {
338		# collect arguments to run teal_module
339	73x	args <- c(list(id = "module"), modules$server_args)
340	73x	if (is_arg_used(modules$server, "reporter")) {
341	1x	args <- c(args, list(reporter = reporter))
342		}
343
344	73x	if (is_arg_used(modules$server, "datasets")) {
345	1x	args <- c(args, datasets = datasets())
346	1x	warning("datasets argument is not reactive and therefore it won't be updated when data is refreshed.")
347		}
348
349	73x	if (is_arg_used(modules$server, "data")) {
350	69x	args <- c(args, data = list(filtered_teal_data))
351		}
352
353	73x	if (is_arg_used(modules$server, "filter_panel_api")) {
354	1x	args <- c(args, filter_panel_api = teal.slice::FilterPanelAPI$new(datasets()))
355		}
356
357	73x	if (is_arg_used(modules$server, "id")) {
358	73x	do.call(modules$server, args)
359		} else {
360	!	do.call(callModule, c(args, list(module = modules$server)))
361		}
362		}
363
364		.resolve_module_datanames <- function(data, modules) {
365	163x	stopifnot("data_rv must be teal_data object." = inherits(data, "teal_data"))
366	163x	if (is.null(modules$datanames) \|\| identical(modules$datanames, "all")) {
367	131x	.topologically_sort_datanames(ls(teal.code::get_env(data)), teal.data::join_keys(data))
368		} else {
369	32x	intersect(
370	32x	.include_parent_datanames(modules$datanames, teal.data::join_keys(data)),
371	32x	ls(teal.code::get_env(data))
372		)
373		}
374		}
375
376		#' Calls expression when condition is met
377		#'
378		#' Function postpones `handlerExpr` to the moment when `eventExpr` (condition) returns `TRUE`,
379		#' otherwise nothing happens.
380		#' @param eventExpr A (quoted or unquoted) logical expression that represents the event;
381		#' this can be a simple reactive value like input$click, a call to a reactive expression
382		#' like dataset(), or even a complex expression inside curly braces.
383		#' @param ... additional arguments passed to `observeEvent` with the exception of `eventExpr` that is not allowed.
384		#' @inheritParams shiny::observeEvent
385		#'
386		#' @return An observer.
387		#'
388		#' @keywords internal
389		call_once_when <- function(eventExpr, # nolint: object_name.
390		handlerExpr, # nolint: object_name.
391		event.env = parent.frame(), # nolint: object_name.
392		handler.env = parent.frame(), # nolint: object_name.
393		...) {
394	184x	event_quo <- rlang::new_quosure(substitute(eventExpr), env = event.env)
395	184x	handler_quo <- rlang::new_quosure(substitute(handlerExpr), env = handler.env)
396
397		# When `condExpr` is TRUE, then `handlerExpr` is evaluated once.
398	184x	activator <- reactive({
399	184x	if (isTRUE(rlang::eval_tidy(event_quo))) {
400	152x	TRUE
401		}
402		})
403
404	184x	observeEvent(
405	184x	eventExpr = activator(),
406	184x	once = TRUE,
407	184x	handlerExpr = rlang::eval_tidy(handler_quo),
408		...
409		)
410		}

1		#' Send input validation messages to output
2		#'
3		#' Captures messages from `InputValidator` objects and collates them
4		#' into one message passed to `validate`.
5		#'
6		#' `shiny::validate` is used to withhold rendering of an output element until
7		#' certain conditions are met and to print a validation message in place
8		#' of the output element.
9		#' `shinyvalidate::InputValidator` allows to validate input elements
10		#' and to display specific messages in their respective input widgets.
11		#' `validate_inputs` provides a hybrid solution.
12		#' Given an `InputValidator` object, messages corresponding to inputs that fail validation
13		#' are extracted and placed in one validation message that is passed to a `validate`/`need` call.
14		#' This way the input `validator` messages are repeated in the output.
15		#'
16		#' The `...` argument accepts any number of `InputValidator` objects
17		#' or a nested list of such objects.
18		#' If `validators` are passed directly, all their messages are printed together
19		#' under one (optional) header message specified by `header`. If a list is passed,
20		#' messages are grouped by `validator`. The list's names are used as headers
21		#' for their respective message groups.
22		#' If neither of the nested list elements is named, a header message is taken from `header`.
23		#'
24		#' @param ... either any number of `InputValidator` objects
25		#' or an optionally named, possibly nested `list` of `InputValidator`
26		#' objects, see `Details`
27		#' @param header (`character(1)`) generic validation message; set to NULL to omit
28		#'
29		#' @return
30		#' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails.
31		#'
32		#' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`]
33		#'
34		#' @examplesIf require("shinyvalidate")
35		#' library(shiny)
36		#' library(shinyvalidate)
37		#'
38		#' ui <- fluidPage(
39		#' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
40		#' sidebarLayout(
41		#' sidebarPanel(
42		#' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
43		#' selectInput("number", "select a number:", 1:6),
44		#' tags$br(),
45		#' selectInput("color", "select a color:",
46		#' c("black", "indianred2", "springgreen2", "cornflowerblue"),
47		#' multiple = TRUE
48		#' ),
49		#' sliderInput("size", "select point size:",
50		#' min = 0.1, max = 4, value = 0.25
51		#' )
52		#' ),
53		#' mainPanel(plotOutput("plot"))
54		#' )
55		#' )
56		#'
57		#' server <- function(input, output) {
58		#' # set up input validation
59		#' iv <- InputValidator$new()
60		#' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
61		#' iv$add_rule("number", function(x) {
62		#' if (as.integer(x) %% 2L == 1L) "choose an even number"
63		#' })
64		#' iv$enable()
65		#' # more input validation
66		#' iv_par <- InputValidator$new()
67		#' iv_par$add_rule("color", sv_required(message = "choose a color"))
68		#' iv_par$add_rule("color", function(x) {
69		#' if (length(x) > 1L) "choose only one color"
70		#' })
71		#' iv_par$add_rule(
72		#' "size",
73		#' sv_between(
74		#' left = 0.5, right = 3,
75		#' message_fmt = "choose a value between {left} and {right}"
76		#' )
77		#' )
78		#' iv_par$enable()
79		#'
80		#' output$plot <- renderPlot({
81		#' # validate output
82		#' switch(input[["method"]],
83		#' "sequential" = {
84		#' validate_inputs(iv)
85		#' validate_inputs(iv_par, header = "Set proper graphical parameters")
86		#' },
87		#' "combined" = validate_inputs(iv, iv_par),
88		#' "grouped" = validate_inputs(list(
89		#' "Some inputs require attention" = iv,
90		#' "Set proper graphical parameters" = iv_par
91		#' ))
92		#' )
93		#'
94		#' plot(faithful$eruptions ~ faithful$waiting,
95		#' las = 1, pch = 16,
96		#' col = input[["color"]], cex = input[["size"]]
97		#' )
98		#' })
99		#' }
100		#'
101		#' if (interactive()) {
102		#' shinyApp(ui, server)
103		#' }
104		#'
105		#' @export
106		#'
107		validate_inputs <- function(..., header = "Some inputs require attention") {
108	36x	dots <- list(...)
109	2x	if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
110
111	34x	messages <- extract_validator(dots, header)
112	34x	failings <- if (!any_names(dots)) {
113	29x	add_header(messages, header)
114		} else {
115	5x	unlist(messages)
116		}
117
118	34x	shiny::validate(shiny::need(is.null(failings), failings))
119		}
120
121		### internal functions
122
123		#' @noRd
124		#' @keywords internal
125		# recursive object type test
126		# returns logical of length 1
127		is_validators <- function(x) {
128	118x	all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))
129		}
130
131		#' @noRd
132		#' @keywords internal
133		# test if an InputValidator object is enabled
134		# returns logical of length 1
135		# official method requested at https://github.com/rstudio/shinyvalidate/issues/64
136		validator_enabled <- function(x) {
137	49x	x$.__enclos_env__$private$enabled
138		}
139
140		#' Recursively extract messages from validator list
141		#' @return A character vector or a list of character vectors, possibly nested and named.
142		#' @noRd
143		#' @keywords internal
144		extract_validator <- function(iv, header) {
145	113x	if (inherits(iv, "InputValidator")) {
146	49x	add_header(gather_messages(iv), header)
147		} else {
148	58x	if (is.null(names(iv))) names(iv) <- rep("", length(iv))
149	64x	mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)
150		}
151		}
152
153		#' Collate failing messages from validator.
154		#' @return `list`
155		#' @noRd
156		#' @keywords internal
157		gather_messages <- function(iv) {
158	49x	if (validator_enabled(iv)) {
159	46x	status <- iv$validate()
160	46x	failing_inputs <- Filter(Negate(is.null), status)
161	46x	unique(lapply(failing_inputs, function(x) x[["message"]]))
162		} else {
163	3x	warning("Validator is disabled and will be omitted.")
164	3x	list()
165		}
166		}
167
168		#' Add optional header to failing messages
169		#' @noRd
170		#' @keywords internal
171		add_header <- function(messages, header = "") {
172	78x	ans <- unlist(messages)
173	78x	if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
174	31x	ans <- c(paste0(header, "\n"), ans, "\n")
175		}
176	78x	ans
177		}
178
179		#' Recursively check if the object contains a named list
180		#' @noRd
181		#' @keywords internal
182		any_names <- function(x) {
183	103x	any(
184	103x	if (is.list(x)) {
185	58x	if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))
186		} else {
187	40x	FALSE
188		}
189		)
190		}

1		#' `teal` main module
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#' Module to create a `teal` app. This module can be called directly instead of [init()] and
6		#' included in your custom application. Please note that [init()] adds `reporter_previewer_module`
7		#' automatically, which is not a case when calling `ui/srv_teal` directly.
8		#'
9		#' @details
10		#'
11		#' Module is responsible for creating the main `shiny` app layout and initializing all the necessary
12		#' components. This module establishes reactive connection between the input `data` and every other
13		#' component in the app. Reactive change of the `data` passed as an argument, reloads the app and
14		#' possibly keeps all input settings the same so the user can continue where one left off.
15		#'
16		#' ## data flow in `teal` application
17		#'
18		#' This module supports multiple data inputs but eventually, they are all converted to `reactive`
19		#' returning `teal_data` in this module. On this `reactive teal_data` object several actions are
20		#' performed:
21		#' - data loading in [`module_init_data`]
22		#' - data filtering in [`module_filter_data`]
23		#' - data transformation in [`module_transform_data`]
24		#'
25		#' ## Fallback on failure
26		#'
27		#' `teal` is designed in such way that app will never crash if the error is introduced in any
28		#' custom `shiny` module provided by app developer (e.g. [teal_data_module()], [teal_transform_module()]).
29		#' If any module returns a failing object, the app will halt the evaluation and display a warning message.
30		#' App user should always have a chance to fix the improper input and continue without restarting the session.
31		#'
32		#' @rdname module_teal
33		#' @name module_teal
34		#'
35		#' @inheritParams module_init_data
36		#' @inheritParams init
37		#'
38		#' @return `NULL` invisibly
39		NULL
40
41		#' @rdname module_teal
42		#' @export
43		ui_teal <- function(id,
44		modules,
45		title = build_app_title(),
46		header = tags$p(),
47		footer = tags$p()) {
48	!	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
49	!	checkmate::assert(
50	!	.var.name = "title",
51	!	checkmate::check_string(title),
52	!	checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
53		)
54	!	checkmate::assert(
55	!	.var.name = "header",
56	!	checkmate::check_string(header),
57	!	checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
58		)
59	!	checkmate::assert(
60	!	.var.name = "footer",
61	!	checkmate::check_string(footer),
62	!	checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
63		)
64
65	!	if (is.character(title)) {
66	!	title <- build_app_title(title)
67		} else {
68	!	validate_app_title_tag(title)
69		}
70
71	!	if (checkmate::test_string(header)) {
72	!	header <- tags$p(header)
73		}
74
75	!	if (checkmate::test_string(footer)) {
76	!	footer <- tags$p(footer)
77		}
78
79	!	ns <- NS(id)
80
81		# show busy icon when `shiny` session is busy computing stuff
82		# based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length.
83	!	shiny_busy_message_panel <- conditionalPanel(
84	!	condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
85	!	tags$div(
86	!	icon("arrows-rotate", class = "fa-spin", prefer_type = "solid"),
87	!	"Computing ...",
88		# CSS defined in `custom.css`
89	!	class = "shinybusymessage"
90		)
91		)
92
93	!	fluidPage(
94	!	id = id,
95	!	title = title,
96	!	theme = get_teal_bs_theme(),
97	!	include_teal_css_js(),
98	!	tags$header(header),
99	!	tags$hr(class = "my-2"),
100	!	shiny_busy_message_panel,
101	!	tags$div(
102	!	id = ns("tabpanel_wrapper"),
103	!	class = "teal-body",
104	!	ui_teal_module(id = ns("teal_modules"), modules = modules)
105		),
106	!	tags$div(
107	!	id = ns("options_buttons"),
108	!	style = "position: absolute; right: 10px;",
109	!	ui_bookmark_panel(ns("bookmark_manager"), modules),
110	!	tags$button(
111	!	class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger
112	!	href = "javascript:void(0)",
113	!	onclick = sprintf("toggleFilterPanel('%s');", ns("tabpanel_wrapper")),
114	!	title = "Toggle filter panel",
115	!	icon("fas fa-bars")
116		),
117	!	ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
118	!	ui_filter_manager_panel(ns("filter_manager_panel"))
119		),
120	!	tags$script(
121	!	HTML(
122	!	sprintf(
123		"
124	!	$(document).ready(function() {
125	!	$('#%s').appendTo('#%s');
126		});
127		",
128	!	ns("options_buttons"),
129	!	ns("teal_modules-active_tab")
130		)
131		)
132		),
133	!	tags$hr(),
134	!	tags$footer(
135	!	tags$div(
136	!	footer,
137	!	teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
138	!	br(),
139	!	ui_teal_lockfile(ns("lockfile")),
140	!	textOutput(ns("identifier"))
141		)
142		)
143		)
144		}
145
146		#' @rdname module_teal
147		#' @export
148		srv_teal <- function(id, data, modules, filter = teal_slices()) {
149	82x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
150	82x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
151	81x	checkmate::assert_class(modules, "teal_modules")
152	81x	checkmate::assert_class(filter, "teal_slices")
153
154	81x	moduleServer(id, function(input, output, session) {
155	81x	logger::log_debug("srv_teal initializing.")
156
157	81x	if (getOption("teal.show_js_log", default = FALSE)) {
158	!	shinyjs::showLog()
159		}
160
161	81x	srv_teal_lockfile("lockfile")
162
163	81x	output$identifier <- renderText(
164	81x	paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
165		)
166
167	81x	teal.widgets::verbatim_popup_srv(
168	81x	"sessionInfo",
169	81x	verbatim_content = utils::capture.output(utils::sessionInfo()),
170	81x	title = "SessionInfo"
171		)
172
173		# `JavaScript` code
174	81x	run_js_files(files = "init.js")
175
176		# set timezone in shiny app
177		# timezone is set in the early beginning so it will be available also
178		# for `DDL` and all shiny modules
179	81x	get_client_timezone(session$ns)
180	81x	observeEvent(
181	81x	eventExpr = input$timezone,
182	81x	once = TRUE,
183	81x	handlerExpr = {
184	!	session$userData$timezone <- input$timezone
185	!	logger::log_debug("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
186		}
187		)
188
189	81x	data_pulled <- srv_init_data("data", data = data)
190	80x	data_validated <- srv_validate_reactive_teal_data(
191	80x	"validate",
192	80x	data = data_pulled,
193	80x	modules = modules,
194	80x	validate_shiny_silent_error = FALSE
195		)
196	80x	data_rv <- reactive({
197	138x	req(inherits(data_validated(), "teal_data"))
198	68x	is_filter_ok <- check_filter_datanames(filter, ls(teal.code::get_env(data_validated())))
199	68x	if (!isTRUE(is_filter_ok)) {
200	2x	showNotification(
201	2x	"Some filters were not applied because of incompatibility with data. Contact app developer.",
202	2x	type = "warning",
203	2x	duration = 10
204		)
205	2x	warning(is_filter_ok)
206		}
207	68x	.add_signature_to_data(data_validated())
208		})
209
210	80x	data_load_status <- reactive({
211	73x	if (inherits(data_pulled(), "teal_data")) {
212	68x	"ok"
213		# todo: should we hide warnings on top for a data?
214	5x	} else if (inherits(data, "teal_data_module")) {
215	5x	"teal_data_module failed"
216		} else {
217	!	"external failed"
218		}
219		})
220
221	80x	datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
222	69x	eventReactive(data_rv(), {
223	59x	req(inherits(data_rv(), "teal_data"))
224	59x	logger::log_debug("srv_teal@1 initializing FilteredData")
225	59x	teal_data_to_filtered_data(data_rv())
226		})
227		}
228
229	80x	if (inherits(data, "teal_data_module")) {
230	9x	setBookmarkExclude(c("teal_modules-active_tab"))
231	9x	shiny::insertTab(
232	9x	inputId = "teal_modules-active_tab",
233	9x	position = "before",
234	9x	select = TRUE,
235	9x	tabPanel(
236	9x	title = icon("fas fa-database"),
237	9x	value = "teal_data_module",
238	9x	tags$div(
239	9x	ui_init_data(session$ns("data")),
240	9x	ui_validate_reactive_teal_data(session$ns("validate"))
241		)
242		)
243		)
244
245	9x	if (attr(data, "once")) {
246	9x	observeEvent(data_rv(), once = TRUE, {
247	4x	logger::log_debug("srv_teal@2 removing data tab.")
248		# when once = TRUE we pull data once and then remove data tab
249	4x	removeTab("teal_modules-active_tab", target = "teal_data_module")
250		})
251		}
252		} else {
253		# when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)
254	71x	insertUI(
255	71x	selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
256	71x	where = "beforeBegin",
257	71x	ui = tags$div(ui_validate_reactive_teal_data(session$ns("validate")), tags$br())
258		)
259		}
260
261	80x	module_labels <- unlist(module_labels(modules), use.names = FALSE)
262	80x	slices_global <- methods::new(".slicesGlobal", filter, module_labels)
263	80x	modules_output <- srv_teal_module(
264	80x	id = "teal_modules",
265	80x	data_rv = data_rv,
266	80x	datasets = datasets_rv,
267	80x	modules = modules,
268	80x	slices_global = slices_global,
269	80x	data_load_status = data_load_status
270		)
271	80x	mapping_table <- srv_filter_manager_panel("filter_manager_panel", slices_global = slices_global)
272	80x	snapshots <- srv_snapshot_manager_panel("snapshot_manager_panel", slices_global = slices_global)
273	80x	srv_bookmark_panel("bookmark_manager", modules)
274		})
275
276	80x	invisible(NULL)
277		}

1		#' Filter state snapshot management
2		#'
3		#' Capture and restore snapshots of the global (app) filter state.
4		#'
5		#' This module introduces snapshots: stored descriptions of the filter state of the entire application.
6		#' Snapshots allow the user to save the current filter state of the application for later use in the session,
7		#' as well as to save it to file in order to share it with an app developer or other users,
8		#' who in turn can upload it to their own session.
9		#'
10		#' The snapshot manager is accessed with the camera icon in the tabset bar.
11		#' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow.
12		#' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file
13		#' and applies the filter states therein, and clicking the arrow resets initial application state.
14		#' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.
15		#'
16		#' @section Server logic:
17		#' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance
18		#' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`
19		#' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation
20		#' (attributes are maintained).
21		#'
22		#' Snapshots are stored in a `reactiveVal` as a named list.
23		#' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.
24		#'
25		#' For every snapshot except the initial one, a piece of UI is generated that contains
26		#' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.
27		#' The initial snapshot is restored by a separate "reset" button.
28		#' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.
29		#'
30		#' @section Snapshot mechanics:
31		#' When a snapshot is captured, the user is prompted to name it.
32		#' Names are displayed as is but since they are used to create button ids,
33		#' under the hood they are converted to syntactically valid strings.
34		#' New snapshot names are validated so that their valid versions are unique.
35		#' Leading and trailing white space is trimmed.
36		#'
37		#' The module can read the global state of the application from `slices_global` and `mapping_matrix`.
38		#' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.
39		#' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.
40		#' The snapshot contains the `mapping` attribute of the initial application state
41		#' (or one that has been restored), which may not reflect the current one,
42		#' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,
43		#' when passed to the `mapping` argument of [teal_slices()], would result in the current mapping.
44		#' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.
45		#'
46		#' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.
47		#' Then state of all `FilteredData` objects (provided in `datasets`) is cleared
48		#' and set anew according to the `mapping` attribute of the snapshot.
49		#' The snapshot is then set as the current content of `slices_global`.
50		#'
51		#' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,
52		#' and then saved to file with [slices_store()].
53		#'
54		#' When a snapshot is uploaded, it will first be added to storage just like a newly created one,
55		#' and then used to restore app state much like a snapshot taken from storage.
56		#' Upon clicking the upload icon the user will be prompted for a file to upload
57		#' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped)
58		#' and normal naming rules apply. Loading the file yields a `teal_slices` object,
59		#' which is disassembled for storage and used directly for restoring app state.
60		#'
61		#' @section Transferring snapshots:
62		#' Snapshots uploaded from disk should only be used in the same application they come from,
63		#' _i.e._ an application that uses the same data and the same modules.
64		#' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of
65		#' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that
66		#' of the current app state and only if the match is the snapshot admitted to the session.
67		#'
68		#' @section Bookmarks:
69		#' An `onBookmark` callback creates a snapshot of the current filter state.
70		#' This is done on the app session, not the module session.
71		#' (The snapshot will be retrieved by `module_teal` in order to set initial app state in a restored app.)
72		#' Then that snapshot, and the previous snapshot history are dumped into the `values.rds` file in `<bookmark_dir>`.
73		#'
74		#' @param id (`character(1)`) `shiny` module instance id.
75		#' @param slices_global (`reactiveVal`) that contains a `teal_slices` object
76		#' containing all `teal_slice`s existing in the app, both active and inactive.
77		#'
78		#' @return `list` containing the snapshot history, where each element is an unlisted `teal_slices` object.
79		#'
80		#' @name module_snapshot_manager
81		#' @rdname module_snapshot_manager
82		#'
83		#' @author Aleksander Chlebowski
84		#' @keywords internal
85		NULL
86
87		#' @rdname module_snapshot_manager
88		ui_snapshot_manager_panel <- function(id) {
89	!	ns <- NS(id)
90	!	tags$button(
91	!	id = ns("show_snapshot_manager"),
92	!	class = "btn action-button wunder_bar_button",
93	!	title = "View filter mapping",
94	!	suppressMessages(icon("fas fa-camera"))
95		)
96		}
97
98		#' @rdname module_snapshot_manager
99		srv_snapshot_manager_panel <- function(id, slices_global) {
100	80x	moduleServer(id, function(input, output, session) {
101	80x	logger::log_debug("srv_snapshot_manager_panel initializing")
102	80x	setBookmarkExclude(c("show_snapshot_manager"))
103	80x	observeEvent(input$show_snapshot_manager, {
104	!	logger::log_debug("srv_snapshot_manager_panel@1 show_snapshot_manager button has been clicked.")
105	!	showModal(
106	!	modalDialog(
107	!	ui_snapshot_manager(session$ns("module")),
108	!	class = "snapshot_manager_modal",
109	!	size = "m",
110	!	footer = NULL,
111	!	easyClose = TRUE
112		)
113		)
114		})
115	80x	srv_snapshot_manager("module", slices_global = slices_global)
116		})
117		}
118
119		#' @rdname module_snapshot_manager
120		ui_snapshot_manager <- function(id) {
121	!	ns <- NS(id)
122	!	tags$div(
123	!	class = "manager_content",
124	!	tags$div(
125	!	class = "manager_table_row",
126	!	tags$span(tags$b("Snapshot manager")),
127	!	actionLink(ns("snapshot_add"), label = NULL, icon = icon("fas fa-camera"), title = "add snapshot"),
128	!	actionLink(ns("snapshot_load"), label = NULL, icon = icon("fas fa-upload"), title = "upload snapshot"),
129	!	actionLink(ns("snapshot_reset"), label = NULL, icon = icon("fas fa-undo"), title = "reset initial state"),
130	!	NULL
131		),
132	!	uiOutput(ns("snapshot_list"))
133		)
134		}
135
136		#' @rdname module_snapshot_manager
137		srv_snapshot_manager <- function(id, slices_global) {
138	80x	checkmate::assert_character(id)
139
140	80x	moduleServer(id, function(input, output, session) {
141	80x	logger::log_debug("srv_snapshot_manager initializing")
142
143		# Set up bookmarking callbacks ----
144		# Register bookmark exclusions (all buttons and text fields).
145	80x	setBookmarkExclude(c(
146	80x	"snapshot_add", "snapshot_load", "snapshot_reset",
147	80x	"snapshot_name_accept", "snaphot_file_accept",
148	80x	"snapshot_name", "snapshot_file"
149		))
150		# Add snapshot history to bookmark.
151	80x	session$onBookmark(function(state) {
152	!	logger::log_debug("srv_snapshot_manager@onBookmark: storing snapshot and bookmark history")
153	!	state$values$snapshot_history <- snapshot_history() # isolate this?
154		})
155
156	80x	ns <- session$ns
157
158		# Track global filter states ----
159	80x	snapshot_history <- reactiveVal({
160		# Restore directly from bookmarked state, if applicable.
161	80x	restoreValue(
162	80x	ns("snapshot_history"),
163	80x	list("Initial application state" = shiny::isolate(as.list(slices_global$all_slices(), recursive = TRUE)))
164		)
165		})
166
167		# Snapshot current application state ----
168		# Name snaphsot.
169	80x	observeEvent(input$snapshot_add, {
170	!	logger::log_debug("srv_snapshot_manager: snapshot_add button clicked")
171	!	showModal(
172	!	modalDialog(
173	!	textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
174	!	footer = tagList(
175	!	actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("far fa-thumbs-up")),
176	!	modalButton(label = "Cancel", icon = icon("far fa-thumbs-down"))
177		),
178	!	size = "s"
179		)
180		)
181		})
182		# Store snaphsot.
183	80x	observeEvent(input$snapshot_name_accept, {
184	!	logger::log_debug("srv_snapshot_manager: snapshot_name_accept button clicked")
185	!	snapshot_name <- trimws(input$snapshot_name)
186	!	if (identical(snapshot_name, "")) {
187	!	logger::log_debug("srv_snapshot_manager: snapshot name rejected")
188	!	showNotification(
189	!	"Please name the snapshot.",
190	!	type = "message"
191		)
192	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
193	!	} else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
194	!	logger::log_debug("srv_snapshot_manager: snapshot name rejected")
195	!	showNotification(
196	!	"This name is in conflict with other snapshot names. Please choose a different one.",
197	!	type = "message"
198		)
199	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
200		} else {
201	!	logger::log_debug("srv_snapshot_manager: snapshot name accepted, adding snapshot")
202	!	snapshot <- as.list(slices_global$all_slices(), recursive = TRUE)
203	!	snapshot_update <- c(snapshot_history(), list(snapshot))
204	!	names(snapshot_update)[length(snapshot_update)] <- snapshot_name
205	!	snapshot_history(snapshot_update)
206	!	removeModal()
207		# Reopen filter manager modal by clicking button in the main application.
208	!	shinyjs::click(id = "teal-wunder_bar-show_snapshot_manager", asis = TRUE)
209		}
210		})
211
212		# Upload a snapshot file ----
213		# Select file.
214	80x	observeEvent(input$snapshot_load, {
215	!	logger::log_debug("srv_snapshot_manager: snapshot_load button clicked")
216	!	showModal(
217	!	modalDialog(
218	!	fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
219	!	textInput(
220	!	ns("snapshot_name"),
221	!	"Name the snapshot (optional)",
222	!	width = "100%",
223	!	placeholder = "Meaningful, unique name"
224		),
225	!	footer = tagList(
226	!	actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("far fa-thumbs-up")),
227	!	modalButton(label = "Cancel", icon = icon("far fa-thumbs-down"))
228		)
229		)
230		)
231		})
232		# Store new snapshot to list and restore filter states.
233	80x	observeEvent(input$snaphot_file_accept, {
234	!	logger::log_debug("srv_snapshot_manager: snapshot_file_accept button clicked")
235	!	snapshot_name <- trimws(input$snapshot_name)
236	!	if (identical(snapshot_name, "")) {
237	!	logger::log_debug("srv_snapshot_manager: no snapshot name provided, naming after file")
238	!	snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)
239		}
240	!	if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
241	!	logger::log_debug("srv_snapshot_manager: snapshot name rejected")
242	!	showNotification(
243	!	"This name is in conflict with other snapshot names. Please choose a different one.",
244	!	type = "message"
245		)
246	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
247		} else {
248		# Restore snapshot and verify app compatibility.
249	!	logger::log_debug("srv_snapshot_manager: snapshot name accepted, loading snapshot")
250	!	snapshot_state <- try(slices_restore(input$snapshot_file$datapath))
251	!	if (!inherits(snapshot_state, "modules_teal_slices")) {
252	!	logger::log_debug("srv_snapshot_manager: snapshot file corrupt")
253	!	showNotification(
254	!	"File appears to be corrupt.",
255	!	type = "error"
256		)
257	!	} else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global$all_slices(), "app_id"))) {
258	!	logger::log_debug("srv_snapshot_manager: snapshot not compatible with app")
259	!	showNotification(
260	!	"This snapshot file is not compatible with the app and cannot be loaded.",
261	!	type = "warning"
262		)
263		} else {
264		# Add to snapshot history.
265	!	logger::log_debug("srv_snapshot_manager: snapshot loaded, adding to history")
266	!	snapshot <- as.list(slices_global$all_slices(), recursive = TRUE)
267	!	snapshot_update <- c(snapshot_history(), list(snapshot))
268	!	names(snapshot_update)[length(snapshot_update)] <- snapshot_name
269	!	snapshot_history(snapshot_update)
270		### Begin simplified restore procedure. ###
271	!	logger::log_debug("srv_snapshot_manager: restoring snapshot")
272	!	slices_global$slices_set(snapshot_state)
273	!	removeModal()
274		### End simplified restore procedure. ###
275		}
276		}
277		})
278		# Apply newly added snapshot.
279
280		# Restore initial state ----
281	80x	observeEvent(input$snapshot_reset, {
282	2x	logger::log_debug("srv_snapshot_manager: snapshot_reset button clicked, restoring snapshot")
283	2x	s <- "Initial application state"
284		### Begin restore procedure. ###
285	2x	snapshot <- snapshot_history()[[s]]
286		# todo: as.teal_slices looses module-mapping if is not global
287	2x	snapshot_state <- as.teal_slices(snapshot)
288	2x	slices_global$slices_set(snapshot_state)
289	2x	removeModal()
290		### End restore procedure. ###
291		})
292
293		# Build snapshot table ----
294		# Create UI elements and server logic for the snapshot table.
295		# Observers must be tracked to avoid duplication and excess reactivity.
296		# Remaining elements are tracked likewise for consistency and a slight speed margin.
297	80x	observers <- reactiveValues()
298	80x	handlers <- reactiveValues()
299	80x	divs <- reactiveValues()
300
301	80x	observeEvent(snapshot_history(), {
302	70x	logger::log_debug("srv_snapshot_manager: snapshot history modified, updating snapshot list")
303	70x	lapply(names(snapshot_history())[-1L], function(s) {
304	!	id_pickme <- sprintf("pickme_%s", make.names(s))
305	!	id_saveme <- sprintf("saveme_%s", make.names(s))
306	!	id_rowme <- sprintf("rowme_%s", make.names(s))
307
308		# Observer for restoring snapshot.
309	!	if (!is.element(id_pickme, names(observers))) {
310	!	observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
311		### Begin restore procedure. ###
312	!	snapshot <- snapshot_history()[[s]]
313	!	snapshot_state <- as.teal_slices(snapshot)
314
315	!	slices_global$slices_set(snapshot_state)
316	!	removeModal()
317		### End restore procedure. ###
318		})
319		}
320		# Create handler for downloading snapshot.
321	!	if (!is.element(id_saveme, names(handlers))) {
322	!	output[[id_saveme]] <- downloadHandler(
323	!	filename = function() {
324	!	sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
325		},
326	!	content = function(file) {
327	!	snapshot <- snapshot_history()[[s]]
328	!	snapshot_state <- as.teal_slices(snapshot)
329	!	slices_store(tss = snapshot_state, file = file)
330		}
331		)
332	!	handlers[[id_saveme]] <- id_saveme
333		}
334		# Create a row for the snapshot table.
335	!	if (!is.element(id_rowme, names(divs))) {
336	!	divs[[id_rowme]] <- tags$div(
337	!	class = "manager_table_row",
338	!	tags$span(tags$h5(s)),
339	!	actionLink(inputId = ns(id_pickme), label = icon("far fa-circle-check"), title = "select"),
340	!	downloadLink(outputId = ns(id_saveme), label = icon("far fa-save"), title = "save to file")
341		)
342		}
343		})
344		})
345
346		# Create table to display list of snapshots and their actions.
347	80x	output$snapshot_list <- renderUI({
348	70x	rows <- rev(reactiveValuesToList(divs))
349	70x	if (length(rows) == 0L) {
350	70x	tags$div(
351	70x	class = "manager_placeholder",
352	70x	"Snapshots will appear here."
353		)
354		} else {
355	!	rows
356		}
357		})
358
359	80x	snapshot_history
360		})
361		}

1		#' App state management.
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' Capture and restore the global (app) input state.
7		#'
8		#' @details
9		#' This module introduces bookmarks into `teal` apps: the `shiny` bookmarking mechanism becomes enabled
10		#' and server-side bookmarks can be created.
11		#'
12		#' The bookmark manager presents a button with the bookmark icon and is placed in the tab-bar.
13		#' When clicked, the button creates a bookmark and opens a modal which displays the bookmark URL.
14		#'
15		#' `teal` does not guarantee that all modules (`teal_module` objects) are bookmarkable.
16		#' Those that are, have a `teal_bookmarkable` attribute set to `TRUE`. If any modules are not bookmarkable,
17		#' the bookmark manager modal displays a warning and the bookmark button displays a flag.
18		#' In order to communicate that a external module is bookmarkable, the module developer
19		#' should set the `teal_bookmarkable` attribute to `TRUE`.
20		#'
21		#' @section Server logic:
22		#' A bookmark is a URL that contains the app address with a `/?_state_id_=<bookmark_dir>` suffix.
23		#' `<bookmark_dir>` is a directory created on the server, where the state of the application is saved.
24		#' Accessing the bookmark URL opens a new session of the app that starts in the previously saved state.
25		#'
26		#' @section Note:
27		#' To enable bookmarking use either:
28		#' - `shiny` app by using `shinyApp(..., enableBookmarking = "server")` (not supported in `shinytest2`)
29		#' - set `options(shiny.bookmarkStore = "server")` before running the app
30		#'
31		#'
32		#' @inheritParams init
33		#'
34		#' @return Invisible `NULL`.
35		#'
36		#' @aliases bookmark bookmark_manager bookmark_manager_module
37		#'
38		#' @name module_bookmark_manager
39		#' @rdname module_bookmark_manager
40		#'
41		#' @keywords internal
42		#'
43		NULL
44
45		#' @rdname module_bookmark_manager
46		ui_bookmark_panel <- function(id, modules) {
47	!	ns <- NS(id)
48
49	!	bookmark_option <- get_bookmarking_option()
50	!	is_unbookmarkable <- need_bookmarking(modules)
51	!	shinyOptions(bookmarkStore = bookmark_option)
52
53		# Render bookmark warnings count
54	!	if (!all(is_unbookmarkable) && identical(bookmark_option, "server")) {
55	!	tags$button(
56	!	id = ns("do_bookmark"),
57	!	class = "btn action-button wunder_bar_button bookmark_manager_button",
58	!	title = "Add bookmark",
59	!	tags$span(
60	!	suppressMessages(icon("fas fa-bookmark")),
61	!	if (any(is_unbookmarkable)) {
62	!	tags$span(
63	!	sum(is_unbookmarkable),
64	!	class = "badge-warning badge-count text-white bg-danger"
65		)
66		}
67		)
68		)
69		}
70		}
71
72		#' @rdname module_bookmark_manager
73		srv_bookmark_panel <- function(id, modules) {
74	80x	checkmate::assert_character(id)
75	80x	checkmate::assert_class(modules, "teal_modules")
76	80x	moduleServer(id, function(input, output, session) {
77	80x	logger::log_debug("bookmark_manager_srv initializing")
78	80x	ns <- session$ns
79	80x	bookmark_option <- get_bookmarking_option()
80	80x	is_unbookmarkable <- need_bookmarking(modules)
81
82		# Set up bookmarking callbacks ----
83		# Register bookmark exclusions: do_bookmark button to avoid re-bookmarking
84	80x	setBookmarkExclude(c("do_bookmark"))
85		# This bookmark can only be used on the app session.
86	80x	app_session <- .subset2(session, "parent")
87	80x	app_session$onBookmarked(function(url) {
88	!	logger::log_debug("bookmark_manager_srv@onBookmarked: bookmark button clicked, registering bookmark")
89	!	modal_content <- if (bookmark_option != "server") {
90	!	msg <- sprintf(
91	!	"Bookmarking has been set to \"%s\".\n%s\n%s",
92	!	bookmark_option,
93	!	"Only server-side bookmarking is supported.",
94	!	"Please contact your app developer."
95		)
96	!	tags$div(
97	!	tags$p(msg, class = "text-warning")
98		)
99		} else {
100	!	tags$div(
101	!	tags$span(
102	!	tags$pre(url)
103		),
104	!	if (any(is_unbookmarkable)) {
105	!	bkmb_summary <- rapply2(
106	!	modules_bookmarkable(modules),
107	!	function(x) {
108	!	if (isTRUE(x)) {
109	!	"\u2705" # check mark
110	!	} else if (isFALSE(x)) {
111	!	"\u274C" # cross mark
112		} else {
113	!	"\u2753" # question mark
114		}
115		}
116		)
117	!	tags$div(
118	!	tags$p(
119	!	icon("fas fa-exclamation-triangle"),
120	!	"Some modules will not be restored when using this bookmark.",
121	!	tags$br(),
122	!	"Check the list below to see which modules are not bookmarkable.",
123	!	class = "text-warning"
124		),
125	!	tags$pre(yaml::as.yaml(bkmb_summary))
126		)
127		}
128		)
129		}
130
131	!	showModal(
132	!	modalDialog(
133	!	id = ns("bookmark_modal"),
134	!	title = "Bookmarked teal app url",
135	!	modal_content,
136	!	easyClose = TRUE
137		)
138		)
139		})
140
141		# manually trigger bookmarking because of the problems reported on windows with bookmarkButton in teal
142	80x	observeEvent(input$do_bookmark, {
143	!	logger::log_debug("bookmark_manager_srv@1 do_bookmark module clicked.")
144	!	session$doBookmark()
145		})
146
147	80x	invisible(NULL)
148		})
149		}
150
151
152		#' @rdname module_bookmark_manager
153		get_bookmarking_option <- function() {
154	80x	bookmark_option <- getShinyOption("bookmarkStore")
155	80x	if (is.null(bookmark_option) && identical(getOption("shiny.bookmarkStore"), "server")) {
156	!	bookmark_option <- getOption("shiny.bookmarkStore")
157		}
158	80x	bookmark_option
159		}
160
161		#' @rdname module_bookmark_manager
162		need_bookmarking <- function(modules) {
163	80x	unlist(rapply2(
164	80x	modules_bookmarkable(modules),
165	80x	Negate(isTRUE)
166		))
167		}
168
169
170		# utilities ----
171
172		#' Restore value from bookmark.
173		#'
174		#' Get value from bookmark or return default.
175		#'
176		#' Bookmarks can store not only inputs but also arbitrary values.
177		#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks,
178		#' and they are placed in the `values` environment in the `session$restoreContext` field.
179		#' Using `teal_data_module` makes it impossible to run the callbacks
180		#' because the app becomes ready before modules execute and callbacks are registered.
181		#' In those cases the stored values can still be recovered from the `session` object directly.
182		#'
183		#' Note that variable names in the `values` environment are prefixed with module name space names,
184		#' therefore, when using this function in modules, `value` must be run through the name space function.
185		#'
186		#' @param value (`character(1)`) name of value to restore
187		#' @param default fallback value
188		#'
189		#' @return
190		#' In an application restored from a server-side bookmark,
191		#' the variable specified by `value` from the `values` environment.
192		#' Otherwise `default`.
193		#'
194		#' @keywords internal
195		#'
196		restoreValue <- function(value, default) { # nolint: object_name.
197	160x	checkmate::assert_character("value")
198	160x	session_default <- shiny::getDefaultReactiveDomain()
199	160x	session_parent <- .subset2(session_default, "parent")
200	160x	session <- if (is.null(session_parent)) session_default else session_parent
201
202	160x	if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
203	!	session$restoreContext$values[[value]]
204		} else {
205	160x	default
206		}
207		}
208
209		#' Compare bookmarks.
210		#'
211		#' Test if two bookmarks store identical state.
212		#'
213		#' `input` environments are compared one variable at a time and if not identical,
214		#' values in both bookmarks are reported. States of `datatable`s are stripped
215		#' of the `time` element before comparing because the time stamp is always different.
216		#' The contents themselves are not printed as they are large and the contents are not informative.
217		#' Elements present in one bookmark and absent in the other are also reported.
218		#' Differences are printed as messages.
219		#'
220		#' `values` environments are compared with `all.equal`.
221		#'
222		#' @section How to use:
223		#' Open an application, change relevant inputs (typically, all of them), and create a bookmark.
224		#' Then open that bookmark and immediately create a bookmark of that.
225		#' If restoring bookmarks occurred properly, the two bookmarks should store the same state.
226		#'
227		#'
228		#' @param book1,book2 bookmark directories stored in `shiny_bookmarks/`;
229		#' default to the two most recently modified directories
230		#'
231		#' @return
232		#' Invisible `NULL` if bookmarks are identical or if there are no bookmarks to test.
233		#' `FALSE` if inconsistencies are detected.
234		#'
235		#' @keywords internal
236		#'
237		bookmarks_identical <- function(book1, book2) {
238	!	if (!dir.exists("shiny_bookmarks")) {
239	!	message("no bookmark directory")
240	!	return(invisible(NULL))
241		}
242
243	!	ans <- TRUE
244
245	!	if (missing(book1) && missing(book2)) {
246	!	dirs <- list.dirs("shiny_bookmarks", recursive = FALSE)
247	!	bookmarks_sorted <- basename(rev(dirs[order(file.mtime(dirs))]))
248	!	if (length(bookmarks_sorted) < 2L) {
249	!	message("no bookmarks to compare")
250	!	return(invisible(NULL))
251		}
252	!	book1 <- bookmarks_sorted[2L]
253	!	book2 <- bookmarks_sorted[1L]
254		} else {
255	!	if (!dir.exists(file.path("shiny_bookmarks", book1))) stop(book1, " not found")
256	!	if (!dir.exists(file.path("shiny_bookmarks", book2))) stop(book2, " not found")
257		}
258
259	!	book1_input <- readRDS(file.path("shiny_bookmarks", book1, "input.rds"))
260	!	book2_input <- readRDS(file.path("shiny_bookmarks", book2, "input.rds"))
261
262	!	elements_common <- intersect(names(book1_input), names(book2_input))
263	!	dt_states <- grepl("_state$", elements_common)
264	!	if (any(dt_states)) {
265	!	for (el in elements_common[dt_states]) {
266	!	book1_input[[el]][["time"]] <- NULL
267	!	book2_input[[el]][["time"]] <- NULL
268		}
269		}
270
271	!	identicals <- mapply(identical, book1_input[elements_common], book2_input[elements_common])
272	!	non_identicals <- names(identicals[!identicals])
273	!	compares <- sprintf("$ %s:\t%s --- %s", non_identicals, book1_input[non_identicals], book2_input[non_identicals])
274	!	if (length(compares) != 0L) {
275	!	message("common elements not identical: \n", paste(compares, collapse = "\n"))
276	!	ans <- FALSE
277		}
278
279	!	elements_boook1 <- setdiff(names(book1_input), names(book2_input))
280	!	if (length(elements_boook1) != 0L) {
281	!	dt_states <- grepl("_state$", elements_boook1)
282	!	if (any(dt_states)) {
283	!	for (el in elements_boook1[dt_states]) {
284	!	if (is.list(book1_input[[el]])) book1_input[[el]] <- "--- data table state ---"
285		}
286		}
287	!	excess1 <- sprintf("$ %s:\t%s", elements_boook1, book1_input[elements_boook1])
288	!	message("elements only in book1: \n", paste(excess1, collapse = "\n"))
289	!	ans <- FALSE
290		}
291
292	!	elements_boook2 <- setdiff(names(book2_input), names(book1_input))
293	!	if (length(elements_boook2) != 0L) {
294	!	dt_states <- grepl("_state$", elements_boook1)
295	!	if (any(dt_states)) {
296	!	for (el in elements_boook1[dt_states]) {
297	!	if (is.list(book2_input[[el]])) book2_input[[el]] <- "--- data table state ---"
298		}
299		}
300	!	excess2 <- sprintf("$ %s:\t%s", elements_boook2, book2_input[elements_boook2])
301	!	message("elements only in book2: \n", paste(excess2, collapse = "\n"))
302	!	ans <- FALSE
303		}
304
305	!	book1_values <- readRDS(file.path("shiny_bookmarks", book1, "values.rds"))
306	!	book2_values <- readRDS(file.path("shiny_bookmarks", book2, "values.rds"))
307
308	!	if (!isTRUE(all.equal(book1_values, book2_values))) {
309	!	message("different values detected")
310	!	message("choices for numeric filters MAY be different, see RangeFilterState$set_choices")
311	!	ans <- FALSE
312		}
313
314	!	if (ans) message("perfect!")
315	!	invisible(NULL)
316		}
317
318
319		# Replacement for [base::rapply] which doesn't handle NULL values - skips the evaluation
320		# of the function and returns NULL for given element.
321		rapply2 <- function(x, f) {
322	185x	if (inherits(x, "list")) {
323	80x	lapply(x, rapply2, f = f)
324		} else {
325	105x	f(x)
326		}
327		}

1		#' Execute and validate `teal_data_module`
2		#'
3		#' This is a low level module to handle `teal_data_module` execution and validation.
4		#' [teal_transform_module()] inherits from [teal_data_module()] so it is handled by this module too.
5		#' [srv_teal()] accepts various `data` objects and eventually they are all transformed to `reactive`
6		#' [teal_data()] which is a standard data class in whole `teal` framework.
7		#'
8		#' @section data validation:
9		#'
10		#' Executed [teal_data_module()] is validated and output is validated for consistency.
11		#' Output `data` is invalid if:
12		#' 1. [teal_data_module()] is invalid if server doesn't return `reactive`. Immediately crashes an app!
13		#' 2. `reactive` throws a `shiny.error` - happens when module creating [teal_data()] fails.
14		#' 3. `reactive` returns `qenv.error` - happens when [teal_data()] evaluates a failing code.
15		#' 4. `reactive` object doesn't return [teal_data()].
16		#' 5. [teal_data()] object lacks any `datanames` specified in the `modules` argument.
17		#'
18		#' `teal` (observers in `srv_teal`) always waits to render an app until `reactive` `teal_data` is
19		#' returned. If error 2-4 occurs, relevant error message is displayed to the app user. Once the issue is
20		#' resolved, the app will continue to run. `teal` guarantees that errors in data don't crash the app
21		#' (except error 1).
22		#'
23		#' @param id (`character(1)`) Module id
24		#' @param data (`reactive teal_data`)
25		#' @param data_module (`teal_data_module`)
26		#' @param modules (`teal_modules` or `teal_module`) For `datanames` validation purpose
27		#' @param validate_shiny_silent_error (`logical`) If `TRUE`, then `shiny.silent.error` is validated and
28		#' @param is_transformer_failed (`reactiveValues`) contains `logical` flags named after each transformer.
29		#' Help to determine if any previous transformer failed, so that following transformers can be disabled
30		#' and display a generic failure message.
31		#'
32		#' @return `reactive` `teal_data`
33		#'
34		#' @rdname module_teal_data
35		#' @name module_teal_data
36		#' @keywords internal
37		NULL
38
39		#' @rdname module_teal_data
40		ui_teal_data <- function(id, data_module = function(id) NULL) {
41	!	checkmate::assert_string(id)
42	!	checkmate::assert_function(data_module, args = "id")
43	!	ns <- NS(id)
44
45	!	shiny::tagList(
46	!	tags$div(id = ns("wrapper"), data_module(id = ns("data"))),
47	!	ui_validate_reactive_teal_data(ns("validate"))
48		)
49		}
50
51		#' @rdname module_teal_data
52		srv_teal_data <- function(id,
53		data_module = function(id) NULL,
54		modules = NULL,
55		validate_shiny_silent_error = TRUE,
56		is_transformer_failed = reactiveValues()) {
57	19x	checkmate::assert_string(id)
58	19x	checkmate::assert_function(data_module, args = "id")
59	19x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
60	19x	checkmate::assert_class(is_transformer_failed, "reactivevalues")
61
62	19x	moduleServer(id, function(input, output, session) {
63	19x	logger::log_debug("srv_teal_data initializing.")
64	19x	is_transformer_failed[[id]] <- FALSE
65	19x	data_out <- data_module(id = "data")
66	19x	data_handled <- reactive(tryCatch(data_out(), error = function(e) e))
67	19x	observeEvent(data_handled(), {
68	21x	if (!inherits(data_handled(), "teal_data")) {
69	6x	is_transformer_failed[[id]] <- TRUE
70		} else {
71	15x	is_transformer_failed[[id]] <- FALSE
72		}
73		})
74
75	19x	is_previous_failed <- reactive({
76	19x	idx_this <- which(names(is_transformer_failed) == id)
77	19x	is_transformer_failed_list <- reactiveValuesToList(is_transformer_failed)
78	19x	idx_failures <- which(unlist(is_transformer_failed_list))
79	19x	any(idx_failures < idx_this)
80		})
81
82	19x	observeEvent(is_previous_failed(), {
83	19x	if (is_previous_failed()) {
84	!	shinyjs::disable("wrapper")
85		} else {
86	19x	shinyjs::enable("wrapper")
87		}
88		})
89
90	19x	srv_validate_reactive_teal_data(
91	19x	"validate",
92	19x	data = data_handled,
93	19x	modules = modules,
94	19x	validate_shiny_silent_error = validate_shiny_silent_error,
95	19x	hide_validation_error = is_previous_failed
96		)
97		})
98		}
99
100		#' @rdname module_teal_data
101		ui_validate_reactive_teal_data <- function(id) {
102	80x	ns <- NS(id)
103	80x	tagList(
104	80x	div(
105	80x	id = ns("validate_messages"),
106	80x	class = "teal_validated",
107	80x	ui_validate_error(ns("silent_error")),
108	80x	ui_check_class_teal_data(ns("class_teal_data")),
109	80x	ui_check_shiny_warnings(ns("shiny_warnings"))
110		),
111	80x	div(
112	80x	class = "teal_validated",
113	80x	uiOutput(ns("previous_failed"))
114		)
115		)
116		}
117
118		#' @rdname module_teal_data
119		srv_validate_reactive_teal_data <- function(id, # nolint: object_length
120		data,
121		modules = NULL,
122		validate_shiny_silent_error = FALSE,
123		hide_validation_error = reactive(FALSE)) {
124	178x	checkmate::assert_string(id)
125	178x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
126	178x	checkmate::assert_flag(validate_shiny_silent_error)
127
128	178x	moduleServer(id, function(input, output, session) {
129		# there is an empty reactive cycle on `init` and `data_rv` has `shiny.silent.error` class
130	178x	srv_validate_error("silent_error", data, validate_shiny_silent_error)
131	178x	srv_check_class_teal_data("class_teal_data", data)
132	178x	srv_check_shiny_warnings("shiny_warnings", data, modules)
133	178x	output$previous_failed <- renderUI({
134	168x	if (hide_validation_error()) {
135	!	shinyjs::hide("validate_messages")
136	!	tags$div("One of previous transformers failed. Please fix and continue.", class = "teal-output-warning")
137		} else {
138	168x	shinyjs::show("validate_messages")
139	168x	NULL
140		}
141		})
142
143	178x	.trigger_on_success(data)
144		})
145		}
146
147		#' @keywords internal
148		ui_validate_error <- function(id) {
149	80x	ns <- NS(id)
150	80x	uiOutput(ns("message"))
151		}
152
153		#' @keywords internal
154		srv_validate_error <- function(id, data, validate_shiny_silent_error) {
155	178x	checkmate::assert_string(id)
156	178x	checkmate::assert_flag(validate_shiny_silent_error)
157	178x	moduleServer(id, function(input, output, session) {
158	178x	output$message <- renderUI({
159	181x	is_shiny_silent_error <- inherits(data(), "shiny.silent.error") && identical(data()$message, "")
160	175x	if (inherits(data(), "qenv.error")) {
161	2x	validate(
162	2x	need(
163	2x	FALSE,
164	2x	paste(
165	2x	"Error when executing the `data` module:",
166	2x	strip_style(paste(data()$message, collapse = "\n")),
167	2x	"\nCheck your inputs or contact app developer if error persists.",
168	2x	collapse = "\n"
169		)
170		)
171		)
172	173x	} else if (inherits(data(), "error")) {
173	7x	if (is_shiny_silent_error && !validate_shiny_silent_error) {
174	1x	return(NULL)
175		}
176	6x	validate(
177	6x	need(
178	6x	FALSE,
179	6x	sprintf(
180	6x	"Shiny error when executing the `data` module.\n%s\n%s",
181	6x	data()$message,
182	6x	"Check your inputs or contact app developer if error persists."
183		)
184		)
185		)
186		}
187		})
188		})
189		}
190
191
192		#' @keywords internal
193		ui_check_class_teal_data <- function(id) {
194	80x	ns <- NS(id)
195	80x	uiOutput(ns("message"))
196		}
197
198		#' @keywords internal
199		srv_check_class_teal_data <- function(id, data) {
200	178x	checkmate::assert_string(id)
201	178x	moduleServer(id, function(input, output, session) {
202	178x	output$message <- renderUI({
203	181x	validate(
204	181x	need(
205	181x	inherits(data(), c("teal_data", "error")),
206	181x	"Did not receive `teal_data` object. Cannot proceed further."
207		)
208		)
209		})
210		})
211		}
212
213		#' @keywords internal
214		ui_check_shiny_warnings <- function(id) {
215	80x	ns <- NS(id)
216	80x	uiOutput(NS(id, "message"))
217		}
218
219		#' @keywords internal
220		srv_check_shiny_warnings <- function(id, data, modules) {
221	178x	checkmate::assert_string(id)
222	178x	moduleServer(id, function(input, output, session) {
223	178x	output$message <- renderUI({
224	181x	if (inherits(data(), "teal_data")) {
225	164x	is_modules_ok <- check_modules_datanames_html(
226	164x	modules = modules, datanames = ls(teal.code::get_env(data()))
227		)
228	164x	if (!isTRUE(is_modules_ok)) {
229	15x	tags$div(is_modules_ok, class = "teal-output-warning")
230		}
231		}
232		})
233		})
234		}
235
236		.trigger_on_success <- function(data) {
237	178x	out <- reactiveVal(NULL)
238	178x	observeEvent(data(), {
239	175x	if (inherits(data(), "teal_data")) {
240	164x	if (!identical(data(), out())) {
241	164x	out(data())
242		}
243		}
244		})
245
246	178x	out
247		}

1		#' Generate lockfile for application's environment reproducibility
2		#'
3		#' @param lockfile_path (`character`) path to the lockfile.
4		#'
5		#' @section Different ways of creating lockfile:
6		#' `teal` leverages [renv::snapshot()], which offers multiple methods for lockfile creation.
7		#'
8		#' - Working directory lockfile: `teal`, by default, will create an `implicit` type lockfile that uses
9		#' `renv::dependencies()` to detect all R packages in the current project's working directory.
10		#' - `DESCRIPTION`-based lockfile: To generate a lockfile based on a `DESCRIPTION` file in your working
11		#' directory, set `renv::settings$snapshot.type("explicit")`. The naming convention for `type` follows
12		#' `renv::snapshot()`. For the `"explicit"` type, refer to `renv::settings$package.dependency.fields()` for the
13		#' `DESCRIPTION` fields included in the lockfile.
14		#' - Custom files-based lockfile: To specify custom files as the basis for the lockfile, set
15		#' `renv::settings$snapshot.type("custom")` and configure the `renv.snapshot.filter` option.
16		#'
17		#' @section lockfile usage:
18		#' After creating the lockfile, you can restore the application's environment using `renv::restore()`.
19		#'
20		#' @seealso [renv::snapshot()], [renv::restore()].
21		#'
22		#' @return `NULL`
23		#'
24		#' @name module_teal_lockfile
25		#' @rdname module_teal_lockfile
26		#'
27		#' @keywords internal
28		NULL
29
30		#' @rdname module_teal_lockfile
31		ui_teal_lockfile <- function(id) {
32	!	ns <- NS(id)
33	!	shiny::tagList(
34	!	tags$span("", id = ns("lockFileStatus")),
35	!	shinyjs::disabled(downloadLink(ns("lockFileLink"), "Download lockfile"))
36		)
37		}
38
39		#' @rdname module_teal_lockfile
40		srv_teal_lockfile <- function(id) {
41	81x	moduleServer(id, function(input, output, session) {
42	81x	logger::log_debug("Initialize srv_teal_lockfile.")
43	81x	enable_lockfile_download <- function() {
44	!	shinyjs::html("lockFileStatus", "Application lockfile ready.")
45	!	shinyjs::hide("lockFileStatus", anim = TRUE)
46	!	shinyjs::enable("lockFileLink")
47	!	output$lockFileLink <- shiny::downloadHandler(
48	!	filename = function() {
49	!	"renv.lock"
50		},
51	!	content = function(file) {
52	!	file.copy(lockfile_path, file)
53	!	file
54		},
55	!	contentType = "application/json"
56		)
57		}
58	81x	disable_lockfile_download <- function() {
59	!	warning("Lockfile creation failed.", call. = FALSE)
60	!	shinyjs::html("lockFileStatus", "Lockfile creation failed.")
61	!	shinyjs::hide("lockFileLink")
62		}
63
64	81x	shiny::onStop(function() {
65	81x	if (file.exists(lockfile_path) && !shiny::isRunning()) {
66	1x	logger::log_debug("Removing lockfile after shutting down the app")
67	1x	file.remove(lockfile_path)
68		}
69		})
70
71	81x	lockfile_path <- "teal_app.lock"
72	81x	mode <- getOption("teal.lockfile.mode", default = "")
73
74	81x	if (!(mode %in% c("auto", "enabled", "disabled"))) {
75	!	stop("'teal.lockfile.mode' option can only be one of \"auto\", \"disabled\" or \"disabled\". ")
76		}
77
78	81x	if (mode == "disabled") {
79	1x	logger::log_debug("'teal.lockfile.mode' option is set to 'disabled'. Hiding lockfile download button.")
80	1x	shinyjs::hide("lockFileLink")
81	1x	return(NULL)
82		}
83
84	80x	if (file.exists(lockfile_path)) {
85	!	logger::log_debug("Lockfile has already been created for this app - skipping automatic creation.")
86	!	enable_lockfile_download()
87	!	return(NULL)
88		}
89
90	80x	if (mode == "auto" && .is_disabled_lockfile_scenario()) {
91	79x	logger::log_debug(
92	79x	"Automatic lockfile creation disabled. Execution scenario satisfies teal:::.is_disabled_lockfile_scenario()."
93		)
94	79x	shinyjs::hide("lockFileLink")
95	79x	return(NULL)
96		}
97
98	1x	if (!.is_lockfile_deps_installed()) {
99	!	warning("Automatic lockfile creation disabled. `mirai` and `renv` packages must be installed.")
100	!	shinyjs::hide("lockFileLink")
101	!	return(NULL)
102		}
103
104		# - Will be run only if the lockfile doesn't exist (see the if-s above)
105		# - We render to the tempfile because the process might last after session is closed and we don't
106		# want to make a "teal_app.renv" then. This is why we copy only during active session.
107	1x	process <- .teal_lockfile_process_invoke(lockfile_path)
108	1x	observeEvent(process$status(), {
109	!	if (process$status() %in% c("initial", "running")) {
110	!	shinyjs::html("lockFileStatus", "Creating lockfile...")
111	!	} else if (process$status() == "success") {
112	!	result <- process$result()
113	!	if (any(grepl("Lockfile written to", result$out))) {
114	!	logger::log_debug("Lockfile containing { length(result$res$Packages) } packages created.")
115	!	if (any(grepl("(WARNING\|ERROR):", result$out))) {
116	!	warning("Lockfile created with warning(s) or error(s):", call. = FALSE)
117	!	for (i in result$out) {
118	!	warning(i, call. = FALSE)
119		}
120		}
121	!	enable_lockfile_download()
122		} else {
123	!	disable_lockfile_download()
124		}
125	!	} else if (process$status() == "error") {
126	!	disable_lockfile_download()
127		}
128		})
129
130	1x	NULL
131		})
132		}
133
134		utils::globalVariables(c("opts", "sysenv", "libpaths", "wd", "lockfilepath", "run")) # needed for mirai call
135		#' @rdname module_teal_lockfile
136		.teal_lockfile_process_invoke <- function(lockfile_path) {
137	1x	mirai_obj <- NULL
138	1x	process <- shiny::ExtendedTask$new(function() {
139	1x	m <- mirai::mirai(
140		{
141	1x	options(opts)
142	1x	do.call(Sys.setenv, sysenv)
143	1x	.libPaths(libpaths)
144	1x	setwd(wd)
145	1x	run(lockfile_path = lockfile_path)
146		},
147	1x	run = .renv_snapshot,
148	1x	lockfile_path = lockfile_path,
149	1x	opts = options(),
150	1x	libpaths = .libPaths(),
151	1x	sysenv = as.list(Sys.getenv()),
152	1x	wd = getwd()
153		)
154	1x	mirai_obj <<- m
155	1x	m
156		})
157
158	1x	shiny::onStop(function() {
159	1x	if (mirai::unresolved(mirai_obj)) {
160	!	logger::log_debug("Terminating a running lockfile process...")
161	!	mirai::stop_mirai(mirai_obj) # this doesn't stop running - renv will be created even if session is closed
162		}
163		})
164
165	1x	suppressWarnings({ # 'package:stats' may not be available when loading
166	1x	process$invoke()
167		})
168
169	1x	logger::log_debug("Lockfile creation started based on { getwd() }.")
170
171	1x	process
172		}
173
174		#' @rdname module_teal_lockfile
175		.renv_snapshot <- function(lockfile_path) {
176	1x	out <- utils::capture.output(
177	1x	res <- renv::snapshot(
178	1x	lockfile = lockfile_path,
179	1x	prompt = FALSE,
180	1x	force = TRUE,
181	1x	type = renv::settings$snapshot.type() # see the section "Different ways of creating lockfile" above here
182		)
183		)
184
185	1x	list(out = out, res = res)
186		}
187
188		#' @rdname module_teal_lockfile
189		.is_lockfile_deps_installed <- function() {
190	1x	requireNamespace("mirai", quietly = TRUE) && requireNamespace("renv", quietly = TRUE)
191		}
192
193		#' @rdname module_teal_lockfile
194		.is_disabled_lockfile_scenario <- function() {
195	79x	identical(Sys.getenv("CALLR_IS_RUNNING"), "true") \|\| # inside callr process
196	79x	identical(Sys.getenv("TESTTHAT"), "true") \|\| # inside devtools::test
197	79x	!identical(Sys.getenv("QUARTO_PROJECT_ROOT"), "") \|\| # inside Quarto process
198		(
199	79x	("CheckExEnv" %in% search()) \|\| any(c("_R_CHECK_TIMINGS_", "_R_CHECK_LICENSE_") %in% names(Sys.getenv()))
200	79x	) # inside R CMD CHECK
201		}

1		#' @title `TealReportCard`
2		#' @description `r lifecycle::badge("experimental")`
3		#' Child class of [`ReportCard`] that is used for `teal` specific applications.
4		#' In addition to the parent methods, it supports rendering `teal` specific elements such as
5		#' the source code, the encodings panel content and the filter panel content as part of the
6		#' meta data.
7		#' @export
8		#'
9		TealReportCard <- R6::R6Class( # nolint: object_name.
10		classname = "TealReportCard",
11		inherit = teal.reporter::ReportCard,
12		public = list(
13		#' @description Appends the source code to the `content` meta data of this `TealReportCard`.
14		#'
15		#' @param src (`character(1)`) code as text.
16		#' @param ... any `rmarkdown` `R` chunk parameter and its value.
17		#' But `eval` parameter is always set to `FALSE`.
18		#' @return Object of class `TealReportCard`, invisibly.
19		#' @examples
20		#' card <- TealReportCard$new()$append_src(
21		#' "plot(iris)"
22		#' )
23		#' card$get_content()[[1]]$get_content()
24		append_src = function(src, ...) {
25	4x	checkmate::assert_character(src, min.len = 0, max.len = 1)
26	4x	params <- list(...)
27	4x	params$eval <- FALSE
28	4x	rblock <- RcodeBlock$new(src)
29	4x	rblock$set_params(params)
30	4x	self$append_content(rblock)
31	4x	self$append_metadata("SRC", src)
32	4x	invisible(self)
33		},
34		#' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.
35		#' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses
36		#' the default `yaml::as.yaml` to format the list.
37		#' If the filter state list is empty, nothing is appended to the `content`.
38		#'
39		#' @param fs (`teal_slices`) object returned from [teal_slices()] function.
40		#' @return `self`, invisibly.
41		append_fs = function(fs) {
42	5x	checkmate::assert_class(fs, "teal_slices")
43	4x	self$append_text("Filter State", "header3")
44	4x	if (length(fs)) {
45	3x	self$append_content(TealSlicesBlock$new(fs))
46		} else {
47	1x	self$append_text("No filters specified.")
48		}
49	4x	invisible(self)
50		},
51		#' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.
52		#'
53		#' @param encodings (`list`) list of encodings selections of the `teal` app.
54		#' @return `self`, invisibly.
55		#' @examples
56		#' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))
57		#' card$get_content()[[1]]$get_content()
58		#'
59		append_encodings = function(encodings) {
60	4x	checkmate::assert_list(encodings)
61	4x	self$append_text("Selected Options", "header3")
62	4x	if (requireNamespace("yaml", quietly = TRUE)) {
63	4x	self$append_text(yaml::as.yaml(encodings, handlers = list(
64	4x	POSIXct = function(x) format(x, "%Y-%m-%d"),
65	4x	POSIXlt = function(x) format(x, "%Y-%m-%d"),
66	4x	Date = function(x) format(x, "%Y-%m-%d")
67	4x	)), "verbatim")
68		} else {
69	!	stop("yaml package is required to format the encodings list")
70		}
71	4x	self$append_metadata("Encodings", encodings)
72	4x	invisible(self)
73		}
74		),
75		private = list(
76		dispatch_block = function(block_class) {
77	!	eval(str2lang(block_class))
78		}
79		)
80		)
81
82		#' @title `TealSlicesBlock`
83		#' @docType class
84		#' @description
85		#' Specialized `TealSlicesBlock` block for managing filter panel content in reports.
86		#' @keywords internal
87		TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter.
88		classname = "TealSlicesBlock",
89		inherit = teal.reporter:::TextBlock,
90		public = list(
91		#' @description Returns a `TealSlicesBlock` object.
92		#'
93		#' @details Returns a `TealSlicesBlock` object with no content and no parameters.
94		#'
95		#' @param content (`teal_slices`) object returned from [teal_slices()] function.
96		#' @param style (`character(1)`) string specifying style to apply.
97		#'
98		#' @return Object of class `TealSlicesBlock`, invisibly.
99		#'
100		initialize = function(content = teal_slices(), style = "verbatim") {
101	9x	self$set_content(content)
102	8x	self$set_style(style)
103	8x	invisible(self)
104		},
105
106		#' @description Sets content of this `TealSlicesBlock`.
107		#' Sets content as `YAML` text which represents a list generated from `teal_slices`.
108		#' The list displays limited number of fields from `teal_slice` objects, but this list is
109		#' sufficient to conclude which filters were applied.
110		#' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"
111		#'
112		#'
113		#' @param content (`teal_slices`) object returned from [teal_slices()] function.
114		#' @return `self`, invisibly.
115		set_content = function(content) {
116	9x	checkmate::assert_class(content, "teal_slices")
117	8x	if (length(content) != 0) {
118	6x	states_list <- lapply(content, function(x) {
119	6x	x_list <- shiny::isolate(as.list(x))
120	6x	if (
121	6x	inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
122	6x	length(x_list$choices) == 2 &&
123	6x	length(x_list$selected) == 2
124		) {
125	!	x_list$range <- paste(x_list$selected, collapse = " - ")
126	!	x_list["selected"] <- NULL
127		}
128	6x	if (!is.null(x_list$arg)) {
129	!	x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"
130		}
131
132	6x	x_list <- x_list[
133	6x	c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
134		]
135	6x	names(x_list) <- c(
136	6x	"Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",
137	6x	"Selected Values", "Selected range", "Include NA values", "Include Inf values"
138		)
139
140	6x	Filter(Negate(is.null), x_list)
141		})
142
143	6x	if (requireNamespace("yaml", quietly = TRUE)) {
144	6x	super$set_content(yaml::as.yaml(states_list))
145		} else {
146	!	stop("yaml package is required to format the filter state list")
147		}
148		}
149	8x	private$teal_slices <- content
150	8x	invisible(self)
151		},
152		#' @description Create the `TealSlicesBlock` from a list.
153		#'
154		#' @param x (`named list`) with two fields `text` and `style`.
155		#' Use the `get_available_styles` method to get all possible styles.
156		#'
157		#' @return `self`, invisibly.
158		#' @examples
159		#' TealSlicesBlock <- getFromNamespace("TealSlicesBlock", "teal")
160		#' block <- TealSlicesBlock$new()
161		#' block$from_list(list(text = "sth", style = "default"))
162		#'
163		from_list = function(x) {
164	1x	checkmate::assert_list(x)
165	1x	checkmate::assert_names(names(x), must.include = c("text", "style"))
166	1x	super$set_content(x$text)
167	1x	super$set_style(x$style)
168	1x	invisible(self)
169		},
170		#' @description Convert the `TealSlicesBlock` to a list.
171		#'
172		#' @return `named list` with a text and style.
173		#' @examples
174		#' TealSlicesBlock <- getFromNamespace("TealSlicesBlock", "teal")
175		#' block <- TealSlicesBlock$new()
176		#' block$to_list()
177		#'
178		to_list = function() {
179	2x	content <- self$get_content()
180	2x	list(
181	2x	text = if (length(content)) content else "",
182	2x	style = self$get_style()
183		)
184		}
185		),
186		private = list(
187		style = "verbatim",
188		teal_slices = NULL # teal_slices
189		)
190		)

1		#' Filter panel module in teal
2		#'
3		#' Creates filter panel module from `teal_data` object and returns `teal_data`. It is build in a way
4		#' that filter panel changes and anything what happens before (e.g. [`module_init_data`]) is triggering
5		#' further reactive events only if something has changed and if the module is visible. Thanks to
6		#' this special implementation all modules' data are recalculated only for those modules which are
7		#' currently displayed.
8		#'
9		#' @return A `eventReactive` containing `teal_data` containing filtered objects and filter code.
10		#' `eventReactive` triggers only if all conditions are met:
11		#' - tab is selected (`is_active`)
12		#' - when filters are changed (`get_filter_expr` is different than previous)
13		#'
14		#' @inheritParams module_teal_module
15		#' @param active_datanames (`reactive` returning `character`) this module's data names
16		#' @name module_filter_data
17		#' @keywords internal
18		NULL
19
20		#' @rdname module_filter_data
21		ui_filter_data <- function(id) {
22	!	ns <- shiny::NS(id)
23	!	uiOutput(ns("panel"))
24		}
25
26		#' @rdname module_filter_data
27		srv_filter_data <- function(id, datasets, active_datanames, data_rv, is_active) {
28	79x	assert_reactive(datasets)
29	79x	moduleServer(id, function(input, output, session) {
30	79x	active_corrected <- reactive(intersect(active_datanames(), datasets()$datanames()))
31
32	79x	output$panel <- renderUI({
33	81x	req(inherits(datasets(), "FilteredData"))
34	81x	isolate({
35		# render will be triggered only when FilteredData object changes (not when filters change)
36		# technically it means that teal_data_module needs to be refreshed
37	81x	logger::log_debug("srv_filter_panel rendering filter panel.")
38	81x	if (length(active_corrected())) {
39	79x	datasets()$srv_active("filters", active_datanames = active_corrected)
40	79x	datasets()$ui_active(session$ns("filters"), active_datanames = active_corrected)
41		}
42		})
43		})
44
45	79x	trigger_data <- .observe_active_filter_changed(datasets, is_active, active_corrected, data_rv)
46
47	79x	eventReactive(trigger_data(), {
48	82x	.make_filtered_teal_data(modules, data = data_rv(), datasets = datasets(), datanames = active_corrected())
49		})
50		})
51		}
52
53		#' @rdname module_filter_data
54		.make_filtered_teal_data <- function(modules, data, datasets = NULL, datanames) {
55	82x	data <- eval_code(
56	82x	data,
57	82x	paste0(
58	82x	".raw_data <- list2env(list(",
59	82x	toString(sprintf("%1$s = %1$s", sapply(datanames, as.name))),
60	82x	"))\n",
61	82x	"lockEnvironment(.raw_data) # @linksto .raw_data" # this is environment and it is shared by qenvs. CAN'T MODIFY!
62		)
63		)
64	82x	filtered_code <- .get_filter_expr(datasets = datasets, datanames = datanames)
65	82x	filtered_teal_data <- .append_evaluated_code(data, filtered_code)
66	82x	filtered_datasets <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)
67	82x	filtered_teal_data <- .append_modified_data(filtered_teal_data, filtered_datasets)
68	82x	filtered_teal_data
69		}
70
71		#' @rdname module_filter_data
72		.observe_active_filter_changed <- function(datasets, is_active, active_datanames, data_rv) {
73	79x	previous_signature <- reactiveVal(NULL)
74	79x	filter_changed <- reactive({
75	181x	req(inherits(datasets(), "FilteredData"))
76	181x	new_signature <- c(
77	181x	teal.code::get_code(data_rv()),
78	181x	.get_filter_expr(datasets = datasets(), datanames = active_datanames())
79		)
80	181x	if (!identical(previous_signature(), new_signature)) {
81	87x	previous_signature(new_signature)
82	87x	TRUE
83		} else {
84	94x	FALSE
85		}
86		})
87
88	79x	trigger_data <- reactiveVal(NULL)
89	79x	observe({
90	194x	if (isTRUE(is_active() && filter_changed())) {
91	87x	isolate({
92	87x	if (is.null(trigger_data())) {
93	79x	trigger_data(0)
94		} else {
95	8x	trigger_data(trigger_data() + 1)
96		}
97		})
98		}
99		})
100
101	79x	trigger_data
102		}
103
104		#' @rdname module_filter_data
105		.get_filter_expr <- function(datasets, datanames) {
106	263x	if (length(datanames)) {
107	257x	teal.slice::get_filter_expr(datasets = datasets, datanames = datanames)
108		} else {
109	6x	NULL
110		}
111		}

1		# This is the main function from teal to be used by the end-users. Although it delegates
2		# directly to `module_teal_with_splash.R`, we keep it in a separate file because its documentation is quite large
3		# and it is very end-user oriented. It may also perform more argument checking with more informative
4		# error messages.
5
6		#' Create the server and UI function for the `shiny` app
7		#'
8		#' @description `r lifecycle::badge("stable")`
9		#'
10		#' End-users: This is the most important function for you to start a
11		#' `teal` app that is composed of `teal` modules.
12		#'
13		#' @param data (`teal_data` or `teal_data_module`)
14		#' For constructing the data object, refer to [teal_data()] and [teal_data_module()].
15		#' If `datanames` are not set for the `teal_data` object, defaults from the `teal_data` environment will be used.
16		#' @param modules (`list` or `teal_modules` or `teal_module`)
17		#' Nested list of `teal_modules` or `teal_module` objects or a single
18		#' `teal_modules` or `teal_module` object. These are the specific output modules which
19		#' will be displayed in the `teal` application. See [modules()] and [module()] for
20		#' more details.
21		#' @param filter (`teal_slices`) Optionally,
22		#' specifies the initial filter using [teal_slices()].
23		#' @param title (`shiny.tag` or `character(1)`) Optionally,
24		#' the browser window title. Defaults to a title "teal app" with the icon of NEST.
25		#' Can be created using the `build_app_title()` or
26		#' by passing a valid `shiny.tag` which is a head tag with title and link tag.
27		#' @param header (`shiny.tag` or `character(1)`) Optionally,
28		#' the header of the app.
29		#' @param footer (`shiny.tag` or `character(1)`) Optionally,
30		#' the footer of the app.
31		#' @param id (`character`) Optionally,
32		#' a string specifying the `shiny` module id in cases it is used as a `shiny` module
33		#' rather than a standalone `shiny` app. This is a legacy feature.
34		#' @param landing_popup (`teal_module_landing`) Optionally,
35		#' a `landing_popup_module` to show up as soon as the teal app is initialized.
36		#'
37		#' @return Named list containing server and UI functions.
38		#'
39		#' @export
40		#'
41		#' @include modules.R
42		#'
43		#' @examples
44		#' app <- init(
45		#' data = within(
46		#' teal_data(),
47		#' {
48		#' new_iris <- transform(iris, id = seq_len(nrow(iris)))
49		#' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
50		#' }
51		#' ),
52		#' modules = modules(
53		#' module(
54		#' label = "data source",
55		#' server = function(input, output, session, data) {},
56		#' ui = function(id, ...) tags$div(p("information about data source")),
57		#' datanames = "all"
58		#' ),
59		#' example_module(label = "example teal module"),
60		#' module(
61		#' "Iris Sepal.Length histogram",
62		#' server = function(input, output, session, data) {
63		#' output$hist <- renderPlot(
64		#' hist(data()[["new_iris"]]$Sepal.Length)
65		#' )
66		#' },
67		#' ui = function(id, ...) {
68		#' ns <- NS(id)
69		#' plotOutput(ns("hist"))
70		#' },
71		#' datanames = "new_iris"
72		#' )
73		#' ),
74		#' filter = teal_slices(
75		#' teal_slice(dataname = "new_iris", varname = "Species"),
76		#' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),
77		#' teal_slice(dataname = "new_mtcars", varname = "cyl"),
78		#' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
79		#' module_specific = TRUE,
80		#' mapping = list(
81		#' `example teal module` = "new_iris Species",
82		#' `Iris Sepal.Length histogram` = "new_iris Species",
83		#' global_filters = "new_mtcars cyl"
84		#' )
85		#' ),
86		#' title = "App title",
87		#' header = tags$h1("Sample App"),
88		#' footer = tags$p("Sample footer")
89		#' )
90		#' if (interactive()) {
91		#' shinyApp(app$ui, app$server)
92		#' }
93		#'
94		init <- function(data,
95		modules,
96		filter = teal_slices(),
97		title = build_app_title(),
98		header = tags$p(),
99		footer = tags$p(),
100		id = character(0),
101		landing_popup = NULL) {
102	12x	logger::log_debug("init initializing teal app with: data ('{ class(data) }').")
103
104		# argument checking (independent)
105		## `data`
106	12x	if (inherits(data, "TealData")) {
107	!	lifecycle::deprecate_stop(
108	!	when = "0.15.0",
109	!	what = "init(data)",
110	!	paste(
111	!	"TealData is no longer supported. Use teal_data() instead.",
112	!	"Please follow migration instructions https://github.com/insightsengineering/teal/discussions/988."
113		)
114		)
115		}
116	12x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
117	12x	checkmate::assert_class(landing_popup, "teal_module_landing", null.ok = TRUE)
118
119		## `modules`
120	12x	checkmate::assert(
121	12x	.var.name = "modules",
122	12x	checkmate::check_multi_class(modules, c("teal_modules", "teal_module")),
123	12x	checkmate::check_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
124		)
125	12x	if (inherits(modules, "teal_module")) {
126	1x	modules <- list(modules)
127		}
128	12x	if (checkmate::test_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))) {
129	6x	modules <- do.call(teal::modules, modules)
130		}
131
132		## `filter`
133	12x	checkmate::assert_class(filter, "teal_slices")
134
135		## all other arguments
136	11x	checkmate::assert(
137	11x	.var.name = "title",
138	11x	checkmate::check_string(title),
139	11x	checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
140		)
141	11x	checkmate::assert(
142	11x	.var.name = "header",
143	11x	checkmate::check_string(header),
144	11x	checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
145		)
146	11x	checkmate::assert(
147	11x	.var.name = "footer",
148	11x	checkmate::check_string(footer),
149	11x	checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
150		)
151	11x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
152
153		# log
154	11x	teal.logger::log_system_info()
155
156		# argument transformations
157		## `modules` - landing module
158	11x	landing <- extract_module(modules, "teal_module_landing")
159	11x	if (length(landing) == 1L) {
160	!	landing_popup <- landing[[1L]]
161	!	modules <- drop_module(modules, "teal_module_landing")
162	!	lifecycle::deprecate_soft(
163	!	when = "0.15.3",
164	!	what = "landing_popup_module()",
165	!	details = paste(
166	!	"Pass `landing_popup_module` to the `landing_popup` argument of the `init` ",
167	!	"instead of wrapping it into `modules()` and passing to the `modules` argument"
168		)
169		)
170	11x	} else if (length(landing) > 1L) {
171	!	stop("Only one `landing_popup_module` can be used.")
172		}
173
174		## `filter` - set app_id attribute unless present (when restoring bookmark)
175	11x	if (is.null(attr(filter, "app_id", exact = TRUE))) attr(filter, "app_id") <- create_app_id(data, modules)
176
177		## `filter` - convert teal.slice::teal_slices to teal::teal_slices
178	11x	filter <- as.teal_slices(as.list(filter))
179
180		# argument checking (interdependent)
181		## `filter` - `modules`
182	11x	if (isTRUE(attr(filter, "module_specific"))) {
183	!	module_names <- unlist(c(module_labels(modules), "global_filters"))
184	!	failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)
185	!	if (length(failed_mod_names)) {
186	!	stop(
187	!	sprintf(
188	!	"Some module names in the mapping arguments don't match module labels.\n %s not in %s",
189	!	toString(failed_mod_names),
190	!	toString(unique(module_names))
191		)
192		)
193		}
194
195	!	if (anyDuplicated(module_names)) {
196		# In teal we are able to set nested modules with duplicated label.
197		# Because mapping argument bases on the relationship between module-label and filter-id,
198		# it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)
199	!	stop(
200	!	sprintf(
201	!	"Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",
202	!	toString(module_names[duplicated(module_names)])
203		)
204		)
205		}
206		}
207
208		## `data` - `modules`
209	11x	if (inherits(data, "teal_data")) {
210	10x	if (length(ls(teal.code::get_env(data))) == 0) {
211	1x	stop("The environment of `data` is empty.")
212		}
213
214	9x	is_modules_ok <- check_modules_datanames(modules, ls(teal.code::get_env(data)))
215	9x	if (!isTRUE(is_modules_ok) && length(unlist(extract_transformers(modules))) == 0) {
216	2x	warning(is_modules_ok, call. = FALSE)
217		}
218
219	9x	is_filter_ok <- check_filter_datanames(filter, ls(teal.code::get_env(data)))
220	9x	if (!isTRUE(is_filter_ok)) {
221	1x	warning(is_filter_ok)
222		# we allow app to continue if applied filters are outside
223		# of possible data range
224		}
225		}
226
227	10x	reporter <- teal.reporter::Reporter$new()$set_id(attr(filter, "app_id"))
228	10x	if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
229	!	modules <- append_module(
230	!	modules,
231	!	reporter_previewer_module(server_args = list(previewer_buttons = c("download", "reset")))
232		)
233		}
234
235	10x	ns <- NS(id)
236		# Note: UI must be a function to support bookmarking.
237	10x	res <- list(
238	10x	ui = function(request) {
239	!	ui_teal(
240	!	id = ns("teal"),
241	!	modules = modules,
242	!	title = title,
243	!	header = header,
244	!	footer = footer
245		)
246		},
247	10x	server = function(input, output, session) {
248	!	if (!is.null(landing_popup)) {
249	!	do.call(landing_popup$server, c(list(id = "landing_module_shiny_id"), landing_popup$server_args))
250		}
251	!	srv_teal(id = ns("teal"), data = data, modules = modules, filter = deep_copy_filter(filter))
252		}
253		)
254
255	10x	logger::log_debug("init teal app has been initialized.")
256
257	10x	res
258		}

1		#' Data module for `teal` applications
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' Create a `teal_data_module` object and evaluate code on it with history tracking.
7		#'
8		#' @details
9		#' `teal_data_module` creates a `shiny` module to interactively supply or modify data in a `teal` application.
10		#' The module allows for running any code (creation _and_ some modification) after the app starts or reloads.
11		#' The body of the server function will be run in the app rather than in the global environment.
12		#' This means it will be run every time the app starts, so use sparingly.
13		#'
14		#' Pass this module instead of a `teal_data` object in a call to [init()].
15		#' Note that the server function must always return a `teal_data` object wrapped in a reactive expression.
16		#'
17		#' See vignette `vignette("data-as-shiny-module", package = "teal")` for more details.
18		#'
19		#' @param ui (`function(id)`)
20		#' `shiny` module UI function; must only take `id` argument
21		#' @param server (`function(id)`)
22		#' `shiny` module server function; must only take `id` argument;
23		#' must return reactive expression containing `teal_data` object
24		#' @param label (`character(1)`) Label of the module.
25		#' @param once (`logical(1)`)
26		#' If `TRUE`, the data module will be shown only once and will disappear after successful data loading.
27		#' App user will no longer be able to interact with this module anymore.
28		#' If `FALSE`, the data module can be reused multiple times.
29		#' App user will be able to interact and change the data output from the module multiple times.
30		#'
31		#' @return
32		#' `teal_data_module` returns a list of class `teal_data_module` containing two elements, `ui` and
33		#' `server` provided via arguments.
34		#'
35		#' @examples
36		#' tdm <- teal_data_module(
37		#' ui = function(id) {
38		#' ns <- NS(id)
39		#' actionButton(ns("submit"), label = "Load data")
40		#' },
41		#' server = function(id) {
42		#' moduleServer(id, function(input, output, session) {
43		#' eventReactive(input$submit, {
44		#' data <- within(
45		#' teal_data(),
46		#' {
47		#' dataset1 <- iris
48		#' dataset2 <- mtcars
49		#' }
50		#' )
51		#' datanames(data) <- c("dataset1", "dataset2")
52		#'
53		#' data
54		#' })
55		#' })
56		#' }
57		#' )
58		#'
59		#' @name teal_data_module
60		#' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]
61		#'
62		#' @export
63		teal_data_module <- function(ui, server, label = "data module", once = TRUE) {
64	33x	checkmate::assert_function(ui, args = "id", nargs = 1)
65	32x	checkmate::assert_function(server, args = "id", nargs = 1)
66	30x	checkmate::assert_string(label)
67	30x	checkmate::assert_flag(once)
68	30x	structure(
69	30x	list(
70	30x	ui = ui,
71	30x	server = function(id) {
72	23x	data_out <- server(id)
73	22x	decorate_err_msg(
74	22x	assert_reactive(data_out),
75	22x	pre = sprintf("From: 'teal_data_module()':\nA 'teal_data_module' with \"%s\" label:", label),
76	22x	post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
77		)
78		}
79		),
80	30x	label = label,
81	30x	class = "teal_data_module",
82	30x	once = once
83		)
84		}
85
86		#' Data module for `teal` transformers.
87		#'
88		#' @description
89		#' `r lifecycle::badge("experimental")`
90		#'
91		#' Create a `teal_data_module` object for custom transformation of data for pre-processing
92		#' before passing the data into the module.
93		#'
94		#' @details
95		#' `teal_transform_module` creates a [`teal_data_module`] object to transform data in a `teal`
96		#' application. This transformation happens after the data has passed through the filtering activity
97		#' in teal. The transformed data is then sent to the server of the [teal_module()].
98		#'
99		#' See vignette `vignette("data-transform-as-shiny-module", package = "teal")` for more details.
100		#'
101		#'
102		#' @inheritParams teal_data_module
103		#' @param server (`function(id, data)`)
104		#' `shiny` module server function; that takes `id` and `data` argument,
105		#' where the `id` is the module id and `data` is the reactive `teal_data` input.
106		#' The server function must return reactive expression containing `teal_data` object.
107		#'
108		#' The server function definition should not use `eventReactive` as it may lead to
109		#' unexpected behavior.
110		#' See `vignettes("data-transform-as-shiny-module")` for more information.
111		#' @param datanames (`character`)
112		#' Names of the datasets that are relevant for this module to evaluate. If set to `character(0)`
113		#' then module would receive [modules()] `datanames`.
114		#' @examples
115		#' my_transformers <- list(
116		#' teal_transform_module(
117		#' label = "Custom transform for iris",
118		#' datanames = "iris",
119		#' ui = function(id) {
120		#' ns <- NS(id)
121		#' tags$div(
122		#' numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
123		#' )
124		#' },
125		#' server = function(id, data) {
126		#' moduleServer(id, function(input, output, session) {
127		#' reactive({
128		#' within(data(),
129		#' {
130		#' iris <- head(iris, num_rows)
131		#' },
132		#' num_rows = input$n_rows
133		#' )
134		#' })
135		#' })
136		#' }
137		#' )
138		#' )
139		#'
140		#' @name teal_transform_module
141		#'
142		#' @export
143		teal_transform_module <- function(ui = function(id) NULL,
144		server = function(id, data) data,
145		label = "transform module",
146		datanames = character(0)) {
147	19x	checkmate::assert_function(ui, args = "id", nargs = 1)
148	19x	checkmate::assert_function(server, args = c("id", "data"), nargs = 2)
149	19x	checkmate::assert_string(label)
150	19x	checkmate::assert_character(datanames)
151	19x	if (identical(datanames, "all")) {
152	1x	stop(
153	1x	"teal_transform_module can't have datanames property equal to 'all'. Set `datanames = character(0)` instead.",
154	1x	call. = FALSE
155		)
156		}
157	18x	structure(
158	18x	list(
159	18x	ui = ui,
160	18x	server = function(id, data) {
161	19x	data_out <- server(id, data)
162
163	19x	if (inherits(data_out, "reactive.event")) {
164		# This warning message partially detects when `eventReactive` is used in `data_module`.
165	1x	warning(
166	1x	"teal_transform_module() ",
167	1x	"Using eventReactive in teal_transform module server code should be avoided as it ",
168	1x	"may lead to unexpected behavior. See the vignettes for more information ",
169	1x	"(`vignette(\"data-transform-as-shiny-module\", package = \"teal\")`).",
170	1x	call. = FALSE
171		)
172		}
173
174	19x	decorate_err_msg(
175	19x	assert_reactive(data_out),
176	19x	pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
177	19x	post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
178		)
179		}
180		),
181	18x	label = label,
182	18x	datanames = datanames,
183	18x	class = c("teal_transform_module", "teal_data_module")
184		)
185		}
186
187
188		#' Extract all `transformers` from `modules`.
189		#'
190		#' @param modules `teal_modules` or `teal_module`
191		#' @return A list of `teal_transform_module` nested in the same way as input `modules`.
192		#' @keywords internal
193		extract_transformers <- function(modules) {
194	6x	if (inherits(modules, "teal_module")) {
195	3x	modules$transformers
196	3x	} else if (inherits(modules, "teal_modules")) {
197	3x	lapply(modules$children, extract_transformers)
198		}
199		}

1		#' An example `teal` module
2		#'
3		#' `r lifecycle::badge("experimental")`
4		#'
5		#' @inheritParams teal_modules
6		#' @return A `teal` module which can be included in the `modules` argument to [init()].
7		#' @examples
8		#' app <- init(
9		#' data = teal_data(IRIS = iris, MTCARS = mtcars),
10		#' modules = example_module()
11		#' )
12		#' if (interactive()) {
13		#' shinyApp(app$ui, app$server)
14		#' }
15		#' @export
16		example_module <- function(label = "example teal module", datanames = "all", transformers = list()) {
17	38x	checkmate::assert_string(label)
18	38x	ans <- module(
19	38x	label,
20	38x	server = function(id, data) {
21	2x	checkmate::assert_class(isolate(data()), "teal_data")
22	2x	moduleServer(id, function(input, output, session) {
23	2x	datanames_rv <- reactive(ls(teal.code::get_env((req(data())))))
24	2x	observeEvent(datanames_rv(), {
25	2x	selected <- input$dataname
26	2x	if (identical(selected, "")) {
27	!	selected <- restoreInput(session$ns("dataname"), NULL)
28	2x	} else if (isFALSE(selected %in% datanames_rv())) {
29	!	selected <- datanames_rv()[1]
30		}
31	2x	updateSelectInput(
32	2x	session = session,
33	2x	inputId = "dataname",
34	2x	choices = datanames_rv(),
35	2x	selected = selected
36		)
37		})
38
39	2x	output$text <- renderPrint({
40	2x	req(input$dataname)
41	!	data()[[input$dataname]]
42		})
43
44	2x	teal.widgets::verbatim_popup_srv(
45	2x	id = "rcode",
46	2x	verbatim_content = reactive(teal.code::get_code(data())),
47	2x	title = "Example Code"
48		)
49		})
50		},
51	38x	ui = function(id) {
52	!	ns <- NS(id)
53	!	teal.widgets::standard_layout(
54	!	output = verbatimTextOutput(ns("text")),
55	!	encoding = tags$div(
56	!	selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
57	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
58		)
59		)
60		},
61	38x	datanames = datanames,
62	38x	transformers = transformers
63		)
64	38x	attr(ans, "teal_bookmarkable") <- TRUE
65	38x	ans
66		}

1		setOldClass("teal_data_module")
2
3		#' Evaluate code on `teal_data_module`
4		#'
5		#' @details
6		#' `eval_code` evaluates given code in the environment of the `teal_data` object created by the `teal_data_module`.
7		#' The code is added to the `@code` slot of the `teal_data`.
8		#'
9		#' @param object (`teal_data_module`)
10		#' @inheritParams teal.code::eval_code
11		#'
12		#' @return
13		#' `eval_code` returns a `teal_data_module` object with a delayed evaluation of `code` when the module is run.
14		#'
15		#' @examples
16		#' eval_code(tdm, "dataset1 <- subset(dataset1, Species == 'virginica')")
17		#'
18		#' @include teal_data_module.R
19		#' @name eval_code
20		#' @rdname teal_data_module
21		#' @aliases eval_code,teal_data_module,character-method
22		#' @aliases eval_code,teal_data_module,language-method
23		#' @aliases eval_code,teal_data_module,expression-method
24		#'
25		#' @importFrom methods setMethod
26		#' @importMethodsFrom teal.code eval_code
27		#'
28		setMethod("eval_code", signature = c("teal_data_module", "character"), function(object, code) {
29	9x	teal_data_module(
30	9x	ui = function(id) {
31	1x	ns <- NS(id)
32	1x	object$ui(ns("mutate_inner"))
33		},
34	9x	server = function(id) {
35	7x	moduleServer(id, function(input, output, session) {
36	7x	teal_data_rv <- object$server("mutate_inner")
37	6x	td <- eventReactive(teal_data_rv(),
38		{
39	6x	if (inherits(teal_data_rv(), c("teal_data", "qenv.error"))) {
40	4x	eval_code(teal_data_rv(), code)
41		} else {
42	2x	teal_data_rv()
43		}
44		},
45	6x	ignoreNULL = FALSE
46		)
47	6x	td
48		})
49		}
50		)
51		})
52
53		setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
54	1x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
55		})
56
57		setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
58	2x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
59		})

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	!	css_files <- list.files(
13	!	system.file("css", package = "teal", mustWork = TRUE),
14	!	pattern = pattern, full.names = TRUE
15		)
16
17	!	singleton(
18	!	tags$head(lapply(css_files, includeCSS))
19		)
20		}
21
22		#' Include `JS` files from `/inst/js/` package directory to application header
23		#'
24		#' `system.file` should not be used to access files in other packages, it does
25		#' not work with `devtools`. Therefore, we redefine this method in each package
26		#' as needed. Thus, we do not export this method
27		#'
28		#' @param pattern (`character`) pattern of files to be included, passed to `system.file`
29		#' @param except (`character`) vector of basename filenames to be excluded
30		#'
31		#' @return HTML code that includes `JS` files.
32		#' @keywords internal
33		include_js_files <- function(pattern = NULL, except = NULL) {
34	!	checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)
35	!	js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
36	!	js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL
37
38	!	singleton(lapply(js_files, includeScript))
39		}
40
41		#' Run `JS` file from `/inst/js/` package directory
42		#'
43		#' This is triggered from the server to execute on the client
44		#' rather than triggered directly on the client.
45		#' Unlike `include_js_files` which includes `JavaScript` functions,
46		#' the `run_js` actually executes `JavaScript` functions.
47		#'
48		#' `system.file` should not be used to access files in other packages, it does
49		#' not work with `devtools`. Therefore, we redefine this method in each package
50		#' as needed. Thus, we do not export this method.
51		#'
52		#' @param files (`character`) vector of filenames.
53		#'
54		#' @return `NULL`, invisibly.
55		#' @keywords internal
56		run_js_files <- function(files) {
57	81x	checkmate::assert_character(files, min.len = 1, any.missing = FALSE)
58	81x	lapply(files, function(file) {
59	81x	shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
60		})
61	81x	invisible(NULL)
62		}
63
64		#' Code to include `teal` `CSS` and `JavaScript` files
65		#'
66		#' This is useful when you want to use the same `JavaScript` and `CSS` files that are
67		#' used with the `teal` application.
68		#' This is also useful for running standalone modules in `teal` with the correct
69		#' styles.
70		#' Also initializes `shinyjs` so you can use it.
71		#'
72		#' Simply add `include_teal_css_js()` as one of the UI elements.
73		#' @return A `shiny.tag.list`.
74		#' @keywords internal
75		include_teal_css_js <- function() {
76	!	tagList(
77	!	shinyjs::useShinyjs(),
78	!	include_css_files(),
79		# init.js is executed from the server
80	!	include_js_files(except = "init.js"),
81	!	shinyjs::hidden(icon("fas fa-gear")), # add hidden icon to load font-awesome css for icons
82		)
83		}

1		#' `teal_data` utils
2		#'
3		#' In `teal` we need to recreate the `teal_data` object due to two operations:
4		#' - we need to append filter-data code and objects which have been evaluated in `FilteredData` and
5		#' we want to avoid double-evaluation.
6		#' - we need to subset `teal_data` to `datanames` used by the module, to shorten obtainable R-code
7		#'
8		#' Due to above recreation of `teal_data` object can't be done simply by using public
9		#' `teal.code` and `teal.data` methods.
10		#'
11		#' @param data (`teal_data`)
12		#' @param code (`character`) code to append to `data@code`
13		#' @param objects (`list`) objects to append to `data@env`
14		#' @param datanames (`character`) names of the datasets
15		#' @return modified `teal_data`
16		#' @keywords internal
17		#' @name teal_data_utilities
18		NULL
19
20		#' @rdname teal_data_utilities
21		.append_evaluated_code <- function(data, code) {
22	82x	checkmate::assert_class(data, "teal_data")
23	82x	data@code <- c(data@code, code)
24	82x	data@id <- c(data@id, max(data@id) + 1L + seq_along(code))
25	82x	data@messages <- c(data@messages, rep("", length(code)))
26	82x	data@warnings <- c(data@warnings, rep("", length(code)))
27	82x	methods::validObject(data)
28	82x	data
29		}
30
31		#' @rdname teal_data_utilities
32		.append_modified_data <- function(data, objects) {
33	82x	checkmate::assert_class(data, "teal_data")
34	82x	checkmate::assert_class(objects, "list")
35	82x	new_env <- list2env(objects, parent = .GlobalEnv)
36	82x	rlang::env_coalesce(new_env, teal.code::get_env(data))
37	82x	data@env <- new_env
38	82x	data
39		}
40
41		#' @rdname teal_data_utilities
42		.subset_teal_data <- function(data, datanames) {
43	81x	checkmate::assert_class(data, "teal_data")
44	81x	checkmate::assert_class(datanames, "character")
45	81x	datanames_corrected <- intersect(datanames, ls(teal.code::get_env(data)))
46	81x	datanames_corrected_with_raw <- c(datanames_corrected, ".raw_data")
47	81x	if (!length(datanames_corrected)) {
48	2x	return(teal_data())
49		}
50
51	79x	new_data <- do.call(
52	79x	teal.data::teal_data,
53	79x	args = c(
54	79x	mget(x = datanames_corrected_with_raw, envir = teal.code::get_env(data)),
55	79x	list(
56	79x	code = teal.code::get_code(data, names = datanames_corrected_with_raw),
57	79x	join_keys = teal.data::join_keys(data)[datanames_corrected]
58		)
59		)
60		)
61	79x	new_data@verified <- data@verified
62	79x	teal.data::datanames(new_data) <- datanames_corrected
63	79x	new_data
64		}

1		#' Filter settings for `teal` applications
2		#'
3		#' Specify initial filter states and filtering settings for a `teal` app.
4		#'
5		#' Produces a `teal_slices` object.
6		#' The `teal_slice` components will specify filter states that will be active when the app starts.
7		#' Attributes (created with the named arguments) will configure the way the app applies filters.
8		#' See argument descriptions for details.
9		#'
10		#' @inheritParams teal.slice::teal_slices
11		#'
12		#' @param module_specific (`logical(1)`) optional,
13		#' - `FALSE` (default) when one filter panel applied to all modules.
14		#' All filters will be shared by all modules.
15		#' - `TRUE` when filter panel module-specific.
16		#' Modules can have different set of filters specified - see `mapping` argument.
17		#' @param mapping `r lifecycle::badge("experimental")`
18		#' _This is a new feature. Do kindly share your opinions on
19		#' [`teal`'s GitHub repository](https://github.com/insightsengineering/teal/)._
20		#'
21		#' (named `list`) specifies which filters will be active in which modules on app start.
22		#' Elements should contain character vector of `teal_slice` `id`s (see [`teal.slice::teal_slice`]).
23		#' Names of the list should correspond to `teal_module` `label` set in [module()] function.
24		#' - `id`s listed under `"global_filters` will be active in all modules.
25		#' - If missing, all filters will be applied to all modules.
26		#' - If empty list, all filters will be available to all modules but will start inactive.
27		#' - If `module_specific` is `FALSE`, only `global_filters` will be active on start.
28		#' @param app_id (`character(1)`)
29		#' For internal use only, do not set manually.
30		#' Added by `init` so that a `teal_slices` can be matched to the app in which it was used.
31		#' Used for verifying snapshots uploaded from file. See `snapshot`.
32		#'
33		#' @param x (`list`) of lists to convert to `teal_slices`
34		#'
35		#' @return
36		#' A `teal_slices` object.
37		#'
38		#' @seealso [`teal.slice::teal_slices`], [`teal.slice::teal_slice`], [slices_store()]
39		#'
40		#' @examples
41		#' filter <- teal_slices(
42		#' teal_slice(dataname = "iris", varname = "Species", id = "species"),
43		#' teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),
44		#' teal_slice(
45		#' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"
46		#' ),
47		#' teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),
48		#' mapping = list(
49		#' module1 = c("species", "sepal_length"),
50		#' module2 = c("mtcars_mpg"),
51		#' global_filters = "long_petals"
52		#' )
53		#' )
54		#'
55		#' app <- init(
56		#' data = teal_data(iris = iris, mtcars = mtcars),
57		#' modules = list(
58		#' module("module1"),
59		#' module("module2")
60		#' ),
61		#' filter = filter
62		#' )
63		#'
64		#' if (interactive()) {
65		#' shinyApp(app$ui, app$server)
66		#' }
67		#'
68		#' @export
69		teal_slices <- function(...,
70		exclude_varnames = NULL,
71		include_varnames = NULL,
72		count_type = NULL,
73		allow_add = TRUE,
74		module_specific = FALSE,
75		mapping,
76		app_id = NULL) {
77	159x	shiny::isolate({
78	159x	checkmate::assert_flag(allow_add)
79	159x	checkmate::assert_flag(module_specific)
80	51x	if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
81	156x	checkmate::assert_string(app_id, null.ok = TRUE)
82
83	156x	slices <- list(...)
84	156x	all_slice_id <- vapply(slices, `[[`, character(1L), "id")
85
86	156x	if (missing(mapping)) {
87	108x	mapping <- if (length(all_slice_id)) {
88	26x	list(global_filters = all_slice_id)
89		} else {
90	82x	list()
91		}
92		}
93
94	156x	if (!module_specific) {
95	137x	mapping[setdiff(names(mapping), "global_filters")] <- NULL
96		}
97
98	156x	failed_slice_id <- setdiff(unlist(mapping), all_slice_id)
99	156x	if (length(failed_slice_id)) {
100	1x	stop(sprintf(
101	1x	"Filters in mapping don't match any available filter.\n %s not in %s",
102	1x	toString(failed_slice_id),
103	1x	toString(all_slice_id)
104		))
105		}
106
107	155x	tss <- teal.slice::teal_slices(
108		...,
109	155x	exclude_varnames = exclude_varnames,
110	155x	include_varnames = include_varnames,
111	155x	count_type = count_type,
112	155x	allow_add = allow_add
113		)
114	155x	attr(tss, "mapping") <- mapping
115	155x	attr(tss, "module_specific") <- module_specific
116	155x	attr(tss, "app_id") <- app_id
117	155x	class(tss) <- c("modules_teal_slices", class(tss))
118	155x	tss
119		})
120		}
121
122
123		#' @rdname teal_slices
124		#' @export
125		#' @keywords internal
126		#'
127		as.teal_slices <- function(x) { # nolint: object_name.
128	13x	checkmate::assert_list(x)
129	13x	lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")
130
131	13x	attrs <- attributes(unclass(x))
132	13x	ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))
133	13x	do.call(teal_slices, c(ans, attrs))
134		}
135
136
137		#' @rdname teal_slices
138		#' @export
139		#' @keywords internal
140		#'
141		c.teal_slices <- function(...) {
142	6x	x <- list(...)
143	6x	checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")
144
145	6x	all_attributes <- lapply(x, attributes)
146	6x	all_attributes <- coalesce_r(all_attributes)
147	6x	all_attributes <- all_attributes[names(all_attributes) != "class"]
148
149	6x	do.call(
150	6x	teal_slices,
151	6x	c(
152	6x	unique(unlist(x, recursive = FALSE)),
153	6x	all_attributes
154		)
155		)
156		}
157
158
159		#' Deep copy `teal_slices`
160		#'
161		#' it's important to create a new copy of `teal_slices` when
162		#' starting a new `shiny` session. Otherwise, object will be shared
163		#' by multiple users as it is created in global environment before
164		#' `shiny` session starts.
165		#' @param filter (`teal_slices`)
166		#' @return `teal_slices`
167		#' @keywords internal
168		deep_copy_filter <- function(filter) {
169	1x	checkmate::assert_class(filter, "teal_slices")
170	1x	shiny::isolate({
171	1x	filter_copy <- lapply(filter, function(slice) {
172	2x	teal.slice::as.teal_slice(as.list(slice))
173		})
174	1x	attributes(filter_copy) <- attributes(filter)
175	1x	filter_copy
176		})
177		}

1		#' Data summary
2		#' @description
3		#' Module and its utils to display the number of rows and subjects in the filtered and unfiltered data.
4		#'
5		#' @details Handling different data classes:
6		#' `get_object_filter_overview()` is a pseudo S3 method which has variants for:
7		#' - `array` (`data.frame`, `DataFrame`, `array`, `Matrix` and `SummarizedExperiment`): Method variant
8		#' can be applied to any two-dimensional objects on which [ncol()] can be used.
9		#' - `MultiAssayExperiment`: for which summary contains counts for `colData` and all `experiments`.
10		#'
11		#' @param id (`character(1)`)
12		#' `shiny` module instance id.
13		#' @param teal_data (`reactive` returning `teal_data`)
14		#'
15		#'
16		#' @name module_data_summary
17		#' @rdname module_data_summary
18		#' @keywords internal
19		#' @return `NULL`.
20		NULL
21
22		#' @rdname module_data_summary
23		ui_data_summary <- function(id) {
24	!	ns <- NS(id)
25	!	content_id <- ns("filters_overview_contents")
26	!	tags$div(
27	!	id = id,
28	!	class = "well",
29	!	tags$div(
30	!	class = "row",
31	!	tags$div(
32	!	class = "col-sm-9",
33	!	tags$label("Active Filter Summary", class = "text-primary mb-4")
34		),
35	!	tags$div(
36	!	class = "col-sm-3",
37	!	tags$i(
38	!	class = "remove pull-right fa fa-angle-down",
39	!	style = "cursor: pointer;",
40	!	title = "fold/expand data summary panel",
41	!	onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", content_id)
42		)
43		)
44		),
45	!	tags$div(
46	!	id = content_id,
47	!	tags$div(
48	!	class = "teal_active_summary_filter_panel",
49	!	tableOutput(ns("table"))
50		)
51		)
52		)
53		}
54
55		#' @rdname module_data_summary
56		srv_data_summary <- function(id, teal_data) {
57	79x	assert_reactive(teal_data)
58	79x	moduleServer(
59	79x	id = id,
60	79x	function(input, output, session) {
61	79x	logger::log_debug("srv_data_summary initializing")
62
63	79x	summary_table <- reactive({
64	87x	req(inherits(teal_data(), "teal_data"))
65	81x	if (!length(ls(teal.code::get_env(teal_data())))) {
66	2x	return(NULL)
67		}
68
69	79x	filter_overview <- get_filter_overview(teal_data)
70	79x	names(filter_overview)[[1]] <- "Data Name"
71
72	79x	filter_overview$Obs <- ifelse(
73	79x	!is.na(filter_overview$obs),
74	79x	sprintf("%s/%s", filter_overview$obs_filtered, filter_overview$obs),
75	79x	ifelse(!is.na(filter_overview$obs_filtered), sprintf("%s", filter_overview$obs_filtered), "")
76		)
77
78	79x	filter_overview$Subjects <- ifelse(
79	79x	!is.na(filter_overview$subjects),
80	79x	sprintf("%s/%s", filter_overview$subjects_filtered, filter_overview$subjects),
81		""
82		)
83
84	79x	filter_overview <- filter_overview[, colnames(filter_overview) %in% c("Data Name", "Obs", "Subjects")]
85	79x	Filter(function(col) !all(col == ""), filter_overview)
86		})
87
88	79x	output$table <- renderUI({
89	87x	summary_table_out <- try(summary_table(), silent = TRUE)
90	87x	if (inherits(summary_table_out, "try-error")) {
91		# Ignore silent shiny error
92	6x	if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
93	!	stop("Error occurred during data processing. See details in the main panel.")
94		}
95	81x	} else if (is.null(summary_table_out)) {
96	2x	"no datasets to show"
97		} else {
98	79x	body_html <- apply(
99	79x	summary_table_out,
100	79x	1,
101	79x	function(x) {
102	142x	tags$tr(
103	142x	tagList(
104	142x	tags$td(
105	142x	if (all(x[-1] == "")) {
106	5x	icon(
107	5x	name = "fas fa-exclamation-triangle",
108	5x	title = "Unsupported dataset",
109	5x	`data-container` = "body",
110	5x	`data-toggle` = "popover",
111	5x	`data-content` = "object not supported by the data_summary module"
112		)
113		},
114	142x	x[1]
115		),
116	142x	lapply(x[-1], tags$td)
117		)
118		)
119		}
120		)
121
122	79x	header_labels <- names(summary_table())
123	79x	header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))
124
125	79x	table_html <- tags$table(
126	79x	class = "table custom-table",
127	79x	tags$thead(header_html),
128	79x	tags$tbody(body_html)
129		)
130	79x	table_html
131		}
132		})
133
134	79x	summary_table # testing purpose
135		}
136		)
137		}
138
139		#' @rdname module_data_summary
140		get_filter_overview <- function(teal_data) {
141	79x	datanames <- teal.data::datanames(teal_data())
142	79x	joinkeys <- teal.data::join_keys(teal_data())
143
144	79x	filtered_data_objs <- sapply(
145	79x	datanames,
146	79x	function(name) teal.code::get_var(teal_data(), name),
147	79x	simplify = FALSE
148		)
149	79x	unfiltered_data_objs <- teal.code::get_var(teal_data(), ".raw_data")
150
151	79x	rows <- lapply(
152	79x	datanames,
153	79x	function(dataname) {
154	142x	parent <- teal.data::parent(joinkeys, dataname)
155		# todo: what should we display for a parent dataset?
156		# - Obs and Subjects
157		# - Obs only
158		# - Subjects only
159		# todo (for later): summary table should be displayed in a way that child datasets
160		# are indented under their parent dataset to form a tree structure
161	142x	subject_keys <- if (length(parent) > 0) {
162	7x	names(joinkeys[dataname, parent])
163		} else {
164	135x	joinkeys[dataname, dataname]
165		}
166	142x	get_object_filter_overview(
167	142x	filtered_data = filtered_data_objs[[dataname]],
168	142x	unfiltered_data = unfiltered_data_objs[[dataname]],
169	142x	dataname = dataname,
170	142x	subject_keys = subject_keys
171		)
172		}
173		)
174
175	79x	unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1)) # this is mainly for vectors
176	79x	do.call(rbind, c(rows[!unssuported_idx], rows[unssuported_idx]))
177		}
178
179		#' @rdname module_data_summary
180		#' @param filtered_data (`list`) of filtered objects
181		#' @param unfiltered_data (`list`) of unfiltered objects
182		#' @param dataname (`character(1)`)
183		get_object_filter_overview <- function(filtered_data, unfiltered_data, dataname, subject_keys) {
184	142x	if (inherits(filtered_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
185	137x	get_object_filter_overview_array(filtered_data, unfiltered_data, dataname, subject_keys)
186	5x	} else if (inherits(filtered_data, "MultiAssayExperiment")) {
187	!	get_object_filter_overview_MultiAssayExperiment(filtered_data, unfiltered_data, dataname)
188		} else {
189	5x	data.frame(
190	5x	dataname = dataname,
191	5x	obs = NA,
192	5x	obs_filtered = NA,
193	5x	subjects = NA,
194	5x	subjects_filtered = NA
195		)
196		}
197		}
198
199		#' @rdname module_data_summary
200		get_object_filter_overview_array <- function(filtered_data, # nolint: object_length.
201		unfiltered_data,
202		dataname,
203		subject_keys) {
204	137x	if (length(subject_keys) == 0) {
205	124x	data.frame(
206	124x	dataname = dataname,
207	124x	obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
208	124x	obs_filtered = nrow(filtered_data),
209	124x	subjects = NA,
210	124x	subjects_filtered = NA
211		)
212		} else {
213	13x	data.frame(
214	13x	dataname = dataname,
215	13x	obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
216	13x	obs_filtered = nrow(filtered_data),
217	13x	subjects = nrow(unique(unfiltered_data[subject_keys])),
218	13x	subjects_filtered = nrow(unique(filtered_data[subject_keys]))
219		)
220		}
221		}
222
223		#' @rdname module_data_summary
224		get_object_filter_overview_MultiAssayExperiment <- function(filtered_data, # nolint: object_length, object_name.
225		unfiltered_data,
226		dataname) {
227	!	experiment_names <- names(unfiltered_data)
228	!	mae_info <- data.frame(
229	!	dataname = dataname,
230	!	obs = NA,
231	!	obs_filtered = NA,
232	!	subjects = nrow(unfiltered_data@colData),
233	!	subjects_filtered = nrow(filtered_data@colData)
234		)
235
236	!	experiment_obs_info <- do.call("rbind", lapply(
237	!	experiment_names,
238	!	function(experiment_name) {
239	!	transform(
240	!	get_object_filter_overview(
241	!	filtered_data[[experiment_name]],
242	!	unfiltered_data[[experiment_name]],
243	!	dataname = experiment_name,
244	!	subject_keys = join_keys() # empty join keys
245		),
246	!	dataname = paste0(" - ", experiment_name)
247		)
248		}
249		))
250
251	!	get_experiment_keys <- function(mae, experiment) {
252	!	sample_subset <- mae@sampleMap[mae@sampleMap$colname %in% colnames(experiment), ]
253	!	length(unique(sample_subset$primary))
254		}
255
256	!	experiment_subjects_info <- do.call("rbind", lapply(
257	!	experiment_names,
258	!	function(experiment_name) {
259	!	data.frame(
260	!	subjects = get_experiment_keys(filtered_data, unfiltered_data[[experiment_name]]),
261	!	subjects_filtered = get_experiment_keys(filtered_data, filtered_data[[experiment_name]])
262		)
263		}
264		))
265
266	!	experiment_info <- cbind(experiment_obs_info[, c("dataname", "obs", "obs_filtered")], experiment_subjects_info)
267	!	rbind(mae_info, experiment_info)
268		}

1		#' UI and server modules of `teal`
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#' Please use [`module_teal`] instead.
5		#'
6		#' @inheritParams ui_teal
7		#' @inheritParams srv_teal
8		#'
9		#' @return
10		#' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not.
11		#' @name module_teal_with_splash
12		#'
13		NULL
14
15		#' @export
16		#' @rdname module_teal_with_splash
17		ui_teal_with_splash <- function(id,
18		data,
19		title = build_app_title(),
20		header = tags$p(),
21		footer = tags$p()) {
22	!	lifecycle::deprecate_soft(
23	!	when = "0.16",
24	!	what = "ui_teal_with_splash()",
25	!	details = "Deprecated, please use `ui_teal` instead"
26		)
27	!	ui_teal(id = id, title = title, header = header, footer = footer)
28		}
29
30		#' @export
31		#' @rdname module_teal_with_splash
32		srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
33	!	lifecycle::deprecate_soft(
34	!	when = "0.16",
35	!	what = "srv_teal_with_splash()",
36	!	details = "Deprecated, please use `srv_teal` instead"
37		)
38	!	srv_teal(id = id, data = data, modules = modules, filter = filter)
39		}

1		#' Data Module for teal
2		#'
3		#' This module manages the `data` argument for `srv_teal`. The `teal` framework uses [teal_data()],
4		#' which can be provided in various ways:
5		#' 1. Directly as a [teal.data::teal_data()] object. This will automatically convert it into a `reactive` `teal_data`.
6		#' 2. As a `reactive` object that returns a [teal.data::teal_data()] object.
7		#'
8		#' @details
9		#' ## Reactive `teal_data`:
10		#'
11		#' The data in the application can be reactively updated, prompting [srv_teal()] to rebuild the
12		#' content accordingly. There are two methods for creating interactive `teal_data`:
13		#' 1. Using a `reactive` object provided from outside the `teal` application. In this scenario,
14		#' reactivity is controlled by an external module, and `srv_teal` responds to changes.
15		#' 2. Using [teal_data_module()], which is embedded within the `teal` application, allowing data to
16		#' be resubmitted by the user as needed.
17		#'
18		#' Since the server of [teal_data_module()] must return a `reactive` `teal_data` object, both
19		#' methods (1 and 2) produce the same reactive behavior within a `teal` application. The distinction
20		#' lies in data control: the first method involves external control, while the second method
21		#' involves control from a custom module within the app.
22		#'
23		#' For more details, see [`module_teal_data`].
24		#'
25		#' @inheritParams init
26		#'
27		#' @param data (`teal_data`, `teal_data_module`, or `reactive` returning `teal_data`)
28		#' The data which application will depend on.
29		#'
30		#' @return A `reactive` object that returns:
31		#' Output of the `data`. If `data` fails then returned error is handled (after [tryCatch()]) so that
32		#' rest of the application can respond to this respectively.
33		#'
34		#' @rdname module_init_data
35		#' @name module_init_data
36		#' @keywords internal
37		NULL
38
39		#' @rdname module_init_data
40		ui_init_data <- function(id) {
41	9x	ns <- shiny::NS(id)
42	9x	shiny::div(
43	9x	id = ns("content"),
44	9x	style = "display: inline-block; width: 100%;",
45	9x	uiOutput(ns("data"))
46		)
47		}
48
49		#' @rdname module_init_data
50		srv_init_data <- function(id, data) {
51	81x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
52	81x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
53
54	81x	moduleServer(id, function(input, output, session) {
55	81x	logger::log_debug("srv_data initializing.")
56		# data_rv contains teal_data object
57		# either passed to teal::init or returned from teal_data_module
58	81x	data_out <- if (inherits(data, "teal_data_module")) {
59	10x	output$data <- renderUI(data$ui(id = session$ns("teal_data_module")))
60	10x	data$server("teal_data_module")
61	81x	} else if (inherits(data, "teal_data")) {
62	41x	reactiveVal(data)
63	81x	} else if (test_reactive(data)) {
64	30x	data
65		}
66
67	80x	data_handled <- reactive({
68	73x	tryCatch(data_out(), error = function(e) e)
69		})
70
71		# We want to exclude teal_data_module elements from bookmarking as they might have some secrets
72	80x	observeEvent(data_handled(), {
73	73x	if (inherits(data_handled(), "teal_data")) {
74	68x	app_session <- .subset2(shiny::getDefaultReactiveDomain(), "parent")
75	68x	setBookmarkExclude(
76	68x	session$ns(
77	68x	grep(
78	68x	pattern = "teal_data_module-",
79	68x	x = names(reactiveValuesToList(input)),
80	68x	value = TRUE
81		)
82		),
83	68x	session = app_session
84		)
85		}
86		})
87
88	80x	data_handled
89		})
90		}
91
92		#' Adds signature protection to the `datanames` in the data
93		#' @param data (`teal_data`)
94		#' @return `teal_data` with additional code that has signature of the `datanames`
95		#' @keywords internal
96		.add_signature_to_data <- function(data) {
97	68x	hashes <- .get_hashes_code(data)
98
99	68x	tdata <- do.call(
100	68x	teal.data::teal_data,
101	68x	c(
102	68x	list(code = trimws(c(teal.code::get_code(data), hashes), which = "right")),
103	68x	list(join_keys = teal.data::join_keys(data)),
104	68x	sapply(
105	68x	ls(teal.code::get_env(data)),
106	68x	teal.code::get_var,
107	68x	object = data,
108	68x	simplify = FALSE
109		)
110		)
111		)
112
113	68x	tdata@verified <- data@verified
114	68x	tdata
115		}
116
117		#' Get code that tests the integrity of the reproducible data
118		#'
119		#' @param data (`teal_data`) object holding the data
120		#' @param datanames (`character`) names of `datasets`
121		#'
122		#' @return A character vector with the code lines.
123		#' @keywords internal
124		#'
125		.get_hashes_code <- function(data, datanames = ls(teal.code::get_env(data))) {
126	68x	vapply(
127	68x	datanames,
128	68x	function(dataname, datasets) {
129	119x	x <- data[[dataname]]
130
131	119x	code <- if (is.function(x) && !is.primitive(x)) {
132	4x	x <- deparse1(x)
133	4x	bquote(rlang::hash(deparse1(.(as.name(dataname)))))
134		} else {
135	115x	bquote(rlang::hash(.(as.name(dataname))))
136		}
137	119x	sprintf(
138	119x	"stopifnot(%s == %s) # @linksto %s",
139	119x	deparse1(code),
140	119x	deparse1(rlang::hash(x)),
141	119x	dataname
142		)
143		},
144	68x	character(1L),
145	68x	USE.NAMES = TRUE
146		)
147		}

1		#' Store and restore `teal_slices` object
2		#'
3		#' Functions that write a `teal_slices` object to a file in the `JSON` format,
4		#' and also restore the object from disk.
5		#'
6		#' Date and date time objects are stored in the following formats:
7		#'
8		#' - `Date` class is converted to the `"ISO8601"` standard (`YYYY-MM-DD`).
9		#' - `POSIX*t` classes are converted to character by using
10		#' `format.POSIX*t(usetz = TRUE, tz = "UTC")` (`YYYY-MM-DD HH:MM:SS UTC`, where
11		#' `UTC` is the `Coordinated Universal Time` timezone short-code).
12		#'
13		#' This format is assumed during `slices_restore`. All `POSIX*t` objects in
14		#' `selected` or `choices` fields of `teal_slice` objects are always printed in
15		#' `UTC` timezone as well.
16		#'
17		#' @param tss (`teal_slices`) object to be stored.
18		#' @param file (`character(1)`) file path where `teal_slices` object will be
19		#' saved and restored. The file extension should be `".json"`.
20		#'
21		#' @return `slices_store` returns `NULL`, invisibly.
22		#'
23		#' @seealso [teal_slices()]
24		#'
25		#' @keywords internal
26		#'
27		slices_store <- function(tss, file) {
28	9x	checkmate::assert_class(tss, "teal_slices")
29	9x	checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json")
30
31	9x	cat(format(tss, trim_lines = FALSE), "\n", file = file)
32		}
33
34		#' @rdname slices_store
35		#' @return `slices_restore` returns a `teal_slices` object restored from the file.
36		#' @keywords internal
37		slices_restore <- function(file) {
38	9x	checkmate::assert_file_exists(file, access = "r", extension = "json")
39
40	9x	tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE)
41	9x	tss_json$slices <-
42	9x	lapply(tss_json$slices, function(slice) {
43	9x	for (field in c("selected", "choices")) {
44	18x	if (!is.null(slice[[field]])) {
45	12x	if (length(slice[[field]]) > 0) {
46	9x	date_partial_regex <- "^[0-9]{4}-[0-9]{2}-[0-9]{2}"
47	9x	time_stamp_regex <- paste0(date_partial_regex, "\\s[0-9]{2}:[0-9]{2}:[0-9]{2}\\sUTC$")
48
49	9x	slice[[field]] <-
50	9x	if (all(grepl(paste0(date_partial_regex, "$"), slice[[field]]))) {
51	3x	as.Date(slice[[field]])
52	9x	} else if (all(grepl(time_stamp_regex, slice[[field]]))) {
53	3x	as.POSIXct(slice[[field]], tz = "UTC")
54		} else {
55	3x	slice[[field]]
56		}
57		} else {
58	3x	slice[[field]] <- character(0)
59		}
60		}
61		}
62	9x	slice
63		})
64
65	9x	tss_elements <- lapply(tss_json$slices, as.teal_slice)
66
67	9x	do.call(teal_slices, c(tss_elements, tss_json$attributes))
68		}

1		#' Generates library calls from current session info
2		#'
3		#' Function to create multiple library calls out of current session info to ensure reproducible code works.
4		#'
5		#' @return Character vector of `library(<package>)` calls.
6		#' @keywords internal
7		get_rcode_libraries <- function() {
8	1x	libraries <- vapply(
9	1x	utils::sessionInfo()$otherPkgs,
10	1x	function(x) {
11	6x	paste0("library(", x$Package, ")")
12		},
13	1x	character(1)
14		)
15	1x	paste0(paste0(rev(libraries), sep = "\n"), collapse = "")
16		}
17
18
19		#' @noRd
20		#' @keywords internal
21		get_rcode_str_install <- function() {
22	5x	code_string <- getOption("teal.load_nest_code")
23	5x	if (is.character(code_string)) {
24	2x	code_string
25		} else {
26	3x	"# Add any code to install/load your NEST environment here\n"
27		}
28		}

1		#' Create a `tdata` object
2		#'
3		#' @description `r lifecycle::badge("superseded")`
4		#'
5		#' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object
6		#' to be passed to the `data` argument but instead they receive a `teal_data` object,
7		#' which is additionally wrapped in a reactive expression in the server functions.
8		#' In order to easily adapt such modules without a proper refactor,
9		#' use this function to downgrade the `data` argument.
10		#'
11		#' @name tdata
12		#' @param ... ignored
13		#' @return nothing
14		NULL
15
16		#' @rdname tdata
17		#' @export
18		new_tdata <- function(...) {
19	!	.deprecate_tdata_msg()
20		}
21
22		#' @rdname tdata
23		#' @export
24		tdata2env <- function(...) {
25	!	.deprecate_tdata_msg()
26		}
27
28		#' @rdname tdata
29		#' @export
30		get_code_tdata <- function(...) {
31	!	.deprecate_tdata_msg()
32		}
33
34		#' @rdname tdata
35		#' @export
36		join_keys.tdata <- function(...) {
37	!	.deprecate_tdata_msg()
38		}
39
40		#' @rdname tdata
41		#' @export
42		get_metadata <- function(...) {
43	!	.deprecate_tdata_msg()
44		}
45
46		#' @rdname tdata
47		#' @export
48		as_tdata <- function(...) {
49	!	.deprecate_tdata_msg()
50		}
51
52
53		.deprecate_tdata_msg <- function() {
54	!	lifecycle::deprecate_stop(
55	!	when = "0.16",
56	!	what = "tdata()",
57	!	details = paste(
58	!	"tdata has been removed in favour of `teal_data`.\n",
59	!	"Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."
60		)
61		)
62		}

1		.onLoad <- function(libname, pkgname) {
2		# adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R
3
4	!	teal_default_options <- list(
5	!	teal.show_js_log = FALSE,
6	!	teal.lockfile.mode = "auto",
7	!	shiny.sanitize.errors = FALSE
8		)
9
10	!	op <- options()
11	!	toset <- !(names(teal_default_options) %in% names(op))
12	!	if (any(toset)) options(teal_default_options[toset])
13
14		# Set up the teal logger instance
15	!	teal.logger::register_logger("teal")
16	!	teal.logger::register_handlers("teal")
17
18	!	invisible()
19		}
20
21		.onAttach <- function(libname, pkgname) {
22	2x	packageStartupMessage(
23	2x	"\nYou are using teal version ",
24		# `system.file` uses the `shim` of `system.file` by `teal`
25		# we avoid `desc` dependency here to get the version
26	2x	read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
27		)
28		}
29
30		# This one is here because setdiff_teal_slice should not be exported from teal.slice.
31		setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
32		# This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice.
33		coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
34		# all *Block objects are private in teal.reporter
35		RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint: object_name.
36
37		# Use non-exported function(s) from teal.code
38		# This one is here because lang2calls should not be exported from teal.code
39		lang2calls <- getFromNamespace("lang2calls", "teal.code")

1		#' Evaluate expression on `teal_data_module`
2		#'
3		#' @details
4		#' `within` is a convenience function for evaluating inline code inside the environment of a `teal_data_module`.
5		#' It accepts only inline expressions (both simple and compound) and allows for injecting values into `expr` through
6		#' the `...` argument: as `name:value` pairs are passed to `...`, `name` in `expr` will be replaced with `value.`
7		#'
8		#' @param data (`teal_data_module`) object
9		#' @param expr (`expression`) to evaluate. Must be inline code. See
10		#' @param ... See `Details`.
11		#'
12		#' @return
13		#' `within` returns a `teal_data_module` object with a delayed evaluation of `expr` when the module is run.
14		#'
15		#' @examples
16		#' within(tdm, dataset1 <- subset(dataset1, Species == "virginica"))
17		#'
18		#' # use additional parameter for expression value substitution.
19		#' valid_species <- "versicolor"
20		#' within(tdm, dataset1 <- subset(dataset1, Species %in% species), species = valid_species)
21		#' @include teal_data_module.R
22		#' @name within
23		#' @rdname teal_data_module
24		#'
25		#' @export
26		#'
27		within.teal_data_module <- function(data, expr, ...) {
28	2x	expr <- substitute(expr)
29	2x	extras <- list(...)
30
31		# Add braces for consistency.
32	2x	if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
33	2x	expr <- call("{", expr)
34		}
35
36	2x	calls <- as.list(expr)[-1]
37
38		# Inject extra values into expressions.
39	2x	calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))
40
41	2x	eval_code(object = data, code = as.expression(calls))
42		}