teal coverage - 68.02%

Files
Source

#' 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() {
  vapply(
    utils::sessionInfo()$otherPkgs,
    function(x) {
      paste0("library(", x$Package, ")")
    },
    character(1)
  ) %>%
    # put it into reverse order to correctly simulate executed code
    rev() %>%
    paste0(sep = "\n") %>%
    paste0(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"
  }
}

#' Get datasets code
#'
#' Retrieve complete code to create, verify, and filter a dataset.
#'
#' @param datanames (`character`) names of datasets to extract code from
#' @param datasets (`FilteredData`) object
#' @param hashes named (`list`) of hashes per dataset
#'
#' @return Character string concatenated from the following elements:
#'  - data pre-processing code (from `data` argument in `init`)
#'  - hash check of loaded objects
#'  - filter code (if any)
#'
#' @keywords internal
get_datasets_code <- function(datanames, datasets, hashes) {
  # preprocessing code
  str_prepro <-
    teal.data:::get_code_dependency(attr(datasets, "preprocessing_code"), names = datanames, check_names = FALSE)
  if (length(str_prepro) == 0) {
    str_prepro <- "message('Preprocessing is empty')"
  } else {
    str_prepro <- paste(str_prepro, collapse = "\n")
  }

  # hash checks
  str_hash <- vapply(datanames, function(dataname) {
    sprintf(
      "stopifnot(%s == %s)",
      deparse1(bquote(rlang::hash(.(as.name(dataname))))),
      deparse1(hashes[[dataname]])
    )
  }, character(1))
  str_hash <- paste(str_hash, collapse = "\n")

  # filter expressions
  str_filter <- teal.slice::get_filter_expr(datasets, datanames)
  if (str_filter == "") {
    str_filter <- character(0)
  }

  # concatenate all code
  str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n")
  sprintf("%s\n", str_code)
}

#' 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.
#'
#' @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`) A vector with `datanames` that are relevant for the item. The
#'   filter panel will automatically update the shown filters to include only
#'   filters in the listed datasets. `NULL` will hide the filter panel,
#'   and the keyword `"all"` will show filters of all datasets. `datanames` also determines
#'   a subset of datasets which are appended to the `data` argument in server function.
#' @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 ...
#' - 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, ...) {
                     moduleServer(id, function(input, output, session) {}) # nolint
                   },
                   ui = function(id, ...) {
                     tags$p(paste0("This module has no UI (id: ", id, " )"))
                   },
                   filters,
                   datanames = "all",
                   server_args = NULL,
                   ui_args = NULL) {
  # 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."
    logger::log_warn(msg)
    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 `...`"
    )
  }

  structure(
    list(
      label = label,
      server = server, ui = ui, datanames = unique(datanames),
      server_args = server_args, ui_args = ui_args
    ),
    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) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
  structure(
    list(
      label = label,
      children = submodules
    ),
    class = "teal_modules"
  )
}

# printing methods ----

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


#' @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) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
  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
  }
}

#' Manage multiple `FilteredData` objects
#'
#' Oversee filter states across the entire application.
#'
#' This module observes changes in the filters of each `FilteredData` object
#' and keeps track of all filters used. A mapping of filters to modules
#' is kept in the `mapping_matrix` object (which is actually a `data.frame`)
#' that tracks which filters (rows) are active in which modules (columns).
#'
#' @name module_filter_manager
#'
#' @param id (`character(1)`)
#'  `shiny` module id.
#' @param filtered_data_list (named `list`)
#'  A list, possibly nested, of `FilteredData` objects.
#'  Each `FilteredData` will be served to one module in the `teal` application.
#'  The structure of the list must reflect the nesting of modules in tabs
#'  and the names of the list must match the labels of their respective modules.
#' @inheritParams init
#' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.
#' @keywords internal
#'
NULL

#' Filter manager modal
#'
#' Opens a modal containing the filter manager UI.
#'
#' @name module_filter_manager_modal
#' @inheritParams module_filter_manager
#' @keywords internal
#'
NULL

#' @rdname module_filter_manager_modal
filter_manager_modal_ui <- function(id) {
  ns <- NS(id)
  tags$button(
    id = ns("show"),
    class = "btn action-button filter_manager_button",
    title = "Show filters manager modal",
    icon("gear")
  )
}

#' @rdname module_filter_manager_modal
filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
  moduleServer(id, function(input, output, session) {
    observeEvent(input$show, {
      logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
      showModal(
        modalDialog(
          filter_manager_ui(session$ns("filter_manager")),
          size = "l",
          footer = NULL,
          easyClose = TRUE
        )
      )
    })

    filter_manager_srv("filter_manager", filtered_data_list, filter)
  })
}

#' @rdname module_filter_manager
filter_manager_ui <- function(id) {
  ns <- NS(id)
  div(
    class = "filter_manager_content",
    tableOutput(ns("slices_table")),
    snapshot_manager_ui(ns("snapshot_manager"))
  )
}

#' @rdname module_filter_manager
filter_manager_srv <- function(id, filtered_data_list, filter) {
  moduleServer(id, function(input, output, session) {
    logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")

    is_module_specific <- isTRUE(attr(filter, "module_specific"))

    # Create a global list of slices.
    # Contains all available teal_slice objects available to all modules.
    # Passed whole to instances of FilteredData used for individual modules.
    # Down there a subset that pertains to the data sets used in that module is applied and displayed.
    slices_global <- reactiveVal(filter)

    filtered_data_list <-
      if (!is_module_specific) {
        # Retrieve the first FilteredData from potentially nested list.
        # List of length one is named "global_filters" because that name is forbidden for a module label.
        list(global_filters = unlist(filtered_data_list)[[1]])
      } else {
        # Flatten potentially nested list of FilteredData objects while maintaining useful names.
        # Simply using `unlist` would result in concatenated names.
        flatten_nested <- function(x, name = NULL) {
          if (inherits(x, "FilteredData")) {
            setNames(list(x), name)
          } else {
            unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))
          }
        }
        flatten_nested(filtered_data_list)
      }

    # Create mapping of filters to modules in matrix form (presented as data.frame).
    # Modules get NAs for filters that cannot be set for them.
    mapping_matrix <- reactive({
      state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")
      mapping_smooth <- lapply(filtered_data_list, function(x) {
        state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")
        state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")
        states_active <- state_ids_global %in% state_ids_local
        ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)
      })

      as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)
    })

    output$slices_table <- renderTable(
      expr = {
        # Display logical values as UTF characters.
        mm <- mapping_matrix()
        mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))
        mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))
        if (!is_module_specific) colnames(mm) <- "Global Filters"

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

        # Report Previewer will not be displayed.
        mm[names(mm) != "Report previewer"]
      },
      align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
      rownames = TRUE
    )

    # Create list of module calls.
    modules_out <- lapply(names(filtered_data_list), function(module_name) {
      filter_manager_module_srv(
        id = module_name,
        module_fd = filtered_data_list[[module_name]],
        slices_global = slices_global
      )
    })

    # Call snapshot manager.
    snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)

    modules_out # returned for testing purpose
  })
}

#' Module specific filter manager
#'
#' Tracks filter states in a single module.
#'
#' This module tracks the state of a single `FilteredData` object and global `teal_slices`
#' and updates both objects as necessary. Filter states added in different modules
#' Filter states added any individual module are added to global `teal_slices`
#' and from there become available in other modules
#' by setting `private$available_teal_slices` in each `FilteredData`.
#'
#' @param id (`character(1)`)
#'  `shiny` module id.
#' @param module_fd (`FilteredData`)
#'   Object containing the data to be filtered in a single `teal` module.
#' @param slices_global (`reactiveVal`)
#'   stores `teal_slices` with all available filters; allows the following actions:
#'   - to disable/enable a specific filter in a module
#'   - to restore saved filter settings
#'   - to save current filter panel settings
#' @return A `reactive` expression containing the slices active in this module.
#' @keywords internal
#'
filter_manager_module_srv <- function(id, module_fd, slices_global) {
  moduleServer(id, function(input, output, session) {
    # Only operate on slices that refer to data sets present in this module.
    module_fd$set_available_teal_slices(reactive(slices_global()))

    # Track filter state of this module.
    slices_module <- reactive(module_fd$get_filter_state())

    # Reactive values for comparing states.
    previous_slices <- reactiveVal(isolate(slices_module()))
    slices_added <- reactiveVal(NULL)

    # Observe changes in module filter state and trigger appropriate actions.
    observeEvent(slices_module(), ignoreNULL = FALSE, {
      logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
      added <- setdiff_teal_slices(slices_module(), slices_global())
      if (length(added)) slices_added(added)
      previous_slices(slices_module())
    })

    observeEvent(slices_added(), ignoreNULL = TRUE, {
      logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
      # In case the new state has the same id as an existing state, add a suffix to it.
      global_ids <- vapply(slices_global(), `[[`, character(1L), "id")
      lapply(
        slices_added(),
        function(slice) {
          if (slice$id %in% global_ids) {
            slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)
          }
        }
      )
      slices_global_new <- c(slices_global(), slices_added())
      slices_global(slices_global_new)
      slices_added(NULL)
    })

    slices_module # returned for testing purpose
  })
}

#' Create a `tdata` object
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' Create a new object called `tdata` which contains `data`, a `reactive` list of `data.frames`
#' (or `MultiAssayExperiment`), with attributes:
#' - `code` (`reactive`) containing code used to generate the data
#' - join_keys (`join_keys`) containing the relationships between the data
#' - metadata (named `list`) containing any metadata associated with the data frames
#'
#' @name tdata
#' @param data (named `list`) A list of `data.frame` or `MultiAssayExperiment` objects,
#'  which optionally can be `reactive`.
#'   Inside this object all of these items will be made `reactive`.
#' @param code (`character` or `reactive` which evaluates to a `character`) containing
#'   the code used to generate the data. This should be `reactive` if the code is changing
#'   during a reactive context (e.g. if filtering changes the code). Inside this
#'   object `code` will be made reactive
#' @param join_keys (`teal.data::join_keys`) object containing relationships between the
#'   datasets.
#' @param metadata (named `list`) each element contains a list of metadata about the named `data.frame`
#' Each element of these list should be atomic and length one.
#' @return A `tdata` object.
#'
#' @seealso `as_tdata`
#'
#' @examples
#'
#' data <- new_tdata(
#'   data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),
#'   code = "iris <- iris
#'     mtcars <- mtcars
#'     dd <- data.frame(x = 1:10)",
#'   metadata = list(dd = list(author = "NEST"), iris = list(version = 1))
#' )
#'
#' # Extract a data.frame
#' isolate(data[["iris"]]())
#'
#' # Get code
#' isolate(get_code_tdata(data))
#'
#' # Get metadata
#' get_metadata(data, "iris")
#'
#' @export
new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
  lifecycle::deprecate_soft(
    when = "0.15.0",
    what = "tdata()",
    details = paste(
      "tdata is deprecated and will be removed in the next release. Use `teal_data` instead.\n",
      "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."
    )
  )
  checkmate::assert_list(
    data,
    any.missing = FALSE, names = "unique",
    types = c("data.frame", "reactive", "MultiAssayExperiment")
  )
  checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)
  checkmate::assert_multi_class(code, c("character", "reactive"))

  checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)
  checkmate::assert_subset(names(metadata), names(data))

  if (is.reactive(code)) {
    isolate(checkmate::assert_class(code(), "character", .var.name = "code"))
  }

  # create reactive data.frames
  for (x in names(data)) {
    if (!is.reactive(data[[x]])) {
      data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))
    }
  }

  # set attributes
  attr(data, "code") <- if (is.reactive(code)) code else reactive(code)
  attr(data, "join_keys") <- join_keys
  attr(data, "metadata") <- metadata

  # set class
  class(data) <- c("tdata", class(data))
  data
}

#' Function to convert a `tdata` object to an `environment`
#'
#' Any `reactive` expressions inside `tdata` are evaluated first.
#' @param data (`tdata`) object
#' @return An `environment`.
#' @examples
#'
#' data <- new_tdata(
#'   data = list(iris = iris, mtcars = reactive(mtcars)),
#'   code = "iris <- iris
#'     mtcars = mtcars"
#' )
#'
#' my_env <- isolate(tdata2env(data))
#'
#' @export
tdata2env <- function(data) { # nolint
  checkmate::assert_class(data, "tdata")
  list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))
}


#' Wrapper for `get_code.tdata`
#'
#' This wrapper is to be used by downstream packages to extract the code of a `tdata` object.
#'
#' @param data (`tdata`) object
#'
#' @return (`character`) code used in the `tdata` object.
#' @export
get_code_tdata <- function(data) {
  checkmate::assert_class(data, "tdata")
  attr(data, "code")()
}

#' Extract `join_keys` from `tdata`
#' @param data (`tdata`) object
#' @param ... Additional arguments (not used)
#' @export
join_keys.tdata <- function(data, ...) {
  attr(data, "join_keys")
}

#' Function to get metadata from a `tdata` object
#' @param data (`tdata` - object) to extract the data from
#' @param dataname (`character(1)`) the dataset name whose metadata is requested
#' @return Either list of metadata or NULL if no metadata.
#' @export
get_metadata <- function(data, dataname) {
  checkmate::assert_string(dataname)
  UseMethod("get_metadata", data)
}

#' @rdname get_metadata
#' @export
get_metadata.tdata <- function(data, dataname) {
  metadata <- attr(data, "metadata")
  if (is.null(metadata)) {
    return(NULL)
  }
  metadata[[dataname]]
}

#' @rdname get_metadata
#' @export
get_metadata.default <- function(data, dataname) {
  stop("get_metadata function not implemented for this object")
}


#' Downgrade `teal_data` objects in modules for compatibility
#'
#' Convert `teal_data` to `tdata` in `teal` modules.
#'
#' 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.
#'
#' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression
#'
#' @return Object of class `tdata`.
#'
#' @examples
#' td <- teal_data()
#' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars)
#' td
#' as_tdata(td)
#' as_tdata(reactive(td))
#'
#' @export
#' @rdname tdata_deprecation
#'
as_tdata <- function(x) {
  if (inherits(x, "tdata")) {
    return(x)
  }
  if (is.reactive(x)) {
    checkmate::assert_class(isolate(x()), "teal_data")
    datanames <- isolate(teal_data_datanames(x()))
    datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)
    code <- reactive(teal.code::get_code(x()))
    join_keys <- isolate(teal.data::join_keys(x()))
  } else if (inherits(x, "teal_data")) {
    datanames <- teal_data_datanames(x)
    datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)
    code <- reactive(teal.code::get_code(x))
    join_keys <- isolate(teal.data::join_keys(x))
  }

  new_tdata(data = datasets, code = code, join_keys = join_keys)
}

#' 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 (`shiny`) input variable accessible with `input$tz` which is a (`character`)
#'  string containing the timezone of the browser/client.
#'
#' @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)) {
    NULL
  } else if (!inherits(bs_theme, "bs_theme")) {
    warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
    NULL
  } else {
    bs_theme
  }
}

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

  unique(c(parents, dataname))
}

#' 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 = teal_data_datanames(x)) {
  checkmate::assert_class(x, "teal_data")
  checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)

  ans <- teal.slice::init_filtered_data(
    x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE),
    join_keys = teal.data::join_keys(x)
  )
  # Piggy-back entire pre-processing code so that filtering code can be appended later.
  attr(ans, "preprocessing_code") <- teal.code::get_code(x)
  attr(ans, "verification_status") <- x@verified
  ans
}

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

#' Resolve `datanames` for the modules
#'
#' Modifies `module$datanames` to include names of the parent dataset (taken from `join_keys`).
#' When `datanames` is set to `"all"` it is replaced with all available datasets names.
#' @param modules (`teal_modules`) object
#' @param datanames (`character`) names of datasets available in the `data` object
#' @param join_keys (`join_keys`) object
#' @return `teal_modules` with resolved `datanames`.
#' @keywords internal
resolve_modules_datanames <- function(modules, datanames, join_keys) {
  if (inherits(modules, "teal_modules")) {
    modules$children <- sapply(
      modules$children,
      resolve_modules_datanames,
      simplify = FALSE,
      datanames = datanames,
      join_keys = join_keys
    )
    modules
  } else {
    modules$datanames <- if (identical(modules$datanames, "all")) {
      datanames
    } else if (is.character(modules$datanames)) {
      extra_datanames <- setdiff(modules$datanames, datanames)
      if (length(extra_datanames)) {
        stop(
          sprintf(
            "Module %s has datanames that are not available in a 'data':\n %s not in %s",
            modules$label,
            toString(extra_datanames),
            toString(datanames)
          )
        )
      }
      datanames_adjusted <- intersect(modules$datanames, datanames)
      include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)
    }
    modules
  }
}

#' Check `datanames` in modules
#'
#' This function ensures specified `datanames` in modules match those in the data object,
#' returning error messages or `TRUE` for successful validation.
#'
#' @param modules (`teal_modules`) 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_modules_datanames <- function(modules, datanames) {
  checkmate::assert_class(modules, "teal_modules")
  checkmate::assert_character(datanames)

  recursive_check_datanames <- function(modules, datanames) {
    # check teal_modules against datanames
    if (inherits(modules, "teal_modules")) {
      sapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))
    } else {
      extra_datanames <- setdiff(modules$datanames, c("all", datanames))
      if (length(extra_datanames)) {
        sprintf(
          "- Module '%s' uses datanames not available in 'data': (%s) not in (%s)",
          modules$label,
          toString(dQuote(extra_datanames, q = FALSE)),
          toString(dQuote(datanames, q = FALSE))
        )
      }
    }
  }
  check_datanames <- unlist(recursive_check_datanames(modules, datanames))
  if (length(check_datanames)) {
    paste(check_datanames, collapse = "\n")
  } else {
    TRUE
  }
}

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

#' Wrapper on `teal.data::datanames`
#'
#' Special function used in internals of `teal` to return names of datasets even if `datanames`
#' has not been set.
#' @param data (`teal_data`)
#' @return `character`
#' @keywords internal
teal_data_datanames <- function(data) {
  checkmate::assert_class(data, "teal_data")
  if (length(teal.data::datanames(data))) {
    teal.data::datanames(data)
  } else {
    ls(teal.code::get_env(data), all.names = 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(data@env)
  } 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
  }
}

