teal coverage - 73.28%

Files
Source

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

#' UI to show a splash screen in the beginning, then delegate to [srv_teal()]
#'
#' @description `r lifecycle::badge("stable")`
#' The splash screen could be used to query for a password to fetch the data.
#' [init()] is a very thin wrapper around this module useful for end-users which
#' assumes that it is a top-level module and cannot be embedded.
#' This function instead adheres to the Shiny module conventions.
#'
#' If data is obtained through delayed loading, its splash screen is used. Otherwise,
#' a default splash screen is shown.
#'
#' Please also refer to the doc of [init()].
#'
#' @param id (`character(1)`)\cr
#'   module id
#' @inheritParams init
#' @export
ui_teal_with_splash <- function(id,
                                data,
                                title,
                                header = tags$p("Add Title Here"),
                                footer = tags$p("Add Footer Here")) {
  checkmate::assert_class(data, "TealDataAbstract")
  is_pulled_data <- teal.data::is_pulled(data)
  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 (is_pulled_data) {
    # blank ui if data is already pulled
    div()
  } else {
    message("App was initialized with delayed data loading.")
    data$get_ui(ns("startapp_module"))
  }

  ui_teal(id = ns("teal"), splash_ui = splash_ui, title = title, header = header, footer = footer)
}

#' Server function that loads the data through reactive loading and then delegates
#' to [srv_teal()].
#'
#' @description `r lifecycle::badge("stable")`
#' Please also refer to the doc of [init()].
#'
#' @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 `reactive`, return value of [srv_teal()]
#' @export
srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
  checkmate::assert_class(data, "TealDataAbstract")
  moduleServer(id, function(input, output, session) {
    logger::log_trace(
      "srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
    )

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

    is_pulled_data <- teal.data::is_pulled(data)
    # raw_data contains TealDataAbstract, i.e. R6 object and container for data
    # reactive to get data through delayed loading
    # we must leave it inside the server because of callModule which needs to pick up the right session
    if (is_pulled_data) {
      raw_data <- reactiveVal(data) # will trigger by setting it
    } else {
      raw_data <- data$get_server()(id = "startapp_module")
      if (!is.reactive(raw_data)) {
        stop("The delayed loading module has to return a reactive object.")
      }
    }

    res <- srv_teal(id = "teal", modules = modules, raw_data = raw_data, filter = filter)
    logger::log_trace(
      "srv_teal_with_splash initialized the module with data { paste(data$get_datanames(), collapse = ' ') }."
    )
    return(res)
  })
}

#' Creates a `teal_modules` object.
#'
#' @description `r lifecycle::badge("stable")`
#' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object
#' containing the passed objects.
#'
#' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules`
#' shapes the navigation panel of a `teal` application.
#'
#' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details
#' @param label (`character(1)`) label of modules collection (default `"root"`).
#' If using the `label` argument then it must be explicitly named.
#' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
#'
#' @export
#'
#' @return object of class \code{teal_modules}. Object 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.
#' @examples
#' library(shiny)
#'
#' app <- init(
#'   data = teal_data(dataset("iris", iris)),
#'   modules = modules(
#'     label = "Modules",
#'     modules(
#'       label = "Module",
#'       module(
#'         label = "Inner 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(
#'       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
#'     )
#'   )
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
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"
  )
}

#' Function which appends a teal_module onto the 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 `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
}

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


#' Creates a `teal_module` object.
#'
#' @description `r lifecycle::badge("stable")`
#' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module.
#'
#' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except
#'  `"global_filters"` - read more in `mapping` argument of [teal::teal_slices].
#' @param server (`function`) `shiny` module with following arguments:
#'  - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]).
#'  - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module.
#'  - `data` (optional) module will receive a `tdata` object, a list of reactive (filtered) data specified in
#'     the `filters` argument.
#'  - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).
#'  - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]).
#   - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).
#'  - `...` (optional) `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.
#'  - `data` (optional)  module will receive list of reactive (filtered) data specified in the `filters` argument.
#'  - `datasets` (optional)  module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).
#'  - `...` (optional) `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.
#'
#' @return object of class `teal_module`.
#' @export
#' @examples
#' library(shiny)
#'
#' app <- init(
#'   data = teal_data(dataset("iris", iris)),
#'   modules = list(
#'     module(
#'       label = "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")))
#'       }
#'     )
#'   )
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
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) {
  checkmate::assert_string(label)
  checkmate::assert_function(server)
  checkmate::assert_function(ui)
  checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)
  checkmate::assert_list(server_args, null.ok = TRUE, names = "named")
  checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")

  if (!missing(filters)) {
    checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE)
    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)
  }

  if (label == "global_filters") {
    stop("Label 'global_filters' is reserved in teal. Please change to something else.")
  }
  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 (!is.element("data", server_formals)) {
    message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
    datanames <- NULL
  }

  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_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 optionaly:",
      "\n - `data` - module will receive list of reactive (filtered) data specied in the `filters` argument",
      "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",
      "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"
    )
  }

  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 = datanames,
      server_args = server_args, ui_args = ui_args
    ),
    class = "teal_module"
  )
}


#' 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
#'
#' @examples
#' mods <- modules(
#'   label = "d1",
#'   modules(
#'     label = "d2",
#'     modules(
#'       label = "d3",
#'       module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3")
#'     ),
#'     module(label = "bbb")
#'   ),
#'   module(label = "ccc")
#' )
#' stopifnot(teal:::modules_depth(mods) == 3L)
#'
#' mods <- modules(
#'   label = "a",
#'   modules(
#'     label = "b1", module(label = "c")
#'   ),
#'   module(label = "b2")
#' )
#' stopifnot(teal:::modules_depth(mods) == 2L)
modules_depth <- function(modules, depth = 0L) {
  checkmate::assert(
    checkmate::check_class(modules, "teal_module"),
    checkmate::check_class(modules, "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
  }
}


module_labels <- function(modules) {
  if (inherits(modules, "teal_modules")) {
    lapply(modules$children, module_labels)
  } else {
    modules$label
  }
}

#' Converts `teal_modules` to a string
#'
#' @param x (`teal_modules`) to print
#' @param indent (`integer`) indent level;
#'   each `submodule` is indented one level more
#' @param ... (optional) additional parameters to pass to recursive calls of `toString`
#' @return (`character`)
#' @export
#' @rdname modules
toString.teal_modules <- function(x, indent = 0, ...) { # nolint
  # argument must be `x` to be consistent with base method
  paste(c(
    paste0(rep(" ", indent), "+ ", x$label),
    unlist(lapply(x$children, toString, indent = indent + 1, ...))
  ), collapse = "\n")
}

#' Converts `teal_module` to a string
#'
#' @inheritParams toString.teal_modules
#' @param x `teal_module`
#' @param ... ignored
#' @export
#' @rdname module
toString.teal_module <- function(x, indent = 0, ...) { # nolint
  paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
}

#' Prints `teal_modules`
#' @param x `teal_modules`
#' @param ... parameters passed to `toString`
#' @export
#' @rdname modules
print.teal_modules <- function(x, ...) {
  s <- toString(x, ...)
  cat(s)
  return(invisible(s))
}

#' Prints `teal_module`
#' @param x `teal_module`
#' @param ... parameters passed to `toString`
#' @export
#' @rdname module
print.teal_module <- print.teal_modules

#' 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.
#'
#' 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 two icons: a camera and an circular arrow.
#' Clicking the camera captures a snapshot 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::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 [`teal.slice::slices_store`].
#'
#' @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_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"
        )
      )
    })
    # Snapshot current application state - 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)
      }
    })

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

    # 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)
              teal.slice::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)
}

#' Filter manager modal
#'
#' Opens modal containing the filter manager UI.
#'
#' @name module_filter_manager_modal
#' @inheritParams filter_manager_srv
#' @examples
#' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris)))
#' fd2 <- teal.slice::init_filtered_data(
#'   list(iris = list(dataset = iris), mtcars = list(dataset = mtcars))
#' )
#' fd3 <- teal.slice::init_filtered_data(
#'   list(iris = list(dataset = iris), women = list(dataset = women))
#' )
#' filter <- teal_slices(
#'   teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length"),
#'   teal.slice::teal_slice(dataname = "iris", varname = "Species"),
#'   teal.slice::teal_slice(dataname = "mtcars", varname = "mpg"),
#'   teal.slice::teal_slice(dataname = "women", varname = "height"),
#'   mapping = list(
#'     module2 = c("mtcars mpg"),
#'     module3 = c("women height"),
#'     global_filters = "iris Species"
#'   )
#' )
#'
#' app <- shinyApp(
#'   ui = fluidPage(
#'     teal:::filter_manager_modal_ui("manager")
#'   ),
#'   server = function(input, output, session) {
#'     teal:::filter_manager_modal_srv(
#'       "manager",
#'       filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3),
#'       filter = filter
#'     )
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
#'
#' @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"))
  )
}

#' Manage multiple `FilteredData` objects
#'
#' Oversee filter states in the whole application.
#'
#' @rdname module_filter_manager
#' @details
#' This module observes the changes of the filters in 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).
#'
#' @param id (`character(1)`)\cr
#'  `shiny` module id.
#' @param filtered_data_list (`named list`)\cr
#'  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 names of the list must be the same as 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
#'
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 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 fo filters to modules in matrix form (presented as data.frame).
    # Modules get NAs for filteres 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) <- ""
        }

        mm
      },
      align = paste(c("l", rep("c", length(filtered_data_list))), 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
#'
#' Track filter states in 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)`)\cr
#'  `shiny` module id.
#' @param module_fd (`FilteredData`)\cr
#'   object to filter data in the teal-module
#' @param slices_global (`reactiveVal`)\cr
#'   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
  })
}

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

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

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

#' @keywords internal
# recursively extract messages from validator list
# returns character vector or a list of character vectors, possibly nested and named
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)
  }
}

#' @keywords internal
# collate failing messages from validator
# returns list
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 {
    logger::log_warn("Validator is disabled and will be omitted.")
    list()
  }
}

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

#' @keywords internal
# recursively check if the object contains a named list
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
    }
  )
}

#' 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
  )
  return(
    shiny::singleton(
      shiny::tags$head(lapply(css_files, shiny::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

  return(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
#' @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"))
  })
  return(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.
#'
#' @return HTML code to include
#' @examples
#' shiny_ui <- tagList(
#'   teal:::include_teal_css_js(),
#'   p("Hello")
#' )
#' @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
  )
}

# 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 `raw_data` (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 ui_teal_with_splash
#'
#' @param splash_ui (`shiny.tag`)\cr 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 raw_data (`reactive`)\cr
#'   returns the `TealData`, only evaluated once, `NULL` value is ignored
#'
#' @return
#' `ui_teal` returns `HTML` for Shiny module UI.
#' `srv_teal` returns `reactive` which returns the currently active module.
#'
#' @keywords internal
#'
#' @examples
#' mods <- teal:::example_modules()
#' raw_data <- reactive(teal:::example_cdisc_data())
#' app <- shinyApp(
#'   ui = function() {
#'     teal:::ui_teal("dummy")
#'   },
#'   server = function(input, output, session) {
#'     active_module <- teal:::srv_teal(id = "dummy", modules = mods, raw_data = raw_data)
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
NULL

#' @rdname module_teal
ui_teal <- function(id,
                    splash_ui = tags$h2("Starting the Teal App"),
                    title = NULL,
                    header = tags$p(""),
                    footer = tags$p("")) {
  if (checkmate::test_string(header)) {
    header <- tags$h1(header)
  }
  if (checkmate::test_string(footer)) {
    footer <- tags$p(footer)
  }
  checkmate::assert(
    checkmate::check_class(splash_ui, "shiny.tag"),
    checkmate::check_class(splash_ui, "shiny.tag.list"),
    checkmate::check_class(splash_ui, "html")
  )
  checkmate::assert(
    checkmate::check_class(header, "shiny.tag"),
    checkmate::check_class(header, "shiny.tag.list"),
    checkmate::check_class(header, "html")
  )
  checkmate::assert(
    checkmate::check_class(footer, "shiny.tag"),
    checkmate::check_class(footer, "shiny.tag.list"),
    checkmate::check_class(footer, "html")
  )

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

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


#' @rdname module_teal
srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
  stopifnot(is.reactive(raw_data))
  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") # `JavaScript` code to make the clipboard accessible
    # 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 }.")
      }
    )

    # loading the data -----
    env <- environment()
    datasets_reactive <- reactive({
      if (is.null(raw_data())) {
        return(NULL)
      }
      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.slice::init_filtered_data(raw_data())
      # 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)) raw_data()$get_datanames() else modules$datanames
          data_objects <- sapply(
            datanames,
            function(dataname) {
              dataset <- raw_data()$get_dataset(dataname)
              list(
                dataset = dataset$get_raw_data(),
                metadata = dataset$get_metadata(),
                label = dataset$get_dataset_label()
              )
            },
            simplify = FALSE
          )
          datasets_module <- teal.slice::init_filtered_data(
            data_objects,
            join_keys = raw_data()$get_join_keys(),
            code = raw_data()$get_code_class(),
            check = raw_data()$get_check()
          )

          # set initial filters
          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
        }
      }
      datasets <- module_datasets(modules)

      logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
      datasets
    })

    reporter <- teal.reporter::Reporter$new()
    is_any_previewer <- function(modules) {
      if (inherits(modules, "teal_modules")) {
        any(unlist(lapply(modules$children, is_any_previewer), use.names = FALSE))
      } else if (inherits(modules, "teal_module_previewer")) {
        TRUE
      } else {
        FALSE
      }
    }
    if (is_arg_used(modules, "reporter") && !is_any_previewer(modules)) {
      modules <- append_module(modules, reporter_previewer_module())
    }

    # 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(), ignoreNULL = TRUE, once = TRUE, {
      logger::log_trace("srv_teal@5 setting main ui after data was pulled")
      env$progress$set(0.5, message = "Setting up main UI")
      on.exit(env$progress$close())
      # main_ui_container contains splash screen first and we remove it and replace it by the real UI

      removeUI(sprintf("#%s:first-child", 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_reactive(),
          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)
      active_module <- srv_tabs_with_filters(
        id = "main_ui",
        datasets = datasets_reactive(),
        modules = modules,
        reporter = reporter,
        filter = filter
      )
      return(active_module)
    })
  })
}