#' @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_linter.
  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")
      self$append_content(TealSlicesBlock$new(fs))
      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()
)

#' @title `RcodeBlock`
#' @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 `RcodeBlock` from a list.
    #' @param x (named `list`) with two fields `c("text", "params")`.
    #' Use the `get_available_params` method to get all possible parameters.
    #' @return `self`, invisibly.
    from_list = function(x) {
      checkmate::assert_list(x)
      checkmate::assert_names(names(x), must.include = c("teal_slices"))
      self$set_content(x$teal_slices)
      invisible(self)
    },
    #' @description Convert the `RcodeBlock` to a list.
    #' @return named `list` with a text and `params`.

    to_list = function() {
      list(teal_slices = private$teal_slices)
    }
  ),
  private = list(
    style = "verbatim",
    teal_slices = NULL # teal_slices
  )
)

#' 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 through the filter manager, with the cog icon in the top right corner.
#' 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 `filtered_data_list`) 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.
#'
#' @param id (`character(1)`) `shiny` module id
#' @param slices_global (`reactiveVal`) that contains a `teal_slices` object
#'                      containing all `teal_slice`s existing in the app, both active and inactive
#' @param mapping_matrix (`reactive`) that contains a `data.frame` representation
#'                       of the mapping of filter state ids (rows) to modules labels (columns);
#'                       all columns are `logical` vectors
#' @param filtered_data_list non-nested (named `list`) that contains `FilteredData` objects
#'
#' @return Nothing is returned.
#'
#' @name snapshot_manager_module
#' @aliases snapshot snapshot_manager
#'
#' @author Aleksander Chlebowski
#'
#' @rdname snapshot_manager_module
#' @keywords internal
#'
snapshot_manager_ui <- function(id) {
  ns <- NS(id)
  div(
    class = "snapshot_manager_content",
    div(
      class = "snapshot_table_row",
      span(tags$b("Snapshot manager")),
      actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
      actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"),
      actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
      NULL
    ),
    uiOutput(ns("snapshot_list"))
  )
}

#' @rdname snapshot_manager_module
#' @keywords internal
#'
snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
  checkmate::assert_character(id)
  checkmate::assert_true(is.reactive(slices_global))
  checkmate::assert_class(isolate(slices_global()), "teal_slices")
  checkmate::assert_true(is.reactive(mapping_matrix))
  checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)
  checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named")

  moduleServer(id, function(input, output, session) {
    ns <- session$ns

    # Store global filter states ----
    filter <- isolate(slices_global())
    snapshot_history <- reactiveVal({
      list(
        "Initial application state" = as.list(filter, recursive = TRUE)
      )
    })

    # Snapshot current application state ----
    # Name snaphsot.
    observeEvent(input$snapshot_add, {
      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("thumbs-up")),
            modalButton(label = "Cancel", icon = icon("thumbs-down"))
          ),
          size = "s"
        )
      )
    })
    # Store snaphsot.
    observeEvent(input$snapshot_name_accept, {
      snapshot_name <- trimws(input$snapshot_name)
      if (identical(snapshot_name, "")) {
        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())))) {
        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 {
        snapshot <- as.list(slices_global(), recursive = TRUE)
        attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())
        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-main_ui-filter_manager-show", asis = TRUE)
      }
    })

    # Upload a snapshot file ----
    # Select file.
    observeEvent(input$snapshot_load, {
      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("thumbs-up")),
            modalButton(label = "Cancel", icon = icon("thumbs-down"))
          )
        )
      )
    })
    # Store new snapshot to list and restore filter states.
    observeEvent(input$snaphot_file_accept, {
      snapshot_name <- trimws(input$snapshot_name)
      if (identical(snapshot_name, "")) {
        snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)
      }
      if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
        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.
        snapshot_state <- try(slices_restore(input$snapshot_file$datapath))
        if (!inherits(snapshot_state, "modules_teal_slices")) {
          showNotification(
            "File appears to be corrupt.",
            type = "error"
          )
        } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) {
          showNotification(
            "This snapshot file is not compatible with the app and cannot be loaded.",
            type = "warning"
          )
        } else {
          # Add to snapshot history.
          snapshot <- as.list(snapshot_state, 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. ###
          mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
          mapply(
            function(filtered_data, filter_ids) {
              filtered_data$clear_filter_states(force = TRUE)
              slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
              filtered_data$set_filter_state(slices)
            },
            filtered_data = filtered_data_list,
            filter_ids = mapping_unfolded
          )
          slices_global(snapshot_state)
          removeModal()
          ### End  simplified restore procedure. ###
        }
      }
    })
    # Apply newly added snapshot.

    # Restore initial state ----
    observeEvent(input$snapshot_reset, {
      s <- "Initial application state"
      ### Begin restore procedure. ###
      snapshot <- snapshot_history()[[s]]
      snapshot_state <- as.teal_slices(snapshot)
      mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
      mapply(
        function(filtered_data, filter_ids) {
          filtered_data$clear_filter_states(force = TRUE)
          slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
          filtered_data$set_filter_state(slices)
        },
        filtered_data = filtered_data_list,
        filter_ids = mapping_unfolded
      )
      slices_global(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(), {
      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)
            mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
            mapply(
              function(filtered_data, filter_ids) {
                filtered_data$clear_filter_states(force = TRUE)
                slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
                filtered_data$set_filter_state(slices)
              },
              filtered_data = filtered_data_list,
              filter_ids = mapping_unfolded
            )
            slices_global(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]] <- div(
            class = "snapshot_table_row",
            span(h5(s)),
            actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
            downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
          )
        }
      })
    })

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

### utility functions ----

#' Explicitly enumerate global filters.
#'
#' Transform module mapping such that global filters are explicitly specified for every module.
#'
#' @param mapping (named `list`) as stored in mapping parameter of `teal_slices`
#' @param module_names (`character`) vector containing names of all modules in the app
#' @return A `named_list` with one element per module, each element containing all filters applied to that module.
#' @keywords internal
#'
unfold_mapping <- function(mapping, module_names) {
  module_names <- structure(module_names, names = module_names)
  lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))
}

#' Convert mapping matrix to filter mapping specification.
#'
#' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,
#' to a list specification like the one used in the `mapping` attribute of `teal_slices`.
#' Global filters are gathered in one list element.
#' If a module has no active filters but the global ones, it will not be mentioned in the output.
#'
#' @param mapping_matrix (`data.frame`) of logical vectors where
#'                       columns represent modules and row represent `teal_slice`s
#' @return Named `list` like that in the `mapping` attribute of a `teal_slices` object.
#' @keywords internal
#'
matrix_to_mapping <- function(mapping_matrix) {
  mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x))
  global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))
  global_filters <- names(global[global])
  local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]

  mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))
  Filter(function(x) length(x) != 0L, mapping)
}

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

#' Create a UI of nested tabs of `teal_modules`
#'
#' @section `ui_nested_tabs`:
#' Each `teal_modules` is translated to a `tabsetPanel` and each
#' of its children is another tab-module called recursively. The UI of a
#' `teal_module` is obtained by calling its UI function.
#'
#' The `datasets` argument is required to resolve the `teal` arguments in an
#' isolated context (with respect to reactivity).
#'
#' @section `srv_nested_tabs`:
#' This module recursively calls all elements of `modules` and returns currently active one.
#' - `teal_module` returns self as a active module.
#' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.
#'
#' @name module_nested_tabs
#'
#' @inheritParams module_tabs_with_filters
#'
#' @param depth (`integer(1)`)
#'  number which helps to determine depth of the modules nesting.
#' @param is_module_specific (`logical(1)`)
#'  flag determining if the filter panel is global or module-specific.
#'  When set to `TRUE`, a filter panel is called inside of each module tab.
#'
#' @return
#' Depending on the class of `modules`, `ui_nested_tabs` returns:
#'   - `teal_module`: instantiated UI of the module.
#'   - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively
#'     calling this function on it.
#'
#' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.
#'
#' @keywords internal
NULL

#' @rdname module_nested_tabs
ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  checkmate::assert_count(depth)
  UseMethod("ui_nested_tabs", modules)
}

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

#' @rdname module_nested_tabs
#' @export
ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
  checkmate::assert_list(datasets, types = c("list", "FilteredData"))
  ns <- NS(id)
  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
          tabPanel(
            title = module_label,
            value = module_id, # when clicked this tab value changes input$<tabset panel id>
            ui_nested_tabs(
              id = ns(module_id),
              modules = modules$children[[module_id]],
              datasets = datasets[[module_label]],
              depth = depth + 1L,
              is_module_specific = is_module_specific
            )
          )
        }
      )
    )
  )
}

#' @rdname module_nested_tabs
#' @export
ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
  checkmate::assert_class(datasets, classes = "FilteredData")
  ns <- NS(id)

  args <- c(list(id = ns("module")), modules$ui_args)

  teal_ui <- tags$div(
    id = id,
    class = "teal_module",
    uiOutput(ns("data_reactive"), inline = TRUE),
    tagList(
      if (depth >= 2L) div(style = "mt-6"),
      do.call(modules$ui, args)
    )
  )

  if (!is.null(modules$datanames) && is_module_specific) {
    fluidRow(
      column(width = 9, teal_ui, class = "teal_primary_col"),
      column(
        width = 3,
        datasets$ui_filter_panel(ns("module_filter_panel")),
        class = "teal_secondary_col"
      )
    )
  } else {
    teal_ui
  }
}

#' @rdname module_nested_tabs
srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,
                            reporter = teal.reporter::Reporter$new()) {
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  checkmate::assert_class(reporter, "Reporter")
  UseMethod("srv_nested_tabs", modules)
}

#' @rdname module_nested_tabs
#' @export
srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,
                                    reporter = teal.reporter::Reporter$new()) {
  stop("Modules class not supported: ", paste(class(modules), collapse = " "))
}

#' @rdname module_nested_tabs
#' @export
srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,
                                         reporter = teal.reporter::Reporter$new()) {
  checkmate::assert_list(datasets, types = c("list", "FilteredData"))

  moduleServer(id = id, module = function(input, output, session) {
    logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")

    labels <- vapply(modules$children, `[[`, character(1), "label")
    modules_reactive <- sapply(
      names(modules$children),
      function(module_id) {
        srv_nested_tabs(
          id = module_id,
          datasets = datasets[[labels[module_id]]],
          modules = modules$children[[module_id]],
          is_module_specific = is_module_specific,
          reporter = reporter
        )
      },
      simplify = FALSE
    )

    # when not ready input$active_tab would return NULL - this would fail next reactive
    input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)
    get_active_module <- reactive({
      if (length(modules$children) == 1L) {
        # single tab is active by default
        modules_reactive[[1]]()
      } else {
        # switch to active tab
        modules_reactive[[input_validated()]]()
      }
    })

    get_active_module
  })
}

#' @rdname module_nested_tabs
#' @export
srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,
                                        reporter = teal.reporter::Reporter$new()) {
  checkmate::assert_class(datasets, "FilteredData")
  logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")

  moduleServer(id = id, module = function(input, output, session) {
    if (!is.null(modules$datanames) && is_module_specific) {
      datasets$srv_filter_panel("module_filter_panel")
    }

    # Create two triggers to limit reactivity between filter-panel and modules.
    # We want to recalculate only visible modules
    # - trigger the data when the tab is selected
    # - trigger module to be called when the tab is selected for the first time
    trigger_data <- reactiveVal(1L)
    trigger_module <- reactiveVal(NULL)
    output$data_reactive <- renderUI({
      lapply(datasets$datanames(), function(x) {
        datasets$get_data(x, filtered = TRUE)
      })
      isolate(trigger_data(trigger_data() + 1))
      isolate(trigger_module(TRUE))

      NULL
    })

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

    if (is_arg_used(modules$server, "data")) {
      data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets))
      args <- c(args, data = list(data))
    }

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

    # observe the trigger_module above to induce the module once the renderUI is triggered
    observeEvent(
      ignoreNULL = TRUE,
      once = TRUE,
      eventExpr = trigger_module(),
      handlerExpr = {
        module_output <- if (is_arg_used(modules$server, "id")) {
          do.call(modules$server, args)
        } else {
          do.call(callModule, c(args, list(module = modules$server)))
        }
      }
    )

    reactive(modules)
  })
}

#' Convert `FilteredData` to reactive list of datasets of the `teal_data` type.
#'
#' Converts `FilteredData` object to `teal_data` object containing datasets needed for a specific module.
#' Please note that if a module needs a dataset which has a parent, then the parent will also be returned.
#' A hash per `dataset` is calculated internally and returned in the code.
#'
#' @param module (`teal_module`) module where needed filters are taken from
#' @param datasets (`FilteredData`) object where needed data are taken from
#'
#' @return A `teal_data` object.
#'
#' @keywords internal
.datasets_to_data <- function(module, datasets) {
  checkmate::assert_class(module, "teal_module")
  checkmate::assert_class(datasets, "FilteredData")

  datanames <- if (is.null(module$datanames) || identical(module$datanames, "all")) {
    datasets$datanames()
  } else {
    include_parent_datanames(
      module$datanames,
      datasets$get_join_keys()
    )
  }

  # list of reactive filtered data
  data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)

  hashes <- calculate_hashes(datanames, datasets)

  code <- c(
    get_rcode_str_install(),
    get_rcode_libraries(),
    get_datasets_code(datanames, datasets, hashes)
  )


  data <- do.call(
    teal.data::teal_data,
    args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames]))
  )

  data@verified <- attr(datasets, "verification_status")
  data
}

#' Get the hash of a dataset
#'
#' @param datanames (`character`) names of datasets
#' @param datasets (`FilteredData`) object holding the data
#'
#' @return A list of hashes per dataset.
#' @keywords internal
#'
calculate_hashes <- function(datanames, datasets) {
  sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)
}

#' Add right filter panel into each of the top-level `teal_modules` UIs
#'
#' The [ui_nested_tabs] function returns a nested tabbed UI corresponding
#' to the nested modules.
#' This function adds the right filter panel to each main tab.
#'
#' The right filter panel's filter choices affect the `datasets` object. Therefore,
#' all modules using the same `datasets` share the same filters.
#'
#' This works with nested modules of depth greater than 2, though the filter
#' panel is inserted at the right of the modules at depth 1 and not at the leaves.
#'
#' @name module_tabs_with_filters
#'
#' @inheritParams module_teal
#'
#' @param datasets (named `list` of `FilteredData`)
#'   object to store filter state and filtered datasets, shared across modules. For more
#'   details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure
#'   of the `modules` argument and list names must correspond to the labels in `modules`.
#'   When filter is not module-specific then list contains the same object in all elements.
#' @param reporter (`Reporter`) object from `teal.reporter`
#'
#' @return
#' A `shiny.tag.list` containing the main menu, placeholders for filters and placeholders for the `teal` modules.
#'
#' @keywords internal
#'
NULL

#' @rdname module_tabs_with_filters
ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
  checkmate::assert_class(modules, "teal_modules")
  checkmate::assert_list(datasets, types = c("list", "FilteredData"))
  checkmate::assert_class(filter, "teal_slices")

  ns <- NS(id)
  is_module_specific <- isTRUE(attr(filter, "module_specific"))

  teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
  filter_panel_btns <- tags$li(
    class = "flex-grow",
    tags$button(
      class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger
      href = "javascript:void(0)",
      onclick = "toggleFilterPanel();", # see sidebar.js
      title = "Toggle filter panels",
      icon("fas fa-bars")
    ),
    filter_manager_modal_ui(ns("filter_manager"))
  )
  teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)

  if (!is_module_specific) {
    # need to rearrange html so that filter panel is within tabset
    tabset_bar <- teal_ui$children[[1]]
    teal_modules <- teal_ui$children[[2]]
    filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
    list(
      tabset_bar,
      tags$hr(class = "my-2"),
      fluidRow(
        column(width = 9, teal_modules, class = "teal_primary_col"),
        column(width = 3, filter_ui, class = "teal_secondary_col")
      )
    )
  } else {
    teal_ui
  }
}

#' @rdname module_tabs_with_filters
srv_tabs_with_filters <- function(id,
                                  datasets,
                                  modules,
                                  reporter = teal.reporter::Reporter$new(),
                                  filter = teal_slices()) {
  checkmate::assert_class(modules, "teal_modules")
  checkmate::assert_list(datasets, types = c("list", "FilteredData"))
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_class(filter, "teal_slices")

  moduleServer(id, function(input, output, session) {
    logger::log_trace("srv_tabs_with_filters initializing the module.")

    is_module_specific <- isTRUE(attr(filter, "module_specific"))
    manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)

    active_module <- srv_nested_tabs(
      id = "root",
      datasets = datasets,
      modules = modules,
      reporter = reporter,
      is_module_specific = is_module_specific
    )

    if (!is_module_specific) {
      active_datanames <- reactive({
        if (identical(active_module()$datanames, "all")) {
          singleton$datanames()
        } else {
          include_parent_datanames(
            active_module()$datanames,
            singleton$get_join_keys()
          )
        }
      })
      singleton <- unlist(datasets)[[1]]
      singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)

      observeEvent(
        eventExpr = active_datanames(),
        handlerExpr = {
          script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
            # hide the filter panel and disable the burger button
            "handleNoActiveDatasets();"
          } else {
            # show the filter panel and enable the burger button
            "handleActiveDatasetsPresent();"
          }
          shinyjs::runjs(script)
        },
        ignoreNULL = FALSE
      )
    }

    showNotification("Data loaded - App fully started up")
    logger::log_trace("srv_tabs_with_filters initialized the module")

    active_module
  })
}

# This file adds a splash screen for delayed data loading on top of teal