#' Get dummy `CDISC` data
#'
#' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`.
#' Some NAs are also introduced to stress test.
#'
#' @return `cdisc_data`
#' @keywords internal
example_cdisc_data <- function() { # nolint
  ADSL <- data.frame( # nolint
    STUDYID = "study",
    USUBJID = 1:10,
    SEX = sample(c("F", "M"), 10, replace = TRUE),
    AGE = stats::rpois(10, 40)
  )
  ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint
  ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
  ADTTE$AVAL <- c( # nolint
    stats::rnorm(10, mean = 700, sd = 200), # dummy OS level
    stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level
    stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level
  )

  ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint
  ADSL$SEX[c(2, 5)] <- NA # nolint

  cdisc_data_obj <- teal.data::cdisc_data(
    cdisc_dataset(dataname = "ADSL", x = ADSL),
    cdisc_dataset(dataname = "ADTTE", x = ADTTE)
  )

  res <- teal.data::cdisc_data(
    teal.data::cdisc_dataset(dataname = "ADSL", x = ADSL),
    teal.data::cdisc_dataset(dataname = "ADTTE", x = ADTTE),
    code = '
      ADSL <- data.frame(
        STUDYID = "study",
        USUBJID = 1:10,
        SEX = sample(c("F", "M"), 10, replace = TRUE),
        AGE = rpois(10, 40)
      )
      ADTTE <- rbind(ADSL, ADSL, ADSL)
      ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
      ADTTE$AVAL <- c(
        rnorm(10, mean = 700, sd = 200),
        rnorm(10, mean = 400, sd = 100),
        rnorm(10, mean = 450, sd = 200)
      )

      ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE)
      ADSL$SEX[c(2, 5)] <- NA
    '
  )
  return(res)
}

#' Get datasets to go with example modules.
#'
#' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`.
#' Each list leaf is the same `FilteredData` object.
#'
#' @return named list of `FilteredData` objects, each with `ADSL` set.
#' @keywords internal
example_datasets <- function() { # nolint
  dummy_cdisc_data <- example_cdisc_data()
  datasets <- teal.slice::init_filtered_data(dummy_cdisc_data)
  list(
    "d2" = list(
      "d3" = list(
        "aaa1" = datasets,
        "aaa2" = datasets,
        "aaa3" = datasets
      ),
      "bbb" = datasets
    ),
    "ccc" = datasets
  )
}

#' An example `teal` module
#'
#' @description `r lifecycle::badge("experimental")`
#' @inheritParams module
#' @return A `teal` module which can be included in the `modules` argument to [teal::init()].
#' @examples
#' app <- init(
#'   data = teal_data(
#'     dataset("IRIS", iris),
#'     dataset("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, "tdata")
      moduleServer(id, function(input, output, session) {
        output$text <- renderPrint(data[[input$dataname]]())
      })
    },
    ui = function(id, data) {
      ns <- NS(id)
      teal.widgets::standard_layout(
        output = verbatimTextOutput(ns("text")),
        encoding = selectInput(ns("dataname"), "Choose a dataset", choices = names(data))
      )
    },
    datanames = datanames
  )
}


#' Get example modules.
#'
#' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created.
#' @param datanames (`character`)\cr
#'  names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`.
#' @return `teal_modules`
#' @keywords internal
example_modules <- function(datanames = c("ADSL", "ADTTE")) {
  checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
  mods <- modules(
    label = "d1",
    modules(
      label = "d2",
      modules(
        label = "d3",
        example_module(label = "aaa1", datanames = datanames),
        example_module(label = "aaa2", datanames = datanames),
        example_module(label = "aaa3", datanames = datanames)
      ),
      example_module(label = "bbb", datanames = datanames)
    ),
    example_module(label = "ccc", datanames = datanames)
  )
  return(mods)
}

#' Get Client Timezone
#'
#' Local timezone in the browser may differ from the system timezone from 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
  return(invisible(NULL))
}

#' Resolve the expected bootstrap theme
#' @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
  }
}

include_parent_datanames <- function(dataname, join_keys) {
  parents <- character(0)
  for (i in dataname) {
    while (length(i) > 0) {
      parent_i <- join_keys$get_parent(i)
      parents <- c(parent_i, parents)
      i <- parent_i
    }
  }

  return(unique(c(parents, dataname)))
}

#' 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`)\cr
#'   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 `tagList` of The main menu, place holders for filters and
#'   place holders for the teal modules
#'
#'
#' @keywords internal
#'
#' @examples
#'
#' mods <- teal:::example_modules()
#' datasets <- teal:::example_datasets()
#'
#' app <- shinyApp(
#'   ui = function() {
#'     tagList(
#'       teal:::include_teal_css_js(),
#'       textOutput("info"),
#'       fluidPage( # needed for nice tabs
#'         ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
#'       )
#'     )
#'   },
#'   server = function(input, output, session) {
#'     output$info <- renderText({
#'       paste0("The currently active tab name is ", active_module()$label)
#'     })
#'     active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods)
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
#'
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(active_module()$datanames)
      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")
    return(active_module)
  })
}

# 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 doc 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 out of teal modules.
#'
#' **Notes for developers**:
#' This is a wrapper function around the `module_teal.R` functions. Unless you are
#' an end-user, don't use this function, but instead this module.
#'
#' @param data (`TealData` or `TealDataset` or `TealDatasetConnector` or `list` or `data.frame`
#' or `MultiAssayExperiment`)\cr
#' `R6` object as returned by [teal.data::cdisc_data()], [teal.data::teal_data()],
#' [teal.data::cdisc_dataset()], [teal.data::dataset()], [teal.data::dataset_connector()] or
#' [teal.data::cdisc_dataset_connector()] or a single `data.frame` or a `MultiAssayExperiment`
#' or a list of the previous objects or function returning a named list.
#' NOTE: teal does not guarantee reproducibility of the code when names of the list elements
#' do not match the original object names. To ensure reproducibility please use [teal.data::teal_data()]
#' or [teal.data::cdisc_data()] with `check = TRUE` enabled.
#' @param modules (`list`, `teal_modules` or `teal_module`)\cr
#'   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 title (`NULL` or `character`)\cr
#'   The browser window title (defaults to the host URL of the page).
#' @param filter (`teal_slices`)\cr
#'   Specification of initial filter. Filters can be specified using [teal::teal_slices()].
#'   Old way of specifying filters through a list is deprecated and will be removed in the
#'   next release. Please fix your applications to use [teal::teal_slices()].
#' @param header (`shiny.tag` or `character`) \cr
#'   the header of the app. Note shiny code placed here (and in the footer
#'   argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function
#'   (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here.
#' @param footer (`shiny.tag` or `character`)\cr
#'   the footer of the app
#' @param id (`character`)\cr
#'   module id to embed it, if provided,
#'   the server function must be called with [shiny::moduleServer()];
#'   See the vignette for an example. However, [ui_teal_with_splash()]
#'   is then preferred to this function.
#'
#' @return named list with `server` and `ui` function
#'
#' @export
#'
#' @include modules.R
#'
#' @examples
#' new_iris <- transform(iris, id = seq_len(nrow(iris)))
#' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
#'
#' app <- init(
#'   data = teal_data(
#'     dataset("new_iris", new_iris),
#'     dataset("new_mtcars", new_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"
#'     )
#'   ),
#'   title = "App title",
#'   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"
#'     )
#'   ),
#'   header = tags$h1("Sample App"),
#'   footer = tags$p("Copyright 2017 - 2023")
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
init <- function(data,
                 modules,
                 title = NULL,
                 filter = teal_slices(),
                 header = tags$p(),
                 footer = tags$p(),
                 id = character(0)) {
  logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
  data <- teal.data::to_relational_data(data = data)

  checkmate::assert_class(data, "TealData")
  checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
  checkmate::assert_string(title, null.ok = TRUE)
  checkmate::assert(
    checkmate::check_class(filter, "teal_slices"),
    checkmate::check_list(filter, names = "named")
  )
  checkmate::assert_multi_class(header, c("shiny.tag", "character"))
  checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)

  teal.logger::log_system_info()

  if (inherits(modules, "teal_module")) {
    modules <- list(modules)
  }
  if (inherits(modules, "list")) {
    modules <- do.call(teal::modules, modules)
  }

  # resolve modules datanames
  datanames <- teal.data::get_dataname(data)
  join_keys <- data$get_join_keys()
  resolve_modules_datanames <- function(modules) {
    if (inherits(modules, "teal_modules")) {
      modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE)
      modules
    } else {
      modules$datanames <- if (identical(modules$datanames, "all")) {
        datanames
      } else if (is.character(modules$datanames)) {
        datanames_adjusted <- intersect(modules$datanames, datanames)
        include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)
      }
      modules
    }
  }
  modules <- resolve_modules_datanames(modules = modules)

  if (!inherits(filter, "teal_slices")) {
    checkmate::assert_subset(names(filter), choices = datanames)
    # list_to_teal_slices is lifted from teal.slice package, see zzz.R
    # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).
    filter <- list_to_teal_slices(filter)
  }
  # convert teal.slice::teal_slices to teal::teal_slices
  filter <- as.teal_slices(as.list(filter))

  # check teal_slices
  for (i in seq_along(filter)) {
    dataname_i <- shiny::isolate(filter[[i]]$dataname)
    if (!dataname_i %in% datanames) {
      stop(
        sprintf(
          "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s",
          i,
          dataname_i,
          toString(datanames)
        )
      )
    }
  }

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

  # Note regarding case `id = character(0)`:
  # rather than using `callModule` and creating a submodule of this module, we directly modify
  # the `ui` and `server` with `id = character(0)` and calling the server function directly
  # rather than through `callModule`
  res <- list(
    ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
    server = function(input, output, session) {
      # copy object so that load won't be shared between the session
      data <- data$copy(deep = TRUE)
      filter <- deep_copy_filter(filter)
      srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)
    }
  )
  logger::log_trace("init teal app has been initialized.")
  return(res)
}

#' Create a `tdata` Object
#'
#' Create a new object called `tdata` which contains `data`, a `reactive` list of data.frames
#' (or `MultiAssayExperiment`), with attributes:
#' \itemize{
#'   \item{`code` (`reactive`) containing code used to generate the data}
#'   \item{join_keys (`JoinKeys`) containing the relationships between the data}
#'   \item{metadata (`named list`) containing any metadata associated with the data frames}
#' }
#' @name tdata
#' @param data A `named list` of `data.frames` (or `MultiAssayExperiment`)
#'  which optionally can be `reactive`.
#'   Inside this object all of these items will be made `reactive`.
#' @param code A `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 A `teal.data::JoinKeys` object containing relationships between the
#'   datasets.
#' @param metadata A `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
#' @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(data))
#'
#' # Get metadata
#' get_metadata(data, "iris")
#'
#' @export
new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
  checkmate::assert_list(
    data,
    any.missing = FALSE, names = "unique",
    types = c("data.frame", "reactive", "MultiAssayExperiment")
  )
  checkmate::assert_class(join_keys, "JoinKeys", 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))
  for (m in metadata) teal.data::validate_metadata(m)

  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]))
    } else {
      isolate(
        checkmate::assert_multi_class(
          data[[x]](), c("data.frame", "MultiAssayExperiment"),
          .var.name = "data"
        )
      )
    }
  }

  # 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 `reactives` inside `tdata` are first evaluated
#' @param data a `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))
}

#' @rdname tdata
#' @param x a `tdata` object
#' @param ... additional arguments for the generic
#' @export
get_code.tdata <- function(x, ...) { # nolint
  # note teal.data which teal depends on defines the get_code method
  attr(x, "code")()
}


#' 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")
  get_code(data)
}


#' Function to get join keys from a `tdata` object
#' @param data `tdata` - object to extract the join keys
#' @return Either `JoinKeys` object or `NULL` if no join keys
#' @export
get_join_keys <- function(data) {
  UseMethod("get_join_keys", data)
}


#' @rdname get_join_keys
#' @export
get_join_keys.tdata <- function(data) {
  attr(data, "join_keys")
}


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

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

#' 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 the `ui` function on it.
#'
#' The `datasets` argument is required to resolve the teal arguments in an
#' isolated context (with respect to reactivity)
#'
#' @section `srv_nested_tabs`:
#' This module calls recursively all elements of the `modules` returns one which
#' is currently active.
#' - `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)`)\cr
#'  number which helps to determine depth of the modules nesting.
#' @param is_module_specific (`logical(1)`)\cr
#'  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 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.\cr
#' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.
#'
#' @examples
#' mods <- teal:::example_modules()
#' datasets <- teal:::example_datasets()
#' app <- shinyApp(
#'   ui = function() {
#'     tagList(
#'       teal:::include_teal_css_js(),
#'       textOutput("info"),
#'       fluidPage( # needed for nice tabs
#'         teal:::ui_nested_tabs("dummy", modules = mods, datasets = datasets)
#'       )
#'     )
#'   },
#'   server = function(input, output, session) {
#'     active_module <- teal:::srv_nested_tabs(
#'       "dummy",
#'       datasets = datasets,
#'       modules = mods
#'     )
#'     output$info <- renderText({
#'       paste0("The currently active tab name is ", active_module()$label)
#'     })
#'   }
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
#' @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, class = "FilteredData")
  ns <- NS(id)

  args <- isolate(teal.transform::resolve_delayed(modules$ui_args, datasets))
  args <- c(list(id = ns("module")), args)

  if (is_arg_used(modules$ui, "datasets")) {
    args <- c(args, datasets = datasets)
  }

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

  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) {
    modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets)
    if (!is.null(modules$datanames) && is_module_specific) {
      datasets$srv_filter_panel("module_filter_panel", active_datanames = reactive(modules$datanames))
    }

    # 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 <- .datasets_to_data(modules, datasets, trigger_data)
      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)
    }

    if (is_arg_used(modules$server, "datasets") && is_arg_used(modules$server, "data")) {
      warning(
        "Module '", modules$label, "' has `data` and `datasets` arguments in the formals.",
        "\nIt's recommended to use `data` to work with filtered objects."
      )
    }

    # 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 `tdata` type.
#'
#' Converts `FilteredData` object to `tdata` object containing datasets needed for a specific module.
#' Please note that if module needs dataset which has a parent, then parent will be also 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
#' @param trigger_data (`reactiveVal`) to trigger getting the filtered data
#' @return list of reactive datasets with following attributes:
#' - `code` (`character`) containing datasets reproducible code.
#' - `join_keys` (`JoinKeys`) containing relationships between datasets.
#' - `metadata` (`list`) containing metadata of datasets.
#'
#' @keywords internal
.datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) {
  checkmate::assert_class(module, "teal_module")
  checkmate::assert_class(datasets, "FilteredData")
  checkmate::assert_class(trigger_data, "reactiveVal")

  datanames <- if (is.null(module$datanames)) datasets$datanames() else module$datanames

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

  hashes <- calculate_hashes(datanames, datasets)
  metadata <- lapply(datanames, datasets$get_metadata)
  names(metadata) <- datanames

  new_tdata(
    data,
    eventReactive(
      trigger_data(),
      c(
        get_rcode_str_install(),
        get_rcode_libraries(),
        get_datasets_code(datanames, datasets, hashes),
        teal.slice::get_filter_expr(datasets, datanames)
      )
    ),
    datasets$get_join_keys(),
    metadata
  )
}

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

#' @title `TealReportCard`
#' @description `r lifecycle::badge("experimental")`
#' A child 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 invisibly self
    #' @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 invisibly self
    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 invisibly self
    #' @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 `TealSlicesBlock`
    #' @examples
    #' block <- teal:::TealSlicesBlock$new()
    #'
    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 invisibly self
    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 invisibly self
    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
  )
)

# This file contains Shiny modules useful for debugging and developing teal.
# We do not export the functions in this file. They are for
# developers only and can be accessed via `:::`.

#' Dummy module to show the filter calls generated by the right encoding panel
#'
#'
#' Please do not remove, this is useful for debugging teal without
#' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
#' and avoids session restarts!
#'
#' @param label `character` label of module
#' @keywords internal
#'
#' @examples
#' app <- init(
#'   data = list(iris = iris, mtcars = mtcars),
#'   modules = teal:::filter_calls_module(),
#'   header = "Simple teal app"
#' )
#' if (interactive()) {
#'   runApp(app)
#' }
filter_calls_module <- function(label = "Filter Calls Module") { # nolint
  checkmate::assert_string(label)

  module(
    label = label,
    server = function(input, output, session, data) {
      checkmate::assert_class(data, "tdata")

      output$filter_calls <- renderText({
        get_code_tdata(data)
      })
    },
    ui = function(id, ...) {
      ns <- NS(id)
      div(
        h2("The following filter calls are generated:"),
        verbatimTextOutput(ns("filter_calls"))
      )
    },
    datanames = "all"
  )
}

#' Validate that dataset has a minimum number of observations
#'
#' @description `r lifecycle::badge("stable")`
#' @param x a data.frame
#' @param min_nrow minimum number of rows in \code{x}
#' @param complete \code{logical} default \code{FALSE} when set to \code{TRUE} then complete cases are checked.
#' @param allow_inf \code{logical} default \code{TRUE} when set to \code{FALSE} then error thrown if any values are
#'   infinite.
#' @param msg (`character(1)`) additional message to display alongside the default message.
#'
#' @details This function is a wrapper for `shiny::validate`.
#'
#' @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({
#'     df <- iris[iris$Sepal.Length <= input$len, ]
#'     validate_has_data(
#'       iris_f,
#'       min_nrow = 10,
#'       complete = FALSE,
#'       msg = "Please adjust Max Length of Sepal"
#'     )
#'
#'     hist(iris_f$Sepal.Length, breaks = 5)
#'   })
#' }
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
validate_has_data <- function(x,
                              min_nrow = NULL,
                              complete = FALSE,
                              allow_inf = TRUE,
                              msg = NULL) {
  stopifnot(
    "Please provide a character vector in msg argument of validate_has_data." = is.character(msg) || is.null(msg)
  )
  validate(need(!is.null(x) && is.data.frame(x), "No data left."))
  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
#'
#' @description `r lifecycle::badge("stable")`
#' @param x a data.frame
#' @param key a vector of ID variables from \code{x} that identify unique records
#'
#' @details This function is a wrapper for `shiny::validate`.
#'
#' @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
#'
#' @description `r lifecycle::badge("stable")`
#' @param x values to test. All must be in \code{choices}
#' @param choices a vector to test for values of \code{x}
#' @param msg warning message to display
#'
#' @details This function is a wrapper for `shiny::validate`.
#'
#' @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
#'
#' @description `r lifecycle::badge("stable")`
#' @param x vector
#' @param msg message to display
#'
#' @details This function is a wrapper for `shiny::validate`.
#'
#' @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
#'
#' @description `r lifecycle::badge("stable")`
#' @param x vector
#' @param y vector
#' @param msg message to display if \code{x} and \code{y} intersect
#'
#' @details This function is a wrapper for `shiny::validate`.
#'
#' @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
#'
#' @description `r lifecycle::badge("stable")`
#' @param data a data.frame
#' @param varname name of variable in \code{data}
#' @param msg message to display if \code{data} does not include \code{varname}
#'
#' @details This function is a wrapper for `shiny::validate`.
#'
#' @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
#'
#' @description `r lifecycle::badge("stable")`
#' @param x variable name. If \code{x} is not a factor, the unique values
#'   are treated as levels.
#' @param min_levels cutoff for minimum number of levels of \code{x}
#' @param max_levels cutoff for maximum number of levels of \code{x}
#' @param var_name name of variable being validated for use in
#'   validation message
#'
#' @details If the number of levels of \code{x} is less than \code{min_levels}
#'   or greater than \code{max_levels} the validation will fail.
#'   This function is a wrapper for `shiny::validate`.
#'
#' @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)
    ))
  }
}

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

# Use non-exported function(s) from teal.slice.
# This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).
list_to_teal_slices <- getFromNamespace("list_to_teal_slices", "teal.slice") # nolint
# This one is here because setdiff_teal_slice should not be exported from teal.slice.
setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
# all *Block objects are private in teal.reporter
RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint

#' Generates library calls from current session info
#'
#' Function to create multiple library calls out of current session info to make reproducible code works.
#'
#' @return Character object contain code
#' @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 = "")
}



get_rcode_str_install <- function() {
  code_string <- getOption("teal.load_nest_code")

  if (!is.null(code_string) && is.character(code_string)) {
    return(code_string)
  }

  return("# Add any code to install/load your NEST environment here\n")
}

#' Get datasets code
#'
#' Get combined code from `FilteredData` and from `CodeClass` object.
#'
#' @param datanames (`character`) names of datasets to extract code from
#' @param datasets (`FilteredData`) object
#' @param hashes named (`list`) of hashes per dataset
#'
#' @return `character(3)` containing following elements:
#'  - code from `CodeClass` (data loading code)
#'  - hash check of loaded objects
#'
#' @keywords internal
get_datasets_code <- function(datanames, datasets, hashes) {
  str_code <- datasets$get_code(datanames)
  if (length(str_code) == 0 || (length(str_code) == 1 && str_code == "")) {
    str_code <- "message('Preprocessing is empty')"
  } else if (length(str_code) > 0) {
    str_code <- paste0(str_code, "\n\n")
  }

  if (!datasets$get_check()) {
    check_note_string <- paste0(
      c(
        "message(paste(\"Reproducibility of data import and preprocessing was not explicitly checked\",",
        "   \" ('check = FALSE' is set). Contact app developer if this is an issue.\n\"))"
      ),
      collapse = "\n"
    )
    str_code <- paste0(str_code, "\n\n", check_note_string)
  }

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

  c(str_code, str_hash)
}

#' 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 [teal::init()] then this
#' module will be added to your application automatically if any of your `teal modules`
#' support report generation
#'
#' @inheritParams module
#' @param server_args (`named list`)\cr
#'  Arguments passed to [teal.reporter::reporter_previewer_srv()].
#' @return `teal_module` 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))))

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

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

  module <- module(
    label = label,
    server = srv, ui = ui,
    server_args = server_args, ui_args = list(), datanames = NULL
  )
  class(module) <- c("teal_module_previewer", class(module))
  module
}