#' Add splash screen to `teal` application
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Displays custom splash screen during initial delayed data loading.
#'
#' @details
#' This module pauses app initialization pending delayed data loading.
#' This is necessary because the filter panel and modules depend on the data to initialize.
#'
#' `teal_with_splash` follows the `shiny` module convention.
#' [`init()`] is a wrapper around this that assumes that `teal` it is
#' the top-level module and cannot be embedded.
#'
#' Note: It is no longer recommended to embed `teal` in `shiny` apps as a module.
#' but rather use `init` to create a standalone application.
#'
#' @seealso [init()]
#'
#' @param id (`character(1)`)
#'   module id
#' @inheritParams init
#' @param modules (`teal_modules`) object containing the output modules which
#'   will be displayed in the `teal` application. See [modules()] and [module()] for
#'   more details.
#' @inheritParams shiny::moduleServer
#' @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
#' @examples
#' teal_modules <- modules(example_module())
#' # Shiny app with modular integration of teal
#' ui <- fluidPage(
#'   ui_teal_with_splash(id = "app1", data = teal_data())
#' )
#'
#' server <- function(input, output, session) {
#'   srv_teal_with_splash(
#'     id = "app1",
#'     data = teal_data(iris = iris),
#'     modules = teal_modules
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
NULL

#' @export
#' @rdname module_teal_with_splash
ui_teal_with_splash <- function(id,
                                data,
                                title = build_app_title(),
                                header = tags$p(),
                                footer = tags$p()) {
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
  checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
  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"))
  )

  ns <- NS(id)

  # Startup splash screen for delayed loading
  # We use delayed loading in all cases, even when the data does not need to be fetched.
  # This has the benefit that when filtering the data takes a lot of time initially, the
  # Shiny app does not time out.
  splash_ui <- if (inherits(data, "teal_data_module")) {
    data$ui(ns("teal_data_module"))
  } else if (inherits(data, "teal_data")) {
    div()
  }
  ui_teal(
    id = ns("teal"),
    splash_ui = div(splash_ui, uiOutput(ns("error"))),
    title = title,
    header = header,
    footer = footer
  )
}

#' @export
#' @rdname module_teal_with_splash
srv_teal_with_splash <- 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"))
  checkmate::assert_class(modules, "teal_modules")
  checkmate::assert_class(filter, "teal_slices")

  moduleServer(id, function(input, output, session) {
    logger::log_trace("srv_teal_with_splash initializing module with data.")

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

    # teal_data_rv contains teal_data object
    # either passed to teal::init or returned from teal_data_module
    teal_data_rv <- if (inherits(data, "teal_data_module")) {
      data <- data$server(id = "teal_data_module")
      if (!is.reactive(data)) {
        stop("The `teal_data_module` passed to `data` must return a reactive expression.", call. = FALSE)
      }
      data
    } else if (inherits(data, "teal_data")) {
      reactiveVal(data)
    }

    teal_data_rv_validate <- reactive({
      # custom module can return error
      data <- tryCatch(teal_data_rv(), error = function(e) e)

      # there is an empty reactive cycle on init!
      if (inherits(data, "shiny.silent.error") && identical(data$message, "")) {
        return(NULL)
      }

      # to handle qenv.error
      if (inherits(data, "qenv.error")) {
        validate(
          need(
            FALSE,
            paste(
              "Error when executing `teal_data_module` passed to `data`:\n ",
              paste(data$message, collapse = "\n"),
              "\n Check your inputs or contact app developer if error persists."
            )
          )
        )
      }

      # to handle module non-qenv errors
      if (inherits(data, "error")) {
        validate(
          need(
            FALSE,
            paste(
              "Error when executing `teal_data_module` passed to `data`:\n ",
              paste(data$message, collpase = "\n"),
              "\n Check your inputs or contact app developer if error persists."
            )
          )
        )
      }

      validate(
        need(
          inherits(data, "teal_data"),
          paste(
            "Error: `teal_data_module` passed to `data` failed to return `teal_data` object, returned",
            toString(sQuote(class(data))),
            "instead.",
            "\n Check your inputs or contact app developer if error persists."
          )
        )
      )

      if (!length(teal.data::datanames(data))) {
        warning("`data` object has no datanames. Default datanames are set using `teal_data`'s environment.")
      }

      is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
      if (!isTRUE(is_modules_ok)) {
        validate(need(isTRUE(is_modules_ok), sprintf("%s. Contact app developer.", is_modules_ok)))
      }

      is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
      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)
      }

      teal_data_rv()
    })

    output$error <- renderUI({
      teal_data_rv_validate()
      NULL
    })


    res <- srv_teal(id = "teal", modules = modules, teal_data_rv = teal_data_rv_validate, filter = filter)
    logger::log_trace("srv_teal_with_splash initialized module with data.")

    res
  })
}

.onLoad <- function(libname, pkgname) { # nolint
  # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R
  teal_default_options <- list(teal.show_js_log = FALSE)

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

  options("shiny.sanitize.errors" = FALSE)

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

  invisible()
}

.onAttach <- function(libname, pkgname) { # nolint
  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

# 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")

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

  logger::log_info("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("teal_module_previewer", class(module))
  module$label <- label
  module
}

#' 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 optional (`logical(1)`)
#'  - `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 <- list(global_filters = all_slice_id)
    }
    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
  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
  })
}

# 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.
#'
#' @details
#' When initializing the `teal` app, if `datanames` are not set for the `teal_data` object,
#' defaults from the `teal_data` environment will be used.
#'
#' @param data (`teal_data` or `teal_data_module`)
#' For constructing the data object, refer to [teal_data()] and [teal_data_module()].
#' @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`)
#'   Specifies the initial filter using [teal_slices()].
#' @param title (`shiny.tag` or `character(1)`)
#'   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)`)
#'   The header of the app.
#' @param footer (`shiny.tag` or `character(1)`)
#'   The footer of the app.
#' @param id (`character`)
#'   Optional 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.
#'
#' @return Named list with server and UI functions.
#'
#' @export
#'
#' @include modules.R
#'
#' @examples
#' app <- init(
#'   data = teal_data(
#'     new_iris = transform(iris, id = seq_len(nrow(iris))),
#'     new_mtcars = transform(mtcars, id = seq_len(nrow(mtcars))),
#'     code = "
#'       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, ...) 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")),
#'     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("Copyright 2017 - 2023")
#' )
#' 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)) {
  logger::log_trace("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"))

  ## `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")
  landing_module <- NULL
  if (length(landing) == 1L) {
    landing_module <- landing[[1L]]
    modules <- drop_module(modules, "teal_module_landing")
  } else if (length(landing) > 1L) {
    stop("Only one `landing_popup_module` can be used.")
  }

  ## `filter` - app_id attribute
  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(teal_data_datanames(data)) == 0) {
      stop("The environment of `data` is empty.")
    }
    # in case of teal_data_module this check is postponed to the srv_teal_with_splash
    is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
    if (!isTRUE(is_modules_ok)) {
      logger::log_error(is_modules_ok)
      checkmate::assert(is_modules_ok, .var.name = "modules")
    }

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

  # Note regarding case `id = character(0)`:
  # rather than creating a submodule of this module, we directly modify
  # the UI and server with `id = character(0)` and calling the server function directly
  res <- list(
    ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
    server = function(input, output, session) {
      if (!is.null(landing_module)) {
        do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args))
      }
      srv_teal_with_splash(id = id, data = data, modules = modules, filter = deep_copy_filter(filter))
    }
  )

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

  res
}

#' 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`]
#'
#' @examples
#' 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),
#'       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", ~ if (as.integer(.) %% 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", ~ if (length(.) > 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(eruptions ~ waiting, faithful,
#'       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
    }
  )
}

# This module is the main teal module that puts everything together.

#' `teal` main app module
#'
#' This is the main `teal` app that puts everything together.
#'
#' It displays the splash UI which is used to fetch the data, possibly
#' prompting for a password input to fetch the data. Once the data is ready,
#' the splash screen is replaced by the actual `teal` UI that is tabsetted and
#' has a filter panel with `datanames` that are relevant for the current tab.
#' Nested tabs are possible, but we limit it to two nesting levels for reasons
#' of clarity of the UI.
#'
#' The splash screen functionality can also be used
#' for non-delayed data which takes time to load into memory, avoiding
#' `shiny` session timeouts.
#'
#' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the
#' `datasets` object that is shared across modules.
#' Once it is ready and non-`NULL`, the splash screen is replaced by the
#' main `teal` UI that depends on the data.
#' The currently active tab is tracked and the right filter panel
#' updates the displayed datasets to filter for according to the active `datanames`
#' of the tab.
#'
#' It is written as a `shiny` module so it can be added into other apps as well.
#'
#' @name module_teal
#'
#' @inheritParams module_teal_with_splash
#'
#' @param splash_ui (`shiny.tag`) UI to display initially,
#'   can be a splash screen or a `shiny` module UI. For the latter, see
#'   [init()] about how to call the corresponding server function.
#'
#' @param teal_data_rv (`reactive`)
#'   returns the `teal_data`, only evaluated once, `NULL` value is ignored
#'
#' @return
#' Returns a `reactive` expression which returns the currently active module.
#'
#' @keywords internal
#'
NULL

#' @rdname module_teal
ui_teal <- function(id,
                    splash_ui = tags$h2("Starting the Teal App"),
                    title = build_app_title(),
                    header = tags$p(),
                    footer = tags$p()) {
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)

  checkmate::assert_multi_class(splash_ui, c("shiny.tag", "shiny.tag.list", "html"))

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

  checkmate::assert(
    .var.name = "header",
    checkmate::check_string(header),
    checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
  )
  if (checkmate::test_string(header)) {
    header <- tags$p(header)
  }

  checkmate::assert(
    .var.name = "footer",
    checkmate::check_string(footer),
    checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
  )
  if (checkmate::test_string(footer)) {
    footer <- tags$p(footer)
  }

  ns <- NS(id)

  # Once the data is loaded, we will remove this element and add the real teal UI instead
  splash_ui <- div(
    # id so we can remove the splash screen once ready, which is the first child of this container
    id = ns("main_ui_container"),
    # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
    # just the first item of the tagList)
    div(splash_ui)
  )

  # 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
  shiny_busy_message_panel <- conditionalPanel(
    condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
    div(
      icon("arrows-rotate", "spin fa-spin"),
      "Computing ...",
      # CSS defined in `custom.css`
      class = "shinybusymessage"
    )
  )

  fluidPage(
    title = title,
    theme = get_teal_bs_theme(),
    include_teal_css_js(),
    tags$header(header),
    tags$hr(class = "my-2"),
    shiny_busy_message_panel,
    splash_ui,
    tags$hr(),
    tags$footer(
      div(
        footer,
        teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
        textOutput(ns("identifier"))
      )
    )
  )
}


#' @rdname module_teal
srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
  stopifnot(is.reactive(teal_data_rv))
  moduleServer(id, function(input, output, session) {
    logger::log_trace("srv_teal initializing the module.")

    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_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
      }
    )

    reporter <- teal.reporter::Reporter$new()
    if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
      modules <- append_module(modules, reporter_previewer_module())
    }

    env <- environment()
    datasets_reactive <- eventReactive(teal_data_rv(), {
      env$progress <- shiny::Progress$new(session)
      env$progress$set(0.25, message = "Setting data")

      # create a list of data following structure of the nested modules list structure.
      # Because it's easier to unpack modules and datasets when they follow the same nested structure.
      datasets_singleton <- teal_data_to_filtered_data(teal_data_rv())

      # Singleton starts with only global filters active.
      filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)
      datasets_singleton$set_filter_state(filter_global)

      module_datasets <- function(modules) {
        if (inherits(modules, "teal_modules")) {
          datasets <- lapply(modules$children, module_datasets)
          labels <- vapply(modules$children, `[[`, character(1), "label")
          names(datasets) <- labels
          datasets
        } else if (isTRUE(attr(filter, "module_specific"))) {
          # we should create FilteredData even if modules$datanames is null
          # null controls a display of filter panel but data should be still passed
          datanames <- if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
            include_parent_datanames(
              teal_data_datanames(teal_data_rv()),
              teal.data::join_keys(teal_data_rv())
            )
          } else {
            modules$datanames
          }
          # todo: subset teal_data to datanames
          datasets_module <- teal_data_to_filtered_data(teal_data_rv(), datanames = datanames)

          # set initial filters
          #  - filtering filters for this module
          slices <- Filter(x = filter, f = function(x) {
            x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&
              x$dataname %in% datanames
          })
          include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]
          exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]
          slices$include_varnames <- include_varnames
          slices$exclude_varnames <- exclude_varnames
          datasets_module$set_filter_state(slices)
          datasets_module
        } else {
          datasets_singleton
        }
      }
      module_datasets(modules)
    })

    # Replace splash / welcome screen once data is loaded ----
    # ignoreNULL to not trigger at the beginning when data is NULL
    # just handle it once because data obtained through delayed loading should
    # usually not change afterwards
    # if restored from bookmarked state, `filter` is ignored

    observeEvent(datasets_reactive(), once = TRUE, {
      logger::log_trace("srv_teal@5 setting main ui after data was pulled")
      on.exit(env$progress$close())
      env$progress$set(0.5, message = "Setting up main UI")
      datasets <- datasets_reactive()

      # main_ui_container contains splash screen first and we remove it and replace it by the real UI
      removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container")))
      insertUI(
        selector = paste0("#", session$ns("main_ui_container")),
        where = "beforeEnd",
        # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
        # just the first item of the tagList)
        ui = div(ui_tabs_with_filters(
          session$ns("main_ui"),
          modules = modules,
          datasets = datasets,
          filter = filter
        )),
        # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not
        # have any effect as they are ignored when not present
        immediate = TRUE
      )

      # must make sure that this is only executed once as modules assume their observers are only
      # registered once (calling server functions twice would trigger observers twice each time)
      srv_tabs_with_filters(
        id = "main_ui",
        datasets = datasets,
        modules = modules,
        reporter = reporter,
        filter = filter
      )
    })
  })
}

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

#' 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 returns `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("gear")), # add hidden icon to load font-awesome css for icons
  )
}

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

#' 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") {
  checkmate::assert_string(label)
  module(
    label,
    server = function(id, data) {
      checkmate::assert_class(data(), "teal_data")
      moduleServer(id, function(input, output, session) {
        updateSelectInput(session, "dataname", choices = isolate(teal.data::datanames(data())))
        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 = div(
          selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
          teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
        )
      )
    },
    datanames = datanames
  )
}

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")

        if (!is.reactive(teal_data_rv)) {
          stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
        }

        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"))
})

#' 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 supply or modify data in a `teal` application.
#' The module allows for running data pre-processing code (creation _and_ some modification) after the app starts.
#' 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
#'
#' @return
#' `teal_data_module` returns an object of class `teal_data_module`.
#'
#' @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) {
  checkmate::assert_function(ui, args = "id", nargs = 1)
  checkmate::assert_function(server, args = "id", nargs = 1)
  structure(
    list(ui = ui, server = server),
    class = "teal_data_module"
  )
}

1		#' Create a `tdata` object
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#'
5		#' Create a new object called `tdata` which contains `data`, a `reactive` list of `data.frames`
6		#' (or `MultiAssayExperiment`), with attributes:
7		#' - `code` (`reactive`) containing code used to generate the data
8		#' - join_keys (`join_keys`) containing the relationships between the data
9		#' - metadata (named `list`) containing any metadata associated with the data frames
10		#'
11		#' @name tdata
12		#' @param data (named `list`) A list of `data.frame` or `MultiAssayExperiment` objects,
13		#' which optionally can be `reactive`.
14		#' Inside this object all of these items will be made `reactive`.
15		#' @param code (`character` or `reactive` which evaluates to a `character`) containing
16		#' the code used to generate the data. This should be `reactive` if the code is changing
17		#' during a reactive context (e.g. if filtering changes the code). Inside this
18		#' object `code` will be made reactive
19		#' @param join_keys (`teal.data::join_keys`) object containing relationships between the
20		#' datasets.
21		#' @param metadata (named `list`) each element contains a list of metadata about the named `data.frame`
22		#' Each element of these list should be atomic and length one.
23		#' @return A `tdata` object.
24		#'
25		#' @seealso `as_tdata`
26		#'
27		#' @examples
28		#'
29		#' data <- new_tdata(
30		#' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),
31		#' code = "iris <- iris
32		#' mtcars <- mtcars
33		#' dd <- data.frame(x = 1:10)",
34		#' metadata = list(dd = list(author = "NEST"), iris = list(version = 1))
35		#' )
36		#'
37		#' # Extract a data.frame
38		#' isolate(data[["iris"]]())
39		#'
40		#' # Get code
41		#' isolate(get_code_tdata(data))
42		#'
43		#' # Get metadata
44		#' get_metadata(data, "iris")
45		#'
46		#' @export
47		new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
48	34x	lifecycle::deprecate_soft(
49	34x	when = "0.15.0",
50	34x	what = "tdata()",
51	34x	details = paste(
52	34x	"tdata is deprecated and will be removed in the next release. Use `teal_data` instead.\n",
53	34x	"Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."
54		)
55		)
56	34x	checkmate::assert_list(
57	34x	data,
58	34x	any.missing = FALSE, names = "unique",
59	34x	types = c("data.frame", "reactive", "MultiAssayExperiment")
60		)
61	30x	checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)
62	29x	checkmate::assert_multi_class(code, c("character", "reactive"))
63
64	28x	checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)
65	26x	checkmate::assert_subset(names(metadata), names(data))
66
67	25x	if (is.reactive(code)) {
68	9x	isolate(checkmate::assert_class(code(), "character", .var.name = "code"))
69		}
70
71		# create reactive data.frames
72	24x	for (x in names(data)) {
73	47x	if (!is.reactive(data[[x]])) {
74	31x	data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))
75		}
76		}
77
78		# set attributes
79	24x	attr(data, "code") <- if (is.reactive(code)) code else reactive(code)
80	24x	attr(data, "join_keys") <- join_keys
81	24x	attr(data, "metadata") <- metadata
82
83		# set class
84	24x	class(data) <- c("tdata", class(data))
85	24x	data
86		}
87
88		#' Function to convert a `tdata` object to an `environment`
89		#'
90		#' Any `reactive` expressions inside `tdata` are evaluated first.
91		#' @param data (`tdata`) object
92		#' @return An `environment`.
93		#' @examples
94		#'
95		#' data <- new_tdata(
96		#' data = list(iris = iris, mtcars = reactive(mtcars)),
97		#' code = "iris <- iris
98		#' mtcars = mtcars"
99		#' )
100		#'
101		#' my_env <- isolate(tdata2env(data))
102		#'
103		#' @export
104		tdata2env <- function(data) { # nolint
105	2x	checkmate::assert_class(data, "tdata")
106	1x	list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))
107		}
108
109
110		#' Wrapper for `get_code.tdata`
111		#'
112		#' This wrapper is to be used by downstream packages to extract the code of a `tdata` object.
113		#'
114		#' @param data (`tdata`) object
115		#'
116		#' @return (`character`) code used in the `tdata` object.
117		#' @export
118		get_code_tdata <- function(data) {
119	7x	checkmate::assert_class(data, "tdata")
120	5x	attr(data, "code")()
121		}
122
123		#' Extract `join_keys` from `tdata`
124		#' @param data (`tdata`) object
125		#' @param ... Additional arguments (not used)
126		#' @export
127		join_keys.tdata <- function(data, ...) {
128	2x	attr(data, "join_keys")
129		}
130
131		#' Function to get metadata from a `tdata` object
132		#' @param data (`tdata` - object) to extract the data from
133		#' @param dataname (`character(1)`) the dataset name whose metadata is requested
134		#' @return Either list of metadata or NULL if no metadata.
135		#' @export
136		get_metadata <- function(data, dataname) {
137	4x	checkmate::assert_string(dataname)
138	4x	UseMethod("get_metadata", data)
139		}
140
141		#' @rdname get_metadata
142		#' @export
143		get_metadata.tdata <- function(data, dataname) {
144	4x	metadata <- attr(data, "metadata")
145	4x	if (is.null(metadata)) {
146	1x	return(NULL)
147		}
148	3x	metadata[[dataname]]
149		}
150
151		#' @rdname get_metadata
152		#' @export
153		get_metadata.default <- function(data, dataname) {
154	!	stop("get_metadata function not implemented for this object")
155		}
156
157
158		#' Downgrade `teal_data` objects in modules for compatibility
159		#'
160		#' Convert `teal_data` to `tdata` in `teal` modules.
161		#'
162		#' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object
163		#' to be passed to the `data` argument but instead they receive a `teal_data` object,
164		#' which is additionally wrapped in a reactive expression in the server functions.
165		#' In order to easily adapt such modules without a proper refactor,
166		#' use this function to downgrade the `data` argument.
167		#'
168		#' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression
169		#'
170		#' @return Object of class `tdata`.
171		#'
172		#' @examples
173		#' td <- teal_data()
174		#' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars)
175		#' td
176		#' as_tdata(td)
177		#' as_tdata(reactive(td))
178		#'
179		#' @export
180		#' @rdname tdata_deprecation
181		#'
182		as_tdata <- function(x) {
183	8x	if (inherits(x, "tdata")) {
184	2x	return(x)
185		}
186	6x	if (is.reactive(x)) {
187	1x	checkmate::assert_class(isolate(x()), "teal_data")
188	1x	datanames <- isolate(teal_data_datanames(x()))
189	1x	datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)
190	1x	code <- reactive(teal.code::get_code(x()))
191	1x	join_keys <- isolate(teal.data::join_keys(x()))
192	5x	} else if (inherits(x, "teal_data")) {
193	5x	datanames <- teal_data_datanames(x)
194	5x	datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)
195	5x	code <- reactive(teal.code::get_code(x))
196	5x	join_keys <- isolate(teal.data::join_keys(x))
197		}
198
199	6x	new_tdata(data = datasets, code = code, join_keys = join_keys)
200		}

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		#' landing_popup_module(
21		#' content = "A place for the welcome message or a disclaimer statement.",
22		#' buttons = modalButton("Proceed")
23		#' ),
24		#' example_module()
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		#' landing_popup_module(
35		#' title = "Welcome",
36		#' content = tags$b(
37		#' "A place for the welcome message or a disclaimer statement.",
38		#' style = "color: red;"
39		#' ),
40		#' buttons = tagList(
41		#' modalButton("Proceed"),
42		#' actionButton("read", "Read more",
43		#' onclick = "window.open('http://google.com', '_blank')"
44		#' ),
45		#' actionButton("close", "Reject", onclick = "window.close()")
46		#' )
47		#' ),
48		#' example_module()
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	!	logger::log_info("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		#' 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	6x	vapply(
9	6x	utils::sessionInfo()$otherPkgs,
10	6x	function(x) {
11	36x	paste0("library(", x$Package, ")")
12		},
13	6x	character(1)
14		) %>%
15		# put it into reverse order to correctly simulate executed code
16	6x	rev() %>%
17	6x	paste0(sep = "\n") %>%
18	6x	paste0(collapse = "")
19		}
20
21		#' @noRd
22		#' @keywords internal
23		get_rcode_str_install <- function() {
24	10x	code_string <- getOption("teal.load_nest_code")
25	10x	if (is.character(code_string)) {
26	2x	code_string
27		} else {
28	8x	"# Add any code to install/load your NEST environment here\n"
29		}
30		}
31
32		#' Get datasets code
33		#'
34		#' Retrieve complete code to create, verify, and filter a dataset.
35		#'
36		#' @param datanames (`character`) names of datasets to extract code from
37		#' @param datasets (`FilteredData`) object
38		#' @param hashes named (`list`) of hashes per dataset
39		#'
40		#' @return Character string concatenated from the following elements:
41		#' - data pre-processing code (from `data` argument in `init`)
42		#' - hash check of loaded objects
43		#' - filter code (if any)
44		#'
45		#' @keywords internal
46		get_datasets_code <- function(datanames, datasets, hashes) {
47		# preprocessing code
48	4x	str_prepro <-
49	4x	teal.data:::get_code_dependency(attr(datasets, "preprocessing_code"), names = datanames, check_names = FALSE)
50	4x	if (length(str_prepro) == 0) {
51	!	str_prepro <- "message('Preprocessing is empty')"
52		} else {
53	4x	str_prepro <- paste(str_prepro, collapse = "\n")
54		}
55
56		# hash checks
57	4x	str_hash <- vapply(datanames, function(dataname) {
58	6x	sprintf(
59	6x	"stopifnot(%s == %s)",
60	6x	deparse1(bquote(rlang::hash(.(as.name(dataname))))),
61	6x	deparse1(hashes[[dataname]])
62		)
63	4x	}, character(1))
64	4x	str_hash <- paste(str_hash, collapse = "\n")
65
66		# filter expressions
67	4x	str_filter <- teal.slice::get_filter_expr(datasets, datanames)
68	4x	if (str_filter == "") {
69	2x	str_filter <- character(0)
70		}
71
72		# concatenate all code
73	4x	str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n")
74	4x	sprintf("%s\n", str_code)
75		}

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