#' Filter settings for teal applications
#'
#' Filter settings for teal applications
#'
#' @inheritParams teal.slice::teal_slices
#'
#' @param module_specific (`logical(1)`)\cr
#'  - `TRUE` when filter panel should be module-specific. All modules can have different set
#'   of filters specified - see `mapping` argument.
#'  - `FALSE` when one filter panel needed to all modules. All filters will be shared
#'    by all modules.
#' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
#'  (`named list`)\cr
#'  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 x (`list`) of lists to convert to `teal_slices`
#'
#' @examples
#' filter <- teal_slices(
#'   teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"),
#'   teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),
#'   teal.slice::teal_slice(
#'     dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"
#'   ),
#'   teal.slice::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 <- teal::init(
#'   modules = list(
#'     module("module1"),
#'     module("module2")
#'   ),
#'   data = list(iris, mtcars),
#'   filter = filter
#' )
#'
#' if (interactive()) {
#'   shiny::runApp(app)
#' }
#'
#' @export
teal_slices <- function(...,
                        exclude_varnames = NULL,
                        include_varnames = NULL,
                        count_type = NULL,
                        allow_add = TRUE,
                        module_specific = FALSE,
                        mapping) {
  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")

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


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

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`)\cr
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 A `tagList` of The main menu, place holders for filters and
25		#' place holders for the teal modules
26		#'
27		#'
28		#' @keywords internal
29		#'
30		#' @examples
31		#'
32		#' mods <- teal:::example_modules()
33		#' datasets <- teal:::example_datasets()
34		#'
35		#' app <- shinyApp(
36		#' ui = function() {
37		#' tagList(
38		#' teal:::include_teal_css_js(),
39		#' textOutput("info"),
40		#' fluidPage( # needed for nice tabs
41		#' ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
42		#' )
43		#' )
44		#' },
45		#' server = function(input, output, session) {
46		#' output$info <- renderText({
47		#' paste0("The currently active tab name is ", active_module()$label)
48		#' })
49		#' active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods)
50		#' }
51		#' )
52		#' if (interactive()) {
53		#' runApp(app)
54		#' }
55		#'
56		NULL
57
58		#' @rdname module_tabs_with_filters
59		ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
60	1x	checkmate::assert_class(modules, "teal_modules")
61	1x	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
62	1x	checkmate::assert_class(filter, "teal_slices")
63
64	1x	ns <- NS(id)
65	1x	is_module_specific <- isTRUE(attr(filter, "module_specific"))
66
67	1x	teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
68	1x	filter_panel_btns <- tags$li(
69	1x	class = "flex-grow",
70	1x	tags$button(
71	1x	class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger
72	1x	href = "javascript:void(0)",
73	1x	onclick = "toggleFilterPanel();", # see sidebar.js
74	1x	title = "Toggle filter panels",
75	1x	icon("fas fa-bars")
76		),
77	1x	filter_manager_modal_ui(ns("filter_manager"))
78		)
79	1x	teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)
80
81	1x	if (!is_module_specific) {
82		# need to rearrange html so that filter panel is within tabset
83	1x	tabset_bar <- teal_ui$children[[1]]
84	1x	teal_modules <- teal_ui$children[[2]]
85	1x	filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
86	1x	list(
87	1x	tabset_bar,
88	1x	tags$hr(class = "my-2"),
89	1x	fluidRow(
90	1x	column(width = 9, teal_modules, class = "teal_primary_col"),
91	1x	column(width = 3, filter_ui, class = "teal_secondary_col")
92		)
93		)
94		} else {
95	!	teal_ui
96		}
97		}
98
99		#' @rdname module_tabs_with_filters
100		srv_tabs_with_filters <- function(id,
101		datasets,
102		modules,
103		reporter = teal.reporter::Reporter$new(),
104		filter = teal_slices()) {
105	6x	checkmate::assert_class(modules, "teal_modules")
106	6x	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
107	6x	checkmate::assert_class(reporter, "Reporter")
108	4x	checkmate::assert_class(filter, "teal_slices")
109
110	4x	moduleServer(id, function(input, output, session) {
111	4x	logger::log_trace("srv_tabs_with_filters initializing the module.")
112
113	4x	is_module_specific <- isTRUE(attr(filter, "module_specific"))
114	4x	manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
115
116	4x	active_module <- srv_nested_tabs(
117	4x	id = "root",
118	4x	datasets = datasets,
119	4x	modules = modules,
120	4x	reporter = reporter,
121	4x	is_module_specific = is_module_specific
122		)
123
124	4x	if (!is_module_specific) {
125	4x	active_datanames <- reactive(active_module()$datanames)
126	4x	singleton <- unlist(datasets)[[1]]
127	4x	singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
128
129	4x	observeEvent(
130	4x	eventExpr = active_datanames(),
131	4x	handlerExpr = {
132	5x	script <- if (length(active_datanames()) == 0 \|\| is.null(active_datanames())) {
133		# hide the filter panel and disable the burger button
134	1x	"handleNoActiveDatasets();"
135		} else {
136		# show the filter panel and enable the burger button
137	4x	"handleActiveDatasetsPresent();"
138		}
139	5x	shinyjs::runjs(script)
140		},
141	4x	ignoreNULL = FALSE
142		)
143		}
144
145	4x	showNotification("Data loaded - App fully started up")
146	4x	logger::log_trace("srv_tabs_with_filters initialized the module")
147	4x	return(active_module)
148		})
149		}

1		# This file adds a splash screen for delayed data loading on top of teal
2
3		#' UI to show a splash screen in the beginning, then delegate to [srv_teal()]
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#' The splash screen could be used to query for a password to fetch the data.
7		#' [init()] is a very thin wrapper around this module useful for end-users which
8		#' assumes that it is a top-level module and cannot be embedded.
9		#' This function instead adheres to the Shiny module conventions.
10		#'
11		#' If data is obtained through delayed loading, its splash screen is used. Otherwise,
12		#' a default splash screen is shown.
13		#'
14		#' Please also refer to the doc of [init()].
15		#'
16		#' @param id (`character(1)`)\cr
17		#' module id
18		#' @inheritParams init
19		#' @export
20		ui_teal_with_splash <- function(id,
21		data,
22		title,
23		header = tags$p("Add Title Here"),
24		footer = tags$p("Add Footer Here")) {
25	32x	checkmate::assert_class(data, "TealDataAbstract")
26	32x	is_pulled_data <- teal.data::is_pulled(data)
27	32x	ns <- NS(id)
28
29		# Startup splash screen for delayed loading
30		# We use delayed loading in all cases, even when the data does not need to be fetched.
31		# This has the benefit that when filtering the data takes a lot of time initially, the
32		# Shiny app does not time out.
33	32x	splash_ui <- if (is_pulled_data) {
34		# blank ui if data is already pulled
35	28x	div()
36		} else {
37	4x	message("App was initialized with delayed data loading.")
38	4x	data$get_ui(ns("startapp_module"))
39		}
40
41	32x	ui_teal(id = ns("teal"), splash_ui = splash_ui, title = title, header = header, footer = footer)
42		}
43
44		#' Server function that loads the data through reactive loading and then delegates
45		#' to [srv_teal()].
46		#'
47		#' @description `r lifecycle::badge("stable")`
48		#' Please also refer to the doc of [init()].
49		#'
50		#' @inheritParams init
51		#' @param modules `teal_modules` object containing the output modules which
52		#' will be displayed in the teal application. See [modules()] and [module()] for
53		#' more details.
54		#' @inheritParams shiny::moduleServer
55		#' @return `reactive`, return value of [srv_teal()]
56		#' @export
57		srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
58	4x	checkmate::assert_class(data, "TealDataAbstract")
59	4x	moduleServer(id, function(input, output, session) {
60	4x	logger::log_trace(
61	4x	"srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
62		)
63
64	4x	if (getOption("teal.show_js_log", default = FALSE)) {
65	!	shinyjs::showLog()
66		}
67
68	4x	is_pulled_data <- teal.data::is_pulled(data)
69		# raw_data contains TealDataAbstract, i.e. R6 object and container for data
70		# reactive to get data through delayed loading
71		# we must leave it inside the server because of callModule which needs to pick up the right session
72	4x	if (is_pulled_data) {
73	2x	raw_data <- reactiveVal(data) # will trigger by setting it
74		} else {
75	2x	raw_data <- data$get_server()(id = "startapp_module")
76	2x	if (!is.reactive(raw_data)) {
77	!	stop("The delayed loading module has to return a reactive object.")
78		}
79		}
80
81	4x	res <- srv_teal(id = "teal", modules = modules, raw_data = raw_data, filter = filter)
82	4x	logger::log_trace(
83	4x	"srv_teal_with_splash initialized the module with data { paste(data$get_datanames(), collapse = ' ') }."
84		)
85	4x	return(res)
86		})
87		}

1		#' Creates a `teal_modules` object.
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object
5		#' containing the passed objects.
6		#'
7		#' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules`
8		#' shapes the navigation panel of a `teal` application.
9		#'
10		#' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details
11		#' @param label (`character(1)`) label of modules collection (default `"root"`).
12		#' If using the `label` argument then it must be explicitly named.
13		#' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
14		#'
15		#' @export
16		#'
17		#' @return object of class \code{teal_modules}. Object contains following fields
18		#' - `label`: taken from the `label` argument
19		#' - `children`: a list containing objects passed in `...`. List elements are named after
20		#' their `label` attribute converted to a valid `shiny` id.
21		#' @examples
22		#' library(shiny)
23		#'
24		#' app <- init(
25		#' data = teal_data(dataset("iris", iris)),
26		#' modules = modules(
27		#' label = "Modules",
28		#' modules(
29		#' label = "Module",
30		#' module(
31		#' label = "Inner module",
32		#' server = function(id, data) {
33		#' moduleServer(
34		#' id,
35		#' module = function(input, output, session) {
36		#' output$data <- renderDataTable(data[["iris"]]())
37		#' }
38		#' )
39		#' },
40		#' ui = function(id) {
41		#' ns <- NS(id)
42		#' tagList(dataTableOutput(ns("data")))
43		#' },
44		#' datanames = "all"
45		#' )
46		#' ),
47		#' module(
48		#' label = "Another module",
49		#' server = function(id) {
50		#' moduleServer(
51		#' id,
52		#' module = function(input, output, session) {
53		#' output$text <- renderText("Another module")
54		#' }
55		#' )
56		#' },
57		#' ui = function(id) {
58		#' ns <- NS(id)
59		#' tagList(textOutput(ns("text")))
60		#' },
61		#' datanames = NULL
62		#' )
63		#' )
64		#' )
65		#' if (interactive()) {
66		#' runApp(app)
67		#' }
68		modules <- function(..., label = "root") {
69	79x	checkmate::assert_string(label)
70	77x	submodules <- list(...)
71	77x	if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
72	2x	stop(
73	2x	"The only character argument to modules() must be 'label' and it must be named, ",
74	2x	"change modules('lab', ...) to modules(label = 'lab', ...)"
75		)
76		}
77
78	75x	checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
79		# name them so we can more easily access the children
80		# beware however that the label of the submodules should not be changed as it must be kept synced
81	72x	labels <- vapply(submodules, function(submodule) submodule$label, character(1))
82	72x	names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
83	72x	structure(
84	72x	list(
85	72x	label = label,
86	72x	children = submodules
87		),
88	72x	class = "teal_modules"
89		)
90		}
91
92		#' Function which appends a teal_module onto the children of a teal_modules object
93		#' @keywords internal
94		#' @param modules `teal_modules`
95		#' @param module `teal_module` object to be appended onto the children of `modules`
96		#' @return `teal_modules` object with `module` appended
97		append_module <- function(modules, module) {
98	7x	checkmate::assert_class(modules, "teal_modules")
99	5x	checkmate::assert_class(module, "teal_module")
100	3x	modules$children <- c(modules$children, list(module))
101	3x	labels <- vapply(modules$children, function(submodule) submodule$label, character(1))
102	3x	names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
103	3x	modules
104		}
105
106		#' Does the object make use of the `arg`
107		#'
108		#' @param modules (`teal_module` or `teal_modules`) object
109		#' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.
110		#' @return `logical` whether the object makes use of `arg`
111		#' @rdname is_arg_used
112		#' @keywords internal
113		is_arg_used <- function(modules, arg) {
114	285x	checkmate::assert_string(arg)
115	282x	if (inherits(modules, "teal_modules")) {
116	19x	any(unlist(lapply(modules$children, is_arg_used, arg)))
117	263x	} else if (inherits(modules, "teal_module")) {
118	32x	is_arg_used(modules$server, arg) \|\| is_arg_used(modules$ui, arg)
119	231x	} else if (is.function(modules)) {
120	229x	isTRUE(arg %in% names(formals(modules)))
121		} else {
122	2x	stop("is_arg_used function not implemented for this object")
123		}
124		}
125
126
127		#' Creates a `teal_module` object.
128		#'
129		#' @description `r lifecycle::badge("stable")`
130		#' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module.
131		#'
132		#' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except
133		#' `"global_filters"` - read more in `mapping` argument of [teal::teal_slices].
134		#' @param server (`function`) `shiny` module with following arguments:
135		#' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]).
136		#' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module.
137		#' - `data` (optional) module will receive a `tdata` object, a list of reactive (filtered) data specified in
138		#' the `filters` argument.
139		#' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).
140		#' - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]).
141		# - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).
142		#' - `...` (optional) `server_args` elements will be passed to the module named argument or to the `...`.
143		#' @param ui (`function`) Shiny `ui` module function with following arguments:
144		#' - `id` - teal will set proper shiny namespace for this module.
145		#' - `data` (optional) module will receive list of reactive (filtered) data specified in the `filters` argument.
146		#' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).
147		#' - `...` (optional) `ui_args` elements will be passed to the module named argument or to the `...`.
148		#' @param filters (`character`) Deprecated. Use `datanames` instead.
149		#' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The
150		#' filter panel will automatically update the shown filters to include only
151		#' filters in the listed datasets. `NULL` will hide the filter panel,
152		#' and the keyword `'all'` will show filters of all datasets. `datanames` also determines
153		#' a subset of datasets which are appended to the `data` argument in `server` function.
154		#' @param server_args (named `list`) with additional arguments passed on to the
155		#' `server` function.
156		#' @param ui_args (named `list`) with additional arguments passed on to the
157		#' `ui` function.
158		#'
159		#' @return object of class `teal_module`.
160		#' @export
161		#' @examples
162		#' library(shiny)
163		#'
164		#' app <- init(
165		#' data = teal_data(dataset("iris", iris)),
166		#' modules = list(
167		#' module(
168		#' label = "Module",
169		#' server = function(id, data) {
170		#' moduleServer(
171		#' id,
172		#' module = function(input, output, session) {
173		#' output$data <- renderDataTable(data[["iris"]]())
174		#' }
175		#' )
176		#' },
177		#' ui = function(id) {
178		#' ns <- NS(id)
179		#' tagList(dataTableOutput(ns("data")))
180		#' }
181		#' )
182		#' )
183		#' )
184		#' if (interactive()) {
185		#' runApp(app)
186		#' }
187		module <- function(label = "module",
188		server = function(id, ...) {
189	1x	moduleServer(id, function(input, output, session) {}) # nolint
190		},
191		ui = function(id, ...) {
192	1x	tags$p(paste0("This module has no UI (id: ", id, " )"))
193		},
194		filters,
195		datanames = "all",
196		server_args = NULL,
197		ui_args = NULL) {
198	109x	checkmate::assert_string(label)
199	106x	checkmate::assert_function(server)
200	106x	checkmate::assert_function(ui)
201	106x	checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)
202	105x	checkmate::assert_list(server_args, null.ok = TRUE, names = "named")
203	103x	checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")
204
205	101x	if (!missing(filters)) {
206	!	checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE)
207	!	datanames <- filters
208	!	msg <-
209	!	"The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."
210	!	logger::log_warn(msg)
211	!	warning(msg)
212		}
213
214	101x	if (label == "global_filters") {
215	1x	stop("Label 'global_filters' is reserved in teal. Please change to something else.")
216		}
217	100x	server_formals <- names(formals(server))
218	100x	if (!(
219	100x	"id" %in% server_formals \|\|
220	100x	all(c("input", "output", "session") %in% server_formals)
221		)) {
222	2x	stop(
223	2x	"\nmodule() `server` argument requires a function with following arguments:",
224	2x	"\n - id - teal will set proper shiny namespace for this module.",
225	2x	"\n - input, output, session (not recommended) - then shiny::callModule will be used to call a module.",
226	2x	"\n\nFollowing arguments can be used optionaly:",
227	2x	"\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",
228	2x	"\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",
229	2x	"\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",
230	2x	"\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",
231	2x	"\n - `...` server_args elements will be passed to the module named argument or to the `...`"
232		)
233		}
234
235	98x	if (!is.element("data", server_formals)) {
236	71x	message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
237	71x	datanames <- NULL
238		}
239
240	98x	srv_extra_args <- setdiff(names(server_args), server_formals)
241	98x	if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
242	1x	stop(
243	1x	"\nFollowing `server_args` elements have no equivalent in the formals of the `server`:\n",
244	1x	paste(paste(" -", srv_extra_args), collapse = "\n"),
245	1x	"\n\nUpdate the `server` arguments by including above or add `...`"
246		)
247		}
248
249	97x	ui_formals <- names(formals(ui))
250	97x	if (!"id" %in% ui_formals) {
251	1x	stop(
252	1x	"\nmodule() `ui` argument requires a function with following arguments:",
253	1x	"\n - id - teal will set proper shiny namespace for this module.",
254	1x	"\n\nFollowing arguments can be used optionaly:",
255	1x	"\n - `data` - module will receive list of reactive (filtered) data specied in the `filters` argument",
256	1x	"\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",
257	1x	"\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"
258		)
259		}
260
261	96x	ui_extra_args <- setdiff(names(ui_args), ui_formals)
262	96x	if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
263	1x	stop(
264	1x	"\nFollowing `ui_args` elements have no equivalent in the formals of `ui`:\n",
265	1x	paste(paste(" -", ui_extra_args), collapse = "\n"),
266	1x	"\n\nUpdate the `ui` arguments by including above or add `...`"
267		)
268		}
269
270	95x	structure(
271	95x	list(
272	95x	label = label,
273	95x	server = server, ui = ui, datanames = datanames,
274	95x	server_args = server_args, ui_args = ui_args
275		),
276	95x	class = "teal_module"
277		)
278		}
279
280
281		#' Get module depth
282		#'
283		#' Depth starts at 0, so a single `teal.module` has depth 0.
284		#' Nesting it increases overall depth by 1.
285		#'
286		#' @inheritParams init
287		#' @param depth optional, integer determining current depth level
288		#'
289		#' @return depth level for given module
290		#' @keywords internal
291		#'
292		#' @examples
293		#' mods <- modules(
294		#' label = "d1",
295		#' modules(
296		#' label = "d2",
297		#' modules(
298		#' label = "d3",
299		#' module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3")
300		#' ),
301		#' module(label = "bbb")
302		#' ),
303		#' module(label = "ccc")
304		#' )
305		#' stopifnot(teal:::modules_depth(mods) == 3L)
306		#'
307		#' mods <- modules(
308		#' label = "a",
309		#' modules(
310		#' label = "b1", module(label = "c")
311		#' ),
312		#' module(label = "b2")
313		#' )
314		#' stopifnot(teal:::modules_depth(mods) == 2L)
315		modules_depth <- function(modules, depth = 0L) {
316	12x	checkmate::assert(
317	12x	checkmate::check_class(modules, "teal_module"),
318	12x	checkmate::check_class(modules, "teal_modules")
319		)
320	12x	checkmate::assert_int(depth, lower = 0)
321	11x	if (inherits(modules, "teal_modules")) {
322	4x	max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))
323		} else {
324	7x	depth
325		}
326		}
327
328
329		module_labels <- function(modules) {
330	!	if (inherits(modules, "teal_modules")) {
331	!	lapply(modules$children, module_labels)
332		} else {
333	!	modules$label
334		}
335		}
336
337		#' Converts `teal_modules` to a string
338		#'
339		#' @param x (`teal_modules`) to print
340		#' @param indent (`integer`) indent level;
341		#' each `submodule` is indented one level more
342		#' @param ... (optional) additional parameters to pass to recursive calls of `toString`
343		#' @return (`character`)
344		#' @export
345		#' @rdname modules
346		toString.teal_modules <- function(x, indent = 0, ...) { # nolint
347		# argument must be `x` to be consistent with base method
348	!	paste(c(
349	!	paste0(rep(" ", indent), "+ ", x$label),
350	!	unlist(lapply(x$children, toString, indent = indent + 1, ...))
351	!	), collapse = "\n")
352		}
353
354		#' Converts `teal_module` to a string
355		#'
356		#' @inheritParams toString.teal_modules
357		#' @param x `teal_module`
358		#' @param ... ignored
359		#' @export
360		#' @rdname module
361		toString.teal_module <- function(x, indent = 0, ...) { # nolint
362	!	paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
363		}
364
365		#' Prints `teal_modules`
366		#' @param x `teal_modules`
367		#' @param ... parameters passed to `toString`
368		#' @export
369		#' @rdname modules
370		print.teal_modules <- function(x, ...) {
371	!	s <- toString(x, ...)
372	!	cat(s)
373	!	return(invisible(s))
374		}
375
376		#' Prints `teal_module`
377		#' @param x `teal_module`
378		#' @param ... parameters passed to `toString`
379		#' @export
380		#' @rdname module
381		print.teal_module <- print.teal_modules

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		#'
9		#' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner.
10		#' At the beginning of a session it presents two icons: a camera and an circular arrow.
11		#' Clicking the camera captures a snapshot and clicking the arrow resets initial application state.
12		#' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.
13		#'
14		#' @section Server logic:
15		#' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance
16		#' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`
17		#' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation
18		#' (attributes are maintained).
19		#'
20		#' Snapshots are stored in a `reactiveVal` as a named list.
21		#' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.
22		#'
23		#' For every snapshot except the initial one, a piece of UI is generated that contains
24		#' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.
25		#' The initial snapshot is restored by a separate "reset" button.
26		#' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.
27		#'
28		#' @section Snapshot mechanics:
29		#' When a snapshot is captured, the user is prompted to name it.
30		#' Names are displayed as is but since they are used to create button ids,
31		#' under the hood they are converted to syntactically valid strings.
32		#' New snapshot names are validated so that their valid versions are unique.
33		#' Leading and trailing white space is trimmed.
34		#'
35		#' The module can read the global state of the application from `slices_global` and `mapping_matrix`.
36		#' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.
37		#' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.
38		#' The snapshot contains the `mapping` attribute of the initial application state
39		#' (or one that has been restored), which may not reflect the current one,
40		#' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,
41		#' when passed to the `mapping` argument of [`teal::teal_slices`], would result in the current mapping.
42		#' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.
43		#'
44		#' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.
45		#' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared
46		#' and set anew according to the `mapping` attribute of the snapshot.
47		#' The snapshot is then set as the current content of `slices_global`.
48		#'
49		#' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,
50		#' and then saved to file with [`teal.slice::slices_store`].
51		#'
52		#' @param id (`character(1)`) `shiny` module id
53		#' @param slices_global (`reactiveVal`) that contains a `teal_slices` object
54		#' containing all `teal_slice`s existing in the app, both active and inactive
55		#' @param mapping_matrix (`reactive`) that contains a `data.frame` representation
56		#' of the mapping of filter state ids (rows) to modules labels (columns);
57		#' all columns are `logical` vectors
58		#' @param filtered_data_list non-nested (`named list`) that contains `FilteredData` objects
59		#'
60		#' @return Nothing is returned.
61		#'
62		#' @name snapshot_manager_module
63		#' @aliases snapshot snapshot_manager
64		#'
65		#' @author Aleksander Chlebowski
66		#'
67		#' @rdname snapshot_manager_module
68		#' @keywords internal
69		#'
70		snapshot_manager_ui <- function(id) {
71	!	ns <- NS(id)
72	!	div(
73	!	class = "snapshot_manager_content",
74	!	div(
75	!	class = "snapshot_table_row",
76	!	span(tags$b("Snapshot manager")),
77	!	actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
78	!	actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
79	!	NULL
80		),
81	!	uiOutput(ns("snapshot_list"))
82		)
83		}
84
85		#' @rdname snapshot_manager_module
86		#' @keywords internal
87		#'
88		snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
89	7x	checkmate::assert_character(id)
90	7x	checkmate::assert_true(is.reactive(slices_global))
91	7x	checkmate::assert_class(isolate(slices_global()), "teal_slices")
92	7x	checkmate::assert_true(is.reactive(mapping_matrix))
93	7x	checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)
94	7x	checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named")
95
96	7x	moduleServer(id, function(input, output, session) {
97	7x	ns <- session$ns
98
99		# Store global filter states.
100	7x	filter <- isolate(slices_global())
101	7x	snapshot_history <- reactiveVal({
102	7x	list(
103	7x	"Initial application state" = as.list(filter, recursive = TRUE)
104		)
105		})
106
107		# Snapshot current application state - name snaphsot.
108	7x	observeEvent(input$snapshot_add, {
109	!	showModal(
110	!	modalDialog(
111	!	textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
112	!	footer = tagList(
113	!	actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
114	!	modalButton(label = "Cancel", icon = icon("thumbs-down"))
115		),
116	!	size = "s"
117		)
118		)
119		})
120		# Snapshot current application state - store snaphsot.
121	7x	observeEvent(input$snapshot_name_accept, {
122	!	snapshot_name <- trimws(input$snapshot_name)
123	!	if (identical(snapshot_name, "")) {
124	!	showNotification(
125	!	"Please name the snapshot.",
126	!	type = "message"
127		)
128	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
129	!	} else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
130	!	showNotification(
131	!	"This name is in conflict with other snapshot names. Please choose a different one.",
132	!	type = "message"
133		)
134	!	updateTextInput(inputId = "snapshot_name", value = , placeholder = "Meaningful, unique name")
135		} else {
136	!	snapshot <- as.list(slices_global(), recursive = TRUE)
137	!	attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())
138	!	snapshot_update <- c(snapshot_history(), list(snapshot))
139	!	names(snapshot_update)[length(snapshot_update)] <- snapshot_name
140	!	snapshot_history(snapshot_update)
141	!	removeModal()
142		# Reopen filter manager modal by clicking button in the main application.
143	!	shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE)
144		}
145		})
146
147		# Restore initial state.
148	7x	observeEvent(input$snapshot_reset, {
149	!	s <- "Initial application state"
150		### Begin restore procedure. ###
151	!	snapshot <- snapshot_history()[[s]]
152	!	snapshot_state <- as.teal_slices(snapshot)
153	!	mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
154	!	mapply(
155	!	function(filtered_data, filter_ids) {
156	!	filtered_data$clear_filter_states(force = TRUE)
157	!	slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
158	!	filtered_data$set_filter_state(slices)
159		},
160	!	filtered_data = filtered_data_list,
161	!	filter_ids = mapping_unfolded
162		)
163	!	slices_global(snapshot_state)
164	!	removeModal()
165		### End restore procedure. ###
166		})
167
168		# Create UI elements and server logic for the snapshot table.
169		# Observers must be tracked to avoid duplication and excess reactivity.
170		# Remaining elements are tracked likewise for consistency and a slight speed margin.
171	7x	observers <- reactiveValues()
172	7x	handlers <- reactiveValues()
173	7x	divs <- reactiveValues()
174
175	7x	observeEvent(snapshot_history(), {
176	3x	lapply(names(snapshot_history())[-1L], function(s) {
177	!	id_pickme <- sprintf("pickme_%s", make.names(s))
178	!	id_saveme <- sprintf("saveme_%s", make.names(s))
179	!	id_rowme <- sprintf("rowme_%s", make.names(s))
180
181		# Observer for restoring snapshot.
182	!	if (!is.element(id_pickme, names(observers))) {
183	!	observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
184		### Begin restore procedure. ###
185	!	snapshot <- snapshot_history()[[s]]
186	!	snapshot_state <- as.teal_slices(snapshot)
187	!	mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))
188	!	mapply(
189	!	function(filtered_data, filter_ids) {
190	!	filtered_data$clear_filter_states(force = TRUE)
191	!	slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
192	!	filtered_data$set_filter_state(slices)
193		},
194	!	filtered_data = filtered_data_list,
195	!	filter_ids = mapping_unfolded
196		)
197	!	slices_global(snapshot_state)
198	!	removeModal()
199		### End restore procedure. ###
200		})
201		}
202		# Create handler for downloading snapshot.
203	!	if (!is.element(id_saveme, names(handlers))) {
204	!	output[[id_saveme]] <- downloadHandler(
205	!	filename = function() {
206	!	sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
207		},
208	!	content = function(file) {
209	!	snapshot <- snapshot_history()[[s]]
210	!	snapshot_state <- as.teal_slices(snapshot)
211	!	teal.slice::slices_store(tss = snapshot_state, file = file)
212		}
213		)
214	!	handlers[[id_saveme]] <- id_saveme
215		}
216		# Create a row for the snapshot table.
217	!	if (!is.element(id_rowme, names(divs))) {
218	!	divs[[id_rowme]] <- div(
219	!	class = "snapshot_table_row",
220	!	span(h5(s)),
221	!	actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
222	!	downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
223		)
224		}
225		})
226		})
227
228		# Create table to display list of snapshots and their actions.
229	7x	output$snapshot_list <- renderUI({
230	3x	rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d)
231	3x	if (length(rows) == 0L) {
232	3x	div(
233	3x	class = "snapshot_manager_placeholder",
234	3x	"Snapshots will appear here."
235		)
236		} else {
237	!	rows
238		}
239		})
240		})
241		}
242
243
244
245
246		### utility functions ----
247
248		#' Explicitly enumerate global filters.
249		#'
250		#' Transform module mapping such that global filters are explicitly specified for every module.
251		#'
252		#' @param mapping (`named list`) as stored in mapping parameter of `teal_slices`
253		#' @param module_names (`character`) vector containing names of all modules in the app
254		#' @return A `named_list` with one element per module, each element containing all filters applied to that module.
255		#' @keywords internal
256		#'
257		unfold_mapping <- function(mapping, module_names) {
258	!	module_names <- structure(module_names, names = module_names)
259	!	lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))
260		}
261
262		#' Convert mapping matrix to filter mapping specification.
263		#'
264		#' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,
265		#' to a list specification like the one used in the `mapping` attribute of `teal_slices`.
266		#' Global filters are gathered in one list element.
267		#' If a module has no active filters but the global ones, it will not be mentioned in the output.
268		#'
269		#' @param mapping_matrix (`data.frame`) of logical vectors where
270		#' columns represent modules and row represent `teal_slice`s
271		#' @return `named list` like that in the `mapping` attribute of a `teal_slices` object.
272		#' @keywords internal
273		#'
274		matrix_to_mapping <- function(mapping_matrix) {
275	!	mapping_matrix[] <- lapply(mapping_matrix, function(x) x \| is.na(x))
276	!	global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))
277	!	global_filters <- names(global[global])
278	!	local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]
279
280	!	mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))
281	!	Filter(function(x) length(x) != 0L, mapping)
282		}

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

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		#' @keywords internal
120		# recursive object type test
121		# returns logical of length 1
122		is_validators <- function(x) {
123	118x	all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))
124		}
125
126		#' @keywords internal
127		# test if an InputValidator object is enabled
128		# returns logical of length 1
129		# official method requested at https://github.com/rstudio/shinyvalidate/issues/64
130		validator_enabled <- function(x) {
131	49x	x$.__enclos_env__$private$enabled
132		}
133
134		#' @keywords internal
135		# recursively extract messages from validator list
136		# returns character vector or a list of character vectors, possibly nested and named
137		extract_validator <- function(iv, header) {
138	113x	if (inherits(iv, "InputValidator")) {
139	49x	add_header(gather_messages(iv), header)
140		} else {
141	58x	if (is.null(names(iv))) names(iv) <- rep("", length(iv))
142	64x	mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)
143		}
144		}
145
146		#' @keywords internal
147		# collate failing messages from validator
148		# returns list
149		gather_messages <- function(iv) {
150	49x	if (validator_enabled(iv)) {
151	46x	status <- iv$validate()
152	46x	failing_inputs <- Filter(Negate(is.null), status)
153	46x	unique(lapply(failing_inputs, function(x) x[["message"]]))
154		} else {
155	3x	logger::log_warn("Validator is disabled and will be omitted.")
156	3x	list()
157		}
158		}
159
160		#' @keywords internal
161		# add optional header to failing messages
162		add_header <- function(messages, header = "") {
163	78x	ans <- unlist(messages)
164	78x	if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
165	31x	ans <- c(paste0(header, "\n"), ans, "\n")
166		}
167	78x	ans
168		}
169
170		#' @keywords internal
171		# recursively check if the object contains a named list
172		any_names <- function(x) {
173	103x	any(
174	103x	if (is.list(x)) {
175	58x	if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))
176		} else {
177	40x	FALSE
178		}
179		)
180		}

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

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 `raw_data` (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 ui_teal_with_splash
31		#'
32		#' @param splash_ui (`shiny.tag`)\cr 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 raw_data (`reactive`)\cr
37		#' returns the `TealData`, only evaluated once, `NULL` value is ignored
38		#'
39		#' @return
40		#' `ui_teal` returns `HTML` for Shiny module UI.
41		#' `srv_teal` returns `reactive` which returns the currently active module.
42		#'
43		#' @keywords internal
44		#'
45		#' @examples
46		#' mods <- teal:::example_modules()
47		#' raw_data <- reactive(teal:::example_cdisc_data())
48		#' app <- shinyApp(
49		#' ui = function() {
50		#' teal:::ui_teal("dummy")
51		#' },
52		#' server = function(input, output, session) {
53		#' active_module <- teal:::srv_teal(id = "dummy", modules = mods, raw_data = raw_data)
54		#' }
55		#' )
56		#' if (interactive()) {
57		#' runApp(app)
58		#' }
59		NULL
60
61		#' @rdname module_teal
62		ui_teal <- function(id,
63		splash_ui = tags$h2("Starting the Teal App"),
64		title = NULL,
65		header = tags$p(""),
66		footer = tags$p("")) {
67	32x	if (checkmate::test_string(header)) {
68	!	header <- tags$h1(header)
69		}
70	32x	if (checkmate::test_string(footer)) {
71	!	footer <- tags$p(footer)
72		}
73	32x	checkmate::assert(
74	32x	checkmate::check_class(splash_ui, "shiny.tag"),
75	32x	checkmate::check_class(splash_ui, "shiny.tag.list"),
76	32x	checkmate::check_class(splash_ui, "html")
77		)
78	32x	checkmate::assert(
79	32x	checkmate::check_class(header, "shiny.tag"),
80	32x	checkmate::check_class(header, "shiny.tag.list"),
81	32x	checkmate::check_class(header, "html")
82		)
83	32x	checkmate::assert(
84	32x	checkmate::check_class(footer, "shiny.tag"),
85	32x	checkmate::check_class(footer, "shiny.tag.list"),
86	32x	checkmate::check_class(footer, "html")
87		)
88
89	32x	ns <- NS(id)
90		# Once the data is loaded, we will remove this element and add the real teal UI instead
91	32x	splash_ui <- div(
92		# id so we can remove the splash screen once ready, which is the first child of this container
93	32x	id = ns("main_ui_container"),
94		# we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
95		# just the first item of the tagList)
96	32x	div(splash_ui)
97		)
98
99		# show busy icon when shiny session is busy computing stuff
100		# based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 #nolint
101	32x	shiny_busy_message_panel <- conditionalPanel(
102	32x	condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
103	32x	div(
104	32x	icon("arrows-rotate", "spin fa-spin"),
105	32x	"Computing ...",
106		# CSS defined in `custom.css`
107	32x	class = "shinybusymessage"
108		)
109		)
110
111	32x	res <- fluidPage(
112	32x	title = title,
113	32x	theme = get_teal_bs_theme(),
114	32x	include_teal_css_js(),
115	32x	tags$header(header),
116	32x	tags$hr(class = "my-2"),
117	32x	shiny_busy_message_panel,
118	32x	splash_ui,
119	32x	tags$hr(),
120	32x	tags$footer(
121	32x	div(
122	32x	footer,
123	32x	teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
124	32x	textOutput(ns("identifier"))
125		)
126		)
127		)
128	32x	return(res)
129		}
130
131
132		#' @rdname module_teal
133		srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
134	9x	stopifnot(is.reactive(raw_data))
135	8x	moduleServer(id, function(input, output, session) {
136	8x	logger::log_trace("srv_teal initializing the module.")
137
138	8x	output$identifier <- renderText(
139	8x	paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
140		)
141
142	8x	teal.widgets::verbatim_popup_srv(
143	8x	"sessionInfo",
144	8x	verbatim_content = utils::capture.output(utils::sessionInfo()),
145	8x	title = "SessionInfo"
146		)
147
148		# `JavaScript` code
149	8x	run_js_files(files = "init.js") # `JavaScript` code to make the clipboard accessible
150		# set timezone in shiny app
151		# timezone is set in the early beginning so it will be available also
152		# for `DDL` and all shiny modules
153	8x	get_client_timezone(session$ns)
154	8x	observeEvent(
155	8x	eventExpr = input$timezone,
156	8x	once = TRUE,
157	8x	handlerExpr = {
158	!	session$userData$timezone <- input$timezone
159	!	logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
160		}
161		)
162
163		# loading the data -----
164	8x	env <- environment()
165	8x	datasets_reactive <- reactive({
166	6x	if (is.null(raw_data())) {
167	1x	return(NULL)
168		}
169	5x	env$progress <- shiny::Progress$new(session)
170	5x	env$progress$set(0.25, message = "Setting data")
171
172		# create a list of data following structure of the nested modules list structure.
173		# Because it's easier to unpack modules and datasets when they follow the same nested structure.
174	5x	datasets_singleton <- teal.slice::init_filtered_data(raw_data())
175		# Singleton starts with only global filters active.
176	5x	filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)
177	5x	datasets_singleton$set_filter_state(filter_global)
178	5x	module_datasets <- function(modules) {
179	19x	if (inherits(modules, "teal_modules")) {
180	8x	datasets <- lapply(modules$children, module_datasets)
181	8x	labels <- vapply(modules$children, `[[`, character(1), "label")
182	8x	names(datasets) <- labels
183	8x	datasets
184	11x	} else if (isTRUE(attr(filter, "module_specific"))) {
185		# we should create FilteredData even if modules$datanames is null
186		# null controls a display of filter panel but data should be still passed
187	3x	datanames <- if (is.null(modules$datanames)) raw_data()$get_datanames() else modules$datanames
188	3x	data_objects <- sapply(
189	3x	datanames,
190	3x	function(dataname) {
191	6x	dataset <- raw_data()$get_dataset(dataname)
192	6x	list(
193	6x	dataset = dataset$get_raw_data(),
194	6x	metadata = dataset$get_metadata(),
195	6x	label = dataset$get_dataset_label()
196		)
197		},
198	3x	simplify = FALSE
199		)
200	3x	datasets_module <- teal.slice::init_filtered_data(
201	3x	data_objects,
202	3x	join_keys = raw_data()$get_join_keys(),
203	3x	code = raw_data()$get_code_class(),
204	3x	check = raw_data()$get_check()
205		)
206
207		# set initial filters
208	3x	slices <- Filter(x = filter, f = function(x) {
209	!	x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&
210	!	x$dataname %in% datanames
211		})
212	3x	include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]
213	3x	exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]
214	3x	slices$include_varnames <- include_varnames
215	3x	slices$exclude_varnames <- exclude_varnames
216	3x	datasets_module$set_filter_state(slices)
217	3x	datasets_module
218		} else {
219	8x	datasets_singleton
220		}
221		}
222	5x	datasets <- module_datasets(modules)
223
224	5x	logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
225	5x	datasets
226		})
227
228	8x	reporter <- teal.reporter::Reporter$new()
229	8x	is_any_previewer <- function(modules) {
230	!	if (inherits(modules, "teal_modules")) {
231	!	any(unlist(lapply(modules$children, is_any_previewer), use.names = FALSE))
232	!	} else if (inherits(modules, "teal_module_previewer")) {
233	!	TRUE
234		} else {
235	!	FALSE
236		}
237		}
238	8x	if (is_arg_used(modules, "reporter") && !is_any_previewer(modules)) {
239	!	modules <- append_module(modules, reporter_previewer_module())
240		}
241
242		# Replace splash / welcome screen once data is loaded ----
243		# ignoreNULL to not trigger at the beginning when data is NULL
244		# just handle it once because data obtained through delayed loading should
245		# usually not change afterwards
246		# if restored from bookmarked state, `filter` is ignored
247	8x	observeEvent(datasets_reactive(), ignoreNULL = TRUE, once = TRUE, {
248	1x	logger::log_trace("srv_teal@5 setting main ui after data was pulled")
249	1x	env$progress$set(0.5, message = "Setting up main UI")
250	1x	on.exit(env$progress$close())
251		# main_ui_container contains splash screen first and we remove it and replace it by the real UI
252
253	1x	removeUI(sprintf("#%s:first-child", session$ns("main_ui_container")))
254	1x	insertUI(
255	1x	selector = paste0("#", session$ns("main_ui_container")),
256	1x	where = "beforeEnd",
257		# we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
258		# just the first item of the tagList)
259	1x	ui = div(ui_tabs_with_filters(
260	1x	session$ns("main_ui"),
261	1x	modules = modules,
262	1x	datasets = datasets_reactive(),
263	1x	filter = filter
264		)),
265		# needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not
266		# have any effect as they are ignored when not present
267	1x	immediate = TRUE
268		)
269
270		# must make sure that this is only executed once as modules assume their observers are only
271		# registered once (calling server functions twice would trigger observers twice each time)
272	1x	active_module <- srv_tabs_with_filters(
273	1x	id = "main_ui",
274	1x	datasets = datasets_reactive(),
275	1x	modules = modules,
276	1x	reporter = reporter,
277	1x	filter = filter
278		)
279	1x	return(active_module)
280		})
281		})
282		}