1		#' Manage multiple `FilteredData` objects
2		#'
3		#' Oversee filter states across the entire application.
4		#'
5		#' This module observes changes in the filters of each `FilteredData` object
6		#' and keeps track of all filters used. A mapping of filters to modules
7		#' is kept in the `mapping_matrix` object (which is actually a `data.frame`)
8		#' that tracks which filters (rows) are active in which modules (columns).
9		#'
10		#' @name module_filter_manager
11		#'
12		#' @param id (`character(1)`)
13		#' `shiny` module id.
14		#' @param filtered_data_list (named `list`)
15		#' A list, possibly nested, of `FilteredData` objects.
16		#' Each `FilteredData` will be served to one module in the `teal` application.
17		#' The structure of the list must reflect the nesting of modules in tabs
18		#' and the names of the list must match the labels of their respective modules.
19		#' @inheritParams init
20		#' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.
21		#' @keywords internal
22		#'
23		NULL
24
25		#' Filter manager modal
26		#'
27		#' Opens a modal containing the filter manager UI.
28		#'
29		#' @name module_filter_manager_modal
30		#' @inheritParams module_filter_manager
31		#' @keywords internal
32		#'
33		NULL
34
35		#' @rdname module_filter_manager_modal
36		filter_manager_modal_ui <- function(id) {
37	!	ns <- NS(id)
38	!	tags$button(
39	!	id = ns("show"),
40	!	class = "btn action-button filter_manager_button",
41	!	title = "Show filters manager modal",
42	!	icon("gear")
43		)
44		}
45
46		#' @rdname module_filter_manager_modal
47		filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
48	3x	moduleServer(id, function(input, output, session) {
49	3x	observeEvent(input$show, {
50	!	logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
51	!	showModal(
52	!	modalDialog(
53	!	filter_manager_ui(session$ns("filter_manager")),
54	!	size = "l",
55	!	footer = NULL,
56	!	easyClose = TRUE
57		)
58		)
59		})
60
61	3x	filter_manager_srv("filter_manager", filtered_data_list, filter)
62		})
63		}
64
65		#' @rdname module_filter_manager
66		filter_manager_ui <- function(id) {
67	!	ns <- NS(id)
68	!	div(
69	!	class = "filter_manager_content",
70	!	tableOutput(ns("slices_table")),
71	!	snapshot_manager_ui(ns("snapshot_manager"))
72		)
73		}
74
75		#' @rdname module_filter_manager
76		filter_manager_srv <- function(id, filtered_data_list, filter) {
77	5x	moduleServer(id, function(input, output, session) {
78	5x	logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
79
80	5x	is_module_specific <- isTRUE(attr(filter, "module_specific"))
81
82		# Create a global list of slices.
83		# Contains all available teal_slice objects available to all modules.
84		# Passed whole to instances of FilteredData used for individual modules.
85		# Down there a subset that pertains to the data sets used in that module is applied and displayed.
86	5x	slices_global <- reactiveVal(filter)
87
88	5x	filtered_data_list <-
89	5x	if (!is_module_specific) {
90		# Retrieve the first FilteredData from potentially nested list.
91		# List of length one is named "global_filters" because that name is forbidden for a module label.
92	4x	list(global_filters = unlist(filtered_data_list)[[1]])
93		} else {
94		# Flatten potentially nested list of FilteredData objects while maintaining useful names.
95		# Simply using `unlist` would result in concatenated names.
96	1x	flatten_nested <- function(x, name = NULL) {
97	5x	if (inherits(x, "FilteredData")) {
98	3x	setNames(list(x), name)
99		} else {
100	2x	unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))
101		}
102		}
103	1x	flatten_nested(filtered_data_list)
104		}
105
106		# Create mapping of filters to modules in matrix form (presented as data.frame).
107		# Modules get NAs for filters that cannot be set for them.
108	5x	mapping_matrix <- reactive({
109	5x	state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")
110	5x	mapping_smooth <- lapply(filtered_data_list, function(x) {
111	7x	state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")
112	7x	state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")
113	7x	states_active <- state_ids_global %in% state_ids_local
114	7x	ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)
115		})
116
117	5x	as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)
118		})
119
120	5x	output$slices_table <- renderTable(
121	5x	expr = {
122		# Display logical values as UTF characters.
123	2x	mm <- mapping_matrix()
124	2x	mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))
125	2x	mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))
126	2x	if (!is_module_specific) colnames(mm) <- "Global Filters"
127
128		# Display placeholder if no filters defined.
129	2x	if (nrow(mm) == 0L) {
130	2x	mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)
131	2x	rownames(mm) <- ""
132		}
133
134		# Report Previewer will not be displayed.
135	2x	mm[names(mm) != "Report previewer"]
136		},
137	5x	align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
138	5x	rownames = TRUE
139		)
140
141		# Create list of module calls.
142	5x	modules_out <- lapply(names(filtered_data_list), function(module_name) {
143	7x	filter_manager_module_srv(
144	7x	id = module_name,
145	7x	module_fd = filtered_data_list[[module_name]],
146	7x	slices_global = slices_global
147		)
148		})
149
150		# Call snapshot manager.
151	5x	snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
152
153	5x	modules_out # returned for testing purpose
154		})
155		}
156
157		#' Module specific filter manager
158		#'
159		#' Tracks filter states in a single module.
160		#'
161		#' This module tracks the state of a single `FilteredData` object and global `teal_slices`
162		#' and updates both objects as necessary. Filter states added in different modules
163		#' Filter states added any individual module are added to global `teal_slices`
164		#' and from there become available in other modules
165		#' by setting `private$available_teal_slices` in each `FilteredData`.
166		#'
167		#' @param id (`character(1)`)
168		#' `shiny` module id.
169		#' @param module_fd (`FilteredData`)
170		#' Object containing the data to be filtered in a single `teal` module.
171		#' @param slices_global (`reactiveVal`)
172		#' stores `teal_slices` with all available filters; allows the following actions:
173		#' - to disable/enable a specific filter in a module
174		#' - to restore saved filter settings
175		#' - to save current filter panel settings
176		#' @return A `reactive` expression containing the slices active in this module.
177		#' @keywords internal
178		#'
179		filter_manager_module_srv <- function(id, module_fd, slices_global) {
180	7x	moduleServer(id, function(input, output, session) {
181		# Only operate on slices that refer to data sets present in this module.
182	7x	module_fd$set_available_teal_slices(reactive(slices_global()))
183
184		# Track filter state of this module.
185	7x	slices_module <- reactive(module_fd$get_filter_state())
186
187		# Reactive values for comparing states.
188	7x	previous_slices <- reactiveVal(isolate(slices_module()))
189	7x	slices_added <- reactiveVal(NULL)
190
191		# Observe changes in module filter state and trigger appropriate actions.
192	7x	observeEvent(slices_module(), ignoreNULL = FALSE, {
193	2x	logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
194	2x	added <- setdiff_teal_slices(slices_module(), slices_global())
195	!	if (length(added)) slices_added(added)
196	2x	previous_slices(slices_module())
197		})
198
199	7x	observeEvent(slices_added(), ignoreNULL = TRUE, {
200	!	logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
201		# In case the new state has the same id as an existing state, add a suffix to it.
202	!	global_ids <- vapply(slices_global(), `[[`, character(1L), "id")
203	!	lapply(
204	!	slices_added(),
205	!	function(slice) {
206	!	if (slice$id %in% global_ids) {
207	!	slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)
208		}
209		}
210		)
211	!	slices_global_new <- c(slices_global(), slices_added())
212	!	slices_global(slices_global_new)
213	!	slices_added(NULL)
214		})
215
216	7x	slices_module # returned for testing purpose
217		})
218		}

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 (`shiny`) input variable accessible with `input$tz` which is a (`character`)
10		#' string containing the timezone of the browser/client.
11		#'
12		#' @keywords internal
13		#'
14		get_client_timezone <- function(ns) {
15	18x	script <- sprintf(
16	18x	"Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",
17	18x	ns("timezone")
18		)
19	18x	shinyjs::runjs(script) # function does not return anything
20	18x	invisible(NULL)
21		}
22
23		#' Resolve the expected bootstrap theme
24		#' @noRd
25		#' @keywords internal
26		get_teal_bs_theme <- function() {
27	11x	bs_theme <- getOption("teal.bs_theme")
28	11x	if (is.null(bs_theme)) {
29	8x	NULL
30	3x	} else if (!inherits(bs_theme, "bs_theme")) {
31	2x	warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
32	2x	NULL
33		} else {
34	1x	bs_theme
35		}
36		}
37
38		#' Return parentnames along with datanames.
39		#' @noRd
40		#' @keywords internal
41		include_parent_datanames <- function(dataname, join_keys) {
42	11x	parents <- character(0)
43	11x	for (i in dataname) {
44	16x	while (length(i) > 0) {
45	18x	parent_i <- teal.data::parent(join_keys, i)
46	18x	parents <- c(parent_i, parents)
47	18x	i <- parent_i
48		}
49		}
50
51	11x	unique(c(parents, dataname))
52		}
53
54		#' Create a `FilteredData`
55		#'
56		#' Create a `FilteredData` object from a `teal_data` object.
57		#'
58		#' @param x (`teal_data`) object
59		#' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)`
60		#' @return A `FilteredData` object.
61		#' @keywords internal
62		teal_data_to_filtered_data <- function(x, datanames = teal_data_datanames(x)) {
63	13x	checkmate::assert_class(x, "teal_data")
64	13x	checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)
65
66	13x	ans <- teal.slice::init_filtered_data(
67	13x	x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE),
68	13x	join_keys = teal.data::join_keys(x)
69		)
70		# Piggy-back entire pre-processing code so that filtering code can be appended later.
71	13x	attr(ans, "preprocessing_code") <- teal.code::get_code(x)
72	13x	attr(ans, "verification_status") <- x@verified
73	13x	ans
74		}
75
76		#' Template function for `TealReportCard` creation and customization
77		#'
78		#' This function generates a report card with a title,
79		#' an optional description, and the option to append the filter state list.
80		#'
81		#' @param title (`character(1)`) title of the card (unless overwritten by label)
82		#' @param label (`character(1)`) label provided by the user when adding the card
83		#' @param description (`character(1)`) optional additional description
84		#' @param with_filter (`logical(1)`) flag indicating to add filter state
85		#' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation
86		#' of the filter state in the report
87		#'
88		#' @return (`TealReportCard`) populated with a title, description and filter state.
89		#'
90		#' @export
91		report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
92	2x	checkmate::assert_string(title)
93	2x	checkmate::assert_string(label)
94	2x	checkmate::assert_string(description, null.ok = TRUE)
95	2x	checkmate::assert_flag(with_filter)
96	2x	checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")
97
98	2x	card <- teal::TealReportCard$new()
99	2x	title <- if (label == "") title else label
100	2x	card$set_name(title)
101	2x	card$append_text(title, "header2")
102	1x	if (!is.null(description)) card$append_text(description, "header3")
103	1x	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
104	2x	card
105		}
106
107		#' Resolve `datanames` for the modules
108		#'
109		#' Modifies `module$datanames` to include names of the parent dataset (taken from `join_keys`).
110		#' When `datanames` is set to `"all"` it is replaced with all available datasets names.
111		#' @param modules (`teal_modules`) object
112		#' @param datanames (`character`) names of datasets available in the `data` object
113		#' @param join_keys (`join_keys`) object
114		#' @return `teal_modules` with resolved `datanames`.
115		#' @keywords internal
116		resolve_modules_datanames <- function(modules, datanames, join_keys) {
117	!	if (inherits(modules, "teal_modules")) {
118	!	modules$children <- sapply(
119	!	modules$children,
120	!	resolve_modules_datanames,
121	!	simplify = FALSE,
122	!	datanames = datanames,
123	!	join_keys = join_keys
124		)
125	!	modules
126		} else {
127	!	modules$datanames <- if (identical(modules$datanames, "all")) {
128	!	datanames
129	!	} else if (is.character(modules$datanames)) {
130	!	extra_datanames <- setdiff(modules$datanames, datanames)
131	!	if (length(extra_datanames)) {
132	!	stop(
133	!	sprintf(
134	!	"Module %s has datanames that are not available in a 'data':\n %s not in %s",
135	!	modules$label,
136	!	toString(extra_datanames),
137	!	toString(datanames)
138		)
139		)
140		}
141	!	datanames_adjusted <- intersect(modules$datanames, datanames)
142	!	include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)
143		}
144	!	modules
145		}
146		}
147
148		#' Check `datanames` in modules
149		#'
150		#' This function ensures specified `datanames` in modules match those in the data object,
151		#' returning error messages or `TRUE` for successful validation.
152		#'
153		#' @param modules (`teal_modules`) object
154		#' @param datanames (`character`) names of datasets available in the `data` object
155		#'
156		#' @return A `character(1)` containing error message or `TRUE` if validation passes.
157		#' @keywords internal
158		check_modules_datanames <- function(modules, datanames) {
159	12x	checkmate::assert_class(modules, "teal_modules")
160	12x	checkmate::assert_character(datanames)
161
162	12x	recursive_check_datanames <- function(modules, datanames) {
163		# check teal_modules against datanames
164	26x	if (inherits(modules, "teal_modules")) {
165	12x	sapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))
166		} else {
167	14x	extra_datanames <- setdiff(modules$datanames, c("all", datanames))
168	14x	if (length(extra_datanames)) {
169	2x	sprintf(
170	2x	"- Module '%s' uses datanames not available in 'data': (%s) not in (%s)",
171	2x	modules$label,
172	2x	toString(dQuote(extra_datanames, q = FALSE)),
173	2x	toString(dQuote(datanames, q = FALSE))
174		)
175		}
176		}
177		}
178	12x	check_datanames <- unlist(recursive_check_datanames(modules, datanames))
179	12x	if (length(check_datanames)) {
180	2x	paste(check_datanames, collapse = "\n")
181		} else {
182	10x	TRUE
183		}
184		}
185
186		#' Check `datanames` in filters
187		#'
188		#' This function checks whether `datanames` in filters correspond to those in `data`,
189		#' returning character vector with error messages or `TRUE` if all checks pass.
190		#'
191		#' @param filters (`teal_slices`) object
192		#' @param datanames (`character`) names of datasets available in the `data` object
193		#'
194		#' @return A `character(1)` containing error message or TRUE if validation passes.
195		#' @keywords internal
196		check_filter_datanames <- function(filters, datanames) {
197	10x	checkmate::assert_class(filters, "teal_slices")
198	10x	checkmate::assert_character(datanames)
199
200		# check teal_slices against datanames
201	10x	out <- unlist(sapply(
202	10x	filters, function(filter) {
203	3x	dataname <- shiny::isolate(filter$dataname)
204	3x	if (!dataname %in% datanames) {
205	2x	sprintf(
206	2x	"- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)",
207	2x	shiny::isolate(filter$id),
208	2x	dQuote(dataname, q = FALSE),
209	2x	toString(dQuote(datanames, q = FALSE))
210		)
211		}
212		}
213		))
214
215
216	10x	if (length(out)) {
217	2x	paste(out, collapse = "\n")
218		} else {
219	8x	TRUE
220		}
221		}
222
223		#' Wrapper on `teal.data::datanames`
224		#'
225		#' Special function used in internals of `teal` to return names of datasets even if `datanames`
226		#' has not been set.
227		#' @param data (`teal_data`)
228		#' @return `character`
229		#' @keywords internal
230		teal_data_datanames <- function(data) {
231	51x	checkmate::assert_class(data, "teal_data")
232	51x	if (length(teal.data::datanames(data))) {
233	47x	teal.data::datanames(data)
234		} else {
235	4x	ls(teal.code::get_env(data), all.names = TRUE)
236		}
237		}
238
239		#' Function for validating the title parameter of `teal::init`
240		#'
241		#' Checks if the input of the title from `teal::init` will create a valid title and favicon tag.
242		#' @param shiny_tag (`shiny.tag`) Object to validate for a valid title.
243		#' @keywords internal
244		validate_app_title_tag <- function(shiny_tag) {
245	14x	checkmate::assert_class(shiny_tag, "shiny.tag")
246	14x	checkmate::assert_true(shiny_tag$name == "head")
247	13x	child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name")
248	13x	checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags")
249	11x	rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel
250	11x	checkmate::assert_subset(
251	11x	rel_attr,
252	11x	c("icon", "shortcut icon"),
253	11x	.var.name = "Link tag's rel attribute",
254	11x	empty.ok = FALSE
255		)
256		}
257
258		#' Build app title with favicon
259		#'
260		#' A helper function to create the browser title along with a logo.
261		#'
262		#' @param title (`character`) The browser title for the `teal` app.
263		#' @param favicon (`character`) The path for the icon for the title.
264		#' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/`
265		#'
266		#' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app.
267		#' @export
268		build_app_title <- function(
269		title = "teal app",
270		favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
271	11x	checkmate::assert_string(title, null.ok = TRUE)
272	11x	checkmate::assert_string(favicon, null.ok = TRUE)
273	11x	tags$head(
274	11x	tags$title(title),
275	11x	tags$link(
276	11x	rel = "icon",
277	11x	href = favicon,
278	11x	sizes = "any"
279		)
280		)
281		}
282
283		#' Application ID
284		#'
285		#' Creates App ID used to match filter snapshots to application.
286		#'
287		#' Calculate app ID that will be used to stamp filter state snapshots.
288		#' App ID is a hash of the app's data and modules.
289		#' See "transferring snapshots" section in ?snapshot.
290		#'
291		#' @param data (`teal_data` or `teal_data_module`) as accepted by `init`
292		#' @param modules (`teal_modules`) object as accepted by `init`
293		#'
294		#' @return A single character string.
295		#'
296		#' @keywords internal
297		create_app_id <- function(data, modules) {
298	19x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
299	18x	checkmate::assert_class(modules, "teal_modules")
300
301	17x	data <- if (inherits(data, "teal_data")) {
302	15x	as.list(data@env)
303	17x	} else if (inherits(data, "teal_data_module")) {
304	2x	deparse1(body(data$server))
305		}
306	17x	modules <- lapply(modules, defunction)
307
308	17x	rlang::hash(list(data = data, modules = modules))
309		}
310
311		#' Go through list and extract bodies of encountered functions as string, recursively.
312		#' @keywords internal
313		#' @noRd
314		defunction <- function(x) {
315	186x	if (is.list(x)) {
316	40x	lapply(x, defunction)
317	146x	} else if (is.function(x)) {
318	44x	deparse1(body(x))
319		} else {
320	102x	x
321		}
322		}

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_linter.
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	self$append_content(TealSlicesBlock$new(fs))
45	4x	invisible(self)
46		},
47		#' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.
48		#'
49		#' @param encodings (`list`) list of encodings selections of the `teal` app.
50		#' @return `self`, invisibly.
51		#' @examples
52		#' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))
53		#' card$get_content()[[1]]$get_content()
54		#'
55		append_encodings = function(encodings) {
56	4x	checkmate::assert_list(encodings)
57	4x	self$append_text("Selected Options", "header3")
58	4x	if (requireNamespace("yaml", quietly = TRUE)) {
59	4x	self$append_text(yaml::as.yaml(encodings, handlers = list(
60	4x	POSIXct = function(x) format(x, "%Y-%m-%d"),
61	4x	POSIXlt = function(x) format(x, "%Y-%m-%d"),
62	4x	Date = function(x) format(x, "%Y-%m-%d")
63	4x	)), "verbatim")
64		} else {
65	!	stop("yaml package is required to format the encodings list")
66		}
67	4x	self$append_metadata("Encodings", encodings)
68	4x	invisible(self)
69		}
70		),
71		private = list()
72		)
73
74		#' @title `RcodeBlock`
75		#' @keywords internal
76		TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter.
77		classname = "TealSlicesBlock",
78		inherit = teal.reporter:::TextBlock,
79		public = list(
80		#' @description Returns a `TealSlicesBlock` object.
81		#'
82		#' @details Returns a `TealSlicesBlock` object with no content and no parameters.
83		#'
84		#' @param content (`teal_slices`) object returned from [teal_slices()] function.
85		#' @param style (`character(1)`) string specifying style to apply.
86		#'
87		#' @return Object of class `TealSlicesBlock`, invisibly.
88		#'
89		initialize = function(content = teal_slices(), style = "verbatim") {
90	10x	self$set_content(content)
91	9x	self$set_style(style)
92	9x	invisible(self)
93		},
94
95		#' @description Sets content of this `TealSlicesBlock`.
96		#' Sets content as `YAML` text which represents a list generated from `teal_slices`.
97		#' The list displays limited number of fields from `teal_slice` objects, but this list is
98		#' sufficient to conclude which filters were applied.
99		#' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"
100		#'
101		#'
102		#' @param content (`teal_slices`) object returned from [teal_slices()] function.
103		#' @return `self`, invisibly.
104		set_content = function(content) {
105	11x	checkmate::assert_class(content, "teal_slices")
106	10x	if (length(content) != 0) {
107	7x	states_list <- lapply(content, function(x) {
108	7x	x_list <- shiny::isolate(as.list(x))
109	7x	if (
110	7x	inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
111	7x	length(x_list$choices) == 2 &&
112	7x	length(x_list$selected) == 2
113		) {
114	!	x_list$range <- paste(x_list$selected, collapse = " - ")
115	!	x_list["selected"] <- NULL
116		}
117	7x	if (!is.null(x_list$arg)) {
118	!	x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"
119		}
120
121	7x	x_list <- x_list[
122	7x	c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
123		]
124	7x	names(x_list) <- c(
125	7x	"Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",
126	7x	"Selected Values", "Selected range", "Include NA values", "Include Inf values"
127		)
128
129	7x	Filter(Negate(is.null), x_list)
130		})
131
132	7x	if (requireNamespace("yaml", quietly = TRUE)) {
133	7x	super$set_content(yaml::as.yaml(states_list))
134		} else {
135	!	stop("yaml package is required to format the filter state list")
136		}
137		}
138	10x	private$teal_slices <- content
139	10x	invisible(self)
140		},
141		#' @description Create the `RcodeBlock` from a list.
142		#' @param x (named `list`) with two fields `c("text", "params")`.
143		#' Use the `get_available_params` method to get all possible parameters.
144		#' @return `self`, invisibly.
145		from_list = function(x) {
146	1x	checkmate::assert_list(x)
147	1x	checkmate::assert_names(names(x), must.include = c("teal_slices"))
148	1x	self$set_content(x$teal_slices)
149	1x	invisible(self)
150		},
151		#' @description Convert the `RcodeBlock` to a list.
152		#' @return named `list` with a text and `params`.
153
154		to_list = function() {
155	2x	list(teal_slices = private$teal_slices)
156		}
157		),
158		private = list(
159		style = "verbatim",
160		teal_slices = NULL # teal_slices
161		)
162		)

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 through the filter manager, with the cog icon in the top right corner.
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 `filtered_data_list`) 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		#' @param id (`character(1)`) `shiny` module id
69		#' @param slices_global (`reactiveVal`) that contains a `teal_slices` object
70		#' containing all `teal_slice`s existing in the app, both active and inactive
71		#' @param mapping_matrix (`reactive`) that contains a `data.frame` representation
72		#' of the mapping of filter state ids (rows) to modules labels (columns);
73		#' all columns are `logical` vectors
74		#' @param filtered_data_list non-nested (named `list`) that contains `FilteredData` objects
75		#'
76		#' @return Nothing is returned.
77		#'
78		#' @name snapshot_manager_module
79		#' @aliases snapshot snapshot_manager
80		#'
81		#' @author Aleksander Chlebowski
82		#'
83		#' @rdname snapshot_manager_module
84		#' @keywords internal
85		#'
86		snapshot_manager_ui <- function(id) {
87	!	ns <- NS(id)
88	!	div(
89	!	class = "snapshot_manager_content",
90	!	div(
91	!	class = "snapshot_table_row",
92	!	span(tags$b("Snapshot manager")),
93	!	actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
94	!	actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"),
95	!	actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
96	!	NULL
97		),
98	!	uiOutput(ns("snapshot_list"))
99		)
100		}
101
102		#' @rdname snapshot_manager_module
103		#' @keywords internal
104		#'
105		snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
106	6x	checkmate::assert_character(id)
107	6x	checkmate::assert_true(is.reactive(slices_global))
108	6x	checkmate::assert_class(isolate(slices_global()), "teal_slices")
109	6x	checkmate::assert_true(is.reactive(mapping_matrix))
110	6x	checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)
111	6x	checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named")
112
113	6x	moduleServer(id, function(input, output, session) {
114	6x	ns <- session$ns
115
116		# Store global filter states ----
117	6x	filter <- isolate(slices_global())
118	6x	snapshot_history <- reactiveVal({
119	6x	list(
120	6x	"Initial application state" = as.list(filter, recursive = TRUE)
121		)
122		})
123
124		# Snapshot current application state ----
125		# Name snaphsot.
126	6x	observeEvent(input$snapshot_add, {
127	!	showModal(
128	!	modalDialog(
129	!	textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
130	!	footer = tagList(
131	!	actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
132	!	modalButton(label = "Cancel", icon = icon("thumbs-down"))
133		),
134	!	size = "s"
135		)
136		)
137		})
138		# Store snaphsot.
139	6x	observeEvent(input$snapshot_name_accept, {
140	!	snapshot_name <- trimws(input$snapshot_name)
141	!	if (identical(snapshot_name, "")) {
142	!	showNotification(
143	!	"Please name the snapshot.",
144	!	type = "message"
145		)
146	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
147	!	} else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
148	!	showNotification(
149	!	"This name is in conflict with other snapshot names. Please choose a different one.",
150	!	type = "message"
151		)
152	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
153		} else {
154	!	snapshot <- as.list(slices_global(), recursive = TRUE)
155	!	attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())
156	!	snapshot_update <- c(snapshot_history(), list(snapshot))
157	!	names(snapshot_update)[length(snapshot_update)] <- snapshot_name
158	!	snapshot_history(snapshot_update)
159	!	removeModal()
160		# Reopen filter manager modal by clicking button in the main application.
161	!	shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE)
162		}
163		})
164
165		# Upload a snapshot file ----
166		# Select file.
167	6x	observeEvent(input$snapshot_load, {
168	!	showModal(
169	!	modalDialog(
170	!	fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
171	!	textInput(
172	!	ns("snapshot_name"),
173	!	"Name the snapshot (optional)",
174	!	width = "100%",
175	!	placeholder = "Meaningful, unique name"
176		),
177	!	footer = tagList(
178	!	actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("thumbs-up")),
179	!	modalButton(label = "Cancel", icon = icon("thumbs-down"))
180		)
181		)
182		)
183		})
184		# Store new snapshot to list and restore filter states.
185	6x	observeEvent(input$snaphot_file_accept, {
186	!	snapshot_name <- trimws(input$snapshot_name)
187	!	if (identical(snapshot_name, "")) {
188	!	snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)
189		}
190	!	if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
191	!	showNotification(
192	!	"This name is in conflict with other snapshot names. Please choose a different one.",
193	!	type = "message"
194		)
195	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
196		} else {
197		# Restore snapshot and verify app compatibility.
198	!	snapshot_state <- try(slices_restore(input$snapshot_file$datapath))
199	!	if (!inherits(snapshot_state, "modules_teal_slices")) {
200	!	showNotification(
201	!	"File appears to be corrupt.",
202	!	type = "error"
203		)
204	!	} else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) {
205	!	showNotification(
206	!	"This snapshot file is not compatible with the app and cannot be loaded.",
207	!	type = "warning"
208		)
209		} else {
210		# Add to snapshot history.
211	!	snapshot <- as.list(snapshot_state, recursive = TRUE)
212	!	snapshot_update <- c(snapshot_history(), list(snapshot))
213	!	names(snapshot_update)[length(snapshot_update)] <- snapshot_name
214	!	snapshot_history(snapshot_update)
215		### Begin simplified restore procedure. ###
216	!	mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
217	!	mapply(
218	!	function(filtered_data, filter_ids) {
219	!	filtered_data$clear_filter_states(force = TRUE)
220	!	slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
221	!	filtered_data$set_filter_state(slices)
222		},
223	!	filtered_data = filtered_data_list,
224	!	filter_ids = mapping_unfolded
225		)
226	!	slices_global(snapshot_state)
227	!	removeModal()
228		### End simplified restore procedure. ###
229		}
230		}
231		})
232		# Apply newly added snapshot.
233
234		# Restore initial state ----
235	6x	observeEvent(input$snapshot_reset, {
236	!	s <- "Initial application state"
237		### Begin restore procedure. ###
238	!	snapshot <- snapshot_history()[[s]]
239	!	snapshot_state <- as.teal_slices(snapshot)
240	!	mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
241	!	mapply(
242	!	function(filtered_data, filter_ids) {
243	!	filtered_data$clear_filter_states(force = TRUE)
244	!	slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
245	!	filtered_data$set_filter_state(slices)
246		},
247	!	filtered_data = filtered_data_list,
248	!	filter_ids = mapping_unfolded
249		)
250	!	slices_global(snapshot_state)
251	!	removeModal()
252		### End restore procedure. ###
253		})
254
255		# Build snapshot table ----
256		# Create UI elements and server logic for the snapshot table.
257		# Observers must be tracked to avoid duplication and excess reactivity.
258		# Remaining elements are tracked likewise for consistency and a slight speed margin.
259	6x	observers <- reactiveValues()
260	6x	handlers <- reactiveValues()
261	6x	divs <- reactiveValues()
262
263	6x	observeEvent(snapshot_history(), {
264	2x	lapply(names(snapshot_history())[-1L], function(s) {
265	!	id_pickme <- sprintf("pickme_%s", make.names(s))
266	!	id_saveme <- sprintf("saveme_%s", make.names(s))
267	!	id_rowme <- sprintf("rowme_%s", make.names(s))
268
269		# Observer for restoring snapshot.
270	!	if (!is.element(id_pickme, names(observers))) {
271	!	observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
272		### Begin restore procedure. ###
273	!	snapshot <- snapshot_history()[[s]]
274	!	snapshot_state <- as.teal_slices(snapshot)
275	!	mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
276	!	mapply(
277	!	function(filtered_data, filter_ids) {
278	!	filtered_data$clear_filter_states(force = TRUE)
279	!	slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
280	!	filtered_data$set_filter_state(slices)
281		},
282	!	filtered_data = filtered_data_list,
283	!	filter_ids = mapping_unfolded
284		)
285	!	slices_global(snapshot_state)
286	!	removeModal()
287		### End restore procedure. ###
288		})
289		}
290		# Create handler for downloading snapshot.
291	!	if (!is.element(id_saveme, names(handlers))) {
292	!	output[[id_saveme]] <- downloadHandler(
293	!	filename = function() {
294	!	sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
295		},
296	!	content = function(file) {
297	!	snapshot <- snapshot_history()[[s]]
298	!	snapshot_state <- as.teal_slices(snapshot)
299	!	slices_store(tss = snapshot_state, file = file)
300		}
301		)
302	!	handlers[[id_saveme]] <- id_saveme
303		}
304		# Create a row for the snapshot table.
305	!	if (!is.element(id_rowme, names(divs))) {
306	!	divs[[id_rowme]] <- div(
307	!	class = "snapshot_table_row",
308	!	span(h5(s)),
309	!	actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
310	!	downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
311		)
312		}
313		})
314		})
315
316		# Create table to display list of snapshots and their actions.
317	6x	output$snapshot_list <- renderUI({
318	2x	rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d)
319	2x	if (length(rows) == 0L) {
320	2x	div(
321	2x	class = "snapshot_manager_placeholder",
322	2x	"Snapshots will appear here."
323		)
324		} else {
325	!	rows
326		}
327		})
328		})
329		}
330
331		### utility functions ----
332
333		#' Explicitly enumerate global filters.
334		#'
335		#' Transform module mapping such that global filters are explicitly specified for every module.
336		#'
337		#' @param mapping (named `list`) as stored in mapping parameter of `teal_slices`
338		#' @param module_names (`character`) vector containing names of all modules in the app
339		#' @return A `named_list` with one element per module, each element containing all filters applied to that module.
340		#' @keywords internal
341		#'
342		unfold_mapping <- function(mapping, module_names) {
343	!	module_names <- structure(module_names, names = module_names)
344	!	lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))
345		}
346
347		#' Convert mapping matrix to filter mapping specification.
348		#'
349		#' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,
350		#' to a list specification like the one used in the `mapping` attribute of `teal_slices`.
351		#' Global filters are gathered in one list element.
352		#' If a module has no active filters but the global ones, it will not be mentioned in the output.
353		#'
354		#' @param mapping_matrix (`data.frame`) of logical vectors where
355		#' columns represent modules and row represent `teal_slice`s
356		#' @return Named `list` like that in the `mapping` attribute of a `teal_slices` object.
357		#' @keywords internal
358		#'
359		matrix_to_mapping <- function(mapping_matrix) {
360	!	mapping_matrix[] <- lapply(mapping_matrix, function(x) x \| is.na(x))
361	!	global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))
362	!	global_filters <- names(global[global])
363	!	local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]
364
365	!	mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))
366	!	Filter(function(x) length(x) != 0L, mapping)
367		}

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		#' Create a UI of nested tabs of `teal_modules`
2		#'
3		#' @section `ui_nested_tabs`:
4		#' Each `teal_modules` is translated to a `tabsetPanel` and each
5		#' of its children is another tab-module called recursively. The UI of a
6		#' `teal_module` is obtained by calling its UI function.
7		#'
8		#' The `datasets` argument is required to resolve the `teal` arguments in an
9		#' isolated context (with respect to reactivity).
10		#'
11		#' @section `srv_nested_tabs`:
12		#' This module recursively calls all elements of `modules` and returns currently active one.
13		#' - `teal_module` returns self as a active module.
14		#' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.
15		#'
16		#' @name module_nested_tabs
17		#'
18		#' @inheritParams module_tabs_with_filters
19		#'
20		#' @param depth (`integer(1)`)
21		#' number which helps to determine depth of the modules nesting.
22		#' @param is_module_specific (`logical(1)`)
23		#' flag determining if the filter panel is global or module-specific.
24		#' When set to `TRUE`, a filter panel is called inside of each module tab.
25		#'
26		#' @return
27		#' Depending on the class of `modules`, `ui_nested_tabs` returns:
28		#' - `teal_module`: instantiated UI of the module.
29		#' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively
30		#' calling this function on it.
31		#'
32		#' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.
33		#'
34		#' @keywords internal
35		NULL
36
37		#' @rdname module_nested_tabs
38		ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
39	!	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
40	!	checkmate::assert_count(depth)
41	!	UseMethod("ui_nested_tabs", modules)
42		}
43
44		#' @rdname module_nested_tabs
45		#' @export
46		ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
47	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
48		}
49
50		#' @rdname module_nested_tabs
51		#' @export
52		ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
53	!	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
54	!	ns <- NS(id)
55	!	do.call(
56	!	tabsetPanel,
57	!	c(
58		# by giving an id, we can reactively respond to tab changes
59	!	list(
60	!	id = ns("active_tab"),
61	!	type = if (modules$label == "root") "pills" else "tabs"
62		),
63	!	lapply(
64	!	names(modules$children),
65	!	function(module_id) {
66	!	module_label <- modules$children[[module_id]]$label
67	!	tabPanel(
68	!	title = module_label,
69	!	value = module_id, # when clicked this tab value changes input$<tabset panel id>
70	!	ui_nested_tabs(
71	!	id = ns(module_id),
72	!	modules = modules$children[[module_id]],
73	!	datasets = datasets[[module_label]],
74	!	depth = depth + 1L,
75	!	is_module_specific = is_module_specific
76		)
77		)
78		}
79		)
80		)
81		)
82		}
83
84		#' @rdname module_nested_tabs
85		#' @export
86		ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
87	!	checkmate::assert_class(datasets, classes = "FilteredData")
88	!	ns <- NS(id)
89
90	!	args <- c(list(id = ns("module")), modules$ui_args)
91
92	!	teal_ui <- tags$div(
93	!	id = id,
94	!	class = "teal_module",
95	!	uiOutput(ns("data_reactive"), inline = TRUE),
96	!	tagList(
97	!	if (depth >= 2L) div(style = "mt-6"),
98	!	do.call(modules$ui, args)
99		)
100		)
101
102	!	if (!is.null(modules$datanames) && is_module_specific) {
103	!	fluidRow(
104	!	column(width = 9, teal_ui, class = "teal_primary_col"),
105	!	column(
106	!	width = 3,
107	!	datasets$ui_filter_panel(ns("module_filter_panel")),
108	!	class = "teal_secondary_col"
109		)
110		)
111		} else {
112	!	teal_ui
113		}
114		}
115
116		#' @rdname module_nested_tabs
117		srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,
118		reporter = teal.reporter::Reporter$new()) {
119	50x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
120	50x	checkmate::assert_class(reporter, "Reporter")
121	49x	UseMethod("srv_nested_tabs", modules)
122		}
123
124		#' @rdname module_nested_tabs
125		#' @export
126		srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,
127		reporter = teal.reporter::Reporter$new()) {
128	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
129		}
130
131		#' @rdname module_nested_tabs
132		#' @export
133		srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,
134		reporter = teal.reporter::Reporter$new()) {
135	22x	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
136
137	22x	moduleServer(id = id, module = function(input, output, session) {
138	22x	logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
139
140	22x	labels <- vapply(modules$children, `[[`, character(1), "label")
141	22x	modules_reactive <- sapply(
142	22x	names(modules$children),
143	22x	function(module_id) {
144	33x	srv_nested_tabs(
145	33x	id = module_id,
146	33x	datasets = datasets[[labels[module_id]]],
147	33x	modules = modules$children[[module_id]],
148	33x	is_module_specific = is_module_specific,
149	33x	reporter = reporter
150		)
151		},
152	22x	simplify = FALSE
153		)
154
155		# when not ready input$active_tab would return NULL - this would fail next reactive
156	22x	input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)
157	22x	get_active_module <- reactive({
158	12x	if (length(modules$children) == 1L) {
159		# single tab is active by default
160	1x	modules_reactive[[1]]()
161		} else {
162		# switch to active tab
163	11x	modules_reactive[[input_validated()]]()
164		}
165		})
166
167	22x	get_active_module
168		})
169		}
170
171		#' @rdname module_nested_tabs
172		#' @export
173		srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,
174		reporter = teal.reporter::Reporter$new()) {
175	27x	checkmate::assert_class(datasets, "FilteredData")
176	27x	logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
177
178	27x	moduleServer(id = id, module = function(input, output, session) {
179	27x	if (!is.null(modules$datanames) && is_module_specific) {
180	!	datasets$srv_filter_panel("module_filter_panel")
181		}
182
183		# Create two triggers to limit reactivity between filter-panel and modules.
184		# We want to recalculate only visible modules
185		# - trigger the data when the tab is selected
186		# - trigger module to be called when the tab is selected for the first time
187	27x	trigger_data <- reactiveVal(1L)
188	27x	trigger_module <- reactiveVal(NULL)
189	27x	output$data_reactive <- renderUI({
190	17x	lapply(datasets$datanames(), function(x) {
191	21x	datasets$get_data(x, filtered = TRUE)
192		})
193	17x	isolate(trigger_data(trigger_data() + 1))
194	17x	isolate(trigger_module(TRUE))
195
196	17x	NULL
197		})
198
199		# collect arguments to run teal_module
200	27x	args <- c(list(id = "module"), modules$server_args)
201	27x	if (is_arg_used(modules$server, "reporter")) {
202	!	args <- c(args, list(reporter = reporter))
203		}
204
205	27x	if (is_arg_used(modules$server, "datasets")) {
206	1x	args <- c(args, datasets = datasets)
207		}
208
209	27x	if (is_arg_used(modules$server, "data")) {
210	7x	data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets))
211	7x	args <- c(args, data = list(data))
212		}
213
214	27x	if (is_arg_used(modules$server, "filter_panel_api")) {
215	2x	filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)
216	2x	args <- c(args, filter_panel_api = filter_panel_api)
217		}
218
219		# observe the trigger_module above to induce the module once the renderUI is triggered
220	27x	observeEvent(
221	27x	ignoreNULL = TRUE,
222	27x	once = TRUE,
223	27x	eventExpr = trigger_module(),
224	27x	handlerExpr = {
225	17x	module_output <- if (is_arg_used(modules$server, "id")) {
226	17x	do.call(modules$server, args)
227		} else {
228	!	do.call(callModule, c(args, list(module = modules$server)))
229		}
230		}
231		)
232
233	27x	reactive(modules)
234		})
235		}
236
237		#' Convert `FilteredData` to reactive list of datasets of the `teal_data` type.
238		#'
239		#' Converts `FilteredData` object to `teal_data` object containing datasets needed for a specific module.
240		#' Please note that if a module needs a dataset which has a parent, then the parent will also be returned.
241		#' A hash per `dataset` is calculated internally and returned in the code.
242		#'
243		#' @param module (`teal_module`) module where needed filters are taken from
244		#' @param datasets (`FilteredData`) object where needed data are taken from
245		#'
246		#' @return A `teal_data` object.
247		#'
248		#' @keywords internal
249		.datasets_to_data <- function(module, datasets) {
250	4x	checkmate::assert_class(module, "teal_module")
251	4x	checkmate::assert_class(datasets, "FilteredData")
252
253	4x	datanames <- if (is.null(module$datanames) \|\| identical(module$datanames, "all")) {
254	1x	datasets$datanames()
255		} else {
256	3x	include_parent_datanames(
257	3x	module$datanames,
258	3x	datasets$get_join_keys()
259		)
260		}
261
262		# list of reactive filtered data
263	4x	data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)
264
265	4x	hashes <- calculate_hashes(datanames, datasets)
266
267	4x	code <- c(
268	4x	get_rcode_str_install(),
269	4x	get_rcode_libraries(),
270	4x	get_datasets_code(datanames, datasets, hashes)
271		)
272
273
274	4x	data <- do.call(
275	4x	teal.data::teal_data,
276	4x	args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames]))
277		)
278
279	4x	data@verified <- attr(datasets, "verification_status")
280	4x	data
281		}
282
283		#' Get the hash of a dataset
284		#'
285		#' @param datanames (`character`) names of datasets
286		#' @param datasets (`FilteredData`) object holding the data
287		#'
288		#' @return A list of hashes per dataset.
289		#' @keywords internal
290		#'
291		calculate_hashes <- function(datanames, datasets) {
292	7x	sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)
293		}

1		#' Add right filter panel into each of the top-level `teal_modules` UIs
2		#'
3		#' The [ui_nested_tabs] function returns a nested tabbed UI corresponding
4		#' to the nested modules.
5		#' This function adds the right filter panel to each main tab.
6		#'
7		#' The right filter panel's filter choices affect the `datasets` object. Therefore,
8		#' all modules using the same `datasets` share the same filters.
9		#'
10		#' This works with nested modules of depth greater than 2, though the filter
11		#' panel is inserted at the right of the modules at depth 1 and not at the leaves.
12		#'
13		#' @name module_tabs_with_filters
14		#'
15		#' @inheritParams module_teal
16		#'
17		#' @param datasets (named `list` of `FilteredData`)
18		#' object to store filter state and filtered datasets, shared across modules. For more
19		#' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure
20		#' of the `modules` argument and list names must correspond to the labels in `modules`.
21		#' When filter is not module-specific then list contains the same object in all elements.
22		#' @param reporter (`Reporter`) object from `teal.reporter`
23		#'
24		#' @return
25		#' A `shiny.tag.list` containing the main menu, placeholders for filters and placeholders for the `teal` modules.
26		#'
27		#' @keywords internal
28		#'
29		NULL
30
31		#' @rdname module_tabs_with_filters
32		ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
33	!	checkmate::assert_class(modules, "teal_modules")
34	!	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
35	!	checkmate::assert_class(filter, "teal_slices")
36
37	!	ns <- NS(id)
38	!	is_module_specific <- isTRUE(attr(filter, "module_specific"))
39
40	!	teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
41	!	filter_panel_btns <- tags$li(
42	!	class = "flex-grow",
43	!	tags$button(
44	!	class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger
45	!	href = "javascript:void(0)",
46	!	onclick = "toggleFilterPanel();", # see sidebar.js
47	!	title = "Toggle filter panels",
48	!	icon("fas fa-bars")
49		),
50	!	filter_manager_modal_ui(ns("filter_manager"))
51		)
52	!	teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)
53
54	!	if (!is_module_specific) {
55		# need to rearrange html so that filter panel is within tabset
56	!	tabset_bar <- teal_ui$children[[1]]
57	!	teal_modules <- teal_ui$children[[2]]
58	!	filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
59	!	list(
60	!	tabset_bar,
61	!	tags$hr(class = "my-2"),
62	!	fluidRow(
63	!	column(width = 9, teal_modules, class = "teal_primary_col"),
64	!	column(width = 3, filter_ui, class = "teal_secondary_col")
65		)
66		)
67		} else {
68	!	teal_ui
69		}
70		}
71
72		#' @rdname module_tabs_with_filters
73		srv_tabs_with_filters <- function(id,
74		datasets,
75		modules,
76		reporter = teal.reporter::Reporter$new(),
77		filter = teal_slices()) {
78	5x	checkmate::assert_class(modules, "teal_modules")
79	5x	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
80	5x	checkmate::assert_class(reporter, "Reporter")
81	3x	checkmate::assert_class(filter, "teal_slices")
82
83	3x	moduleServer(id, function(input, output, session) {
84	3x	logger::log_trace("srv_tabs_with_filters initializing the module.")
85
86	3x	is_module_specific <- isTRUE(attr(filter, "module_specific"))
87	3x	manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
88
89	3x	active_module <- srv_nested_tabs(
90	3x	id = "root",
91	3x	datasets = datasets,
92	3x	modules = modules,
93	3x	reporter = reporter,
94	3x	is_module_specific = is_module_specific
95		)
96
97	3x	if (!is_module_specific) {
98	3x	active_datanames <- reactive({
99	6x	if (identical(active_module()$datanames, "all")) {
100	!	singleton$datanames()
101		} else {
102	5x	include_parent_datanames(
103	5x	active_module()$datanames,
104	5x	singleton$get_join_keys()
105		)
106		}
107		})
108	3x	singleton <- unlist(datasets)[[1]]
109	3x	singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
110
111	3x	observeEvent(
112	3x	eventExpr = active_datanames(),
113	3x	handlerExpr = {
114	4x	script <- if (length(active_datanames()) == 0 \|\| is.null(active_datanames())) {
115		# hide the filter panel and disable the burger button
116	!	"handleNoActiveDatasets();"
117		} else {
118		# show the filter panel and enable the burger button
119	4x	"handleActiveDatasetsPresent();"
120		}
121	4x	shinyjs::runjs(script)
122		},
123	3x	ignoreNULL = FALSE
124		)
125		}
126
127	3x	showNotification("Data loaded - App fully started up")
128	3x	logger::log_trace("srv_tabs_with_filters initialized the module")
129
130	3x	active_module
131		})
132		}