1		#' Get dummy `CDISC` data
2		#'
3		#' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`.
4		#' Some NAs are also introduced to stress test.
5		#'
6		#' @return `cdisc_data`
7		#' @keywords internal
8		example_cdisc_data <- function() { # nolint
9	!	ADSL <- data.frame( # nolint
10	!	STUDYID = "study",
11	!	USUBJID = 1:10,
12	!	SEX = sample(c("F", "M"), 10, replace = TRUE),
13	!	AGE = stats::rpois(10, 40)
14		)
15	!	ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint
16	!	ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
17	!	ADTTE$AVAL <- c( # nolint
18	!	stats::rnorm(10, mean = 700, sd = 200), # dummy OS level
19	!	stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level
20	!	stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level
21		)
22
23	!	ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint
24	!	ADSL$SEX[c(2, 5)] <- NA # nolint
25
26	!	cdisc_data_obj <- teal.data::cdisc_data(
27	!	cdisc_dataset(dataname = "ADSL", x = ADSL),
28	!	cdisc_dataset(dataname = "ADTTE", x = ADTTE)
29		)
30
31	!	res <- teal.data::cdisc_data(
32	!	teal.data::cdisc_dataset(dataname = "ADSL", x = ADSL),
33	!	teal.data::cdisc_dataset(dataname = "ADTTE", x = ADTTE),
34	!	code = '
35	!	ADSL <- data.frame(
36	!	STUDYID = "study",
37	!	USUBJID = 1:10,
38	!	SEX = sample(c("F", "M"), 10, replace = TRUE),
39	!	AGE = rpois(10, 40)
40		)
41	!	ADTTE <- rbind(ADSL, ADSL, ADSL)
42	!	ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
43	!	ADTTE$AVAL <- c(
44	!	rnorm(10, mean = 700, sd = 200),
45	!	rnorm(10, mean = 400, sd = 100),
46	!	rnorm(10, mean = 450, sd = 200)
47		)
48
49	!	ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE)
50	!	ADSL$SEX[c(2, 5)] <- NA
51		'
52		)
53	!	return(res)
54		}
55
56		#' Get datasets to go with example modules.
57		#'
58		#' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`.
59		#' Each list leaf is the same `FilteredData` object.
60		#'
61		#' @return named list of `FilteredData` objects, each with `ADSL` set.
62		#' @keywords internal
63		example_datasets <- function() { # nolint
64	!	dummy_cdisc_data <- example_cdisc_data()
65	!	datasets <- teal.slice::init_filtered_data(dummy_cdisc_data)
66	!	list(
67	!	"d2" = list(
68	!	"d3" = list(
69	!	"aaa1" = datasets,
70	!	"aaa2" = datasets,
71	!	"aaa3" = datasets
72		),
73	!	"bbb" = datasets
74		),
75	!	"ccc" = datasets
76		)
77		}
78
79		#' An example `teal` module
80		#'
81		#' @description `r lifecycle::badge("experimental")`
82		#' @inheritParams module
83		#' @return A `teal` module which can be included in the `modules` argument to [teal::init()].
84		#' @examples
85		#' app <- init(
86		#' data = teal_data(
87		#' dataset("IRIS", iris),
88		#' dataset("MTCARS", mtcars)
89		#' ),
90		#' modules = example_module()
91		#' )
92		#' if (interactive()) {
93		#' shinyApp(app$ui, app$server)
94		#' }
95		#' @export
96		example_module <- function(label = "example teal module", datanames = "all") {
97	15x	checkmate::assert_string(label)
98	15x	module(
99	15x	label,
100	15x	server = function(id, data) {
101	!	checkmate::assert_class(data, "tdata")
102	!	moduleServer(id, function(input, output, session) {
103	!	output$text <- renderPrint(data[[input$dataname]]())
104		})
105		},
106	15x	ui = function(id, data) {
107	!	ns <- NS(id)
108	!	teal.widgets::standard_layout(
109	!	output = verbatimTextOutput(ns("text")),
110	!	encoding = selectInput(ns("dataname"), "Choose a dataset", choices = names(data))
111		)
112		},
113	15x	datanames = datanames
114		)
115		}
116
117
118		#' Get example modules.
119		#'
120		#' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created.
121		#' @param datanames (`character`)\cr
122		#' names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`.
123		#' @return `teal_modules`
124		#' @keywords internal
125		example_modules <- function(datanames = c("ADSL", "ADTTE")) {
126	2x	checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
127	2x	mods <- modules(
128	2x	label = "d1",
129	2x	modules(
130	2x	label = "d2",
131	2x	modules(
132	2x	label = "d3",
133	2x	example_module(label = "aaa1", datanames = datanames),
134	2x	example_module(label = "aaa2", datanames = datanames),
135	2x	example_module(label = "aaa3", datanames = datanames)
136		),
137	2x	example_module(label = "bbb", datanames = datanames)
138		),
139	2x	example_module(label = "ccc", datanames = datanames)
140		)
141	2x	return(mods)
142		}

1		#' Get Client Timezone
2		#'
3		#' Local timezone in the browser may differ from the system timezone from the server.
4		#' This script can be run to register a shiny input which contains information about
5		#' the timezone in the browser.
6		#'
7		#' @param ns (`function`) namespace function passed from the `session` object in the
8		#' Shiny server. For Shiny modules this will allow for proper name spacing of the
9		#' registered input.
10		#'
11		#' @return (`Shiny`) input variable accessible with `input$tz` which is a (`character`)
12		#' string containing the timezone of the browser/client.
13		#' @keywords internal
14		get_client_timezone <- function(ns) {
15	8x	script <- sprintf(
16	8x	"Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",
17	8x	ns("timezone")
18		)
19	8x	shinyjs::runjs(script) # function does not return anything
20	8x	return(invisible(NULL))
21		}
22
23		#' Resolve the expected bootstrap theme
24		#' @keywords internal
25		get_teal_bs_theme <- function() {
26	36x	bs_theme <- getOption("teal.bs_theme")
27	36x	if (is.null(bs_theme)) {
28	33x	NULL
29	3x	} else if (!inherits(bs_theme, "bs_theme")) {
30	2x	warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
31	2x	NULL
32		} else {
33	1x	bs_theme
34		}
35		}
36
37		include_parent_datanames <- function(dataname, join_keys) {
38	145x	parents <- character(0)
39	145x	for (i in dataname) {
40	25x	while (length(i) > 0) {
41	25x	parent_i <- join_keys$get_parent(i)
42	25x	parents <- c(parent_i, parents)
43	25x	i <- parent_i
44		}
45		}
46
47	145x	return(unique(c(parents, dataname)))
48		}

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 doc 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
7		#' Create the Server and UI Function For the Shiny App
8		#'
9		#' @description `r lifecycle::badge("stable")`
10		#' End-users: This is the most important function for you to start a
11		#' teal app that is composed out of teal modules.
12		#'
13		#' Notes for developers:
14		#' This is a wrapper function around the `module_teal.R` functions. Unless you are
15		#' an end-user, don't use this function, but instead this module.
16		#'
17		#' @param data (`TealData` or `TealDataset` or `TealDatasetConnector` or `list` or `data.frame`
18		#' or `MultiAssayExperiment`)\cr
19		#' `R6` object as returned by [teal.data::cdisc_data()], [teal.data::teal_data()],
20		#' [teal.data::cdisc_dataset()], [teal.data::dataset()], [teal.data::dataset_connector()] or
21		#' [teal.data::cdisc_dataset_connector()] or a single `data.frame` or a `MultiAssayExperiment`
22		#' or a list of the previous objects or function returning a named list.
23		#' NOTE: teal does not guarantee reproducibility of the code when names of the list elements
24		#' do not match the original object names. To ensure reproducibility please use [teal.data::teal_data()]
25		#' or [teal.data::cdisc_data()] with `check = TRUE` enabled.
26		#' @param modules (`list`, `teal_modules` or `teal_module`)\cr
27		#' nested list of `teal_modules` or `teal_module` objects or a single
28		#' `teal_modules` or `teal_module` object. These are the specific output modules which
29		#' will be displayed in the teal application. See [modules()] and [module()] for
30		#' more details.
31		#' @param title (`NULL` or `character`)\cr
32		#' The browser window title (defaults to the host URL of the page).
33		#' @param filter (`teal_slices`)\cr
34		#' Specification of initial filter. Filters can be specified using [teal::teal_slices()].
35		#' Old way of specifying filters through a list is deprecated and will be removed in the
36		#' next release. Please fix your applications to use [teal::teal_slices()].
37		#' @param header (`shiny.tag` or `character`) \cr
38		#' the header of the app. Note shiny code placed here (and in the footer
39		#' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function
40		#' (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here.
41		#' @param footer (`shiny.tag` or `character`)\cr
42		#' the footer of the app
43		#' @param id (`character`)\cr
44		#' module id to embed it, if provided,
45		#' the server function must be called with [shiny::moduleServer()];
46		#' See the vignette for an example. However, [ui_teal_with_splash()]
47		#' is then preferred to this function.
48		#'
49		#' @return named list with `server` and `ui` function
50		#'
51		#' @export
52		#'
53		#' @include modules.R
54		#'
55		#' @examples
56		#' new_iris <- transform(iris, id = seq_len(nrow(iris)))
57		#' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
58		#'
59		#' app <- init(
60		#' data = teal_data(
61		#' dataset("new_iris", new_iris),
62		#' dataset("new_mtcars", new_mtcars),
63		#' code = "
64		#' new_iris <- transform(iris, id = seq_len(nrow(iris)))
65		#' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
66		#' "
67		#' ),
68		#' modules = modules(
69		#' module(
70		#' label = "data source",
71		#' server = function(input, output, session, data) {},
72		#' ui = function(id, ...) div(p("information about data source")),
73		#' datanames = "all"
74		#' ),
75		#' example_module(label = "example teal module"),
76		#' module(
77		#' "Iris Sepal.Length histogram",
78		#' server = function(input, output, session, data) {
79		#' output$hist <- renderPlot(
80		#' hist(data[["new_iris"]]()$Sepal.Length)
81		#' )
82		#' },
83		#' ui = function(id, ...) {
84		#' ns <- NS(id)
85		#' plotOutput(ns("hist"))
86		#' },
87		#' datanames = "new_iris"
88		#' )
89		#' ),
90		#' title = "App title",
91		#' filter = teal_slices(
92		#' teal_slice(dataname = "new_iris", varname = "Species"),
93		#' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),
94		#' teal_slice(dataname = "new_mtcars", varname = "cyl"),
95		#' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
96		#' mapping = list(
97		#' `example teal module` = "new_iris Species",
98		#' `Iris Sepal.Length histogram` = "new_iris Species",
99		#' global_filters = "new_mtcars cyl"
100		#' )
101		#' ),
102		#' header = tags$h1("Sample App"),
103		#' footer = tags$p("Copyright 2017 - 2023")
104		#' )
105		#' if (interactive()) {
106		#' shinyApp(app$ui, app$server)
107		#' }
108		#'
109		init <- function(data,
110		modules,
111		title = NULL,
112		filter = teal_slices(),
113		header = tags$p(),
114		footer = tags$p(),
115		id = character(0)) {
116	38x	logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
117	38x	data <- teal.data::to_relational_data(data = data)
118
119	33x	checkmate::assert_class(data, "TealData")
120	33x	checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
121	33x	checkmate::assert_string(title, null.ok = TRUE)
122	33x	checkmate::assert(
123	33x	checkmate::check_class(filter, "teal_slices"),
124	33x	checkmate::check_list(filter, names = "named")
125		)
126	32x	checkmate::assert_multi_class(header, c("shiny.tag", "character"))
127	32x	checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
128	32x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
129
130	32x	teal.logger::log_system_info()
131
132	32x	if (inherits(modules, "teal_module")) {
133	1x	modules <- list(modules)
134		}
135	32x	if (inherits(modules, "list")) {
136	2x	modules <- do.call(teal::modules, modules)
137		}
138
139		# resolve modules datanames
140	32x	datanames <- teal.data::get_dataname(data)
141	32x	join_keys <- data$get_join_keys()
142	32x	resolve_modules_datanames <- function(modules) {
143	240x	if (inherits(modules, "teal_modules")) {
144	90x	modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE)
145	90x	modules
146		} else {
147	150x	modules$datanames <- if (identical(modules$datanames, "all")) {
148	5x	datanames
149	150x	} else if (is.character(modules$datanames)) {
150	145x	datanames_adjusted <- intersect(modules$datanames, datanames)
151	145x	include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)
152		}
153	150x	modules
154		}
155		}
156	32x	modules <- resolve_modules_datanames(modules = modules)
157
158	32x	if (!inherits(filter, "teal_slices")) {
159	1x	checkmate::assert_subset(names(filter), choices = datanames)
160		# list_to_teal_slices is lifted from teal.slice package, see zzz.R
161		# This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).
162	1x	filter <- list_to_teal_slices(filter)
163		}
164		# convert teal.slice::teal_slices to teal::teal_slices
165	32x	filter <- as.teal_slices(as.list(filter))
166
167		# check teal_slices
168	32x	for (i in seq_along(filter)) {
169	2x	dataname_i <- shiny::isolate(filter[[i]]$dataname)
170	2x	if (!dataname_i %in% datanames) {
171	!	stop(
172	!	sprintf(
173	!	"filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s",
174	!	i,
175	!	dataname_i,
176	!	toString(datanames)
177		)
178		)
179		}
180		}
181
182	32x	if (isTRUE(attr(filter, "module_specific"))) {
183	!	module_names <- unlist(c(module_labels(modules), "global_filters"))
184	!	failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)
185	!	if (length(failed_mod_names)) {
186	!	stop(
187	!	sprintf(
188	!	"Some module names in the mapping arguments don't match module labels.\n %s not in %s",
189	!	toString(failed_mod_names),
190	!	toString(unique(module_names))
191		)
192		)
193		}
194
195	!	if (anyDuplicated(module_names)) {
196		# In teal we are able to set nested modules with duplicated label.
197		# Because mapping argument bases on the relationship between module-label and filter-id,
198		# it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)
199	!	stop(
200	!	sprintf(
201	!	"Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",
202	!	toString(module_names[duplicated(module_names)])
203		)
204		)
205		}
206		}
207
208		# Note regarding case `id = character(0)`:
209		# rather than using `callModule` and creating a submodule of this module, we directly modify
210		# the `ui` and `server` with `id = character(0)` and calling the server function directly
211		# rather than through `callModule`
212	32x	res <- list(
213	32x	ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
214	32x	server = function(input, output, session) {
215		# copy object so that load won't be shared between the session
216	!	data <- data$copy(deep = TRUE)
217	!	filter <- deep_copy_filter(filter)
218	!	srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)
219		}
220		)
221	32x	logger::log_trace("init teal app has been initialized.")
222	32x	return(res)
223		}

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