1		# This file adds a splash screen for delayed data loading on top of teal
2
3		#' Add splash screen to `teal` application
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' Displays custom splash screen during initial delayed data loading.
8		#'
9		#' @details
10		#' This module pauses app initialization pending delayed data loading.
11		#' This is necessary because the filter panel and modules depend on the data to initialize.
12		#'
13		#' `teal_with_splash` follows the `shiny` module convention.
14		#' [`init()`] is a wrapper around this that assumes that `teal` it is
15		#' the top-level module and cannot be embedded.
16		#'
17		#' Note: It is no longer recommended to embed `teal` in `shiny` apps as a module.
18		#' but rather use `init` to create a standalone application.
19		#'
20		#' @seealso [init()]
21		#'
22		#' @param id (`character(1)`)
23		#' module id
24		#' @inheritParams init
25		#' @param modules (`teal_modules`) object containing the output modules which
26		#' will be displayed in the `teal` application. See [modules()] and [module()] for
27		#' more details.
28		#' @inheritParams shiny::moduleServer
29		#' @return
30		#' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not.
31		#' @name module_teal_with_splash
32		#' @examples
33		#' teal_modules <- modules(example_module())
34		#' # Shiny app with modular integration of teal
35		#' ui <- fluidPage(
36		#' ui_teal_with_splash(id = "app1", data = teal_data())
37		#' )
38		#'
39		#' server <- function(input, output, session) {
40		#' srv_teal_with_splash(
41		#' id = "app1",
42		#' data = teal_data(iris = iris),
43		#' modules = teal_modules
44		#' )
45		#' }
46		#'
47		#' if (interactive()) {
48		#' shinyApp(ui, server)
49		#' }
50		#'
51		NULL
52
53		#' @export
54		#' @rdname module_teal_with_splash
55		ui_teal_with_splash <- function(id,
56		data,
57		title = build_app_title(),
58		header = tags$p(),
59		footer = tags$p()) {
60	7x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
61	7x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
62	7x	checkmate::assert(
63	7x	.var.name = "title",
64	7x	checkmate::check_string(title),
65	7x	checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
66		)
67	7x	checkmate::assert(
68	7x	.var.name = "header",
69	7x	checkmate::check_string(header),
70	7x	checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
71		)
72	7x	checkmate::assert(
73	7x	.var.name = "footer",
74	7x	checkmate::check_string(footer),
75	7x	checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
76		)
77
78	7x	ns <- NS(id)
79
80		# Startup splash screen for delayed loading
81		# We use delayed loading in all cases, even when the data does not need to be fetched.
82		# This has the benefit that when filtering the data takes a lot of time initially, the
83		# Shiny app does not time out.
84	7x	splash_ui <- if (inherits(data, "teal_data_module")) {
85	1x	data$ui(ns("teal_data_module"))
86	7x	} else if (inherits(data, "teal_data")) {
87	6x	div()
88		}
89	7x	ui_teal(
90	7x	id = ns("teal"),
91	7x	splash_ui = div(splash_ui, uiOutput(ns("error"))),
92	7x	title = title,
93	7x	header = header,
94	7x	footer = footer
95		)
96		}
97
98		#' @export
99		#' @rdname module_teal_with_splash
100		srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
101	15x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
102	15x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
103	15x	checkmate::assert_class(modules, "teal_modules")
104	15x	checkmate::assert_class(filter, "teal_slices")
105
106	15x	moduleServer(id, function(input, output, session) {
107	15x	logger::log_trace("srv_teal_with_splash initializing module with data.")
108
109	15x	if (getOption("teal.show_js_log", default = FALSE)) {
110	!	shinyjs::showLog()
111		}
112
113		# teal_data_rv contains teal_data object
114		# either passed to teal::init or returned from teal_data_module
115	15x	teal_data_rv <- if (inherits(data, "teal_data_module")) {
116	10x	data <- data$server(id = "teal_data_module")
117	10x	if (!is.reactive(data)) {
118	1x	stop("The `teal_data_module` passed to `data` must return a reactive expression.", call. = FALSE)
119		}
120	9x	data
121	15x	} else if (inherits(data, "teal_data")) {
122	5x	reactiveVal(data)
123		}
124
125	14x	teal_data_rv_validate <- reactive({
126		# custom module can return error
127	11x	data <- tryCatch(teal_data_rv(), error = function(e) e)
128
129		# there is an empty reactive cycle on init!
130	11x	if (inherits(data, "shiny.silent.error") && identical(data$message, "")) {
131	!	return(NULL)
132		}
133
134		# to handle qenv.error
135	11x	if (inherits(data, "qenv.error")) {
136	2x	validate(
137	2x	need(
138	2x	FALSE,
139	2x	paste(
140	2x	"Error when executing `teal_data_module` passed to `data`:\n ",
141	2x	paste(data$message, collapse = "\n"),
142	2x	"\n Check your inputs or contact app developer if error persists."
143		)
144		)
145		)
146		}
147
148		# to handle module non-qenv errors
149	9x	if (inherits(data, "error")) {
150	1x	validate(
151	1x	need(
152	1x	FALSE,
153	1x	paste(
154	1x	"Error when executing `teal_data_module` passed to `data`:\n ",
155	1x	paste(data$message, collpase = "\n"),
156	1x	"\n Check your inputs or contact app developer if error persists."
157		)
158		)
159		)
160		}
161
162	8x	validate(
163	8x	need(
164	8x	inherits(data, "teal_data"),
165	8x	paste(
166	8x	"Error: `teal_data_module` passed to `data` failed to return `teal_data` object, returned",
167	8x	toString(sQuote(class(data))),
168	8x	"instead.",
169	8x	"\n Check your inputs or contact app developer if error persists."
170		)
171		)
172		)
173
174	5x	if (!length(teal.data::datanames(data))) {
175	1x	warning("`data` object has no datanames. Default datanames are set using `teal_data`'s environment.")
176		}
177
178	5x	is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
179	5x	if (!isTRUE(is_modules_ok)) {
180	1x	validate(need(isTRUE(is_modules_ok), sprintf("%s. Contact app developer.", is_modules_ok)))
181		}
182
183	4x	is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
184	4x	if (!isTRUE(is_filter_ok)) {
185	1x	showNotification(
186	1x	"Some filters were not applied because of incompatibility with data. Contact app developer.",
187	1x	type = "warning",
188	1x	duration = 10
189		)
190	1x	warning(is_filter_ok)
191		}
192
193	4x	teal_data_rv()
194		})
195
196	14x	output$error <- renderUI({
197	!	teal_data_rv_validate()
198	!	NULL
199		})
200
201
202	14x	res <- srv_teal(id = "teal", modules = modules, teal_data_rv = teal_data_rv_validate, filter = filter)
203	14x	logger::log_trace("srv_teal_with_splash initialized module with data.")
204
205	14x	res
206		})
207		}

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

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	4x	checkmate::assert_string(label)
24	2x	checkmate::assert_list(server_args, names = "named")
25	2x	checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))
26
27	2x	logger::log_info("Initializing reporter_previewer_module")
28
29	2x	srv <- function(id, reporter, ...) {
30	!	teal.reporter::reporter_previewer_srv(id, reporter, ...)
31		}
32
33	2x	ui <- function(id, ...) {
34	!	teal.reporter::reporter_previewer_ui(id, ...)
35		}
36
37	2x	module <- module(
38	2x	label = "temporary label",
39	2x	server = srv, ui = ui,
40	2x	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	2x	class(module) <- c("teal_module_previewer", class(module))
45	2x	module$label <- label
46	2x	module
47		}

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 optional (`logical(1)`)
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	78x	shiny::isolate({
78	78x	checkmate::assert_flag(allow_add)
79	78x	checkmate::assert_flag(module_specific)
80	32x	if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
81	75x	checkmate::assert_string(app_id, null.ok = TRUE)
82
83	75x	slices <- list(...)
84	75x	all_slice_id <- vapply(slices, `[[`, character(1L), "id")
85
86	75x	if (missing(mapping)) {
87	46x	mapping <- list(global_filters = all_slice_id)
88		}
89	75x	if (!module_specific) {
90	71x	mapping[setdiff(names(mapping), "global_filters")] <- NULL
91		}
92
93	75x	failed_slice_id <- setdiff(unlist(mapping), all_slice_id)
94	75x	if (length(failed_slice_id)) {
95	1x	stop(sprintf(
96	1x	"Filters in mapping don't match any available filter.\n %s not in %s",
97	1x	toString(failed_slice_id),
98	1x	toString(all_slice_id)
99		))
100		}
101
102	74x	tss <- teal.slice::teal_slices(
103		...,
104	74x	exclude_varnames = exclude_varnames,
105	74x	include_varnames = include_varnames,
106	74x	count_type = count_type,
107	74x	allow_add = allow_add
108		)
109	74x	attr(tss, "mapping") <- mapping
110	74x	attr(tss, "module_specific") <- module_specific
111	74x	attr(tss, "app_id") <- app_id
112	74x	class(tss) <- c("modules_teal_slices", class(tss))
113	74x	tss
114		})
115		}
116
117
118		#' @rdname teal_slices
119		#' @export
120		#' @keywords internal
121		#'
122		as.teal_slices <- function(x) { # nolint
123	10x	checkmate::assert_list(x)
124	10x	lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")
125
126	10x	attrs <- attributes(unclass(x))
127	10x	ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))
128	10x	do.call(teal_slices, c(ans, attrs))
129		}
130
131
132		#' @rdname teal_slices
133		#' @export
134		#' @keywords internal
135		#'
136		c.teal_slices <- function(...) {
137	!	x <- list(...)
138	!	checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")
139
140	!	all_attributes <- lapply(x, attributes)
141	!	all_attributes <- coalesce_r(all_attributes)
142	!	all_attributes <- all_attributes[names(all_attributes) != "class"]
143
144	!	do.call(
145	!	teal_slices,
146	!	c(
147	!	unique(unlist(x, recursive = FALSE)),
148	!	all_attributes
149		)
150		)
151		}
152
153
154		#' Deep copy `teal_slices`
155		#'
156		#' it's important to create a new copy of `teal_slices` when
157		#' starting a new `shiny` session. Otherwise, object will be shared
158		#' by multiple users as it is created in global environment before
159		#' `shiny` session starts.
160		#' @param filter (`teal_slices`)
161		#' @return `teal_slices`
162		#' @keywords internal
163		deep_copy_filter <- function(filter) {
164	1x	checkmate::assert_class(filter, "teal_slices")
165	1x	shiny::isolate({
166	1x	filter_copy <- lapply(filter, function(slice) {
167	2x	teal.slice::as.teal_slice(as.list(slice))
168		})
169	1x	attributes(filter_copy) <- attributes(filter)
170	1x	filter_copy
171		})
172		}

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		#' @details
14		#' When initializing the `teal` app, if `datanames` are not set for the `teal_data` object,
15		#' defaults from the `teal_data` environment will be used.
16		#'
17		#' @param data (`teal_data` or `teal_data_module`)
18		#' For constructing the data object, refer to [teal_data()] and [teal_data_module()].
19		#' @param modules (`list` or `teal_modules` or `teal_module`)
20		#' nested list of `teal_modules` or `teal_module` objects or a single
21		#' `teal_modules` or `teal_module` object. These are the specific output modules which
22		#' will be displayed in the `teal` application. See [modules()] and [module()] for
23		#' more details.
24		#' @param filter (`teal_slices`)
25		#' Specifies the initial filter using [teal_slices()].
26		#' @param title (`shiny.tag` or `character(1)`)
27		#' The browser window title. Defaults to a title "teal app" with the icon of NEST.
28		#' Can be created using the `build_app_title()` or
29		#' by passing a valid `shiny.tag` which is a head tag with title and link tag.
30		#' @param header (`shiny.tag` or `character(1)`)
31		#' The header of the app.
32		#' @param footer (`shiny.tag` or `character(1)`)
33		#' The footer of the app.
34		#' @param id (`character`)
35		#' Optional string specifying the `shiny` module id in cases it is used as a `shiny` module
36		#' rather than a standalone `shiny` app. This is a legacy feature.
37		#'
38		#' @return Named list with server and UI functions.
39		#'
40		#' @export
41		#'
42		#' @include modules.R
43		#'
44		#' @examples
45		#' app <- init(
46		#' data = teal_data(
47		#' new_iris = transform(iris, id = seq_len(nrow(iris))),
48		#' new_mtcars = transform(mtcars, id = seq_len(nrow(mtcars))),
49		#' code = "
50		#' new_iris <- transform(iris, id = seq_len(nrow(iris)))
51		#' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
52		#' "
53		#' ),
54		#' modules = modules(
55		#' module(
56		#' label = "data source",
57		#' server = function(input, output, session, data) {},
58		#' ui = function(id, ...) div(p("information about data source")),
59		#' datanames = "all"
60		#' ),
61		#' example_module(label = "example teal module"),
62		#' module(
63		#' "Iris Sepal.Length histogram",
64		#' server = function(input, output, session, data) {
65		#' output$hist <- renderPlot(
66		#' hist(data()[["new_iris"]]$Sepal.Length)
67		#' )
68		#' },
69		#' ui = function(id, ...) {
70		#' ns <- NS(id)
71		#' plotOutput(ns("hist"))
72		#' },
73		#' datanames = "new_iris"
74		#' )
75		#' ),
76		#' filter = teal_slices(
77		#' teal_slice(dataname = "new_iris", varname = "Species"),
78		#' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),
79		#' teal_slice(dataname = "new_mtcars", varname = "cyl"),
80		#' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
81		#' mapping = list(
82		#' `example teal module` = "new_iris Species",
83		#' `Iris Sepal.Length histogram` = "new_iris Species",
84		#' global_filters = "new_mtcars cyl"
85		#' )
86		#' ),
87		#' title = "App title",
88		#' header = tags$h1("Sample App"),
89		#' footer = tags$p("Copyright 2017 - 2023")
90		#' )
91		#' if (interactive()) {
92		#' shinyApp(app$ui, app$server)
93		#' }
94		#'
95		init <- function(data,
96		modules,
97		filter = teal_slices(),
98		title = build_app_title(),
99		header = tags$p(),
100		footer = tags$p(),
101		id = character(0)) {
102	10x	logger::log_trace("init initializing teal app with: data ('{ class(data) }').")
103
104		# argument checking (independent)
105		## `data`
106	10x	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	10x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
117
118		## `modules`
119	10x	checkmate::assert(
120	10x	.var.name = "modules",
121	10x	checkmate::check_multi_class(modules, c("teal_modules", "teal_module")),
122	10x	checkmate::check_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
123		)
124	10x	if (inherits(modules, "teal_module")) {
125	1x	modules <- list(modules)
126		}
127	10x	if (checkmate::test_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))) {
128	4x	modules <- do.call(teal::modules, modules)
129		}
130
131		## `filter`
132	10x	checkmate::assert_class(filter, "teal_slices")
133
134		## all other arguments
135	9x	checkmate::assert(
136	9x	.var.name = "title",
137	9x	checkmate::check_string(title),
138	9x	checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
139		)
140	9x	checkmate::assert(
141	9x	.var.name = "header",
142	9x	checkmate::check_string(header),
143	9x	checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
144		)
145	9x	checkmate::assert(
146	9x	.var.name = "footer",
147	9x	checkmate::check_string(footer),
148	9x	checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
149		)
150	9x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
151
152		# log
153	9x	teal.logger::log_system_info()
154
155		# argument transformations
156		## `modules` - landing module
157	9x	landing <- extract_module(modules, "teal_module_landing")
158	9x	landing_module <- NULL
159	9x	if (length(landing) == 1L) {
160	!	landing_module <- landing[[1L]]
161	!	modules <- drop_module(modules, "teal_module_landing")
162	9x	} else if (length(landing) > 1L) {
163	!	stop("Only one `landing_popup_module` can be used.")
164		}
165
166		## `filter` - app_id attribute
167	9x	attr(filter, "app_id") <- create_app_id(data, modules)
168
169		## `filter` - convert teal.slice::teal_slices to teal::teal_slices
170	9x	filter <- as.teal_slices(as.list(filter))
171
172		# argument checking (interdependent)
173		## `filter` - `modules`
174	9x	if (isTRUE(attr(filter, "module_specific"))) {
175	!	module_names <- unlist(c(module_labels(modules), "global_filters"))
176	!	failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)
177	!	if (length(failed_mod_names)) {
178	!	stop(
179	!	sprintf(
180	!	"Some module names in the mapping arguments don't match module labels.\n %s not in %s",
181	!	toString(failed_mod_names),
182	!	toString(unique(module_names))
183		)
184		)
185		}
186
187	!	if (anyDuplicated(module_names)) {
188		# In teal we are able to set nested modules with duplicated label.
189		# Because mapping argument bases on the relationship between module-label and filter-id,
190		# it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)
191	!	stop(
192	!	sprintf(
193	!	"Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",
194	!	toString(module_names[duplicated(module_names)])
195		)
196		)
197		}
198		}
199
200		## `data` - `modules`
201	9x	if (inherits(data, "teal_data")) {
202	8x	if (length(teal_data_datanames(data)) == 0) {
203	1x	stop("The environment of `data` is empty.")
204		}
205		# in case of teal_data_module this check is postponed to the srv_teal_with_splash
206	7x	is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
207	7x	if (!isTRUE(is_modules_ok)) {
208	1x	logger::log_error(is_modules_ok)
209	1x	checkmate::assert(is_modules_ok, .var.name = "modules")
210		}
211
212	6x	is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
213	6x	if (!isTRUE(is_filter_ok)) {
214	1x	warning(is_filter_ok)
215		# we allow app to continue if applied filters are outside
216		# of possible data range
217		}
218		}
219
220		# Note regarding case `id = character(0)`:
221		# rather than creating a submodule of this module, we directly modify
222		# the UI and server with `id = character(0)` and calling the server function directly
223	7x	res <- list(
224	7x	ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
225	7x	server = function(input, output, session) {
226	!	if (!is.null(landing_module)) {
227	!	do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args))
228		}
229	!	srv_teal_with_splash(id = id, data = data, modules = modules, filter = deep_copy_filter(filter))
230		}
231		)
232
233	7x	logger::log_trace("init teal app has been initialized.")
234
235	7x	res
236		}

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		#' @examples
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		#' 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", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
62		#' iv$enable()
63		#' # more input validation
64		#' iv_par <- InputValidator$new()
65		#' iv_par$add_rule("color", sv_required(message = "choose a color"))
66		#' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color")
67		#' iv_par$add_rule(
68		#' "size",
69		#' sv_between(
70		#' left = 0.5, right = 3,
71		#' message_fmt = "choose a value between {left} and {right}"
72		#' )
73		#' )
74		#' iv_par$enable()
75		#'
76		#' output$plot <- renderPlot({
77		#' # validate output
78		#' switch(input[["method"]],
79		#' "sequential" = {
80		#' validate_inputs(iv)
81		#' validate_inputs(iv_par, header = "Set proper graphical parameters")
82		#' },
83		#' "combined" = validate_inputs(iv, iv_par),
84		#' "grouped" = validate_inputs(list(
85		#' "Some inputs require attention" = iv,
86		#' "Set proper graphical parameters" = iv_par
87		#' ))
88		#' )
89		#'
90		#' plot(eruptions ~ waiting, faithful,
91		#' las = 1, pch = 16,
92		#' col = input[["color"]], cex = input[["size"]]
93		#' )
94		#' })
95		#' }
96		#'
97		#' if (interactive()) {
98		#' shinyApp(ui, server)
99		#' }
100		#'
101		#' @export
102		#'
103		validate_inputs <- function(..., header = "Some inputs require attention") {
104	36x	dots <- list(...)
105	2x	if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
106
107	34x	messages <- extract_validator(dots, header)
108	34x	failings <- if (!any_names(dots)) {
109	29x	add_header(messages, header)
110		} else {
111	5x	unlist(messages)
112		}
113
114	34x	shiny::validate(shiny::need(is.null(failings), failings))
115		}
116
117		### internal functions
118
119		#' @noRd
120		#' @keywords internal
121		# recursive object type test
122		# returns logical of length 1
123		is_validators <- function(x) {
124	118x	all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))
125		}
126
127		#' @noRd
128		#' @keywords internal
129		# test if an InputValidator object is enabled
130		# returns logical of length 1
131		# official method requested at https://github.com/rstudio/shinyvalidate/issues/64
132		validator_enabled <- function(x) {
133	49x	x$.__enclos_env__$private$enabled
134		}
135
136		#' Recursively extract messages from validator list
137		#' @return A character vector or a list of character vectors, possibly nested and named.
138		#' @noRd
139		#' @keywords internal
140		extract_validator <- function(iv, header) {
141	113x	if (inherits(iv, "InputValidator")) {
142	49x	add_header(gather_messages(iv), header)
143		} else {
144	58x	if (is.null(names(iv))) names(iv) <- rep("", length(iv))
145	64x	mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)
146		}
147		}
148
149		#' Collate failing messages from validator.
150		#' @return `list`
151		#' @noRd
152		#' @keywords internal
153		gather_messages <- function(iv) {
154	49x	if (validator_enabled(iv)) {
155	46x	status <- iv$validate()
156	46x	failing_inputs <- Filter(Negate(is.null), status)
157	46x	unique(lapply(failing_inputs, function(x) x[["message"]]))
158		} else {
159	3x	warning("Validator is disabled and will be omitted.")
160	3x	list()
161		}
162		}
163
164		#' Add optional header to failing messages
165		#' @noRd
166		#' @keywords internal
167		add_header <- function(messages, header = "") {
168	78x	ans <- unlist(messages)
169	78x	if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
170	31x	ans <- c(paste0(header, "\n"), ans, "\n")
171		}
172	78x	ans
173		}
174
175		#' Recursively check if the object contains a named list
176		#' @noRd
177		#' @keywords internal
178		any_names <- function(x) {
179	103x	any(
180	103x	if (is.list(x)) {
181	58x	if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))
182		} else {
183	40x	FALSE
184		}
185		)
186		}