1		#' Create a `tdata` Object
2		#'
3		#' Create a new object called `tdata` which contains `data`, a `reactive` list of data.frames
4		#' (or `MultiAssayExperiment`), with attributes:
5		#' \itemize{
6		#' \item{`code` (`reactive`) containing code used to generate the data}
7		#' \item{join_keys (`JoinKeys`) containing the relationships between the data}
8		#' \item{metadata (`named list`) containing any metadata associated with the data frames}
9		#' }
10		#' @name tdata
11		#' @param data A `named list` of `data.frames` (or `MultiAssayExperiment`)
12		#' which optionally can be `reactive`.
13		#' Inside this object all of these items will be made `reactive`.
14		#' @param code A `character` (or `reactive` which evaluates to a `character`) containing
15		#' the code used to generate the data. This should be `reactive` if the code is changing
16		#' during a reactive context (e.g. if filtering changes the code). Inside this
17		#' object `code` will be made reactive
18		#' @param join_keys A `teal.data::JoinKeys` object containing relationships between the
19		#' datasets.
20		#' @param metadata A `named list` each element contains a list of metadata about the named data.frame
21		#' Each element of these list should be atomic and length one.
22		#' @return A `tdata` object
23		#' @examples
24		#'
25		#' data <- new_tdata(
26		#' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),
27		#' code = "iris <- iris
28		#' mtcars <- mtcars
29		#' dd <- data.frame(x = 1:10)",
30		#' metadata = list(dd = list(author = "NEST"), iris = list(version = 1))
31		#' )
32		#'
33		#' # Extract a data.frame
34		#' isolate(data[["iris"]]())
35		#'
36		#' # Get code
37		#' isolate(get_code(data))
38		#'
39		#' # Get metadata
40		#' get_metadata(data, "iris")
41		#'
42		#' @export
43		new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
44	40x	checkmate::assert_list(
45	40x	data,
46	40x	any.missing = FALSE, names = "unique",
47	40x	types = c("data.frame", "reactive", "MultiAssayExperiment")
48		)
49	36x	checkmate::assert_class(join_keys, "JoinKeys", null.ok = TRUE)
50	35x	checkmate::assert_multi_class(code, c("character", "reactive"))
51
52	34x	checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)
53	32x	checkmate::assert_subset(names(metadata), names(data))
54	20x	for (m in metadata) teal.data::validate_metadata(m)
55
56	31x	if (is.reactive(code)) {
57	15x	isolate(checkmate::assert_class(code(), "character", .var.name = "code"))
58		}
59
60		# create reactive data.frames
61	30x	for (x in names(data)) {
62	49x	if (!is.reactive(data[[x]])) {
63	29x	data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))
64		} else {
65	20x	isolate(
66	20x	checkmate::assert_multi_class(
67	20x	data[[x]](), c("data.frame", "MultiAssayExperiment"),
68	20x	.var.name = "data"
69		)
70		)
71		}
72		}
73
74		# set attributes
75	29x	attr(data, "code") <- if (is.reactive(code)) code else reactive(code)
76	29x	attr(data, "join_keys") <- join_keys
77	29x	attr(data, "metadata") <- metadata
78
79		# set class
80	29x	class(data) <- c("tdata", class(data))
81	29x	data
82		}
83
84		#' Function to convert a `tdata` object to an `environment`
85		#' Any `reactives` inside `tdata` are first evaluated
86		#' @param data a `tdata` object
87		#' @return an `environment`
88		#' @examples
89		#'
90		#' data <- new_tdata(
91		#' data = list(iris = iris, mtcars = reactive(mtcars)),
92		#' code = "iris <- iris
93		#' mtcars = mtcars"
94		#' )
95		#'
96		#' my_env <- isolate(tdata2env(data))
97		#'
98		#' @export
99		tdata2env <- function(data) { # nolint
100	2x	checkmate::assert_class(data, "tdata")
101	1x	list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))
102		}
103
104		#' @rdname tdata
105		#' @param x a `tdata` object
106		#' @param ... additional arguments for the generic
107		#' @export
108		get_code.tdata <- function(x, ...) { # nolint
109		# note teal.data which teal depends on defines the get_code method
110	6x	attr(x, "code")()
111		}
112
113
114		#' Wrapper for `get_code.tdata`
115		#' This wrapper is to be used by downstream packages to extract the code of a `tdata` object
116		#'
117		#' @param data (`tdata`) object
118		#'
119		#' @return (`character`) code used in the `tdata` object.
120		#' @export
121		get_code_tdata <- function(data) {
122	4x	checkmate::assert_class(data, "tdata")
123	2x	get_code(data)
124		}
125
126
127		#' Function to get join keys from a `tdata` object
128		#' @param data `tdata` - object to extract the join keys
129		#' @return Either `JoinKeys` object or `NULL` if no join keys
130		#' @export
131		get_join_keys <- function(data) {
132	3x	UseMethod("get_join_keys", data)
133		}
134
135
136		#' @rdname get_join_keys
137		#' @export
138		get_join_keys.tdata <- function(data) {
139	3x	attr(data, "join_keys")
140		}
141
142
143		#' @rdname get_join_keys
144		#' @export
145		get_join_keys.default <- function(data) {
146	!	stop("get_join_keys function not implemented for this object")
147		}
148
149		#' Function to get metadata from a `tdata` object
150		#' @param data `tdata` - object to extract the data from
151		#' @param dataname `character(1)` the dataset name whose metadata is requested
152		#' @return Either list of metadata or NULL if no metadata
153		#' @export
154		get_metadata <- function(data, dataname) {
155	6x	checkmate::assert_string(dataname)
156	6x	UseMethod("get_metadata", data)
157		}
158
159		#' @rdname get_metadata
160		#' @export
161		get_metadata.tdata <- function(data, dataname) {
162	6x	metadata <- attr(data, "metadata")
163	6x	if (is.null(metadata)) {
164	1x	return(NULL)
165		}
166	5x	metadata[[dataname]]
167		}
168
169		#' @rdname get_metadata
170		#' @export
171		get_metadata.default <- function(data, dataname) {
172	!	stop("get_metadata function not implemented for this object")
173		}

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

1		#' @title `TealReportCard`
2		#' @description `r lifecycle::badge("experimental")`
3		#' A child 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 invisibly self
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 invisibly self
41		append_fs = function(fs) {
42	4x	checkmate::assert_class(fs, "teal_slices")
43	3x	self$append_text("Filter State", "header3")
44	3x	self$append_content(TealSlicesBlock$new(fs))
45	3x	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 invisibly self
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 `TealSlicesBlock`
88		#' @examples
89		#' block <- teal:::TealSlicesBlock$new()
90		#'
91		initialize = function(content = teal_slices(), style = "verbatim") {
92	9x	self$set_content(content)
93	8x	self$set_style(style)
94	8x	invisible(self)
95		},
96
97		#' @description Sets content of this `TealSlicesBlock`.
98		#' Sets content as `YAML` text which represents a list generated from `teal_slices`.
99		#' The list displays limited number of fields from `teal_slice` objects, but this list is
100		#' sufficient to conclude which filters were applied.
101		#' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"
102		#'
103		#'
104		#' @param content (`teal_slices`) object returned from [teal_slices()] function.
105		#' @return invisibly self
106		set_content = function(content) {
107	10x	checkmate::assert_class(content, "teal_slices")
108	9x	if (length(content) != 0) {
109	7x	states_list <- lapply(content, function(x) {
110	7x	x_list <- shiny::isolate(as.list(x))
111	7x	if (
112	7x	inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
113	7x	length(x_list$choices) == 2 &&
114	7x	length(x_list$selected) == 2
115		) {
116	!	x_list$range <- paste(x_list$selected, collapse = " - ")
117	!	x_list["selected"] <- NULL
118		}
119	7x	if (!is.null(x_list$arg)) {
120	!	x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"
121		}
122
123	7x	x_list <- x_list[
124	7x	c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
125		]
126	7x	names(x_list) <- c(
127	7x	"Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",
128	7x	"Selected Values", "Selected range", "Include NA values", "Include Inf values"
129		)
130
131	7x	Filter(Negate(is.null), x_list)
132		})
133
134	7x	if (requireNamespace("yaml", quietly = TRUE)) {
135	7x	super$set_content(yaml::as.yaml(states_list))
136		} else {
137	!	stop("yaml package is required to format the filter state list")
138		}
139		}
140	9x	private$teal_slices <- content
141	9x	invisible(self)
142		},
143		#' @description Create the `RcodeBlock` from a list.
144		#' @param x `named list` with two fields `c("text", "params")`.
145		#' Use the `get_available_params` method to get all possible parameters.
146		#' @return invisibly self
147		from_list = function(x) {
148	1x	checkmate::assert_list(x)
149	1x	checkmate::assert_names(names(x), must.include = c("teal_slices"))
150	1x	self$set_content(x$teal_slices)
151	1x	invisible(self)
152		},
153		#' @description Convert the `RcodeBlock` to a list.
154		#' @return `named list` with a text and `params`.
155
156		to_list = function() {
157	2x	list(teal_slices = private$teal_slices)
158		}
159		),
160		private = list(
161		style = "verbatim",
162		teal_slices = NULL # teal_slices
163		)
164		)

1		# This file contains Shiny modules useful for debugging and developing teal.
2		# We do not export the functions in this file. They are for
3		# developers only and can be accessed via `:::`.
4
5		#' Dummy module to show the filter calls generated by the right encoding panel
6		#'
7		#'
8		#' Please do not remove, this is useful for debugging teal without
9		#' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
10		#' and avoids session restarts!
11		#'
12		#' @param label `character` label of module
13		#' @keywords internal
14		#'
15		#' @examples
16		#' app <- init(
17		#' data = list(iris = iris, mtcars = mtcars),
18		#' modules = teal:::filter_calls_module(),
19		#' header = "Simple teal app"
20		#' )
21		#' if (interactive()) {
22		#' runApp(app)
23		#' }
24		filter_calls_module <- function(label = "Filter Calls Module") { # nolint
25	!	checkmate::assert_string(label)
26
27	!	module(
28	!	label = label,
29	!	server = function(input, output, session, data) {
30	!	checkmate::assert_class(data, "tdata")
31
32	!	output$filter_calls <- renderText({
33	!	get_code_tdata(data)
34		})
35		},
36	!	ui = function(id, ...) {
37	!	ns <- NS(id)
38	!	div(
39	!	h2("The following filter calls are generated:"),
40	!	verbatimTextOutput(ns("filter_calls"))
41		)
42		},
43	!	datanames = "all"
44		)
45		}

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

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		# Use non-exported function(s) from teal.slice.
27		# This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).
28		list_to_teal_slices <- getFromNamespace("list_to_teal_slices", "teal.slice") # nolint
29		# This one is here because setdiff_teal_slice should not be exported from teal.slice.
30		setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
31		# all *Block objects are private in teal.reporter
32		RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint

1		#' Generates library calls from current session info
2		#'
3		#' Function to create multiple library calls out of current session info to make reproducible code works.
4		#'
5		#' @return Character object contain code
6		#' @keywords internal
7		get_rcode_libraries <- function() {
8	14x	vapply(
9	14x	utils::sessionInfo()$otherPkgs,
10	14x	function(x) {
11	238x	paste0("library(", x$Package, ")")
12		},
13	14x	character(1)
14		) %>%
15		# put it into reverse order to correctly simulate executed code
16	14x	rev() %>%
17	14x	paste0(sep = "\n") %>%
18	14x	paste0(collapse = "")
19		}
20
21
22
23		get_rcode_str_install <- function() {
24	18x	code_string <- getOption("teal.load_nest_code")
25
26	18x	if (!is.null(code_string) && is.character(code_string)) {
27	2x	return(code_string)
28		}
29
30	16x	return("# Add any code to install/load your NEST environment here\n")
31		}
32
33		#' Get datasets code
34		#'
35		#' Get combined code from `FilteredData` and from `CodeClass` object.
36		#'
37		#' @param datanames (`character`) names of datasets to extract code from
38		#' @param datasets (`FilteredData`) object
39		#' @param hashes named (`list`) of hashes per dataset
40		#'
41		#' @return `character(3)` containing following elements:
42		#' - code from `CodeClass` (data loading code)
43		#' - hash check of loaded objects
44		#'
45		#' @keywords internal
46		get_datasets_code <- function(datanames, datasets, hashes) {
47	14x	str_code <- datasets$get_code(datanames)
48	14x	if (length(str_code) == 0 \|\| (length(str_code) == 1 && str_code == "")) {
49	!	str_code <- "message('Preprocessing is empty')"
50	14x	} else if (length(str_code) > 0) {
51	14x	str_code <- paste0(str_code, "\n\n")
52		}
53
54	14x	if (!datasets$get_check()) {
55	10x	check_note_string <- paste0(
56	10x	c(
57	10x	"message(paste(\"Reproducibility of data import and preprocessing was not explicitly checked\",",
58	10x	" \" ('check = FALSE' is set). Contact app developer if this is an issue.\n\"))"
59		),
60	10x	collapse = "\n"
61		)
62	10x	str_code <- paste0(str_code, "\n\n", check_note_string)
63		}
64
65	14x	str_hash <- paste(
66	14x	paste0(
67	14x	vapply(
68	14x	datanames,
69	14x	function(dataname) {
70	17x	sprintf(
71	17x	"stopifnot(%s == %s)",
72	17x	deparse1(bquote(rlang::hash(.(as.name(dataname))))),
73	17x	deparse1(hashes[[dataname]])
74		)
75		},
76	14x	character(1)
77		),
78	14x	collapse = "\n"
79		),
80	14x	"\n\n"
81		)
82
83	14x	c(str_code, str_hash)
84		}

1		#' Create a `teal` module for previewing a report
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#' This function wraps [teal.reporter::reporter_previewer_ui()] and
5		#' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be
6		#' used in `teal` applications.
7		#'
8		#' If you are creating a `teal` application using [teal::init()] then this
9		#' module will be added to your application automatically if any of your `teal modules`
10		#' support report generation
11		#'
12		#' @inheritParams module
13		#' @param server_args (`named list`)\cr
14		#' Arguments passed to [teal.reporter::reporter_previewer_srv()].
15		#' @return `teal_module` containing the `teal.reporter` previewer functionality
16		#' @export
17		reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
18	4x	checkmate::assert_string(label)
19	2x	checkmate::assert_list(server_args, names = "named")
20	2x	checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))
21
22	2x	srv <- function(id, reporter, ...) {
23	!	teal.reporter::reporter_previewer_srv(id, reporter, ...)
24		}
25
26	2x	ui <- function(id, ...) {
27	!	teal.reporter::reporter_previewer_ui(id, ...)
28		}
29
30	2x	module <- module(
31	2x	label = label,
32	2x	server = srv, ui = ui,
33	2x	server_args = server_args, ui_args = list(), datanames = NULL
34		)
35	2x	class(module) <- c("teal_module_previewer", class(module))
36	2x	module
37		}

1		#' Filter settings for teal applications
2		#'
3		#' Filter settings for teal applications
4		#'
5		#' @inheritParams teal.slice::teal_slices
6		#'
7		#' @param module_specific (`logical(1)`)\cr
8		#' - `TRUE` when filter panel should be module-specific. All modules can have different set
9		#' of filters specified - see `mapping` argument.
10		#' - `FALSE` when one filter panel needed to all modules. All filters will be shared
11		#' by all modules.
12		#' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
13		#' (`named list`)\cr
14		#' Specifies which filters will be active in which modules on app start.
15		#' Elements should contain character vector of `teal_slice` `id`s (see [teal.slice::teal_slice()]).
16		#' Names of the list should correspond to `teal_module` `label` set in [module()] function.
17		#' `id`s listed under `"global_filters` will be active in all modules.
18		#' If missing, all filters will be applied to all modules.
19		#' If empty list, all filters will be available to all modules but will start inactive.
20		#' If `module_specific` is `FALSE`, only `global_filters` will be active on start.
21		#'
22		#' @param x (`list`) of lists to convert to `teal_slices`
23		#'
24		#' @examples
25		#' filter <- teal_slices(
26		#' teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"),
27		#' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),
28		#' teal.slice::teal_slice(
29		#' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"
30		#' ),
31		#' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),
32		#' mapping = list(
33		#' module1 = c("species", "sepal_length"),
34		#' module2 = c("mtcars_mpg"),
35		#' global_filters = "long_petals"
36		#' )
37		#' )
38		#'
39		#' app <- teal::init(
40		#' modules = list(
41		#' module("module1"),
42		#' module("module2")
43		#' ),
44		#' data = list(iris, mtcars),
45		#' filter = filter
46		#' )
47		#'
48		#' if (interactive()) {
49		#' shiny::runApp(app)
50		#' }
51		#'
52		#' @export
53		teal_slices <- function(...,
54		exclude_varnames = NULL,
55		include_varnames = NULL,
56		count_type = NULL,
57		allow_add = TRUE,
58		module_specific = FALSE,
59		mapping) {
60	91x	shiny::isolate({
61	91x	checkmate::assert_flag(allow_add)
62	91x	checkmate::assert_flag(module_specific)
63	45x	if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
64
65	88x	slices <- list(...)
66	88x	all_slice_id <- vapply(slices, `[[`, character(1L), "id")
67
68	88x	if (missing(mapping)) {
69	46x	mapping <- list(global_filters = all_slice_id)
70		}
71	88x	if (!module_specific) {
72	84x	mapping[setdiff(names(mapping), "global_filters")] <- NULL
73		}
74
75	88x	failed_slice_id <- setdiff(unlist(mapping), all_slice_id)
76	88x	if (length(failed_slice_id)) {
77	1x	stop(sprintf(
78	1x	"Filters in mapping don't match any available filter.\n %s not in %s",
79	1x	toString(failed_slice_id),
80	1x	toString(all_slice_id)
81		))
82		}
83
84	87x	tss <- teal.slice::teal_slices(
85		...,
86	87x	exclude_varnames = exclude_varnames,
87	87x	include_varnames = include_varnames,
88	87x	count_type = count_type,
89	87x	allow_add = allow_add
90		)
91	87x	attr(tss, "mapping") <- mapping
92	87x	attr(tss, "module_specific") <- module_specific
93	87x	class(tss) <- c("modules_teal_slices", class(tss))
94	87x	tss
95		})
96		}
97
98
99		#' @rdname teal_slices
100		#' @export
101		#' @keywords internal
102		#'
103		as.teal_slices <- function(x) { # nolint
104	33x	checkmate::assert_list(x)
105	33x	lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")
106
107	33x	attrs <- attributes(unclass(x))
108	33x	ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))
109	33x	do.call(teal_slices, c(ans, attrs))
110		}
111
112
113		#' Deep copy `teal_slices`
114		#'
115		#' it's important to create a new copy of `teal_slices` when
116		#' starting a new `shiny` session. Otherwise, object will be shared
117		#' by multiple users as it is created in global environment before
118		#' `shiny` session starts.
119		#' @param filter (`teal_slices`)
120		#' @return `teal_slices`
121		#' @keywords internal
122		deep_copy_filter <- function(filter) {
123	1x	checkmate::assert_class(filter, "teal_slices")
124	1x	shiny::isolate({
125	1x	filter_copy <- lapply(filter, function(slice) {
126	2x	teal.slice::as.teal_slice(as.list(slice))
127		})
128	1x	attributes(filter_copy) <- attributes(filter)
129	1x	filter_copy
130		})
131		}