1		# This module is the main teal module that puts everything together.
2
3		#' `teal` main app module
4		#'
5		#' This is the main `teal` app that puts everything together.
6		#'
7		#' It displays the splash UI which is used to fetch the data, possibly
8		#' prompting for a password input to fetch the data. Once the data is ready,
9		#' the splash screen is replaced by the actual `teal` UI that is tabsetted and
10		#' has a filter panel with `datanames` that are relevant for the current tab.
11		#' Nested tabs are possible, but we limit it to two nesting levels for reasons
12		#' of clarity of the UI.
13		#'
14		#' The splash screen functionality can also be used
15		#' for non-delayed data which takes time to load into memory, avoiding
16		#' `shiny` session timeouts.
17		#'
18		#' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the
19		#' `datasets` object that is shared across modules.
20		#' Once it is ready and non-`NULL`, the splash screen is replaced by the
21		#' main `teal` UI that depends on the data.
22		#' The currently active tab is tracked and the right filter panel
23		#' updates the displayed datasets to filter for according to the active `datanames`
24		#' of the tab.
25		#'
26		#' It is written as a `shiny` module so it can be added into other apps as well.
27		#'
28		#' @name module_teal
29		#'
30		#' @inheritParams module_teal_with_splash
31		#'
32		#' @param splash_ui (`shiny.tag`) UI to display initially,
33		#' can be a splash screen or a `shiny` module UI. For the latter, see
34		#' [init()] about how to call the corresponding server function.
35		#'
36		#' @param teal_data_rv (`reactive`)
37		#' returns the `teal_data`, only evaluated once, `NULL` value is ignored
38		#'
39		#' @return
40		#' Returns a `reactive` expression which returns the currently active module.
41		#'
42		#' @keywords internal
43		#'
44		NULL
45
46		#' @rdname module_teal
47		ui_teal <- function(id,
48		splash_ui = tags$h2("Starting the Teal App"),
49		title = build_app_title(),
50		header = tags$p(),
51		footer = tags$p()) {
52	7x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
53
54	7x	checkmate::assert_multi_class(splash_ui, c("shiny.tag", "shiny.tag.list", "html"))
55
56	7x	if (is.character(title)) {
57	!	title <- build_app_title(title)
58		} else {
59	7x	validate_app_title_tag(title)
60		}
61
62	7x	checkmate::assert(
63	7x	.var.name = "header",
64	7x	checkmate::check_string(header),
65	7x	checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
66		)
67	7x	if (checkmate::test_string(header)) {
68	!	header <- tags$p(header)
69		}
70
71	7x	checkmate::assert(
72	7x	.var.name = "footer",
73	7x	checkmate::check_string(footer),
74	7x	checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
75		)
76	7x	if (checkmate::test_string(footer)) {
77	!	footer <- tags$p(footer)
78		}
79
80	7x	ns <- NS(id)
81
82		# Once the data is loaded, we will remove this element and add the real teal UI instead
83	7x	splash_ui <- div(
84		# id so we can remove the splash screen once ready, which is the first child of this container
85	7x	id = ns("main_ui_container"),
86		# we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
87		# just the first item of the tagList)
88	7x	div(splash_ui)
89		)
90
91		# show busy icon when `shiny` session is busy computing stuff
92		# based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint
93	7x	shiny_busy_message_panel <- conditionalPanel(
94	7x	condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
95	7x	div(
96	7x	icon("arrows-rotate", "spin fa-spin"),
97	7x	"Computing ...",
98		# CSS defined in `custom.css`
99	7x	class = "shinybusymessage"
100		)
101		)
102
103	7x	fluidPage(
104	7x	title = title,
105	7x	theme = get_teal_bs_theme(),
106	7x	include_teal_css_js(),
107	7x	tags$header(header),
108	7x	tags$hr(class = "my-2"),
109	7x	shiny_busy_message_panel,
110	7x	splash_ui,
111	7x	tags$hr(),
112	7x	tags$footer(
113	7x	div(
114	7x	footer,
115	7x	teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
116	7x	textOutput(ns("identifier"))
117		)
118		)
119		)
120		}
121
122
123		#' @rdname module_teal
124		srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
125	19x	stopifnot(is.reactive(teal_data_rv))
126	18x	moduleServer(id, function(input, output, session) {
127	18x	logger::log_trace("srv_teal initializing the module.")
128
129	18x	output$identifier <- renderText(
130	18x	paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
131		)
132
133	18x	teal.widgets::verbatim_popup_srv(
134	18x	"sessionInfo",
135	18x	verbatim_content = utils::capture.output(utils::sessionInfo()),
136	18x	title = "SessionInfo"
137		)
138
139		# `JavaScript` code
140	18x	run_js_files(files = "init.js")
141
142		# set timezone in shiny app
143		# timezone is set in the early beginning so it will be available also
144		# for `DDL` and all shiny modules
145	18x	get_client_timezone(session$ns)
146	18x	observeEvent(
147	18x	eventExpr = input$timezone,
148	18x	once = TRUE,
149	18x	handlerExpr = {
150	!	session$userData$timezone <- input$timezone
151	!	logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
152		}
153		)
154
155	18x	reporter <- teal.reporter::Reporter$new()
156	18x	if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
157	!	modules <- append_module(modules, reporter_previewer_module())
158		}
159
160	18x	env <- environment()
161	18x	datasets_reactive <- eventReactive(teal_data_rv(), {
162	4x	env$progress <- shiny::Progress$new(session)
163	4x	env$progress$set(0.25, message = "Setting data")
164
165		# create a list of data following structure of the nested modules list structure.
166		# Because it's easier to unpack modules and datasets when they follow the same nested structure.
167	4x	datasets_singleton <- teal_data_to_filtered_data(teal_data_rv())
168
169		# Singleton starts with only global filters active.
170	4x	filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)
171	4x	datasets_singleton$set_filter_state(filter_global)
172
173	4x	module_datasets <- function(modules) {
174	18x	if (inherits(modules, "teal_modules")) {
175	7x	datasets <- lapply(modules$children, module_datasets)
176	7x	labels <- vapply(modules$children, `[[`, character(1), "label")
177	7x	names(datasets) <- labels
178	7x	datasets
179	11x	} else if (isTRUE(attr(filter, "module_specific"))) {
180		# we should create FilteredData even if modules$datanames is null
181		# null controls a display of filter panel but data should be still passed
182	3x	datanames <- if (is.null(modules$datanames) \|\| identical(modules$datanames, "all")) {
183	3x	include_parent_datanames(
184	3x	teal_data_datanames(teal_data_rv()),
185	3x	teal.data::join_keys(teal_data_rv())
186		)
187		} else {
188	!	modules$datanames
189		}
190		# todo: subset teal_data to datanames
191	3x	datasets_module <- teal_data_to_filtered_data(teal_data_rv(), datanames = datanames)
192
193		# set initial filters
194		# - filtering filters for this module
195	3x	slices <- Filter(x = filter, f = function(x) {
196	!	x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&
197	!	x$dataname %in% datanames
198		})
199	3x	include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]
200	3x	exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]
201	3x	slices$include_varnames <- include_varnames
202	3x	slices$exclude_varnames <- exclude_varnames
203	3x	datasets_module$set_filter_state(slices)
204	3x	datasets_module
205		} else {
206	8x	datasets_singleton
207		}
208		}
209	4x	module_datasets(modules)
210		})
211
212		# Replace splash / welcome screen once data is loaded ----
213		# ignoreNULL to not trigger at the beginning when data is NULL
214		# just handle it once because data obtained through delayed loading should
215		# usually not change afterwards
216		# if restored from bookmarked state, `filter` is ignored
217
218	18x	observeEvent(datasets_reactive(), once = TRUE, {
219	!	logger::log_trace("srv_teal@5 setting main ui after data was pulled")
220	!	on.exit(env$progress$close())
221	!	env$progress$set(0.5, message = "Setting up main UI")
222	!	datasets <- datasets_reactive()
223
224		# main_ui_container contains splash screen first and we remove it and replace it by the real UI
225	!	removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container")))
226	!	insertUI(
227	!	selector = paste0("#", session$ns("main_ui_container")),
228	!	where = "beforeEnd",
229		# we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
230		# just the first item of the tagList)
231	!	ui = div(ui_tabs_with_filters(
232	!	session$ns("main_ui"),
233	!	modules = modules,
234	!	datasets = datasets,
235	!	filter = filter
236		)),
237		# needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not
238		# have any effect as they are ignored when not present
239	!	immediate = TRUE
240		)
241
242		# must make sure that this is only executed once as modules assume their observers are only
243		# registered once (calling server functions twice would trigger observers twice each time)
244	!	srv_tabs_with_filters(
245	!	id = "main_ui",
246	!	datasets = datasets,
247	!	modules = modules,
248	!	reporter = reporter,
249	!	filter = filter
250		)
251		})
252		})
253		}

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		#' 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	7x	css_files <- list.files(
13	7x	system.file("css", package = "teal", mustWork = TRUE),
14	7x	pattern = pattern, full.names = TRUE
15		)
16
17	7x	singleton(
18	7x	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	7x	checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)
35	7x	js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
36	7x	js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL
37
38	7x	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 returns `NULL`, invisibly.
55		#' @keywords internal
56		run_js_files <- function(files) {
57	18x	checkmate::assert_character(files, min.len = 1, any.missing = FALSE)
58	18x	lapply(files, function(file) {
59	18x	shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
60		})
61	18x	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	7x	tagList(
77	7x	shinyjs::useShinyjs(),
78	7x	include_css_files(),
79		# init.js is executed from the server
80	7x	include_js_files(except = "init.js"),
81	7x	shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
82		)
83		}

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	6x	expr <- substitute(expr)
29	6x	extras <- list(...)
30
31		# Add braces for consistency.
32	6x	if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
33	6x	expr <- call("{", expr)
34		}
35
36	6x	calls <- as.list(expr)[-1]
37
38		# Inject extra values into expressions.
39	6x	calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))
40
41	6x	eval_code(object = data, code = as.expression(calls))
42		}

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") {
17	49x	checkmate::assert_string(label)
18	49x	module(
19	49x	label,
20	49x	server = function(id, data) {
21	!	checkmate::assert_class(data(), "teal_data")
22	!	moduleServer(id, function(input, output, session) {
23	!	updateSelectInput(session, "dataname", choices = isolate(teal.data::datanames(data())))
24	!	output$text <- renderPrint({
25	!	req(input$dataname)
26	!	data()[[input$dataname]]
27		})
28	!	teal.widgets::verbatim_popup_srv(
29	!	id = "rcode",
30	!	verbatim_content = reactive(teal.code::get_code(data())),
31	!	title = "Example Code"
32		)
33		})
34		},
35	49x	ui = function(id) {
36	!	ns <- NS(id)
37	!	teal.widgets::standard_layout(
38	!	output = verbatimTextOutput(ns("text")),
39	!	encoding = div(
40	!	selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
41	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
42		)
43		)
44		},
45	49x	datanames = datanames
46		)
47		}

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	13x	teal_data_module(
30	13x	ui = function(id) {
31	1x	ns <- NS(id)
32	1x	object$ui(ns("mutate_inner"))
33		},
34	13x	server = function(id) {
35	11x	moduleServer(id, function(input, output, session) {
36	11x	teal_data_rv <- object$server("mutate_inner")
37
38	11x	if (!is.reactive(teal_data_rv)) {
39	1x	stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
40		}
41
42	10x	td <- eventReactive(teal_data_rv(),
43		{
44	10x	if (inherits(teal_data_rv(), c("teal_data", "qenv.error"))) {
45	6x	eval_code(teal_data_rv(), code)
46		} else {
47	4x	teal_data_rv()
48		}
49		},
50	10x	ignoreNULL = FALSE
51		)
52	10x	td
53		})
54		}
55		)
56		})
57
58		setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
59	1x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
60		})
61
62		setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
63	6x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
64		})

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 supply or modify data in a `teal` application.
10		#' The module allows for running data pre-processing code (creation _and_ some modification) after the app starts.
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		#'
25		#' @return
26		#' `teal_data_module` returns an object of class `teal_data_module`.
27		#'
28		#' @examples
29		#' tdm <- teal_data_module(
30		#' ui = function(id) {
31		#' ns <- NS(id)
32		#' actionButton(ns("submit"), label = "Load data")
33		#' },
34		#' server = function(id) {
35		#' moduleServer(id, function(input, output, session) {
36		#' eventReactive(input$submit, {
37		#' data <- within(
38		#' teal_data(),
39		#' {
40		#' dataset1 <- iris
41		#' dataset2 <- mtcars
42		#' }
43		#' )
44		#' datanames(data) <- c("dataset1", "dataset2")
45		#'
46		#' data
47		#' })
48		#' })
49		#' }
50		#' )
51		#'
52		#' @name teal_data_module
53		#' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]
54		#'
55		#' @export
56		teal_data_module <- function(ui, server) {
57	36x	checkmate::assert_function(ui, args = "id", nargs = 1)
58	35x	checkmate::assert_function(server, args = "id", nargs = 1)
59	34x	structure(
60	34x	list(ui = ui, server = server),
61	34x	class = "teal_data_module"
62		)
63		}

1		#' Show `R` code modal
2		#'
3		#' @description `r lifecycle::badge("stable")`
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, if missing then [shiny::getDefaultReactiveDomain()] is used.
13		#'
14		#' @references [shiny::showModal()]
15		#' @export
16		show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) {
17	!	rcode <- paste(rcode, collapse = "\n")
18
19	!	ns <- session$ns
20	!	showModal(modalDialog(
21	!	tagList(
22	!	tags$div(
23	!	actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
24	!	modalButton("Dismiss"),
25	!	style = "mb-4"
26		),
27	!	tags$div(tags$pre(id = ns("r_code"), rcode)),
28		),
29	!	title = title,
30	!	footer = tagList(
31	!	actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
32	!	modalButton("Dismiss")
33		),
34	!	size = "l",
35	!	easyClose = TRUE
36		))
37		}