teal coverage - 53.19%

Files
Source

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

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

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

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

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

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

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

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

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

  trigger_data
}

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

#' The default favicon for the teal app.
#' @keywords internal
.teal_favicon <- "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/teal.png"

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

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

  if (is.null(bs_theme)) {
    bs_theme <- bslib::bs_theme()
  }

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

  bs_theme
}

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

  unique(ordered_datanames)
}

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


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

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


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

#' @rdname check_modules_datanames
check_reserved_datanames <- function(datanames) {
  reserved_datanames <- datanames[datanames %in% c("all", ".raw_data")]
  if (length(reserved_datanames) == 0L) {
    return(NULL)
  }

  tags$span(
    to_html_code_list(reserved_datanames),
    sprintf(
      "%s reserved for internal use. Please avoid using %s as %s.",
      pluralize(reserved_datanames, "is", "are"),
      pluralize(reserved_datanames, "it", "them"),
      pluralize(reserved_datanames, "a dataset name", "dataset names")
    )
  )
}

#' @rdname check_modules_datanames
check_modules_datanames_html <- function(modules, datanames) {
  check_datanames <- check_modules_datanames_recursive(modules, datanames)
  show_module_info <- inherits(modules, "teal_modules") # used in two contexts - module and app

  reserved_datanames <- check_reserved_datanames(datanames)

  if (!length(check_datanames)) {
    out <- if (is.null(reserved_datanames)) {
      TRUE
    } else {
      shiny::tagList(reserved_datanames)
    }
    return(out)
  }
  shiny::tagList(
    reserved_datanames,
    lapply(
      check_datanames,
      function(mod) {
        tagList(
          tags$span(
            tags$span(pluralize(mod$missing_datanames, "Dataset")),
            to_html_code_list(mod$missing_datanames),
            tags$span(
              sprintf(
                "%s missing%s.",
                pluralize(mod$missing_datanames, "is", "are"),
                if (show_module_info) sprintf(" for module '%s'", mod$label) else ""
              )
            )
          ),
          if (length(datanames) >= 1) {
            tagList(
              tags$span(pluralize(datanames, "Dataset")),
              tags$span("available in data:"),
              tagList(
                tags$span(
                  to_html_code_list(datanames),
                  tags$span(".", .noWS = "outside"),
                  .noWS = c("outside")
                )
              )
            )
          } else {
            tags$span("No datasets are available in data.")
          },
          tags$br(.noWS = "before")
        )
      }
    )
  )
}

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

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


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

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


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

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

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

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

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

  # Suppress warnings of type: `package:MultiAssayExperiment' may not be available when loading`
  # This is because the package namespace may be part of the `data` object
  suppressWarnings(rlang::hash(list(data = data, modules = modules)))
}

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

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

#' @keywords internal
#' @noRd
pasten <- function(...) paste0(..., "\n")

#' Convert character list to human readable html with commas and "and"
#' @noRd
paste_datanames_character <- function(x,
                                      tags = list(span = shiny::tags$span, code = shiny::tags$code),
                                      tagList = shiny::tagList) { # nolint: object_name.
  checkmate::assert_character(x)
  do.call(
    tagList,
    lapply(seq_along(x), function(.ix) {
      tagList(
        tags$code(x[.ix]),
        if (.ix != length(x)) {
          tags$span(if (.ix == length(x) - 1) " and " else ", ")
        }
      )
    })
  )
}

#' Build datanames error string for error message
#'
#' tags and tagList are overwritten in arguments allowing to create strings for
#' logging purposes
#' @noRd
build_datanames_error_message <- function(label = NULL,
                                          datanames,
                                          extra_datanames,
                                          tags = list(span = shiny::tags$span, code = shiny::tags$code),
                                          tagList = shiny::tagList) { # nolint: object_name.
  tags$span(
    tags$span(pluralize(extra_datanames, "Dataset")),
    paste_datanames_character(extra_datanames, tags, tagList),
    tags$span(
      sprintf(
        "%s missing%s",
        pluralize(extra_datanames, "is", "are"),
        if (is.null(label)) "" else sprintf(" for tab '%s'", label)
      )
    ),
    if (length(datanames) >= 1) {
      tagList(
        tags$span(pluralize(datanames, "Dataset")),
        tags$span("available in data:"),
        tagList(
          tags$span(
            paste_datanames_character(datanames, tags, tagList),
            tags$span(".", .noWS = "outside"),
            .noWS = c("outside")
          )
        )
      )
    } else {
      tags$span("No datasets are available in data.")
    }
  )
}

#' Smart `rbind`
#'
#' Combine `data.frame` objects which have different columns
#'
#' @param ... (`data.frame`)
#' @keywords internal
.smart_rbind <- function(...) {
  dots <- list(...)
  checkmate::assert_list(dots, "data.frame", .var.name = "...")
  Reduce(
    x = dots,
    function(x, y) {
      all_columns <- union(colnames(x), colnames(y))
      x[setdiff(all_columns, colnames(x))] <- NA
      y[setdiff(all_columns, colnames(y))] <- NA
      rbind(x, y)
    }
  )
}

#' Pluralize a word depending on the size of the input
#'
#' @param x (`object`) to check length for plural.
#' @param singular (`character`) singular form of the word.
#' @param plural (optional `character`) plural form of the word. If not given an "s"
#' is added to the singular form.
#'
#' @return A `character` that correctly represents the size of the `x` argument.
#' @keywords internal
pluralize <- function(x, singular, plural = NULL) {
  checkmate::assert_string(singular)
  checkmate::assert_string(plural, null.ok = TRUE)
  if (length(x) == 1L) { # Zero length object should use plural form.
    singular
  } else {
    if (is.null(plural)) {
      sprintf("%ss", singular)
    } else {
      plural
    }
  }
}

#' @keywords internal
.dropdown_button <- function(id = NULL, label, icon) {
  tags$span(
    class = "teal dropdown-button",
    tags$a(
      id = id,
      class = "action-button",
      role = "button",
      style = "text-decoration: none;",
      bsicons::bs_icon(icon, class = "text-primary"),
      label,
      bsicons::bs_icon("chevron-down", class = "text-primary dropdown-arrow")
    )
  )
}

#' @keywords internal
.expand_button <- function(id, label, icon) {
  tags$span(
    class = "teal expand-button",
    htmltools::htmlDependency(
      name = "teal-busy-disable",
      version = utils::packageVersion("teal"),
      package = "teal",
      src = "js",
      script = "busy-disable.js"
    ),
    shinyjs::useShinyjs(),
    tags$button(
      id = id,
      class = "action-button teal-busy-disable",
      role = "button",
      style = "text-decoration: none;",
      tags$span(class = "icon", bsicons::bs_icon(icon, class = "text-primary")),
      tags$span(class = "label", label)
    )
  )
}


#' @keywords internal
.primary_button <- function(id, label, icon = NULL) {
  tags$a(
    id = id,
    class = "teal primary-button action-button",
    role = "button",
    style = "text-decoration: none;",
    if (!is.null(icon)) {
      bsicons::bs_icon(icon, class = "text-primary")
    },
    label
  )
}

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

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

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

  moduleServer(id, function(input, output, session) {
    logger::log_debug("srv_data initializing.")
    data_out <- if (inherits(data, "teal_data_module")) {
      output$data <- renderUI(data$ui(id = session$ns("teal_data_module")))
      data$server("teal_data_module")
    } else if (inherits(data, "teal_data")) {
      reactiveVal(data)
    } else if (test_reactive(data)) {
      data
    }

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

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

    data_handled
  })
}

#' Adds signature protection to the `datanames` in the data
#' @param data (`teal_data`)
#' @return `teal_data` with additional code that has signature of the `datanames`
#' @keywords internal
.add_signature_to_data <- function(data) {
  hashes <- .get_hashes_code(data)
  data_teal_report <- as(data, "teal_report")
  if (!inherits(data, "teal_report")) {
    teal.reporter::teal_card(data_teal_report) <- c(
      teal.reporter::teal_card(),
      "## Code preparation",
      teal.reporter::teal_card(data_teal_report)
    )
  }
  tdata <- do.call(
    teal.reporter::teal_report,
    c(
      list(
        code = trimws(c(teal.code::get_code(data_teal_report), hashes), which = "right"),
        join_keys = teal.data::join_keys(data_teal_report),
        teal_card = teal.reporter::teal_card(data_teal_report)
      ),
      sapply(
        names(data_teal_report),
        base::get,
        envir = data_teal_report,
        simplify = FALSE
      )
    )
  )
  tdata@verified <- data_teal_report@verified
  tdata
}

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

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

#' `teal` main module
#'
#' @description
#' Module to create a `teal` app as a Shiny Module.
#'
#' @details
#' This module can be used instead of [init()] in custom Shiny applications. Unlike [init()], it doesn't
#' automatically include [`module_session_info`].
#'
#' Module is responsible for creating the main `shiny` app layout and initializing all the necessary
#' components. This module establishes reactive connection between the input `data` and every other
#' component in the app. Reactive change of the `data` passed as an argument, reloads the app and
#' possibly keeps all input settings the same so the user can continue where one left off.
#'
#' ## data flow in `teal` application
#'
#' This module supports multiple data inputs but eventually, they are all converted to `reactive`
#' returning `teal_data` in this module. On this `reactive teal_data` object several actions are
#' performed:
#' - data loading in [`module_init_data`]
#' - data filtering in [`module_filter_data`]
#' - data transformation in [`module_transform_data`]
#'
#' ## Fallback on failure
#'
#' `teal` is designed in such way that app will never crash if the error is introduced in any
#' custom `shiny` module provided by app developer (e.g. [teal_data_module()], [teal_transform_module()]).
#' If any module returns a failing object, the app will halt the evaluation and display a warning message.
#' App user should always have a chance to fix the improper input and continue without restarting the session.
#'
#' @rdname module_teal
#' @name module_teal
#'
#' @inheritParams init
#' @param id (`character(1)`) `shiny` module instance id.
#' @param data (`teal_data`, `teal_data_module`, or `reactive` returning `teal_data`)
#' The data which application will depend on.
#' @param modules (`teal_modules`)
#'   `teal_modules` object. These are the specific output modules which
#'   will be displayed in the `teal` application. See [modules()] and [module()] for
#'   more details.
#'
#' @return `NULL` invisibly
NULL

#' @rdname module_teal
#' @export
ui_teal <- function(id, modules) {
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
  checkmate::assert_class(modules, "teal_modules")
  ns <- NS(id)

  mod <- extract_module(modules, class = "teal_module_previewer")
  reporter_opts <- if (length(mod)) .get_reporter_options(mod[[1]]$server_args)
  modules <- drop_module(modules, "teal_module_landing")

  # show busy icon when `shiny` session is busy computing stuff
  # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length.
  shiny_busy_message_panel <- conditionalPanel(
    condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
    tags$div(
      icon("arrows-rotate", class = "fa-spin", prefer_type = "solid"),
      "Computing ...",
      style = "position: fixed; bottom: 0; right: 0;
          width: 140px; margin: 15px; padding: 5px 0 5px 10px;
          text-align: left; font-weight: bold; font-size: 100%;
          color: #ffffff; background-color: #347ab7; z-index: 105;"
    )
  )

  navbar <- ui_teal_module(id = ns("teal_modules"), modules = modules)
  nav_elements <- list(
    withr::with_options(reporter_opts, { # for backwards compatibility of the report_previewer_module$server_args
      tags$div(
        id = ns("reporter_menu_container"),
        .teal_navbar_menu(
          label = "Report",
          icon = "file-text-fill",
          class = "reporter-menu",
          if ("preview" %in% getOption("teal.reporter.nav_buttons")) {
            teal.reporter::preview_report_button_ui(ns("preview_report"), label = "Preview Report")
          },
          tags$hr(style = "margin: 0.5rem;"),
          if ("download" %in% getOption("teal.reporter.nav_buttons")) {
            teal.reporter::download_report_button_ui(ns("download_report"), label = "Download Report")
          },
          if ("load" %in% getOption("teal.reporter.nav_buttons")) {
            teal.reporter::report_load_ui(ns("load_report"), label = "Load Report")
          },
          tags$hr(style = "margin: 0.5rem;"),
          if ("reset" %in% getOption("teal.reporter.nav_buttons")) {
            teal.reporter::reset_report_button_ui(ns("reset_reports"), label = "Reset Report")
          }
        )
      )
    }),
    tags$span(style = "margin-left: auto;"),
    ui_bookmark_panel(ns("bookmark_manager"), modules),
    ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
    ui_filter_manager_panel(ns("filter_manager_panel"))
  )
  navbar <- .teal_navbar_append(navbar, nav_elements)

  bslib::page_fluid(
    id = id,
    theme = get_teal_bs_theme(),
    include_teal_css_js(),
    shinyjs::useShinyjs(),
    shiny::includeScript(system.file("js/extendShinyJs.js", package = "teal.reporter")),
    shiny_busy_message_panel,
    tags$div(id = ns("tabpanel_wrapper"), class = "teal-body", navbar),
    tags$hr(style = "margin: 1rem 0 0.5rem 0;")
  )
}

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

  modules <- drop_module(modules, "teal_module_landing")

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

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

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

    data_handled <- srv_init_data("data", data = data)

    validate_ui <- tags$div(
      id = session$ns("validate_messages"),
      class = "teal_validated",
      ui_check_class_teal_data(session$ns("class_teal_data")),
      ui_validate_error(session$ns("silent_error")),
      ui_check_module_datanames(session$ns("datanames_warning"))
    )
    srv_check_class_teal_data("class_teal_data", data_handled)
    srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
    srv_check_module_datanames("datanames_warning", data_handled, modules)

    data_validated <- .trigger_on_success(data_handled)
    data_signatured <- reactive({
      req(inherits(data_validated(), "teal_data"))
      is_filter_ok <- check_filter_datanames(filter, names(data_validated()))
      if (!isTRUE(is_filter_ok)) {
        showNotification(
          "Some filters were not applied because of incompatibility with data. Contact app developer.",
          type = "warning",
          duration = 10
        )
        warning(is_filter_ok)
      }
      .add_signature_to_data(data_validated())
    })

    data_load_status <- reactive({
      if (inherits(data_handled(), "teal_data")) {
        shinyjs::enable(id = "close_teal_data_module_modal")
        "ok"
      } else if (inherits(data, "teal_data_module")) {
        shinyjs::disable(id = "close_teal_data_module_modal")
        "teal_data_module failed"
      } else {
        "external failed"
      }
    })

    if (inherits(data, "teal_data_module")) {
      setBookmarkExclude(c("teal_data_module_ui", "open_teal_data_module_ui"))
      .teal_navbar_insert_ui(
        ui = .expand_button(
          id = session$ns("open_teal_data_module_ui"),
          label = "Load Data",
          icon = "database-fill"
        )
      )
      observeEvent(
        input$open_teal_data_module_ui,
        ignoreInit = TRUE,
        ignoreNULL = FALSE, # should be shown on startup
        {
          showModal(
            div(
              class = "teal teal-data-module-popup",
              modalDialog(
                id = session$ns("teal_data_module_ui"),
                size = "xl",
                tags$div(
                  ui_init_data(session$ns("data")),
                  validate_ui
                ),
                easyClose = FALSE,
                footer = tags$div(id = session$ns("close_teal_data_module_modal"), modalButton("Dismiss"))
              )
            )
          )
          if (data_load_status() == "ok") {
            shinyjs::enable(id = "close_teal_data_module_modal")
          } else {
            shinyjs::disable(id = "close_teal_data_module_modal")
          }
        }
      )

      if (isTRUE(attr(data, "once"))) {
        # when once = TRUE we pull data once and then remove data button and a modal
        shiny::removeUI(selector = sprintf(".teal.expand-button:has(#%s)", session$ns("open_teal_data_module_ui")))
        observeEvent(data_signatured(), once = TRUE, {
          logger::log_debug("srv_teal@2 removing data tab.")
          shiny::removeModal()
        })
      }
    } else {
      # when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)
      insertUI(
        selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
        where = "beforeBegin",
        ui = tags$div(validate_ui)
      )
    }

    # Wait for UI to be rendered before showing/hiding reporter UI elements
    # See: https://github.com/rstudio/shiny/issues/3348
    observeEvent(
      once = TRUE,
      ignoreInit = TRUE,
      reactiveValuesToList(session$input),
      {
        if (!is.null(reporter)) {
          reporter$set_id(attr(filter, "app_id"))
          teal.reporter::preview_report_button_srv("preview_report", reporter)
          teal.reporter::report_load_srv("load_report", reporter)
          teal.reporter::download_report_button_srv(id = "download_report", reporter = reporter)
          teal.reporter::reset_report_button_srv("reset_reports", reporter)
        } else {
          removeUI(selector = sprintf("#%s", session$ns("reporter_menu_container")))
        }
      }
    )

    datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
      eventReactive(data_signatured(), {
        req(inherits(data_signatured(), "teal_data"))
        logger::log_debug("srv_teal@1 initializing FilteredData")
        teal_data_to_filtered_data(data_signatured())
      })
    }
    module_labels <- unlist(modules_slot(modules, "label"), use.names = FALSE)
    slices_global <- methods::new(".slicesGlobal", filter, module_labels)

    modules_output <- srv_teal_module(
      "teal_modules",
      data = data_signatured,
      modules = modules,
      datasets = datasets_rv,
      slices_global = slices_global,
      reporter = reporter,
      data_load_status = data_load_status
    )

    mapping_table <- srv_filter_manager_panel("filter_manager_panel", slices_global = slices_global)
    snapshots <- srv_snapshot_manager_panel("snapshot_manager_panel", slices_global = slices_global)
    srv_bookmark_panel("bookmark_manager", modules)
  })

  invisible(NULL)
}

#' Module to transform `reactive` `teal_data`
#'
#' Module calls [teal_transform_module()] in sequence so that `reactive teal_data` output
#' from one module is handed over to the following module's input.
#'
#' @inheritParams module_teal_data
#' @inheritParams teal_modules
#' @param class (character(1)) CSS class to be added in the `div` wrapper tag.

#' @return `reactive` `teal_data`
#'
#' @name module_transform_data
NULL

#' @export
#' @rdname module_transform_data
ui_transform_teal_data <- function(id, transformators, class = "well") {
  checkmate::assert_string(id)
  if (length(transformators) == 0L) {
    return(NULL)
  }
  if (inherits(transformators, "teal_transform_module")) {
    transformators <- list(transformators)
  }
  checkmate::assert_list(transformators, "teal_transform_module")
  names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))

  lapply(
    names(transformators),
    function(name) {
      child_id <- NS(id, name)
      ns <- NS(child_id)
      data_mod <- transformators[[name]]
      transform_wrapper_id <- ns(sprintf("wrapper_%s", name))

      display_fun <- if (is.null(data_mod$ui)) shinyjs::hidden else function(x) x

      display_fun(
        bslib::accordion(
          bslib::accordion_panel(
            attr(data_mod, "label"),
            icon = bsicons::bs_icon("palette-fill"),
            tags$div(
              id = transform_wrapper_id,
              if (is.null(data_mod$ui)) {
                return(NULL)
              } else {
                data_mod$ui(id = ns("transform"))
              },
              div(
                id = ns("validate_messages"),
                class = "teal_validated",
                uiOutput(ns("error_wrapper"))
              )
            )
          )
        )
      )
    }
  )
}

#' @export
#' @rdname module_transform_data
srv_transform_teal_data <- function(id, data, transformators, modules = NULL, is_transform_failed = reactiveValues()) {
  checkmate::assert_string(id)
  assert_reactive(data)
  checkmate::assert_class(modules, "teal_module", null.ok = TRUE)
  if (length(transformators) == 0L) {
    return(data)
  }
  if (inherits(transformators, "teal_transform_module")) {
    transformators <- list(transformators)
  }
  checkmate::assert_list(transformators, "teal_transform_module", null.ok = TRUE)
  names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))

  moduleServer(id, function(input, output, session) {
    module_output <- Reduce(
      function(data_previous, name) {
        moduleServer(name, function(input, output, session) {
          logger::log_debug("srv_transform_teal_data@1 initializing module for { name }.")

          data_out <- reactiveVal()
          .call_once_when(inherits(data_previous(), "teal_data"), {
            logger::log_debug("srv_teal_transform_teal_data@2 triggering a transform module call for { name }.")
            data_unhandled <- transformators[[name]]$server("transform", data = data_previous)
            data_handled <- reactive(tryCatch(data_unhandled(), error = function(e) e))

            observeEvent(data_handled(), {
              if (inherits(data_handled(), "teal_data")) {
                if (!identical(data_handled(), data_out())) {
                  data_out(data_handled())
                }
              }
            })

            is_transform_failed[[name]] <- FALSE
            observeEvent(data_handled(), {
              if (inherits(data_handled(), "teal_data")) {
                is_transform_failed[[name]] <- FALSE
              } else {
                is_transform_failed[[name]] <- TRUE
              }
            })

            is_previous_failed <- reactive({
              idx_this <- which(names(is_transform_failed) == name)
              is_transform_failed_list <- reactiveValuesToList(is_transform_failed)
              idx_failures <- which(unlist(is_transform_failed_list))
              any(idx_failures < idx_this)
            })

            srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
            srv_check_class_teal_data("class_teal_data", data_handled)
            if (!is.null(modules)) {
              srv_check_module_datanames("datanames_warning", data_handled, modules)
            }

            # When there is no UI (`ui = NULL`) it should still show the errors
            observe({
              if (!inherits(data_handled(), "teal_data") && !is_previous_failed()) {
                shinyjs::show("wrapper")
              }
            })

            transform_wrapper_id <- sprintf("wrapper_%s", name)
            output$error_wrapper <- renderUI({
              if (is_previous_failed()) {
                shinyjs::disable(transform_wrapper_id)
                tags$div(
                  "One of previous transformators failed. Please check its inputs.",
                  class = "teal-output-warning"
                )
              } else {
                shinyjs::enable(transform_wrapper_id)
                shiny::tagList(
                  ui_validate_error(session$ns("silent_error")),
                  ui_check_class_teal_data(session$ns("class_teal_data")),
                  ui_check_module_datanames(session$ns("datanames_warning"))
                )
              }
            })
          })

          # Ignoring unwanted reactivity breaks during initialization
          reactive({
            req(data_out())
          })
        })
      },
      x = names(transformators),
      init = data
    )

    module_output
  })
}

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

#' @rdname module_filter_manager
ui_filter_manager_panel <- function(id) {
  ns <- NS(id)
  .expand_button(
    id = ns("show_filter_manager"),
    label = "Filter Manager",
    icon = "funnel-fill"
  )
}

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

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

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

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

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

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

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

        mm
      })
    })

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

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

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

    mapping_table # for testing purpose
  })
}

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

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

    module_fd_previous <- reactiveVal(NULL)

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

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

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

      module_fd()$set_filter_state(slices)

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

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

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

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

    slices_module # returned for testing purpose
  })
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    NULL
  })
}

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

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

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

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

  process
}

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

  list(out = out, res = res)
}

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

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

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

#' @rdname module_snapshot_manager
ui_snapshot_manager_panel <- function(id) {
  ns <- NS(id)
  .expand_button(
    id = ns("show_snapshot_manager"),
    label = "Snapshot Manager",
    icon = "camera-fill"
  )
}

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

#' @rdname module_snapshot_manager
ui_snapshot_manager <- function(id) {
  ns <- NS(id)
  tags$div(
    tags$div(
      class = "teal manager_table_row",
      tags$span(tags$b("Snapshot manager")),
      bslib::tooltip(
        tags$span(actionLink(ns("snapshot_add"), label = NULL, icon = icon("fas fa-camera"))),
        "Add snapshot",
        placement = "top"
      ),
      bslib::tooltip(
        tags$span(actionLink(ns("snapshot_load"), label = NULL, icon = icon("fas fa-upload"))),
        "Upload snapshot",
        placement = "top"
      ),
      bslib::tooltip(
        tags$span(actionLink(ns("snapshot_reset"), label = NULL, icon = icon("fas fa-undo"))),
        "Reset initial state",
        placement = "top"
      ),
      NULL
    ),
    tags$br(),
    uiOutput(ns("snapshot_list"))
  )
}

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

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

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

    ns <- session$ns

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

    # Snapshot current application state ----
    # Name snapshot.
    observeEvent(input$snapshot_add, {
      logger::log_debug("srv_snapshot_manager: snapshot_add button clicked")
      showModal(
        modalDialog(
          easyClose = TRUE,
          textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
          tags$script(
            shiny::HTML(
              sprintf("shinyjs.autoFocusModal('%s');", ns("snapshot_name")),
              sprintf("shinyjs.enterToSubmit('%s', '%s');", ns("snapshot_name"), ns("snapshot_name_accept"))
            )
          ),
          footer = shiny::div(
            shiny::tags$button(
              type = "button",
              class = "btn btn-outline-secondary",
              `data-bs-dismiss` = "modal",
              NULL,
              "Dismiss"
            ),
            shiny::tags$button(
              id = ns("snapshot_name_accept"),
              type = "button",
              class = "btn btn-primary action-button",
              NULL,
              "Accept"
            )
          ),
          size = "s"
        )
      )
    })
    # Store snapshot.
    observeEvent(input$snapshot_name_accept, {
      logger::log_debug("srv_snapshot_manager: snapshot_name_accept button clicked")
      snapshot_name <- trimws(input$snapshot_name)
      if (identical(snapshot_name, "")) {
        logger::log_debug("srv_snapshot_manager: snapshot name rejected")
        showNotification(
          "Please name the snapshot.",
          type = "message"
        )
        updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
      } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
        logger::log_debug("srv_snapshot_manager: snapshot name rejected")
        showNotification(
          "This name is in conflict with other snapshot names. Please choose a different one.",
          type = "message"
        )
        updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
      } else {
        logger::log_debug("srv_snapshot_manager: snapshot name accepted, adding snapshot")
        snapshot <- as.list(slices_global$all_slices(), recursive = TRUE)
        snapshot_update <- c(snapshot_history(), list(snapshot))
        names(snapshot_update)[length(snapshot_update)] <- snapshot_name
        snapshot_history(snapshot_update)
        removeModal()
        # Reopen filter manager modal by clicking button in the main application.
        shinyjs::click(id = "teal-wunder_bar-show_snapshot_manager", asis = TRUE)
      }
    })

    # Upload a snapshot file ----
    # Select file.
    observeEvent(input$snapshot_load, {
      logger::log_debug("srv_snapshot_manager: snapshot_load button clicked")
      showModal(
        modalDialog(
          easyClose = TRUE,
          fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
          textInput(
            ns("snapshot_name"),
            "Name the snapshot (optional)",
            width = "100%",
            placeholder = "Meaningful, unique name"
          ),
          footer = shiny::div(
            shiny::tags$button(
              type = "button",
              class = "btn btn-outline-secondary",
              `data-bs-dismiss` = "modal",
              NULL,
              "Dismiss"
            ),
            shinyjs::disabled(
              shiny::tags$button(
                id = ns("snapshot_file_accept"),
                type = "button",
                class = "btn btn-primary action-button",
                NULL,
                "Accept"
              )
            )
          )
        )
      )
    })

    observeEvent(input$snapshot_file, {
      shinyjs::enable("snapshot_file_accept")
    })
    # Store new snapshot to list and restore filter states.
    observeEvent(input$snapshot_file_accept, {
      logger::log_debug("srv_snapshot_manager: snapshot_file_accept button clicked")
      snapshot_name <- trimws(input$snapshot_name)
      if (identical(snapshot_name, "")) {
        logger::log_debug("srv_snapshot_manager: no snapshot name provided, naming after file")
        snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)
      }
      if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
        logger::log_debug("srv_snapshot_manager: snapshot name rejected")
        showNotification(
          "This name is in conflict with other snapshot names. Please choose a different one.",
          type = "message"
        )
        updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
      } else {
        # Restore snapshot and verify app compatibility.
        logger::log_debug("srv_snapshot_manager: snapshot name accepted, loading snapshot")
        snapshot_state <- try(slices_restore(input$snapshot_file$datapath))
        if (!inherits(snapshot_state, "modules_teal_slices")) {
          logger::log_debug("srv_snapshot_manager: snapshot file corrupt")
          showNotification(
            "File appears to be corrupt.",
            type = "error"
          )
        } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global$all_slices(), "app_id"))) {
          logger::log_debug("srv_snapshot_manager: snapshot not compatible with app")
          showNotification(
            "This snapshot file is not compatible with the app and cannot be loaded.",
            type = "warning"
          )
        } else {
          # Add to snapshot history.
          logger::log_debug("srv_snapshot_manager: snapshot loaded, adding to history")
          snapshot <- as.list(slices_global$all_slices(), recursive = TRUE)
          snapshot_update <- c(snapshot_history(), list(snapshot))
          names(snapshot_update)[length(snapshot_update)] <- snapshot_name
          snapshot_history(snapshot_update)
          ### Begin simplified restore procedure. ###
          logger::log_debug("srv_snapshot_manager: restoring snapshot")
          slices_global$slices_set(snapshot_state)
          removeModal()
          ### End  simplified restore procedure. ###
        }
      }
    })
    # Apply newly added snapshot.

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

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

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

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

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

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

    snapshot_history
  })
}

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

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

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

  if (!all(is_unbookmarkable) && identical(bookmark_option, "server")) {
    .expand_button(
      id = ns("do_bookmark"),
      label = "Bookmark",
      icon = "bookmark-fill"
    )
  }
}

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

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


      showModal(
        div(
          class = "teal bookmark-popup",
          modalDialog(
            id = ns("bookmark_modal"),
            title = "Bookmarked teal app url",
            modal_content,
            easyClose = TRUE,
            footer = NULL
          )
        )
      )
    })

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

    invisible(NULL)
  })
}


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

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


# utilities ----

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

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

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

  ans <- TRUE

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

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

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

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

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

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

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

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

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


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

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

#' @rdname module_teal_data
#' @aliases ui_teal_data
#' @note
#' `ui_teal_data_module` was renamed from `ui_teal_data`.
ui_teal_data_module <- function(id, data_module = function(id) NULL) {
  checkmate::assert_string(id)
  checkmate::assert_function(data_module, args = "id")
  ns <- NS(id)

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

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

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

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

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

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

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

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

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

    .trigger_on_success(data)
  })
}

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

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


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

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

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

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

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

  out
}

#' Data summary
#' @description
#' Module and its utils to display the number of rows and subjects in the filtered and unfiltered data.
#'
#' @details Handling different data classes:
#' `get_filter_overview()` is a pseudo S3 method which has variants for:
#' - `array` (`data.frame`, `DataFrame`, `array`, `Matrix` and `SummarizedExperiment`): Method variant
#' can be applied to any two-dimensional objects on which [ncol()] can be used.
#' - `MultiAssayExperiment`: for which summary contains counts for `colData` and all `experiments`.
#' - For other data types module displays data name with warning icon and no more details.
#'
#' Module includes also "Show/Hide unsupported" button to toggle rows of the summary table
#' containing datasets where number of observations are not calculated.
#'
#' @inheritParams module_teal_module
#'
#' @name module_data_summary
#' @rdname module_data_summary
#' @keywords internal
#' @return `NULL`.
NULL

#' @rdname module_data_summary
ui_data_summary <- function(id) {
  ns <- NS(id)
  tableOutput(ns("table"))
}

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

      summary_table <- reactive({
        req(inherits(data(), "teal_data"))
        if (!length(data())) {
          return(NULL)
        }
        get_filter_overview_wrapper(data)
      })

      output$table <- renderUI({
        summary_table_out <- try(summary_table(), silent = TRUE)
        if (inherits(summary_table_out, "try-error")) {
          # Ignore silent shiny error
          if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
            stop("Error occurred during data processing. See details in the main panel.")
          }
        } else if (is.null(summary_table_out)) {
          "no datasets to show"
        } else {
          is_unsupported <- apply(summary_table(), 1, function(x) all(is.na(x[-1])))
          summary_table_out[is.na(summary_table_out)] <- ""
          body_html <- apply(
            summary_table_out,
            1,
            function(x) {
              is_supported <- !all(x[-1] == "")
              if (is_supported) {
                tags$tr(
                  tagList(
                    tags$td(x[1]),
                    lapply(x[-1], tags$td)
                  )
                )
              }
            }
          )

          header_labels <- tools::toTitleCase(names(summary_table_out))
          header_labels[header_labels == "Dataname"] <- "Data Name"
          header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))

          table_html <- tags$table(
            class = "table custom-table",
            tags$thead(header_html),
            tags$tbody(body_html)
          )
          div(
            table_html,
            if (any(is_unsupported)) {
              p(
                class = c("pull-right", "float-right", "text-secondary"),
                style = "font-size: 0.8em;",
                sprintf("And %s more unfilterable object(s)", sum(is_unsupported)),
                bslib::tooltip(
                  trigger = icon(name = "far fa-circle-question"),
                  options = list(trigger = "hover"),
                  paste(
                    sep = "",
                    collapse = "\n",
                    shQuote(summary_table()[is_unsupported, "dataname"]),
                    " (",
                    vapply(
                      summary_table()[is_unsupported, "dataname"],
                      function(x) class(data()[[x]])[1],
                      character(1L)
                    ),
                    ")"
                  )
                )
              )
            }
          )
        }
      })

      NULL
    }
  )
}

#' @rdname module_data_summary
get_filter_overview_wrapper <- function(teal_data) {
  # Sort datanames in topological order
  datanames <- names(teal_data())
  joinkeys <- teal.data::join_keys(teal_data())

  current_data_objs <- sapply(
    datanames,
    function(name) teal_data()[[name]],
    simplify = FALSE
  )
  initial_data_objs <- teal_data()[[".raw_data"]]

  out <- lapply(
    datanames,
    function(dataname) {
      parent <- teal.data::parent(joinkeys, dataname)
      subject_keys <- if (length(parent) > 0) {
        names(joinkeys[dataname, parent])
      } else {
        joinkeys[dataname, dataname]
      }
      get_filter_overview(
        current_data = current_data_objs[[dataname]],
        initial_data = initial_data_objs[[dataname]],
        dataname = dataname,
        subject_keys = subject_keys
      )
    }
  )

  do.call(.smart_rbind, out)
}


#' @rdname module_data_summary
#' @param current_data (`object`) current object (after filtering and transforming).
#' @param initial_data (`object`) initial object.
#' @param dataname (`character(1)`)
#' @param subject_keys (`character`) names of the columns which determine a single unique subjects
get_filter_overview <- function(current_data, initial_data, dataname, subject_keys) {
  if (inherits(current_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
    get_filter_overview_array(current_data, initial_data, dataname, subject_keys)
  } else if (inherits(current_data, "MultiAssayExperiment")) {
    get_filter_overview_MultiAssayExperiment(current_data, initial_data, dataname)
  } else {
    data.frame(dataname = dataname)
  }
}

#' @rdname module_data_summary
get_filter_overview_array <- function(current_data,
                                      initial_data,
                                      dataname,
                                      subject_keys) {
  if (length(subject_keys) == 0) {
    data.frame(
      dataname = dataname,
      obs = if (!is.null(initial_data)) {
        sprintf("%s/%s", nrow(current_data), nrow(initial_data))
      } else {
        nrow(current_data)
      }
    )
  } else {
    data.frame(
      dataname = dataname,
      obs = if (!is.null(initial_data)) {
        sprintf("%s/%s", nrow(current_data), nrow(initial_data))
      } else {
        nrow(current_data)
      },
      subjects = if (!is.null(initial_data)) {
        sprintf("%s/%s", nrow(unique(current_data[subject_keys])), nrow(unique(initial_data[subject_keys])))
      } else {
        nrow(unique(current_data[subject_keys]))
      }
    )
  }
}

#' @rdname module_data_summary
get_filter_overview_MultiAssayExperiment <- function(current_data, # nolint: object_length, object_name.
                                                     initial_data,
                                                     dataname) {
  experiment_names <- names(current_data)
  mae_info <- data.frame(
    dataname = dataname,
    subjects = if (!is.null(initial_data)) {
      sprintf("%s/%s", nrow(current_data@colData), nrow(initial_data@colData))
    } else {
      nrow(current_data@colData)
    }
  )

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

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

  experiment_subjects_info <- do.call("rbind", lapply(
    experiment_names,
    function(experiment_name) {
      data.frame(
        subjects = if (!is.null(initial_data)) {
          sprintf(
            "%s/%s",
            get_experiment_keys(current_data, current_data[[experiment_name]]),
            get_experiment_keys(current_data, initial_data[[experiment_name]])
          )
        } else {
          get_experiment_keys(current_data, current_data[[experiment_name]])
        }
      )
    }
  ))

  experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)
  .smart_rbind(mae_info, experiment_info)
}

#' Executes modifications to the result of a module
#'
#' Primarily used to modify the output object of module to change the containing
#' report.
#' @param x (`teal_module`)
#' @param ui (`function(id, elem, ...)`) function to receive output (`shiny.tag`) from `x$ui`
#' @param server (`function(input, output, session, data, ...)`) function to receive output data from `x$server`
#' @param ... additional argument passed to `ui` and `server` by matching their formals names.
#' @return A `teal_report` object with the result of the server function.
#' @export
after <- function(x,
                  ui = function(id, elem) elem,
                  server = function(input, output, session, data) data,
                  ...) {
  # todo: make a method for teal_app and remove teal_extend_server?
  checkmate::assert_multi_class(x, "teal_module")
  if (!is.function(ui) || !all(names(formals(ui)) %in% c("id", "elem"))) {
    stop("ui should be a function of id and elem")
  }
  if (!is.function(server) || !all(names(formals(server)) %in% c("input", "output", "session", "data"))) {
    stop("server should be a function of `input` and `output`, `session`, `data`")
  }

  additional_args <- list(...)
  new_x <- x # because overwriting x$ui/server will cause infinite recursion
  new_x$ui <- .after_ui(x$ui, ui, additional_args)
  new_x$server <- .after_server(x$server, server, additional_args)
  new_x
}

.after_ui <- function(x, y, additional_args) {
  # add `_`-prefix to make sure objects are not masked in the wrapper functions
  `_x` <- x # nolint: object_name.
  `_y` <- y # nolint: object_name.
  new_x <- function(id, ...) {
    original_args <- as.list(environment())
    if ("..." %in% names(formals(`_x`))) {
      original_args <- c(original_args, list(...))
    }
    ns <- NS(id)
    original_args$id <- ns("wrapped")
    original_out <- do.call(`_x`, original_args, quote = TRUE)

    wrapper_args <- c(
      additional_args,
      list(id = ns("wrapper"), elem = original_out)
    )
    do.call(`_y`, args = wrapper_args[names(formals(`_y`))])
  }
  formals(new_x) <- formals(x)
  new_x
}

.after_server <- function(x, y, additional_args) {
  # add `_`-prefix to make sure objects are not masked in the wrapper functions
  `_x` <- x # nolint: object_name.
  `_y` <- y # nolint: object_name.
  new_x <- function(id, ...) {
    original_args <- as.list(environment())
    original_args$id <- "wrapped"
    if ("..." %in% names(formals(`_x`))) {
      original_args <- c(original_args, list(...))
    }
    moduleServer(id, function(input, output, session) {
      original_out <- if (all(c("input", "output", "session") %in% names(formals(`_x`)))) {
        original_args$module <- `_x`
        do.call(shiny::callModule, args = original_args)
      } else {
        do.call(`_x`, original_args)
      }
      original_out_r <- reactive(
        if (is.reactive(original_out)) {
          original_out()
        } else {
          original_out
        }
      )
      wrapper_args <- utils::modifyList(
        additional_args,
        list(id = "wrapper", input = input, output = output, session = session)
      )
      reactive({
        req(original_out_r())
        wrapper_args$data <- original_out()
        do.call(`_y`, wrapper_args[names(formals(`_y`))], quote = TRUE)
      })
    })
  }
  formals(new_x) <- formals(x)
  new_x
}

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

  teal_default_options <- list(
    teal.show_js_log = FALSE,
    teal.lockfile.mode = "auto",
    shiny.sanitize.errors = FALSE,
    teal.sidebar.position = "left",
    teal.sidebar.width = 250,
    teal.reporter.nav_buttons = c("preview", "download", "load", "reset")
  )

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

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

  invisible()
}

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

# This one is here because setdiff_teal_slice should not be exported from teal.slice.
setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
# This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice.
coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")

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

#' Create a `teal` module for previewing a report
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' This function controls the appearance of the drop-down menu for the reporter.
#' It is now deprecated in favor of the options:
#' - `teal.reporter.nav_buttons = c("preview", "download", "load", "reset")` to control which
#'  buttons will be displayed in the drop-down.
#' - `teal.reporter.rmd_output`: passed to [teal.reporter::download_report_button_srv()]
#' - `teal.reporter.rmd_yaml_args`: passed to [teal.reporter::download_report_button_srv()]
#' - `teal.reporter.global_knitr`: passed to [teal.reporter::download_report_button_srv()]
#'
#' @inheritParams teal_modules
#' @param server_args (named `list`) Arguments will overwrite the default `teal.reporter` options
#' described in the description.
#'
#' @return
#' `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer functionality.
#'
#' @export
reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
  checkmate::assert_string(label)
  checkmate::assert_list(server_args, names = "named")
  checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))

  lifecycle::deprecate_soft(
    when = "1.0.0",
    what = "reporter_previewer_module()",
    details = paste(
      "Please use `options()` to customize the reporter options:\n",
      "`teal.reporter.nav_buttons` to control which buttons will be displayed in the 'Report' drop-down.\n",
      "`teal.reporter.rmd_output` to customize the R Markdown outputs types for the report.\n",
      "`teal.reporter.rmd_yaml_args` to customize the widget inputs in the download report modal.\n",
      "`teal.reporter.global_knitr` to customize the global knitr options for the report."
    )
  )

  message("Initializing reporter_previewer_module")

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

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

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

#' Temporary function to handle server_args of the report_previewer_module before its hard
#' deprecation.
#' @param args (`list`)
#'
#' @keywords internal
.get_reporter_options <- function(args) {
  opts <- list()
  if (length(args$previewer_buttons)) {
    opts <- c(opts, list(teal.reporter.nav_buttons = args$previewer_buttons))
  }

  if (length(args$global_knitr)) {
    opts <- c(opts, list(teal.reporter.global_knitr = args$global_knitr))
  }

  if (length(args$rmd_output)) {
    opts <- c(opts, list(teal.reporter.rmd_output = args$rmd_output))
  }

  if (length(args$rmd_yaml_args)) {
    opts <- c(opts, list(teal.reporter.rmd_yaml_args = args$rmd_yaml_args))
  }

  opts
}

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

#' @export
#' @rdname module_teal_with_splash
ui_teal_with_splash <- function(id,
                                data,
                                modules,
                                title = build_app_title(),
                                header = tags$p(),
                                footer = tags$p()) {
  lifecycle::deprecate_soft(
    when = "0.16.0",
    what = "ui_teal_with_splash()",
    details = "Please use `?ui_teal` instead"
  )
  ns <- shiny::NS(id)
  fluidPage(
    title = tags$div(
      id = ns("teal-app-title"),
      tags$head(
        tags$title("teal app"),
        tags$link(
          rel = "icon",
          href = .teal_favicon,
          sizes = "any"
        )
      )
    ),
    tags$header(id = ns("teal-header-content")),
    ui_teal(id = id, modules = modules),
    tags$footer(
      id = "teal-footer",
      tags$div(id = "teal-footer-content"),
      ui_session_info(ns("teal-footer-session_info"))
    )
  )
}

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

#' @title `TealReportCard`
#' @description `r lifecycle::badge("experimental")`
#' Child class of [`teal.reporter::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
#' @importFrom methods as
#'
TealReportCard <- R6::R6Class( # nolint: object_name.
  classname = "TealReportCard",
  inherit = teal.reporter::ReportCard,
  public = list(
    #' @description Appends the source code to the `content` meta data of this `TealReportCard`.
    #'
    #' @param src (`character(1)`) code as text.
    #' @param ... any `rmarkdown` `R` chunk parameter and its value.
    #' But `eval` parameter is always set to `FALSE`.
    #' @return Object of class `TealReportCard`, invisibly.
    #' @examples
    #' card <- TealReportCard$new()$append_src(
    #'   "plot(iris)"
    #' )
    #' card$get_content()[[1]]
    append_src = function(src, ...) {
      super$append_rcode(text = src, ...)
    },
    #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.
    #'  If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses
    #'  the default `yaml::as.yaml` to format the list.
    #'  If the filter state list is empty, nothing is appended to the `content`.
    #'
    #' @param fs (`teal_slices`) object returned from [teal_slices()] function.
    #' @return `self`, invisibly.
    append_fs = function(fs) {
      checkmate::assert_class(fs, "teal_slices")
      if (length(fs) > 0) {
        self$append_content(teal.reporter::code_chunk(.teal_slice_to_yaml(fs), eval = FALSE, lang = "verbatim"))
      }
      invisible(self)
    },
    #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.
    #'
    #' @param encodings (`list`) list of encodings selections of the `teal` app.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))
    #' card$get_content()[[1]]
    #'
    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)
    }
  )
)

.teal_slice_to_yaml <- function(fs) {
  checkmate::assert_class(fs, "teal_slices")
  states_list <- lapply(fs, 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)) {
    yaml::as.yaml(states_list)
  } else {
    stop("yaml package is required to format the filter state list")
  }
}

#' @noRd
ui_add_reporter <- function(id) uiOutput(NS(id, "reporter_add_container"))

#' @noRd
srv_add_reporter <- function(id, module_out, reporter) {
  if (is.null(reporter)) {
    return(FALSE)
  } # early exit
  moduleServer(id, function(input, output, session) {
    mod_out_r <- reactive({
      req(module_out)
      if (is.reactive(module_out)) {
        module_out()
      }
    })

    doc_out <- reactive({
      req(mod_out_r())
      teal_data_handled <- tryCatch(mod_out_r(), error = function(e) e)
      tcard <- if (inherits(teal_data_handled, "teal_report")) {
        teal.reporter::teal_card(teal_data_handled)
      } else if (inherits(teal_data_handled, "teal_data")) {
        teal.reporter::teal_card(as(teal_data_handled, "teal_report"))
      } else if (inherits(teal_data_handled, "teal_card")) {
        teal_data_handled
      }

      if (length(tcard)) .collapse_subsequent_chunks(tcard)
    })

    .call_once_when(!is.null(doc_out()) && !is.null(reporter), {
      output$reporter_add_container <- renderUI({
        tags$div(
          class = "teal add-reporter-container",
          teal.reporter::add_card_button_ui(session$ns("reporter_add"), label = "Add to Report")
        )
      })
      teal.reporter::add_card_button_srv("reporter_add", reporter = reporter, card_fun = doc_out)
    })



    observeEvent(doc_out(), ignoreNULL = FALSE, {
      shinyjs::toggleState("reporter_add_container", condition = inherits(doc_out(), "teal_card"))
    })
  })
}

#' Disable the report for a `teal_module`
#'
#' Convenience function that disables the user's ability to add the module
#' to the report previewer.
#' @param x (`teal_module`) a `teal_module` object.
#' @return `NULL` that indicates that it should disable the reporter functionality.
#' @export
#' @examples
#' app <- init(
#'   data = within(teal_data(), iris <- iris),
#'   modules = modules(
#'     example_module(label = "example teal module") |> disable_report()
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
disable_report <- function(x) {
  checkmate::assert_class(x, "teal_module")
  after(x, server = function(data) {
    teal.reporter::teal_card(data) <- teal.reporter::teal_card()
    NULL
  })
}

#' Calls all `modules`
#'
#' Modules create navigation bar with drop-down menu and tab content. Each `teal_module` is called recursively
#' according to the structure of `modules` argument. This is a custom module which utilizes shiny/Bootstrap
#' `.nav` class. `modules` are called with an `id` derived from `teal_module`'s label and labels of its
#' ancestors (if any).
#'
#' ### Functions
#'
#' - `ui/srv_teal_module` - wrapper module which links drop-down buttons with modules panels.
#'   Here `input$active_module_id` is instantiated.
#' - `.ui/srv_teal_module` - recursive S3 method which calls each module
#' - `.teal_navbar_append` - wrapper for [htmltools::tagAppendChild()] to add any element to navigation bar.
#' - `.teal_navbar_insert_ui` - wrapper for [shiny::insertUI()] to insert any element to navigation bar.
#' - `.teal_navbar_menu` - UI function to create a drop-down menu for navigation bar.
#'
#' ### Utilizing `.nav` class
#'
#' No extra `javascript` or server functionality were introduced to have navigation buttons toggle between
#' tab panels. This works thanks to `.nav` container which links `.nav-link` buttons `href = #<module id>`
#' attribute with `.tab-pane`'s `id = <module id>` (see ``.ui_teal_module.teal_module`).
#'
#' ### Initialization and isolation of the `teal_module`(s)
#'
#' Modules are initialized only when they are active. This speeds up app initialization and on
#' startup only the first module is activated and its outputs are calculated.
#' Only the active module is listening to reactive events. This way, modules are isolated and only
#' one can run at any given time. This makes the app more efficient by reducing unnecessary
#' computations on server side.
#'
#' @name module_teal_module
#'
#' @inheritParams module_teal
#'
#' @param data (`reactive` returning `teal_data`)
#'
#' @param slices_global (`reactiveVal` returning `modules_teal_slices`)
#'   see [`module_filter_manager`]
#'
#' @param datasets (`reactive` returning `FilteredData` or `NULL`)
#'  When `datasets` is passed from the parent module (`srv_teal`) then `dataset` is a singleton
#'  which implies the filter-panel to be "global". When `NULL` then filter-panel is "module-specific".
#'
#' @param reporter (`Reporter`, singleton)
#'  Stores reporter-cards appended in the server of `teal_module`.
#'
#' @param data_load_status (`reactive` returning `character(1)`)
#'  Determines action dependent on a data loading status:
#'  - `"ok"` when `teal_data` is returned from the data loading.
#'  - `"teal_data_module failed"` when [teal_data_module()] didn't return `teal_data`. Disables tab buttons.
#'  - `"external failed"` when a `reactive` passed to `srv_teal(data)` didn't return `teal_data`. Hides the whole tab
#'    panel.
#'
#' @param active_module_id (`reactive` returning `character(1)`)
#'   `id` of the currently active module. This helps to determine which module can listen to reactive events.
#'
#' @return
#' Output of currently active module.
#' - `srv_teal_module.teal_module` returns `reactiveVal` containing output of the called module.
#' - `srv_teal_module.teal_modules` returns output of modules in a list following the hierarchy of `modules`
#'
#' @keywords internal
NULL


#' @rdname module_teal_module
ui_teal_module <- function(id, modules) {
  ns <- NS(id)
  active_module_id <- restoreInput(
    ns("active_module_id"),
    unlist(modules_slot(modules, "path"), use.names = FALSE)[1]
  )

  module_items <- .ui_teal_module(id = ns("nav"), modules = modules, active_module_id = active_module_id)

  tags$div(
    class = "teal-modules-wrapper",
    htmltools::htmlDependency(
      name = "module-navigation",
      version = utils::packageVersion("teal"),
      package = "teal",
      src = "module-navigation",
      stylesheet = "module-navigation.css"
    ),
    tags$ul(
      id = ns("active_module_id"),
      style = "align-items: center; gap: 1em; font-size: large;",
      class = "teal-navbar nav shiny-tab-input", # to mimic nav and mimic tabsetPanel
      `data-tabsetid` = "test",
      .teal_navbar_menu(
        !!!module_items$link,
        label = sprintf("Module (%d)", length(unlist(modules_slot(modules, "label")))),
        class = "teal-modules-tree",
        icon = "diagram-3-fill"
      )
    ),
    tags$div(class = "tab-content", module_items$tab_pane)
  )
}

#' @rdname module_teal_module
srv_teal_module <- function(id,
                            data,
                            modules,
                            datasets = NULL,
                            slices_global,
                            reporter = teal.reporter::Reporter$new(),
                            data_load_status = reactive("ok")) {
  moduleServer(id, function(input, output, session) {
    .srv_teal_module(
      id = "nav",
      data = data,
      modules = modules,
      datasets = datasets,
      slices_global = slices_global,
      reporter = reporter,
      data_load_status = data_load_status,
      active_module_id = reactive(input$active_module_id)
    )
  })
}

#' @rdname module_teal_module
.teal_navbar_append <- function(navbar, child) {
  tagAppendChild(tag = navbar, child = child, .cssSelector = ".teal-navbar")
}

#' @rdname module_teal_module
.teal_navbar_insert_ui <- function(ui, where = "afterBegin", session = getDefaultReactiveDomain()) {
  insertUI(
    selector = ".teal-navbar",
    where = where,
    ui = ui,
    session = session
  )
}

#' @rdname module_teal_module
.teal_navbar_menu <- function(..., id = NULL, label = NULL, class = NULL, icon = NULL) {
  tags$div(
    class = "dropdown nav-item-custom",
    .dropdown_button(
      id = id,
      label = label,
      icon = icon
    ),
    tags$div(
      class = "dropdown-menu",
      tags$ul(class = class, !!!rlang::list2(...))
    )
  )
}

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

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

#' @rdname module_teal_module
#' @export
.ui_teal_module.teal_modules <- function(id, modules, active_module_id) {
  items <- mapply(
    FUN = .ui_teal_module,
    id = NS(id, .label_to_id(sapply(modules$children, `[[`, "label"))),
    modules = modules$children,
    active_module_id = active_module_id,
    SIMPLIFY = FALSE
  )

  list(
    link = tagList(
      if (length(modules$label)) tags$li(tags$span(modules$label, class = "module-group-label")),
      tags$li(tags$ul(lapply(items, `[[`, "link")))
    ),
    tab_pane = tagList(lapply(items, `[[`, "tab_pane"))
  )
}

#' @rdname module_teal_module
#' @export
.ui_teal_module.teal_module <- function(id, modules, active_module_id) {
  ns <- NS(id)
  args <- c(list(id = ns("module")), modules$ui_args)
  ui_teal <- tags$div(
    shinyjs::hidden(
      tags$div(
        id = ns("transform_failure_info"),
        class = "teal_validated",
        div(
          class = "teal-output-warning",
          "One of transformators failed. Please check its inputs."
        )
      )
    ),
    tags$div(
      id = ns("teal_module_ui"),
      tags$div(
        class = "teal_validated",
        ui_check_module_datanames(ns("validate_datanames"))
      ),
      do.call(what = modules$ui, args = args, quote = TRUE)
    )
  )
  container_id <- ns("wrapper")
  module_id <- modules$path

  link <- tags$li(
    tags$a(
      href = paste0("#", container_id), # links button with module content in `tab-content` with same id.
      `data-bs-toggle` = "tab", # signals shiny to treat this element as bootstrap tab buttons for toggle.
      `data-value` = module_id, # this data is set as the shiny input.
      class = c("nav-link", "module-button", "btn-default", if (identical(module_id, active_module_id)) "active"),
      # `nav-link` is required to mimic bslib tab panel.
      modules$label
    )
  )

  tab_pane <- div(
    id = container_id,
    class = c("tab-pane", "teal_module", if (identical(module_id, active_module_id)) "active"),
    ui_add_reporter(ns("add_reporter_wrapper")),
    tagList(
      .modules_breadcrumb(modules),
      if (!is.null(modules$datanames)) {
        tagList(
          bslib::layout_sidebar(
            class = "teal-sidebar-layout",
            sidebar = bslib::sidebar(
              id = ns("teal_module_sidebar"),
              class = "teal-sidebar",
              position = getOption("teal.sidebar.position", "left"),
              width = getOption("teal.sidebar.width", 250),
              tags$div(
                tags$div(
                  class = "teal-active-data-summary-panel",
                  bslib::accordion(
                    id = ns("data_summary_accordion"),
                    bslib::accordion_panel(
                      "Active Data Summary",
                      tags$div(
                        class = "teal-active-data-summary",
                        ui_data_summary(ns("data_summary"))
                      )
                    )
                  )
                ),
                tags$br(),
                tags$div(
                  class = "teal-filter-panel",
                  ui_filter_data(ns("filter_panel"))
                ),
                if (length(modules$transformators) > 0 && !isTRUE(attr(modules$transformators, "custom_ui"))) {
                  tags$div(
                    tags$br(),
                    tags$div(
                      class = "teal-transform-panel",
                      bslib::accordion(
                        id = ns("data_transform_accordion"),
                        bslib::accordion_panel(
                          "Transform Data",
                          ui_transform_teal_data(
                            ns("data_transform"),
                            transformators = modules$transformators
                          )
                        )
                      )
                    )
                  )
                }
              )
            ),
            ui_teal
          ),
          div(
            id = ns("sidebar_toggle_buttons"),
            class = "sidebar-toggle-buttons",
            actionButton(
              class = "data-summary-toggle btn-outline-primary",
              ns("data_summary_toggle"),
              icon("fas fa-list")
            ),
            actionButton(
              class = "data-filters-toggle btn-outline-secondary",
              ns("data_filters_toggle"),
              icon("fas fa-filter")
            ),
            if (length(modules$transformators) > 0) {
              actionButton(
                class = "data-transforms-toggle btn-outline-primary",
                ns("data_transforms_toggle"),
                icon("fas fa-pen-to-square")
              )
            }
          ),
          tags$script(
            HTML(
              sprintf(
                "
                  $(document).ready(function() {
                    $('#%s').insertAfter('#%s > .bslib-sidebar-layout > button.collapse-toggle');
                  });
                ",
                ns("sidebar_toggle_buttons"),
                ns("wrapper")
              )
            )
          )
        )
      } else {
        ui_teal
      }
    )
  )

  list(link = link, tab_pane = tab_pane)
}

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

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

#' @rdname module_teal_module
#' @export
.srv_teal_module.teal_modules <- function(id,
                                          data,
                                          modules,
                                          datasets = NULL,
                                          slices_global,
                                          reporter = teal.reporter::Reporter$new(),
                                          data_load_status = reactive("ok"),
                                          active_module_id = reactive(TRUE)) {
  moduleServer(id = id, module = function(input, output, session) {
    logger::log_debug("srv_teal_module.teal_modules initializing the module { deparse1(modules$label) }.")
    modules_output <- mapply(
      function(id, modules) {
        .srv_teal_module(
          id = id,
          modules = modules,
          data = data,
          datasets = datasets,
          slices_global = slices_global,
          reporter = reporter,
          data_load_status = data_load_status,
          active_module_id = active_module_id
        )
      },
      id = .label_to_id(sapply(modules$children, `[[`, "label")),
      modules = modules$children,
      SIMPLIFY = FALSE
    )

    modules_output
  })
}

#' @rdname module_teal_module
#' @export
.srv_teal_module.teal_module <- function(id,
                                         data,
                                         modules,
                                         datasets = NULL,
                                         slices_global,
                                         reporter = teal.reporter::Reporter$new(),
                                         data_load_status = reactive("ok"),
                                         active_module_id = reactive(TRUE)) {
  logger::log_debug("srv_teal_module.teal_module initializing the module: { deparse1(modules$label) }.")
  moduleServer(id = id, module = function(input, output, session) {
    module_out <- reactiveVal()
    module_id <- modules$path
    is_active <- reactive({
      identical(data_load_status(), "ok") && identical(module_id, active_module_id())
    })
    active_datanames <- reactive({
      .resolve_module_datanames(data = data(), modules = modules)
    })
    if (is.null(datasets)) {
      datasets <- eventReactive(data(), {
        req(inherits(data(), "teal_data"))
        logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
        teal_data_to_filtered_data(data(), datanames = active_datanames())
      })
    }

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

    .call_once_when(is_active(), {
      filtered_teal_data <- srv_filter_data(
        "filter_panel",
        datasets = datasets,
        active_datanames = active_datanames,
        data = data,
        is_active = is_active
      )
      is_transform_failed <- reactiveValues()
      transformed_teal_data <- srv_transform_teal_data(
        "data_transform",
        data = filtered_teal_data,
        transformators = modules$transformators,
        modules = modules,
        is_transform_failed = is_transform_failed
      )
      any_transform_failed <- reactive({
        any(unlist(reactiveValuesToList(is_transform_failed)))
      })

      observeEvent(any_transform_failed(), {
        if (isTRUE(any_transform_failed())) {
          shinyjs::hide("teal_module_ui")
          shinyjs::show("transform_failure_info")
        } else {
          shinyjs::show("teal_module_ui")
          shinyjs::hide("transform_failure_info")
        }
      })

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

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

      summary_table <- srv_data_summary("data_summary", module_teal_data)

      observeEvent(input$data_summary_toggle, {
        bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
        bslib::accordion_panel_open(id = "data_summary_accordion", values = TRUE)
        bslib::accordion_panel_close(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
        bslib::accordion_panel_close(id = "data_transform_accordion", values = TRUE)
      })

      observeEvent(input$data_filters_toggle, {
        bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
        bslib::accordion_panel_close(id = "data_summary_accordion", values = TRUE)
        bslib::accordion_panel_open(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
        bslib::accordion_panel_close(id = "data_transform_accordion", values = TRUE)
      })

      observeEvent(input$data_transforms_toggle, {
        bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
        bslib::accordion_panel_close(id = "data_summary_accordion", values = TRUE)
        bslib::accordion_panel_close(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
        bslib::accordion_panel_open(id = "data_transform_accordion", values = TRUE)
      })

      # Call modules.
      obs_module <- .call_once_when(
        !is.null(module_teal_data()),
        ignoreNULL = TRUE,
        handlerExpr = {
          out <- .call_teal_module(modules, datasets, module_teal_data, reporter)
          srv_add_reporter("add_reporter_wrapper", out, reporter)
          module_out(out)
        }
      )
    })
    module_out
  })
}

# This function calls a module server function.
.call_teal_module <- function(modules, datasets, data, reporter) {
  assert_reactive(data)

  # collect arguments to run teal_module
  args <- c(list(id = "module"), modules$server_args)
  if (is_arg_used(modules$server, "reporter") && !is.null(reporter)) {
    args <- c(args, list(reporter = reporter))
  }

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

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

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

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

.resolve_module_datanames <- function(data, modules) {
  stopifnot("data must be teal_data object." = inherits(data, "teal_data"))
  if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
    names(data)
  } else {
    intersect(
      names(data), # Keep topological order from teal.data::names()
      .include_parent_datanames(modules$datanames, teal.data::join_keys(data))
    )
  }
}

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

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

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

.modules_breadcrumb <- function(module) {
  tags$div(
    style = "color: var(--bs-secondary); font-size: large; opacity: 0.6; margin: 0 0.5em 0.5em 0.5em;",
    paste("Home", module$path, sep = " / ")
  )
}

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

#' @rdname teal_data_utilities
.append_evaluated_code <- function(data, code) {
  checkmate::assert_class(data, "teal_data")
  if (length(code) && !identical(code, "")) {
    data@code <- c(data@code, code2list(code))
    teal.reporter::teal_card(data) <- c(
      teal.reporter::teal_card(data),
      "## Data filtering",
      teal.reporter::code_chunk(code)
    )
    methods::validObject(data)
  }
  data
}

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

#' @rdname teal_data_utilities
.collapse_subsequent_chunks <- function(report) {
  Reduce(
    function(x, this) {
      l <- length(x)
      if (
        l &&
          inherits(x[[l]], "code_chunk") &&
          inherits(this, "code_chunk") &&
          identical(attr(x[[l]], "params"), attr(this, "params"))
      ) {
        x[[length(x)]] <- do.call(
          teal.reporter::code_chunk,
          args = c(
            list(code = paste(x[[l]], this, sep = "\n")),
            attr(x[[l]], "params")
          )
        )
        x
      } else {
        c(x, this)
      }
    },
    init = teal.reporter::teal_card(),
    x = report
  )
}

setOldClass("teal_data_module")

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

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

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

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

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

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

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

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

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

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

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

#' Code to include `teal` `CSS` and `JavaScript` files
#'
#' This is useful when you want to use the same `JavaScript` and `CSS` files that are
#' used with the `teal` application.
#' This is also useful for running standalone modules in `teal` with the correct
#' styles.
#' Also initializes `shinyjs` so you can use it.
#'
#' Simply add `include_teal_css_js()` as one of the UI elements.
#' @return A `shiny.tag.list`.
#' @keywords internal
include_teal_css_js <- function() {
  tagList(
    shinyjs::useShinyjs(),
    include_css_files()
  )
}

1		#' Module to transform `reactive` `teal_data`
2		#'
3		#' Module calls [teal_transform_module()] in sequence so that `reactive teal_data` output
4		#' from one module is handed over to the following module's input.
5		#'
6		#' @inheritParams module_teal_data
7		#' @inheritParams teal_modules
8		#' @param class (character(1)) CSS class to be added in the `div` wrapper tag.
9
10		#' @return `reactive` `teal_data`
11		#'
12		#' @name module_transform_data
13		NULL
14
15		#' @export
16		#' @rdname module_transform_data
17		ui_transform_teal_data <- function(id, transformators, class = "well") {
18	1x	checkmate::assert_string(id)
19	1x	if (length(transformators) == 0L) {
20	!	return(NULL)
21		}
22	1x	if (inherits(transformators, "teal_transform_module")) {
23	1x	transformators <- list(transformators)
24		}
25	1x	checkmate::assert_list(transformators, "teal_transform_module")
26	1x	names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))
27
28	1x	lapply(
29	1x	names(transformators),
30	1x	function(name) {
31	1x	child_id <- NS(id, name)
32	1x	ns <- NS(child_id)
33	1x	data_mod <- transformators[[name]]
34	1x	transform_wrapper_id <- ns(sprintf("wrapper_%s", name))
35
36	1x	display_fun <- if (is.null(data_mod$ui)) shinyjs::hidden else function(x) x
37
38	1x	display_fun(
39	1x	bslib::accordion(
40	1x	bslib::accordion_panel(
41	1x	attr(data_mod, "label"),
42	1x	icon = bsicons::bs_icon("palette-fill"),
43	1x	tags$div(
44	1x	id = transform_wrapper_id,
45	1x	if (is.null(data_mod$ui)) {
46	!	return(NULL)
47		} else {
48	1x	data_mod$ui(id = ns("transform"))
49		},
50	1x	div(
51	1x	id = ns("validate_messages"),
52	1x	class = "teal_validated",
53	1x	uiOutput(ns("error_wrapper"))
54		)
55		)
56		)
57		)
58		)
59		}
60		)
61		}
62
63		#' @export
64		#' @rdname module_transform_data
65		srv_transform_teal_data <- function(id, data, transformators, modules = NULL, is_transform_failed = reactiveValues()) {
66	95x	checkmate::assert_string(id)
67	95x	assert_reactive(data)
68	95x	checkmate::assert_class(modules, "teal_module", null.ok = TRUE)
69	95x	if (length(transformators) == 0L) {
70	72x	return(data)
71		}
72	23x	if (inherits(transformators, "teal_transform_module")) {
73	3x	transformators <- list(transformators)
74		}
75	23x	checkmate::assert_list(transformators, "teal_transform_module", null.ok = TRUE)
76	23x	names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))
77
78	23x	moduleServer(id, function(input, output, session) {
79	23x	module_output <- Reduce(
80	23x	function(data_previous, name) {
81	26x	moduleServer(name, function(input, output, session) {
82	26x	logger::log_debug("srv_transform_teal_data@1 initializing module for { name }.")
83
84	26x	data_out <- reactiveVal()
85	26x	.call_once_when(inherits(data_previous(), "teal_data"), {
86	26x	logger::log_debug("srv_teal_transform_teal_data@2 triggering a transform module call for { name }.")
87	26x	data_unhandled <- transformators[[name]]$server("transform", data = data_previous)
88	26x	data_handled <- reactive(tryCatch(data_unhandled(), error = function(e) e))
89
90	26x	observeEvent(data_handled(), {
91	29x	if (inherits(data_handled(), "teal_data")) {
92	22x	if (!identical(data_handled(), data_out())) {
93	22x	data_out(data_handled())
94		}
95		}
96		})
97
98	26x	is_transform_failed[[name]] <- FALSE
99	26x	observeEvent(data_handled(), {
100	29x	if (inherits(data_handled(), "teal_data")) {
101	22x	is_transform_failed[[name]] <- FALSE
102		} else {
103	7x	is_transform_failed[[name]] <- TRUE
104		}
105		})
106
107	26x	is_previous_failed <- reactive({
108	30x	idx_this <- which(names(is_transform_failed) == name)
109	30x	is_transform_failed_list <- reactiveValuesToList(is_transform_failed)
110	30x	idx_failures <- which(unlist(is_transform_failed_list))
111	30x	any(idx_failures < idx_this)
112		})
113
114	26x	srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
115	26x	srv_check_class_teal_data("class_teal_data", data_handled)
116	26x	if (!is.null(modules)) {
117	20x	srv_check_module_datanames("datanames_warning", data_handled, modules)
118		}
119
120		# When there is no UI (`ui = NULL`) it should still show the errors
121	26x	observe({
122	29x	if (!inherits(data_handled(), "teal_data") && !is_previous_failed()) {
123	7x	shinyjs::show("wrapper")
124		}
125		})
126
127	26x	transform_wrapper_id <- sprintf("wrapper_%s", name)
128	26x	output$error_wrapper <- renderUI({
129	30x	if (is_previous_failed()) {
130	!	shinyjs::disable(transform_wrapper_id)
131	!	tags$div(
132	!	"One of previous transformators failed. Please check its inputs.",
133	!	class = "teal-output-warning"
134		)
135		} else {
136	30x	shinyjs::enable(transform_wrapper_id)
137	30x	shiny::tagList(
138	30x	ui_validate_error(session$ns("silent_error")),
139	30x	ui_check_class_teal_data(session$ns("class_teal_data")),
140	30x	ui_check_module_datanames(session$ns("datanames_warning"))
141		)
142		}
143		})
144		})
145
146		# Ignoring unwanted reactivity breaks during initialization
147	26x	reactive({
148	45x	req(data_out())
149		})
150		})
151		},
152	23x	x = names(transformators),
153	23x	init = data
154		)
155
156	23x	module_output
157		})
158		}

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

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

1		#' An example `teal` module
2		#'
3		#' This module creates an object called `object` that can be modified with decorators.
4		#' The `object` is determined by what's selected in `Choose a dataset` input in UI.
5		#' The object can be anything that can be handled by `renderPrint()`.
6		#' See the `vignette("transform-module-output", package = "teal")` or [`teal_transform_module`]
7		#' to read more about decorators.
8		#'
9		#' @inheritParams teal_modules
10		#' @param decorators `r lifecycle::badge("experimental")` (`list` of `teal_transform_module`) optional,
11		#' decorator for `object` included in the module.
12		#'
13		#' @return A `teal` module which can be included in the `modules` argument to [init()].
14		#'
15		#' @examplesShinylive
16		#' library(teal)
17		#' interactive <- function() TRUE
18		#' {{ next_example }}
19		#' @examples
20		#' app <- init(
21		#' data = teal_data(IRIS = iris, MTCARS = mtcars),
22		#' modules = example_module()
23		#' )
24		#' if (interactive()) {
25		#' shinyApp(app$ui, app$server)
26		#' }
27		#' @export
28		example_module <- function(label = "example teal module",
29		datanames = "all",
30		transformators = list(),
31		decorators = list()) {
32	41x	checkmate::assert_string(label)
33	41x	checkmate::assert_list(decorators, "teal_transform_module")
34
35	41x	ans <- module(
36	41x	label,
37	41x	server = function(id, data, decorators) {
38	5x	checkmate::assert_class(isolate(data()), "teal_data")
39	5x	moduleServer(id, function(input, output, session) {
40	5x	datanames_rv <- reactive(names(req(data())))
41	5x	observeEvent(datanames_rv(), {
42	5x	selected <- input$dataname
43	5x	if (identical(selected, "")) {
44	!	selected <- restoreInput(session$ns("dataname"), NULL)
45	5x	} else if (isFALSE(selected %in% datanames_rv())) {
46	!	selected <- datanames_rv()[1]
47		}
48	5x	updateSelectInput(
49	5x	session = session,
50	5x	inputId = "dataname",
51	5x	choices = datanames_rv(),
52	5x	selected = selected
53		)
54		})
55
56	5x	table_data <- reactive({
57	8x	req(input$dataname)
58	3x	within(data(),
59		{
60	3x	object <- dataname
61		},
62	3x	dataname = as.name(input$dataname)
63		)
64		})
65
66	5x	table_data_decorated_no_print <- srv_transform_teal_data(
67	5x	"decorate",
68	5x	data = table_data,
69	5x	transformators = decorators
70		)
71	5x	table_data_decorated <- reactive(within(req(table_data_decorated_no_print()), expr = object))
72
73	5x	output$text <- renderPrint({
74	11x	req(table_data()) # Ensure original errors from module are displayed
75	6x	table_data_decorated()[["object"]]
76		})
77
78	5x	teal.widgets::verbatim_popup_srv(
79	5x	id = "rcode",
80	5x	verbatim_content = reactive(teal.code::get_code(req(table_data_decorated()))),
81	5x	title = "Example Code"
82		)
83
84	5x	table_data_decorated
85		})
86		},
87	41x	ui = function(id, decorators) {
88	!	ns <- NS(id)
89	!	teal.widgets::standard_layout(
90	!	output = verbatimTextOutput(ns("text")),
91	!	encoding = tags$div(
92	!	selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
93	!	ui_transform_teal_data(ns("decorate"), transformators = decorators),
94	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
95		)
96		)
97		},
98	41x	ui_args = list(decorators = decorators),
99	41x	server_args = list(decorators = decorators),
100	41x	datanames = datanames,
101	41x	transformators = transformators
102		)
103	41x	attr(ans, "teal_bookmarkable") <- TRUE
104	41x	ans
105		}
106
107		globalVariables("dataname")

1		#' Landing popup module
2		#'
3		#' @description `r lifecycle::badge("deprecated")` Creates a landing welcome popup for `teal` applications.
4		#'
5		#' This module is used to display a popup dialog when the application starts.
6		#' The dialog blocks access to the application and must be closed with a button before the application can be viewed.
7		#' This function is deprecated, please use `add_landing_modal()` on the teal app object instead.
8		#'
9		#' @param label (`character(1)`) Label of the module.
10		#' @param title (`character(1)`) Text to be displayed as popup title.
11		#' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup.
12		#' Passed to `...` of `shiny::modalDialog`. See examples.
13		#' @param buttons (`shiny.tag` or `shiny.tag.list`) Typically a `modalButton` or `actionButton`. See examples.
14		#'
15		#' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications.
16		#'
17		#' @export
18		landing_popup_module <- function(label = "Landing Popup",
19		title = NULL,
20		content = NULL,
21		buttons = modalButton("Accept")) {
22	!	lifecycle::deprecate_soft(
23	!	when = "0.16.0",
24	!	what = "landing_popup_module()",
25	!	details = paste(
26	!	"landing_popup_module() is deprecated.",
27	!	"Use add_landing_modal() on the teal app object instead."
28		)
29		)
30	!	checkmate::assert_string(label)
31	!	checkmate::assert_string(title, null.ok = TRUE)
32	!	checkmate::assert_multi_class(
33	!	content,
34	!	classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
35		)
36	!	checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
37
38	!	message("Initializing landing_popup_module")
39
40	!	module <- module(
41	!	label = label,
42	!	datanames = NULL,
43	!	server = function(id) {
44	!	moduleServer(id, function(input, output, session) {
45	!	showModal(
46	!	modalDialog(
47	!	id = "landingpopup",
48	!	title = title,
49	!	content,
50	!	footer = buttons
51		)
52		)
53		})
54		}
55		)
56	!	class(module) <- c("teal_module_landing", class(module))
57	!	module
58		}

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

1		#' The default favicon for the teal app.
2		#' @keywords internal
3		.teal_favicon <- "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/teal.png"
4
5		#' Get client timezone
6		#'
7		#' User timezone in the browser may be different to the one on the server.
8		#' This script can be run to register a `shiny` input which contains information about the timezone in the browser.
9		#'
10		#' @param ns (`function`) namespace function passed from the `session` object in the `shiny` server.
11		#' For `shiny` modules this will allow for proper name spacing of the registered input.
12		#'
13		#' @return `NULL`, invisibly.
14		#'
15		#' @keywords internal
16		#'
17		get_client_timezone <- function(ns) {
18	88x	script <- sprintf(
19	88x	"Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",
20	88x	ns("timezone")
21		)
22	88x	shinyjs::runjs(script) # function does not return anything
23	88x	invisible(NULL)
24		}
25
26		#' Resolve the expected bootstrap theme
27		#' @noRd
28		#' @keywords internal
29		get_teal_bs_theme <- function() {
30	4x	bs_theme <- getOption("teal.bs_theme")
31
32	4x	if (is.null(bs_theme)) {
33	1x	bs_theme <- bslib::bs_theme()
34		}
35
36	4x	if (!checkmate::test_class(bs_theme, "bs_theme")) {
37	2x	warning(
38	2x	"Assertion on 'teal.bs_theme' option value failed: ",
39	2x	checkmate::check_class(bs_theme, "bs_theme"),
40	2x	". The default bslib Bootstrap theme will be used."
41		)
42	2x	bs_theme <- bslib::bs_theme()
43		}
44
45	4x	bs_theme
46		}
47
48		#' Return parentnames along with datanames.
49		#' @noRd
50		#' @keywords internal
51		.include_parent_datanames <- function(datanames, join_keys) {
52	32x	ordered_datanames <- datanames
53	32x	for (current in datanames) {
54	62x	parents <- character(0L)
55	62x	while (length(current) > 0) {
56	64x	current <- teal.data::parent(join_keys, current)
57	64x	parents <- c(current, parents)
58		}
59	62x	ordered_datanames <- c(parents, ordered_datanames)
60		}
61
62	32x	unique(ordered_datanames)
63		}
64
65		#' Create a `FilteredData`
66		#'
67		#' Create a `FilteredData` object from a `teal_data` object.
68		#'
69		#' @param x (`teal_data`) object
70		#' @param datanames (`character`) vector of data set names to include; must be subset of `names(x)`
71		#' @return A `FilteredData` object.
72		#' @keywords internal
73		teal_data_to_filtered_data <- function(x, datanames = names(x)) {
74	85x	checkmate::assert_class(x, "teal_data")
75	85x	checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)
76		# Otherwise, FilteredData will be created in the modules' scope later
77	85x	teal.slice::init_filtered_data(
78	85x	x = Filter(length, sapply(datanames, function(dn) x[[dn]], simplify = FALSE)),
79	85x	join_keys = teal.data::join_keys(x)
80		)
81		}
82
83
84		#' Template function for `TealReportCard` creation and customization
85		#'
86		#' This function generates a report card with a title,
87		#' an optional description, and the option to append the filter state list.
88		#'
89		#' @param title (`character(1)`) title of the card (unless overwritten by label)
90		#' @param label (`character(1)`) label provided by the user when adding the card
91		#' @param description (`character(1)`) optional, additional description
92		#' @param with_filter (`logical(1)`) flag indicating to add filter state
93		#' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation
94		#' of the filter state in the report
95		#'
96		#' @return (`TealReportCard`) populated with a title, description and filter state.
97		#'
98		#' @export
99		report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
100	2x	checkmate::assert_string(title)
101	2x	checkmate::assert_string(label)
102	2x	checkmate::assert_string(description, null.ok = TRUE)
103	2x	checkmate::assert_flag(with_filter)
104	2x	checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")
105
106	2x	card <- teal::TealReportCard$new()
107	2x	title <- if (label == "") title else label
108	2x	card$set_name(title)
109	2x	card$append_text(title, "header2")
110	1x	if (!is.null(description)) card$append_text(description, "header3")
111	1x	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
112	2x	card
113		}
114
115
116		#' Check `datanames` in modules
117		#'
118		#' These functions check if specified `datanames` in modules match those in the data object,
119		#' returning error messages or `TRUE` for successful validation. Two functions return error message
120		#' in different forms:
121		#' - `check_modules_datanames` returns `character(1)` for basic assertion usage
122		#' - `check_modules_datanames_html` returns `shiny.tag.list` to display it in the app.
123		#'
124		#' @param modules (`teal_modules`) object
125		#' @param datanames (`character`) names of datasets available in the `data` object
126		#'
127		#' @return `TRUE` if validation passes, otherwise `character(1)` or `shiny.tag.list`
128		#' @keywords internal
129		check_modules_datanames <- function(modules, datanames) {
130	11x	out <- check_modules_datanames_html(modules, datanames)
131	11x	if (inherits(out, "shiny.tag.list")) {
132	5x	out_with_ticks <- gsub("<code>\|</code>", "`", toString(out))
133	5x	out_text <- gsub("<[^<>]+>", "", toString(out_with_ticks))
134	5x	trimws(gsub("[[:space:]]+", " ", out_text))
135		} else {
136	6x	out
137		}
138		}
139
140		#' @rdname check_modules_datanames
141		check_reserved_datanames <- function(datanames) {
142	193x	reserved_datanames <- datanames[datanames %in% c("all", ".raw_data")]
143	193x	if (length(reserved_datanames) == 0L) {
144	187x	return(NULL)
145		}
146
147	6x	tags$span(
148	6x	to_html_code_list(reserved_datanames),
149	6x	sprintf(
150	6x	"%s reserved for internal use. Please avoid using %s as %s.",
151	6x	pluralize(reserved_datanames, "is", "are"),
152	6x	pluralize(reserved_datanames, "it", "them"),
153	6x	pluralize(reserved_datanames, "a dataset name", "dataset names")
154		)
155		)
156		}
157
158		#' @rdname check_modules_datanames
159		check_modules_datanames_html <- function(modules, datanames) {
160	193x	check_datanames <- check_modules_datanames_recursive(modules, datanames)
161	193x	show_module_info <- inherits(modules, "teal_modules") # used in two contexts - module and app
162
163	193x	reserved_datanames <- check_reserved_datanames(datanames)
164
165	193x	if (!length(check_datanames)) {
166	175x	out <- if (is.null(reserved_datanames)) {
167	169x	TRUE
168		} else {
169	6x	shiny::tagList(reserved_datanames)
170		}
171	175x	return(out)
172		}
173	18x	shiny::tagList(
174	18x	reserved_datanames,
175	18x	lapply(
176	18x	check_datanames,
177	18x	function(mod) {
178	18x	tagList(
179	18x	tags$span(
180	18x	tags$span(pluralize(mod$missing_datanames, "Dataset")),
181	18x	to_html_code_list(mod$missing_datanames),
182	18x	tags$span(
183	18x	sprintf(
184	18x	"%s missing%s.",
185	18x	pluralize(mod$missing_datanames, "is", "are"),
186	18x	if (show_module_info) sprintf(" for module '%s'", mod$label) else ""
187		)
188		)
189		),
190	18x	if (length(datanames) >= 1) {
191	16x	tagList(
192	16x	tags$span(pluralize(datanames, "Dataset")),
193	16x	tags$span("available in data:"),
194	16x	tagList(
195	16x	tags$span(
196	16x	to_html_code_list(datanames),
197	16x	tags$span(".", .noWS = "outside"),
198	16x	.noWS = c("outside")
199		)
200		)
201		)
202		} else {
203	2x	tags$span("No datasets are available in data.")
204		},
205	18x	tags$br(.noWS = "before")
206		)
207		}
208		)
209		)
210		}
211
212		#' Recursively checks modules and returns list for every datanames mismatch between module and data
213		#' @noRd
214		check_modules_datanames_recursive <- function(modules, datanames) { # nolint: object_name_length
215	302x	checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
216	302x	checkmate::assert_character(datanames)
217	302x	if (inherits(modules, "teal_modules")) {
218	88x	unlist(
219	88x	lapply(modules$children, check_modules_datanames_recursive, datanames = datanames),
220	88x	recursive = FALSE
221		)
222		} else {
223	214x	missing_datanames <- setdiff(modules$datanames, c("all", datanames))
224	214x	if (length(missing_datanames)) {
225	18x	list(list(
226	18x	label = modules$label,
227	18x	missing_datanames = missing_datanames
228		))
229		}
230		}
231		}
232
233		#' Convert character vector to html code separated with commas and "and"
234		#' @noRd
235		to_html_code_list <- function(x) {
236	40x	checkmate::assert_character(x)
237	40x	do.call(
238	40x	tagList,
239	40x	lapply(seq_along(x), function(.ix) {
240	56x	tagList(
241	56x	tags$code(x[.ix]),
242	56x	if (.ix != length(x)) {
243	1x	if (.ix == length(x) - 1) tags$span(" and ") else tags$span(", ", .noWS = "before")
244		}
245		)
246		})
247		)
248		}
249
250
251		#' Check `datanames` in filters
252		#'
253		#' This function checks whether `datanames` in filters correspond to those in `data`,
254		#' returning character vector with error messages or `TRUE` if all checks pass.
255		#'
256		#' @param filters (`teal_slices`) object
257		#' @param datanames (`character`) names of datasets available in the `data` object
258		#'
259		#' @return A `character(1)` containing error message or TRUE if validation passes.
260		#' @keywords internal
261		check_filter_datanames <- function(filters, datanames) {
262	88x	checkmate::assert_class(filters, "teal_slices")
263	88x	checkmate::assert_character(datanames)
264
265		# check teal_slices against datanames
266	88x	out <- unlist(sapply(
267	88x	filters, function(filter) {
268	24x	dataname <- shiny::isolate(filter$dataname)
269	24x	if (!dataname %in% datanames) {
270	3x	sprintf(
271	3x	"- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)",
272	3x	shiny::isolate(filter$id),
273	3x	dQuote(dataname, q = FALSE),
274	3x	toString(dQuote(datanames, q = FALSE))
275		)
276		}
277		}
278		))
279
280
281	88x	if (length(out)) {
282	3x	paste(out, collapse = "\n")
283		} else {
284	85x	TRUE
285		}
286		}
287
288		#' Function for validating the title parameter of `teal::init`
289		#'
290		#' Checks if the input of the title from `teal::init` will create a valid title and favicon tag.
291		#' @param shiny_tag (`shiny.tag`) Object to validate for a valid title.
292		#' @keywords internal
293		validate_app_title_tag <- function(shiny_tag) {
294	7x	checkmate::assert_class(shiny_tag, "shiny.tag")
295	7x	checkmate::assert_true(shiny_tag$name == "head")
296	6x	child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name")
297	6x	checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags")
298	4x	rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel
299	4x	checkmate::assert_subset(
300	4x	rel_attr,
301	4x	c("icon", "shortcut icon"),
302	4x	.var.name = "Link tag's rel attribute",
303	4x	empty.ok = FALSE
304		)
305		}
306
307		#' Build app title with favicon
308		#'
309		#' A helper function to create the browser title along with a logo.
310		#'
311		#' @param title (`character`) The browser title for the `teal` app.
312		#' @param favicon (`character`) The path for the icon for the title.
313		#' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/`
314		#'
315		#' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app.
316		#' @export
317		build_app_title <- function(
318		title = "teal app",
319		favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
320	2x	lifecycle::deprecate_soft(
321	2x	when = "0.16.0",
322	2x	what = "build_app_title()",
323	2x	details = "Use `modify_title()` on the object created using the `init`."
324		)
325	2x	checkmate::assert_string(title, null.ok = TRUE)
326	2x	checkmate::assert_string(favicon, null.ok = TRUE)
327	2x	tags$head(
328	2x	tags$title(title),
329	2x	tags$link(
330	2x	rel = "icon",
331	2x	href = favicon,
332	2x	sizes = "any"
333		)
334		)
335		}
336
337		#' Application ID
338		#'
339		#' Creates App ID used to match filter snapshots to application.
340		#'
341		#' Calculate app ID that will be used to stamp filter state snapshots.
342		#' App ID is a hash of the app's data and modules.
343		#' See "transferring snapshots" section in ?snapshot.
344		#'
345		#' @param data (`teal_data` or `teal_data_module`) as accepted by `init`
346		#' @param modules (`teal_modules`) object as accepted by `init`
347		#'
348		#' @return A single character string.
349		#'
350		#' @keywords internal
351		create_app_id <- function(data, modules) {
352	23x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
353	22x	checkmate::assert_class(modules, "teal_modules")
354
355	21x	data <- if (inherits(data, "teal_data")) {
356	19x	as.list(data)
357	21x	} else if (inherits(data, "teal_data_module")) {
358	2x	deparse1(body(data$server))
359		}
360	21x	modules <- lapply(modules, defunction)
361
362		# Suppress warnings of type: `package:MultiAssayExperiment' may not be available when loading`
363		# This is because the package namespace may be part of the `data` object
364	21x	suppressWarnings(rlang::hash(list(data = data, modules = modules)))
365		}
366
367		#' Go through list and extract bodies of encountered functions as string, recursively.
368		#' @keywords internal
369		#' @noRd
370		defunction <- function(x) {
371	321x	if (is.list(x)) {
372	169x	lapply(x, defunction)
373	152x	} else if (is.function(x)) {
374	54x	deparse1(body(x))
375		} else {
376	98x	x
377		}
378		}
379
380		#' Get unique labels
381		#'
382		#' Get unique labels for the modules to avoid namespace conflicts.
383		#'
384		#' @param labels (`character`) vector of labels
385		#'
386		#' @return (`character`) vector of unique labels
387		#'
388		#' @keywords internal
389		get_unique_labels <- function(labels) {
390	1x	make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
391		}
392
393		#' @keywords internal
394		#' @noRd
395	4x	pasten <- function(...) paste0(..., "\n")
396
397		#' Convert character list to human readable html with commas and "and"
398		#' @noRd
399		paste_datanames_character <- function(x,
400		tags = list(span = shiny::tags$span, code = shiny::tags$code),
401		tagList = shiny::tagList) { # nolint: object_name.
402	!	checkmate::assert_character(x)
403	!	do.call(
404	!	tagList,
405	!	lapply(seq_along(x), function(.ix) {
406	!	tagList(
407	!	tags$code(x[.ix]),
408	!	if (.ix != length(x)) {
409	!	tags$span(if (.ix == length(x) - 1) " and " else ", ")
410		}
411		)
412		})
413		)
414		}
415
416		#' Build datanames error string for error message
417		#'
418		#' tags and tagList are overwritten in arguments allowing to create strings for
419		#' logging purposes
420		#' @noRd
421		build_datanames_error_message <- function(label = NULL,
422		datanames,
423		extra_datanames,
424		tags = list(span = shiny::tags$span, code = shiny::tags$code),
425		tagList = shiny::tagList) { # nolint: object_name.
426	!	tags$span(
427	!	tags$span(pluralize(extra_datanames, "Dataset")),
428	!	paste_datanames_character(extra_datanames, tags, tagList),
429	!	tags$span(
430	!	sprintf(
431	!	"%s missing%s",
432	!	pluralize(extra_datanames, "is", "are"),
433	!	if (is.null(label)) "" else sprintf(" for tab '%s'", label)
434		)
435		),
436	!	if (length(datanames) >= 1) {
437	!	tagList(
438	!	tags$span(pluralize(datanames, "Dataset")),
439	!	tags$span("available in data:"),
440	!	tagList(
441	!	tags$span(
442	!	paste_datanames_character(datanames, tags, tagList),
443	!	tags$span(".", .noWS = "outside"),
444	!	.noWS = c("outside")
445		)
446		)
447		)
448		} else {
449	!	tags$span("No datasets are available in data.")
450		}
451		)
452		}
453
454		#' Smart `rbind`
455		#'
456		#' Combine `data.frame` objects which have different columns
457		#'
458		#' @param ... (`data.frame`)
459		#' @keywords internal
460		.smart_rbind <- function(...) {
461	90x	dots <- list(...)
462	90x	checkmate::assert_list(dots, "data.frame", .var.name = "...")
463	90x	Reduce(
464	90x	x = dots,
465	90x	function(x, y) {
466	72x	all_columns <- union(colnames(x), colnames(y))
467	72x	x[setdiff(all_columns, colnames(x))] <- NA
468	72x	y[setdiff(all_columns, colnames(y))] <- NA
469	72x	rbind(x, y)
470		}
471		)
472		}
473
474		#' Pluralize a word depending on the size of the input
475		#'
476		#' @param x (`object`) to check length for plural.
477		#' @param singular (`character`) singular form of the word.
478		#' @param plural (optional `character`) plural form of the word. If not given an "s"
479		#' is added to the singular form.
480		#'
481		#' @return A `character` that correctly represents the size of the `x` argument.
482		#' @keywords internal
483		pluralize <- function(x, singular, plural = NULL) {
484	70x	checkmate::assert_string(singular)
485	70x	checkmate::assert_string(plural, null.ok = TRUE)
486	70x	if (length(x) == 1L) { # Zero length object should use plural form.
487	42x	singular
488		} else {
489	28x	if (is.null(plural)) {
490	12x	sprintf("%ss", singular)
491		} else {
492	16x	plural
493		}
494		}
495		}
496
497		#' @keywords internal
498		.dropdown_button <- function(id = NULL, label, icon) {
499	!	tags$span(
500	!	class = "teal dropdown-button",
501	!	tags$a(
502	!	id = id,
503	!	class = "action-button",
504	!	role = "button",
505	!	style = "text-decoration: none;",
506	!	bsicons::bs_icon(icon, class = "text-primary"),
507	!	label,
508	!	bsicons::bs_icon("chevron-down", class = "text-primary dropdown-arrow")
509		)
510		)
511		}
512
513		#' @keywords internal
514		.expand_button <- function(id, label, icon) {
515	9x	tags$span(
516	9x	class = "teal expand-button",
517	9x	htmltools::htmlDependency(
518	9x	name = "teal-busy-disable",
519	9x	version = utils::packageVersion("teal"),
520	9x	package = "teal",
521	9x	src = "js",
522	9x	script = "busy-disable.js"
523		),
524	9x	shinyjs::useShinyjs(),
525	9x	tags$button(
526	9x	id = id,
527	9x	class = "action-button teal-busy-disable",
528	9x	role = "button",
529	9x	style = "text-decoration: none;",
530	9x	tags$span(class = "icon", bsicons::bs_icon(icon, class = "text-primary")),
531	9x	tags$span(class = "label", label)
532		)
533		)
534		}
535
536
537		#' @keywords internal
538		.primary_button <- function(id, label, icon = NULL) {
539	!	tags$a(
540	!	id = id,
541	!	class = "teal primary-button action-button",
542	!	role = "button",
543	!	style = "text-decoration: none;",
544	!	if (!is.null(icon)) {
545	!	bsicons::bs_icon(icon, class = "text-primary")
546		},
547	!	label
548		)
549		}

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

1		#' `teal` main module
2		#'
3		#' @description
4		#' Module to create a `teal` app as a Shiny Module.
5		#'
6		#' @details
7		#' This module can be used instead of [init()] in custom Shiny applications. Unlike [init()], it doesn't
8		#' automatically include [`module_session_info`].
9		#'
10		#' Module is responsible for creating the main `shiny` app layout and initializing all the necessary
11		#' components. This module establishes reactive connection between the input `data` and every other
12		#' component in the app. Reactive change of the `data` passed as an argument, reloads the app and
13		#' possibly keeps all input settings the same so the user can continue where one left off.
14		#'
15		#' ## data flow in `teal` application
16		#'
17		#' This module supports multiple data inputs but eventually, they are all converted to `reactive`
18		#' returning `teal_data` in this module. On this `reactive teal_data` object several actions are
19		#' performed:
20		#' - data loading in [`module_init_data`]
21		#' - data filtering in [`module_filter_data`]
22		#' - data transformation in [`module_transform_data`]
23		#'
24		#' ## Fallback on failure
25		#'
26		#' `teal` is designed in such way that app will never crash if the error is introduced in any
27		#' custom `shiny` module provided by app developer (e.g. [teal_data_module()], [teal_transform_module()]).
28		#' If any module returns a failing object, the app will halt the evaluation and display a warning message.
29		#' App user should always have a chance to fix the improper input and continue without restarting the session.
30		#'
31		#' @rdname module_teal
32		#' @name module_teal
33		#'
34		#' @inheritParams init
35		#' @param id (`character(1)`) `shiny` module instance id.
36		#' @param data (`teal_data`, `teal_data_module`, or `reactive` returning `teal_data`)
37		#' The data which application will depend on.
38		#' @param modules (`teal_modules`)
39		#' `teal_modules` object. These are the specific output modules which
40		#' will be displayed in the `teal` application. See [modules()] and [module()] for
41		#' more details.
42		#'
43		#' @return `NULL` invisibly
44		NULL
45
46		#' @rdname module_teal
47		#' @export
48		ui_teal <- function(id, modules) {
49	!	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
50	!	checkmate::assert_class(modules, "teal_modules")
51	!	ns <- NS(id)
52
53	!	mod <- extract_module(modules, class = "teal_module_previewer")
54	!	reporter_opts <- if (length(mod)) .get_reporter_options(mod[[1]]$server_args)
55	!	modules <- drop_module(modules, "teal_module_landing")
56
57		# show busy icon when `shiny` session is busy computing stuff
58		# based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length.
59	!	shiny_busy_message_panel <- conditionalPanel(
60	!	condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
61	!	tags$div(
62	!	icon("arrows-rotate", class = "fa-spin", prefer_type = "solid"),
63	!	"Computing ...",
64	!	style = "position: fixed; bottom: 0; right: 0;
65	!	width: 140px; margin: 15px; padding: 5px 0 5px 10px;
66	!	text-align: left; font-weight: bold; font-size: 100%;
67	!	color: #ffffff; background-color: #347ab7; z-index: 105;"
68		)
69		)
70
71	!	navbar <- ui_teal_module(id = ns("teal_modules"), modules = modules)
72	!	nav_elements <- list(
73	!	withr::with_options(reporter_opts, { # for backwards compatibility of the report_previewer_module$server_args
74	!	tags$div(
75	!	id = ns("reporter_menu_container"),
76	!	.teal_navbar_menu(
77	!	label = "Report",
78	!	icon = "file-text-fill",
79	!	class = "reporter-menu",
80	!	if ("preview" %in% getOption("teal.reporter.nav_buttons")) {
81	!	teal.reporter::preview_report_button_ui(ns("preview_report"), label = "Preview Report")
82		},
83	!	tags$hr(style = "margin: 0.5rem;"),
84	!	if ("download" %in% getOption("teal.reporter.nav_buttons")) {
85	!	teal.reporter::download_report_button_ui(ns("download_report"), label = "Download Report")
86		},
87	!	if ("load" %in% getOption("teal.reporter.nav_buttons")) {
88	!	teal.reporter::report_load_ui(ns("load_report"), label = "Load Report")
89		},
90	!	tags$hr(style = "margin: 0.5rem;"),
91	!	if ("reset" %in% getOption("teal.reporter.nav_buttons")) {
92	!	teal.reporter::reset_report_button_ui(ns("reset_reports"), label = "Reset Report")
93		}
94		)
95		)
96		}),
97	!	tags$span(style = "margin-left: auto;"),
98	!	ui_bookmark_panel(ns("bookmark_manager"), modules),
99	!	ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
100	!	ui_filter_manager_panel(ns("filter_manager_panel"))
101		)
102	!	navbar <- .teal_navbar_append(navbar, nav_elements)
103
104	!	bslib::page_fluid(
105	!	id = id,
106	!	theme = get_teal_bs_theme(),
107	!	include_teal_css_js(),
108	!	shinyjs::useShinyjs(),
109	!	shiny::includeScript(system.file("js/extendShinyJs.js", package = "teal.reporter")),
110	!	shiny_busy_message_panel,
111	!	tags$div(id = ns("tabpanel_wrapper"), class = "teal-body", navbar),
112	!	tags$hr(style = "margin: 1rem 0 0.5rem 0;")
113		)
114		}
115
116		#' @rdname module_teal
117		#' @export
118		srv_teal <- function(id, data, modules, filter = teal_slices(), reporter = teal.reporter::Reporter$new()) {
119	89x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
120	89x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
121	88x	checkmate::assert_class(modules, "teal_modules")
122	88x	checkmate::assert_class(filter, "teal_slices")
123
124	88x	modules <- drop_module(modules, "teal_module_landing")
125
126	88x	moduleServer(id, function(input, output, session) {
127	88x	logger::log_debug("srv_teal initializing.")
128
129	88x	if (getOption("teal.show_js_log", default = FALSE)) {
130	!	shinyjs::showLog()
131		}
132
133		# set timezone in shiny app
134		# timezone is set in the early beginning so it will be available also
135		# for `DDL` and all shiny modules
136	88x	get_client_timezone(session$ns)
137	88x	observeEvent(
138	88x	eventExpr = input$timezone,
139	88x	once = TRUE,
140	88x	handlerExpr = {
141	!	session$userData$timezone <- input$timezone
142	!	logger::log_debug("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
143		}
144		)
145
146	88x	data_handled <- srv_init_data("data", data = data)
147
148	87x	validate_ui <- tags$div(
149	87x	id = session$ns("validate_messages"),
150	87x	class = "teal_validated",
151	87x	ui_check_class_teal_data(session$ns("class_teal_data")),
152	87x	ui_validate_error(session$ns("silent_error")),
153	87x	ui_check_module_datanames(session$ns("datanames_warning"))
154		)
155	87x	srv_check_class_teal_data("class_teal_data", data_handled)
156	87x	srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
157	87x	srv_check_module_datanames("datanames_warning", data_handled, modules)
158
159	87x	data_validated <- .trigger_on_success(data_handled)
160	87x	data_signatured <- reactive({
161	156x	req(inherits(data_validated(), "teal_data"))
162	77x	is_filter_ok <- check_filter_datanames(filter, names(data_validated()))
163	77x	if (!isTRUE(is_filter_ok)) {
164	2x	showNotification(
165	2x	"Some filters were not applied because of incompatibility with data. Contact app developer.",
166	2x	type = "warning",
167	2x	duration = 10
168		)
169	2x	warning(is_filter_ok)
170		}
171	77x	.add_signature_to_data(data_validated())
172		})
173
174	87x	data_load_status <- reactive({
175	82x	if (inherits(data_handled(), "teal_data")) {
176	77x	shinyjs::enable(id = "close_teal_data_module_modal")
177	77x	"ok"
178	5x	} else if (inherits(data, "teal_data_module")) {
179	5x	shinyjs::disable(id = "close_teal_data_module_modal")
180	5x	"teal_data_module failed"
181		} else {
182	!	"external failed"
183		}
184		})
185
186	87x	if (inherits(data, "teal_data_module")) {
187	9x	setBookmarkExclude(c("teal_data_module_ui", "open_teal_data_module_ui"))
188	9x	.teal_navbar_insert_ui(
189	9x	ui = .expand_button(
190	9x	id = session$ns("open_teal_data_module_ui"),
191	9x	label = "Load Data",
192	9x	icon = "database-fill"
193		)
194		)
195	9x	observeEvent(
196	9x	input$open_teal_data_module_ui,
197	9x	ignoreInit = TRUE,
198	9x	ignoreNULL = FALSE, # should be shown on startup
199		{
200	!	showModal(
201	!	div(
202	!	class = "teal teal-data-module-popup",
203	!	modalDialog(
204	!	id = session$ns("teal_data_module_ui"),
205	!	size = "xl",
206	!	tags$div(
207	!	ui_init_data(session$ns("data")),
208	!	validate_ui
209		),
210	!	easyClose = FALSE,
211	!	footer = tags$div(id = session$ns("close_teal_data_module_modal"), modalButton("Dismiss"))
212		)
213		)
214		)
215	!	if (data_load_status() == "ok") {
216	!	shinyjs::enable(id = "close_teal_data_module_modal")
217		} else {
218	!	shinyjs::disable(id = "close_teal_data_module_modal")
219		}
220		}
221		)
222
223	9x	if (isTRUE(attr(data, "once"))) {
224		# when once = TRUE we pull data once and then remove data button and a modal
225	9x	shiny::removeUI(selector = sprintf(".teal.expand-button:has(#%s)", session$ns("open_teal_data_module_ui")))
226	9x	observeEvent(data_signatured(), once = TRUE, {
227	4x	logger::log_debug("srv_teal@2 removing data tab.")
228	4x	shiny::removeModal()
229		})
230		}
231		} else {
232		# when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)
233	78x	insertUI(
234	78x	selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
235	78x	where = "beforeBegin",
236	78x	ui = tags$div(validate_ui)
237		)
238		}
239
240		# Wait for UI to be rendered before showing/hiding reporter UI elements
241		# See: https://github.com/rstudio/shiny/issues/3348
242	87x	observeEvent(
243	87x	once = TRUE,
244	87x	ignoreInit = TRUE,
245	87x	reactiveValuesToList(session$input),
246		{
247	20x	if (!is.null(reporter)) {
248	20x	reporter$set_id(attr(filter, "app_id"))
249	20x	teal.reporter::preview_report_button_srv("preview_report", reporter)
250	20x	teal.reporter::report_load_srv("load_report", reporter)
251	20x	teal.reporter::download_report_button_srv(id = "download_report", reporter = reporter)
252	20x	teal.reporter::reset_report_button_srv("reset_reports", reporter)
253		} else {
254	!	removeUI(selector = sprintf("#%s", session$ns("reporter_menu_container")))
255		}
256		}
257		)
258
259	87x	datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
260	76x	eventReactive(data_signatured(), {
261	68x	req(inherits(data_signatured(), "teal_data"))
262	68x	logger::log_debug("srv_teal@1 initializing FilteredData")
263	68x	teal_data_to_filtered_data(data_signatured())
264		})
265		}
266	87x	module_labels <- unlist(modules_slot(modules, "label"), use.names = FALSE)
267	87x	slices_global <- methods::new(".slicesGlobal", filter, module_labels)
268
269	87x	modules_output <- srv_teal_module(
270	87x	"teal_modules",
271	87x	data = data_signatured,
272	87x	modules = modules,
273	87x	datasets = datasets_rv,
274	87x	slices_global = slices_global,
275	87x	reporter = reporter,
276	87x	data_load_status = data_load_status
277		)
278
279	87x	mapping_table <- srv_filter_manager_panel("filter_manager_panel", slices_global = slices_global)
280	87x	snapshots <- srv_snapshot_manager_panel("snapshot_manager_panel", slices_global = slices_global)
281	87x	srv_bookmark_panel("bookmark_manager", modules)
282		})
283
284	87x	invisible(NULL)
285		}

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

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

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

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

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

1		#' Data summary
2		#' @description
3		#' Module and its utils to display the number of rows and subjects in the filtered and unfiltered data.
4		#'
5		#' @details Handling different data classes:
6		#' `get_filter_overview()` is a pseudo S3 method which has variants for:
7		#' - `array` (`data.frame`, `DataFrame`, `array`, `Matrix` and `SummarizedExperiment`): Method variant
8		#' can be applied to any two-dimensional objects on which [ncol()] can be used.
9		#' - `MultiAssayExperiment`: for which summary contains counts for `colData` and all `experiments`.
10		#' - For other data types module displays data name with warning icon and no more details.
11		#'
12		#' Module includes also "Show/Hide unsupported" button to toggle rows of the summary table
13		#' containing datasets where number of observations are not calculated.
14		#'
15		#' @inheritParams module_teal_module
16		#'
17		#' @name module_data_summary
18		#' @rdname module_data_summary
19		#' @keywords internal
20		#' @return `NULL`.
21		NULL
22
23		#' @rdname module_data_summary
24		ui_data_summary <- function(id) {
25	!	ns <- NS(id)
26	!	tableOutput(ns("table"))
27		}
28
29		#' @rdname module_data_summary
30		srv_data_summary <- function(id, data) {
31	87x	assert_reactive(data)
32	87x	moduleServer(
33	87x	id = id,
34	87x	function(input, output, session) {
35	87x	logger::log_debug("srv_data_summary initializing")
36
37	87x	summary_table <- reactive({
38	106x	req(inherits(data(), "teal_data"))
39	89x	if (!length(data())) {
40	!	return(NULL)
41		}
42	89x	get_filter_overview_wrapper(data)
43		})
44
45	87x	output$table <- renderUI({
46	106x	summary_table_out <- try(summary_table(), silent = TRUE)
47	106x	if (inherits(summary_table_out, "try-error")) {
48		# Ignore silent shiny error
49	17x	if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
50	!	stop("Error occurred during data processing. See details in the main panel.")
51		}
52	89x	} else if (is.null(summary_table_out)) {
53	2x	"no datasets to show"
54		} else {
55	87x	is_unsupported <- apply(summary_table(), 1, function(x) all(is.na(x[-1])))
56	87x	summary_table_out[is.na(summary_table_out)] <- ""
57	87x	body_html <- apply(
58	87x	summary_table_out,
59	87x	1,
60	87x	function(x) {
61	163x	is_supported <- !all(x[-1] == "")
62	163x	if (is_supported) {
63	154x	tags$tr(
64	154x	tagList(
65	154x	tags$td(x[1]),
66	154x	lapply(x[-1], tags$td)
67		)
68		)
69		}
70		}
71		)
72
73	87x	header_labels <- tools::toTitleCase(names(summary_table_out))
74	87x	header_labels[header_labels == "Dataname"] <- "Data Name"
75	87x	header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))
76
77	87x	table_html <- tags$table(
78	87x	class = "table custom-table",
79	87x	tags$thead(header_html),
80	87x	tags$tbody(body_html)
81		)
82	87x	div(
83	87x	table_html,
84	87x	if (any(is_unsupported)) {
85	9x	p(
86	9x	class = c("pull-right", "float-right", "text-secondary"),
87	9x	style = "font-size: 0.8em;",
88	9x	sprintf("And %s more unfilterable object(s)", sum(is_unsupported)),
89	9x	bslib::tooltip(
90	9x	trigger = icon(name = "far fa-circle-question"),
91	9x	options = list(trigger = "hover"),
92	9x	paste(
93	9x	sep = "",
94	9x	collapse = "\n",
95	9x	shQuote(summary_table()[is_unsupported, "dataname"]),
96		" (",
97	9x	vapply(
98	9x	summary_table()[is_unsupported, "dataname"],
99	9x	function(x) class(data()[[x]])[1],
100	9x	character(1L)
101		),
102		")"
103		)
104		)
105		)
106		}
107		)
108		}
109		})
110
111	87x	NULL
112		}
113		)
114		}
115
116		#' @rdname module_data_summary
117		get_filter_overview_wrapper <- function(teal_data) {
118		# Sort datanames in topological order
119	89x	datanames <- names(teal_data())
120	89x	joinkeys <- teal.data::join_keys(teal_data())
121
122	89x	current_data_objs <- sapply(
123	89x	datanames,
124	89x	function(name) teal_data()[[name]],
125	89x	simplify = FALSE
126		)
127	89x	initial_data_objs <- teal_data()[[".raw_data"]]
128
129	89x	out <- lapply(
130	89x	datanames,
131	89x	function(dataname) {
132	158x	parent <- teal.data::parent(joinkeys, dataname)
133	158x	subject_keys <- if (length(parent) > 0) {
134	8x	names(joinkeys[dataname, parent])
135		} else {
136	150x	joinkeys[dataname, dataname]
137		}
138	158x	get_filter_overview(
139	158x	current_data = current_data_objs[[dataname]],
140	158x	initial_data = initial_data_objs[[dataname]],
141	158x	dataname = dataname,
142	158x	subject_keys = subject_keys
143		)
144		}
145		)
146
147	89x	do.call(.smart_rbind, out)
148		}
149
150
151		#' @rdname module_data_summary
152		#' @param current_data (`object`) current object (after filtering and transforming).
153		#' @param initial_data (`object`) initial object.
154		#' @param dataname (`character(1)`)
155		#' @param subject_keys (`character`) names of the columns which determine a single unique subjects
156		get_filter_overview <- function(current_data, initial_data, dataname, subject_keys) {
157	163x	if (inherits(current_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
158	153x	get_filter_overview_array(current_data, initial_data, dataname, subject_keys)
159	10x	} else if (inherits(current_data, "MultiAssayExperiment")) {
160	1x	get_filter_overview_MultiAssayExperiment(current_data, initial_data, dataname)
161		} else {
162	9x	data.frame(dataname = dataname)
163		}
164		}
165
166		#' @rdname module_data_summary
167		get_filter_overview_array <- function(current_data,
168		initial_data,
169		dataname,
170		subject_keys) {
171	153x	if (length(subject_keys) == 0) {
172	139x	data.frame(
173	139x	dataname = dataname,
174	139x	obs = if (!is.null(initial_data)) {
175	128x	sprintf("%s/%s", nrow(current_data), nrow(initial_data))
176		} else {
177	11x	nrow(current_data)
178		}
179		)
180		} else {
181	14x	data.frame(
182	14x	dataname = dataname,
183	14x	obs = if (!is.null(initial_data)) {
184	13x	sprintf("%s/%s", nrow(current_data), nrow(initial_data))
185		} else {
186	1x	nrow(current_data)
187		},
188	14x	subjects = if (!is.null(initial_data)) {
189	13x	sprintf("%s/%s", nrow(unique(current_data[subject_keys])), nrow(unique(initial_data[subject_keys])))
190		} else {
191	1x	nrow(unique(current_data[subject_keys]))
192		}
193		)
194		}
195		}
196
197		#' @rdname module_data_summary
198		get_filter_overview_MultiAssayExperiment <- function(current_data, # nolint: object_length, object_name.
199		initial_data,
200		dataname) {
201	1x	experiment_names <- names(current_data)
202	1x	mae_info <- data.frame(
203	1x	dataname = dataname,
204	1x	subjects = if (!is.null(initial_data)) {
205	!	sprintf("%s/%s", nrow(current_data@colData), nrow(initial_data@colData))
206		} else {
207	1x	nrow(current_data@colData)
208		}
209		)
210
211	1x	experiment_obs_info <- do.call("rbind", lapply(
212	1x	experiment_names,
213	1x	function(experiment_name) {
214	5x	transform(
215	5x	get_filter_overview(
216	5x	current_data[[experiment_name]],
217	5x	initial_data[[experiment_name]],
218	5x	dataname = experiment_name,
219	5x	subject_keys = join_keys() # empty join keys
220		),
221	5x	dataname = paste0(" - ", experiment_name)
222		)
223		}
224		))
225
226	1x	get_experiment_keys <- function(mae, experiment) {
227	5x	sample_subset <- mae@sampleMap[mae@sampleMap$colname %in% colnames(experiment), ]
228	5x	length(unique(sample_subset$primary))
229		}
230
231	1x	experiment_subjects_info <- do.call("rbind", lapply(
232	1x	experiment_names,
233	1x	function(experiment_name) {
234	5x	data.frame(
235	5x	subjects = if (!is.null(initial_data)) {
236	!	sprintf(
237	!	"%s/%s",
238	!	get_experiment_keys(current_data, current_data[[experiment_name]]),
239	!	get_experiment_keys(current_data, initial_data[[experiment_name]])
240		)
241		} else {
242	5x	get_experiment_keys(current_data, current_data[[experiment_name]])
243		}
244		)
245		}
246		))
247
248	1x	experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)
249	1x	.smart_rbind(mae_info, experiment_info)
250		}

1		#' Executes modifications to the result of a module
2		#'
3		#' Primarily used to modify the output object of module to change the containing
4		#' report.
5		#' @param x (`teal_module`)
6		#' @param ui (`function(id, elem, ...)`) function to receive output (`shiny.tag`) from `x$ui`
7		#' @param server (`function(input, output, session, data, ...)`) function to receive output data from `x$server`
8		#' @param ... additional argument passed to `ui` and `server` by matching their formals names.
9		#' @return A `teal_report` object with the result of the server function.
10		#' @export
11		after <- function(x,
12		ui = function(id, elem) elem,
13		server = function(input, output, session, data) data,
14		...) {
15		# todo: make a method for teal_app and remove teal_extend_server?
16	!	checkmate::assert_multi_class(x, "teal_module")
17	!	if (!is.function(ui) \|\| !all(names(formals(ui)) %in% c("id", "elem"))) {
18	!	stop("ui should be a function of id and elem")
19		}
20	!	if (!is.function(server) \|\| !all(names(formals(server)) %in% c("input", "output", "session", "data"))) {
21	!	stop("server should be a function of `input` and `output`, `session`, `data`")
22		}
23
24	!	additional_args <- list(...)
25	!	new_x <- x # because overwriting x$ui/server will cause infinite recursion
26	!	new_x$ui <- .after_ui(x$ui, ui, additional_args)
27	!	new_x$server <- .after_server(x$server, server, additional_args)
28	!	new_x
29		}
30
31		.after_ui <- function(x, y, additional_args) {
32		# add `_`-prefix to make sure objects are not masked in the wrapper functions
33	!	`_x` <- x # nolint: object_name.
34	!	`_y` <- y # nolint: object_name.
35	!	new_x <- function(id, ...) {
36	!	original_args <- as.list(environment())
37	!	if ("..." %in% names(formals(`_x`))) {
38	!	original_args <- c(original_args, list(...))
39		}
40	!	ns <- NS(id)
41	!	original_args$id <- ns("wrapped")
42	!	original_out <- do.call(`_x`, original_args, quote = TRUE)
43
44	!	wrapper_args <- c(
45	!	additional_args,
46	!	list(id = ns("wrapper"), elem = original_out)
47		)
48	!	do.call(`_y`, args = wrapper_args[names(formals(`_y`))])
49		}
50	!	formals(new_x) <- formals(x)
51	!	new_x
52		}
53
54		.after_server <- function(x, y, additional_args) {
55		# add `_`-prefix to make sure objects are not masked in the wrapper functions
56	!	`_x` <- x # nolint: object_name.
57	!	`_y` <- y # nolint: object_name.
58	!	new_x <- function(id, ...) {
59	!	original_args <- as.list(environment())
60	!	original_args$id <- "wrapped"
61	!	if ("..." %in% names(formals(`_x`))) {
62	!	original_args <- c(original_args, list(...))
63		}
64	!	moduleServer(id, function(input, output, session) {
65	!	original_out <- if (all(c("input", "output", "session") %in% names(formals(`_x`)))) {
66	!	original_args$module <- `_x`
67	!	do.call(shiny::callModule, args = original_args)
68		} else {
69	!	do.call(`_x`, original_args)
70		}
71	!	original_out_r <- reactive(
72	!	if (is.reactive(original_out)) {
73	!	original_out()
74		} else {
75	!	original_out
76		}
77		)
78	!	wrapper_args <- utils::modifyList(
79	!	additional_args,
80	!	list(id = "wrapper", input = input, output = output, session = session)
81		)
82	!	reactive({
83	!	req(original_out_r())
84	!	wrapper_args$data <- original_out()
85	!	do.call(`_y`, wrapper_args[names(formals(`_y`))], quote = TRUE)
86		})
87		})
88		}
89	!	formals(new_x) <- formals(x)
90	!	new_x
91		}

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

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

1		#' Create a `teal` module for previewing a report
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#'
5		#' This function controls the appearance of the drop-down menu for the reporter.
6		#' It is now deprecated in favor of the options:
7		#' - `teal.reporter.nav_buttons = c("preview", "download", "load", "reset")` to control which
8		#' buttons will be displayed in the drop-down.
9		#' - `teal.reporter.rmd_output`: passed to [teal.reporter::download_report_button_srv()]
10		#' - `teal.reporter.rmd_yaml_args`: passed to [teal.reporter::download_report_button_srv()]
11		#' - `teal.reporter.global_knitr`: passed to [teal.reporter::download_report_button_srv()]
12		#'
13		#' @inheritParams teal_modules
14		#' @param server_args (named `list`) Arguments will overwrite the default `teal.reporter` options
15		#' described in the description.
16		#'
17		#' @return
18		#' `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer functionality.
19		#'
20		#' @export
21		reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
22	!	checkmate::assert_string(label)
23	!	checkmate::assert_list(server_args, names = "named")
24	!	checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))
25
26	!	lifecycle::deprecate_soft(
27	!	when = "1.0.0",
28	!	what = "reporter_previewer_module()",
29	!	details = paste(
30	!	"Please use `options()` to customize the reporter options:\n",
31	!	"`teal.reporter.nav_buttons` to control which buttons will be displayed in the 'Report' drop-down.\n",
32	!	"`teal.reporter.rmd_output` to customize the R Markdown outputs types for the report.\n",
33	!	"`teal.reporter.rmd_yaml_args` to customize the widget inputs in the download report modal.\n",
34	!	"`teal.reporter.global_knitr` to customize the global knitr options for the report."
35		)
36		)
37
38	!	message("Initializing reporter_previewer_module")
39
40	!	srv <- function(id, reporter, ...) {
41	!	teal.reporter::reporter_previewer_srv(id, reporter, ...)
42		}
43
44	!	ui <- function(id, ...) {
45	!	teal.reporter::reporter_previewer_ui(id, ...)
46		}
47
48	!	module <- module(
49	!	label = "temporary label",
50	!	server = srv, ui = ui,
51	!	server_args = server_args, ui_args = list(), datanames = NULL
52		)
53		# Module is created with a placeholder label and path and both are changed later.
54		# This is to prevent another module being labeled "Report previewer".
55	!	class(module) <- c(class(module), "teal_module_previewer")
56	!	module$label <- label
57	!	module$path <- label
58	!	attr(module, "teal_bookmarkable") <- TRUE
59	!	module
60		}
61
62		#' Temporary function to handle server_args of the report_previewer_module before its hard
63		#' deprecation.
64		#' @param args (`list`)
65		#'
66		#' @keywords internal
67		.get_reporter_options <- function(args) {
68	!	opts <- list()
69	!	if (length(args$previewer_buttons)) {
70	!	opts <- c(opts, list(teal.reporter.nav_buttons = args$previewer_buttons))
71		}
72
73	!	if (length(args$global_knitr)) {
74	!	opts <- c(opts, list(teal.reporter.global_knitr = args$global_knitr))
75		}
76
77	!	if (length(args$rmd_output)) {
78	!	opts <- c(opts, list(teal.reporter.rmd_output = args$rmd_output))
79		}
80
81	!	if (length(args$rmd_yaml_args)) {
82	!	opts <- c(opts, list(teal.reporter.rmd_yaml_args = args$rmd_yaml_args))
83		}
84
85	!	opts
86		}

1		#' Replace UI Elements in `teal` UI objects
2		#'
3		#' @param x (`teal_app`) A `teal_app` object created using the `init` function.
4		#' @param element Replacement UI element (shiny tag or HTML)
5		#' @param title (`shiny.tag` or `character(1)`) The new title to be used.
6		#' @param favicon (`character`) The path for the icon for the title.
7		#' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/`.
8		#' If the favicon is `NULL` the `teal` logo will be used as the favicon.
9		#' @name teal_modifiers
10		#' @rdname teal_modifiers
11		#'
12		#' @keywords internal
13		#'
14		NULL
15
16
17		#' @rdname teal_modifiers
18		#' @keywords internal
19		#' @noRd
20		#' @param x One of:
21		#' - A `teal_app` object created using the `init` function.
22		#' - A `teal_module`, `teal_data_module`, or `teal_transform_module` object.
23		#' - A Shiny module UI function with `id` parameter
24		#' @param selector (`character(1)`) CSS selector to find elements to replace
25		teal_replace_ui <- function(x, selector, element) {
26	!	if (inherits(x, c("teal_app", "teal_module", "teal_data_module", "teal_transform_module"))) {
27	!	x$ui <- teal_replace_ui(x$ui, selector, element)
28	!	x
29	!	} else if (checkmate::test_function(x, args = "request")) {
30		# shiny ui function from teal_app
31	!	function(request) {
32	!	ui_tq <- htmltools::tagQuery(x(request = request))
33	!	ui_tq$find(selector)$empty()$append(element)$allTags()
34		}
35	!	} else if (checkmate::test_function(x, args = "id")) {
36		# shiny module ui function
37	!	function(id, ...) {
38	!	ui_tq <- htmltools::tagQuery(x(id = id, ...))
39	!	if (grepl("^#[a-zA-Z0-9_-]+$", selector)) {
40	!	selector <- paste0("#", NS(id, gsub("^#", "", selector)))
41		}
42	!	ui_tq$find(selector)$empty()$append(element)$allTags()
43		}
44		} else {
45	!	stop("Invalid UI object")
46		}
47		}
48
49		#' @rdname teal_modifiers
50		#' @export
51		#'
52		#' @examplesShinylive
53		#' library(teal)
54		#' interactive <- function() TRUE
55		#' {{ next_example }}
56		#' @examples
57		#' app <- init(
58		#' data = teal_data(IRIS = iris, MTCARS = mtcars),
59		#' modules = modules(example_module())
60		#' ) \|>
61		#' modify_title(title = "Custom title")
62		#'
63		#' if (interactive()) {
64		#' shinyApp(app$ui, app$server)
65		#' }
66		modify_title <- function(
67		x,
68		title = "teal app",
69		favicon = NULL) {
70	!	checkmate::assert_multi_class(x, "teal_app")
71	!	checkmate::assert_multi_class(title, c("shiny.tag", "shiny.tag.list", "html", "character"))
72	!	checkmate::assert_string(favicon, null.ok = TRUE)
73	!	if (is.null(favicon)) {
74	!	favicon <- .teal_favicon
75		}
76	!	teal_replace_ui(
77	!	x,
78	!	"#teal-app-title",
79	!	tags$head(
80	!	tags$title(title),
81	!	tags$link(
82	!	rel = "icon",
83	!	href = favicon,
84	!	sizes = "any"
85		)
86		)
87		)
88		}
89
90		#' @rdname teal_modifiers
91		#' @export
92		#'
93		#' @examplesShinylive
94		#' library(teal)
95		#' interactive <- function() TRUE
96		#' {{ next_example }}
97		#' @examples
98		#' app <- init(
99		#' data = teal_data(IRIS = iris),
100		#' modules = modules(example_module())
101		#' ) \|>
102		#' modify_header(element = tags$div(h3("Custom header")))
103		#'
104		#' if (interactive()) {
105		#' shinyApp(app$ui, app$server)
106		#' }
107		modify_header <- function(x, element = tags$p()) {
108	!	checkmate::assert_multi_class(x, "teal_app")
109	!	checkmate::assert_multi_class(element, c("shiny.tag", "shiny.tag.list", "html", "character"))
110	!	teal_replace_ui(x, "#teal-header-content", element)
111		}
112
113		#' @rdname teal_modifiers
114		#' @export
115		#'
116		#' @examplesShinylive
117		#' library(teal)
118		#' interactive <- function() TRUE
119		#' {{ next_example }}
120		#' @examples
121		#' app <- init(
122		#' data = teal_data(IRIS = iris),
123		#' modules = modules(example_module())
124		#' ) \|>
125		#' modify_footer(element = "Custom footer")
126		#'
127		#' if (interactive()) {
128		#' shinyApp(app$ui, app$server)
129		#' }
130		modify_footer <- function(x, element = tags$p()) {
131	!	checkmate::assert_multi_class(x, "teal_app")
132	!	checkmate::assert_multi_class(element, c("shiny.tag", "shiny.tag.list", "html", "character"))
133	!	teal_replace_ui(x, "#teal-footer-content", element)
134		}
135
136		#' Add a Landing Popup to `teal` Application
137		#'
138		#' @description Adds a landing popup to the `teal` app. This popup will be shown when the app starts.
139		#' The dialog must be closed by the app user to proceed to the main application.
140		#'
141		#' @param x (`teal_app`) A `teal_app` object created using the `init` function.
142		#' @inheritParams shiny::modalDialog
143		#' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup.
144		#' @param ... Additional arguments to [shiny::modalDialog()].
145		#' @export
146		#'
147		#' @examplesShinylive
148		#' library(teal)
149		#' interactive <- function() TRUE
150		#' {{ next_example }}
151		#' @examples
152		#' app <- init(
153		#' data = teal_data(IRIS = iris, MTCARS = mtcars),
154		#' modules = modules(example_module())
155		#' ) \|>
156		#' add_landing_modal(
157		#' title = "Welcome",
158		#' content = "This is a landing popup.",
159		#' buttons = modalButton("Accept")
160		#' )
161		#'
162		#' if (interactive()) {
163		#' shinyApp(app$ui, app$server)
164		#' }
165		add_landing_modal <- function(
166		x,
167		title = NULL,
168		content = NULL,
169		footer = modalButton("Accept"),
170		...) {
171	!	checkmate::assert_class(x, "teal_app")
172	!	custom_server <- function(input, output, session) {
173	!	checkmate::assert_string(title, null.ok = TRUE)
174	!	checkmate::assert_multi_class(
175	!	content,
176	!	classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
177		)
178	!	checkmate::assert_multi_class(footer, classes = c("shiny.tag", "shiny.tag.list"))
179	!	showModal(
180	!	modalDialog(
181	!	id = "landingpopup",
182	!	title = title,
183	!	content,
184	!	footer = footer,
185		...
186		)
187		)
188		}
189	!	teal_extend_server(x, custom_server)
190		}
191
192		#' Add a Custom Server Logic to `teal` Application
193		#'
194		#' @description Adds a custom server function to the `teal` app. This function can define additional server logic.
195		#'
196		#' @param x (`teal_app`) A `teal_app` object created using the `init` function.
197		#' @param custom_server (`function(input, output, session)` or `function(id, ...)`)
198		#' The custom server function or server module to set.
199		#' @param module_id (`character(1)`) The ID of the module when a module server function is passed.
200		#' @keywords internal
201		teal_extend_server <- function(x, custom_server, module_id = character(0)) {
202	!	checkmate::assert_class(x, "teal_app")
203	!	checkmate::assert_function(custom_server)
204	!	old_server <- x$server
205
206	!	x$server <- function(input, output, session) {
207	!	old_server(input, output, session)
208	!	if (all(c("input", "output", "session") %in% names(formals(custom_server)))) {
209	!	callModule(custom_server, module_id)
210	!	} else if ("id" %in% names(formals(custom_server))) {
211	!	custom_server(module_id)
212		}
213		}
214	!	x
215		}

1		#' UI and server modules of `teal`
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#' Please use [`module_teal`] instead.
5		#'
6		#' @inheritParams ui_teal
7		#' @inheritParams srv_teal
8		#' @inheritParams init
9		#'
10		#' @return
11		#' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not.
12		#' @name module_teal_with_splash
13		#'
14		NULL
15
16		#' @export
17		#' @rdname module_teal_with_splash
18		ui_teal_with_splash <- function(id,
19		data,
20		modules,
21		title = build_app_title(),
22		header = tags$p(),
23		footer = tags$p()) {
24	!	lifecycle::deprecate_soft(
25	!	when = "0.16.0",
26	!	what = "ui_teal_with_splash()",
27	!	details = "Please use `?ui_teal` instead"
28		)
29	!	ns <- shiny::NS(id)
30	!	fluidPage(
31	!	title = tags$div(
32	!	id = ns("teal-app-title"),
33	!	tags$head(
34	!	tags$title("teal app"),
35	!	tags$link(
36	!	rel = "icon",
37	!	href = .teal_favicon,
38	!	sizes = "any"
39		)
40		)
41		),
42	!	tags$header(id = ns("teal-header-content")),
43	!	ui_teal(id = id, modules = modules),
44	!	tags$footer(
45	!	id = "teal-footer",
46	!	tags$div(id = "teal-footer-content"),
47	!	ui_session_info(ns("teal-footer-session_info"))
48		)
49		)
50		}
51
52		#' @export
53		#' @rdname module_teal_with_splash
54		srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
55	!	lifecycle::deprecate_soft(
56	!	when = "0.16.0",
57	!	what = "srv_teal_with_splash()",
58	!	details = "Deprecated, please use `?srv_teal` instead"
59		)
60	!	srv_teal(id = id, data = data, modules = modules, filter = filter)
61	!	srv_session_info("teal-footer-session_info")
62		}

1		#' @title `TealReportCard`
2		#' @description `r lifecycle::badge("experimental")`
3		#' Child class of [`teal.reporter::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		#' @importFrom methods as
9		#'
10		TealReportCard <- R6::R6Class( # nolint: object_name.
11		classname = "TealReportCard",
12		inherit = teal.reporter::ReportCard,
13		public = list(
14		#' @description Appends the source code to the `content` meta data of this `TealReportCard`.
15		#'
16		#' @param src (`character(1)`) code as text.
17		#' @param ... any `rmarkdown` `R` chunk parameter and its value.
18		#' But `eval` parameter is always set to `FALSE`.
19		#' @return Object of class `TealReportCard`, invisibly.
20		#' @examples
21		#' card <- TealReportCard$new()$append_src(
22		#' "plot(iris)"
23		#' )
24		#' card$get_content()[[1]]
25		append_src = function(src, ...) {
26	4x	super$append_rcode(text = src, ...)
27		},
28		#' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.
29		#' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses
30		#' the default `yaml::as.yaml` to format the list.
31		#' If the filter state list is empty, nothing is appended to the `content`.
32		#'
33		#' @param fs (`teal_slices`) object returned from [teal_slices()] function.
34		#' @return `self`, invisibly.
35		append_fs = function(fs) {
36	5x	checkmate::assert_class(fs, "teal_slices")
37	4x	if (length(fs) > 0) {
38	3x	self$append_content(teal.reporter::code_chunk(.teal_slice_to_yaml(fs), eval = FALSE, lang = "verbatim"))
39		}
40	4x	invisible(self)
41		},
42		#' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.
43		#'
44		#' @param encodings (`list`) list of encodings selections of the `teal` app.
45		#' @return `self`, invisibly.
46		#' @examples
47		#' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))
48		#' card$get_content()[[1]]
49		#'
50		append_encodings = function(encodings) {
51	4x	checkmate::assert_list(encodings)
52	4x	self$append_text("Selected Options", "header3")
53	4x	if (requireNamespace("yaml", quietly = TRUE)) {
54	4x	self$append_text(yaml::as.yaml(encodings, handlers = list(
55	4x	POSIXct = function(x) format(x, "%Y-%m-%d"),
56	4x	POSIXlt = function(x) format(x, "%Y-%m-%d"),
57	4x	Date = function(x) format(x, "%Y-%m-%d")
58	4x	)), "verbatim")
59		} else {
60	!	stop("yaml package is required to format the encodings list")
61		}
62	4x	self$append_metadata("Encodings", encodings)
63	4x	invisible(self)
64		}
65		)
66		)
67
68		.teal_slice_to_yaml <- function(fs) {
69	3x	checkmate::assert_class(fs, "teal_slices")
70	3x	states_list <- lapply(fs, function(x) {
71	3x	x_list <- shiny::isolate(as.list(x))
72	3x	if (
73	3x	inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
74	3x	length(x_list$choices) == 2 &&
75	3x	length(x_list$selected) == 2
76		) {
77	!	x_list$range <- paste(x_list$selected, collapse = " - ")
78	!	x_list["selected"] <- NULL
79		}
80	3x	if (!is.null(x_list$arg)) {
81	!	x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"
82		}
83
84	3x	x_list <- x_list[
85	3x	c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
86		]
87	3x	names(x_list) <- c(
88	3x	"Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",
89	3x	"Selected Values", "Selected range", "Include NA values", "Include Inf values"
90		)
91
92	3x	Filter(Negate(is.null), x_list)
93		})
94
95	3x	if (requireNamespace("yaml", quietly = TRUE)) {
96	3x	yaml::as.yaml(states_list)
97		} else {
98	!	stop("yaml package is required to format the filter state list")
99		}
100		}
101
102		#' @noRd
103	!	ui_add_reporter <- function(id) uiOutput(NS(id, "reporter_add_container"))
104
105		#' @noRd
106		srv_add_reporter <- function(id, module_out, reporter) {
107	81x	if (is.null(reporter)) {
108	!	return(FALSE)
109		} # early exit
110	81x	moduleServer(id, function(input, output, session) {
111	81x	mod_out_r <- reactive({
112	91x	req(module_out)
113	87x	if (is.reactive(module_out)) {
114	75x	module_out()
115		}
116		})
117
118	81x	doc_out <- reactive({
119	91x	req(mod_out_r())
120	70x	teal_data_handled <- tryCatch(mod_out_r(), error = function(e) e)
121	70x	tcard <- if (inherits(teal_data_handled, "teal_report")) {
122	70x	teal.reporter::teal_card(teal_data_handled)
123	70x	} else if (inherits(teal_data_handled, "teal_data")) {
124	!	teal.reporter::teal_card(as(teal_data_handled, "teal_report"))
125	70x	} else if (inherits(teal_data_handled, "teal_card")) {
126	!	teal_data_handled
127		}
128
129	70x	if (length(tcard)) .collapse_subsequent_chunks(tcard)
130		})
131
132	81x	.call_once_when(!is.null(doc_out()) && !is.null(reporter), {
133	63x	output$reporter_add_container <- renderUI({
134	63x	tags$div(
135	63x	class = "teal add-reporter-container",
136	63x	teal.reporter::add_card_button_ui(session$ns("reporter_add"), label = "Add to Report")
137		)
138		})
139	63x	teal.reporter::add_card_button_srv("reporter_add", reporter = reporter, card_fun = doc_out)
140		})
141
142
143
144	81x	observeEvent(doc_out(), ignoreNULL = FALSE, {
145	70x	shinyjs::toggleState("reporter_add_container", condition = inherits(doc_out(), "teal_card"))
146		})
147		})
148		}
149
150		#' Disable the report for a `teal_module`
151		#'
152		#' Convenience function that disables the user's ability to add the module
153		#' to the report previewer.
154		#' @param x (`teal_module`) a `teal_module` object.
155		#' @return `NULL` that indicates that it should disable the reporter functionality.
156		#' @export
157		#' @examples
158		#' app <- init(
159		#' data = within(teal_data(), iris <- iris),
160		#' modules = modules(
161		#' example_module(label = "example teal module") \|> disable_report()
162		#' )
163		#' )
164		#' if (interactive()) {
165		#' shinyApp(app$ui, app$server)
166		#' }
167		disable_report <- function(x) {
168	!	checkmate::assert_class(x, "teal_module")
169	!	after(x, server = function(data) {
170	!	teal.reporter::teal_card(data) <- teal.reporter::teal_card()
171	!	NULL
172		})
173		}

1		#' Calls all `modules`
2		#'
3		#' Modules create navigation bar with drop-down menu and tab content. Each `teal_module` is called recursively
4		#' according to the structure of `modules` argument. This is a custom module which utilizes shiny/Bootstrap
5		#' `.nav` class. `modules` are called with an `id` derived from `teal_module`'s label and labels of its
6		#' ancestors (if any).
7		#'
8		#' ### Functions
9		#'
10		#' - `ui/srv_teal_module` - wrapper module which links drop-down buttons with modules panels.
11		#' Here `input$active_module_id` is instantiated.
12		#' - `.ui/srv_teal_module` - recursive S3 method which calls each module
13		#' - `.teal_navbar_append` - wrapper for [htmltools::tagAppendChild()] to add any element to navigation bar.
14		#' - `.teal_navbar_insert_ui` - wrapper for [shiny::insertUI()] to insert any element to navigation bar.
15		#' - `.teal_navbar_menu` - UI function to create a drop-down menu for navigation bar.
16		#'
17		#' ### Utilizing `.nav` class
18		#'
19		#' No extra `javascript` or server functionality were introduced to have navigation buttons toggle between
20		#' tab panels. This works thanks to `.nav` container which links `.nav-link` buttons `href = #<module id>`
21		#' attribute with `.tab-pane`'s `id = <module id>` (see ``.ui_teal_module.teal_module`).
22		#'
23		#' ### Initialization and isolation of the `teal_module`(s)
24		#'
25		#' Modules are initialized only when they are active. This speeds up app initialization and on
26		#' startup only the first module is activated and its outputs are calculated.
27		#' Only the active module is listening to reactive events. This way, modules are isolated and only
28		#' one can run at any given time. This makes the app more efficient by reducing unnecessary
29		#' computations on server side.
30		#'
31		#' @name module_teal_module
32		#'
33		#' @inheritParams module_teal
34		#'
35		#' @param data (`reactive` returning `teal_data`)
36		#'
37		#' @param slices_global (`reactiveVal` returning `modules_teal_slices`)
38		#' see [`module_filter_manager`]
39		#'
40		#' @param datasets (`reactive` returning `FilteredData` or `NULL`)
41		#' When `datasets` is passed from the parent module (`srv_teal`) then `dataset` is a singleton
42		#' which implies the filter-panel to be "global". When `NULL` then filter-panel is "module-specific".
43		#'
44		#' @param reporter (`Reporter`, singleton)
45		#' Stores reporter-cards appended in the server of `teal_module`.
46		#'
47		#' @param data_load_status (`reactive` returning `character(1)`)
48		#' Determines action dependent on a data loading status:
49		#' - `"ok"` when `teal_data` is returned from the data loading.
50		#' - `"teal_data_module failed"` when [teal_data_module()] didn't return `teal_data`. Disables tab buttons.
51		#' - `"external failed"` when a `reactive` passed to `srv_teal(data)` didn't return `teal_data`. Hides the whole tab
52		#' panel.
53		#'
54		#' @param active_module_id (`reactive` returning `character(1)`)
55		#' `id` of the currently active module. This helps to determine which module can listen to reactive events.
56		#'
57		#' @return
58		#' Output of currently active module.
59		#' - `srv_teal_module.teal_module` returns `reactiveVal` containing output of the called module.
60		#' - `srv_teal_module.teal_modules` returns output of modules in a list following the hierarchy of `modules`
61		#'
62		#' @keywords internal
63		NULL
64
65
66		#' @rdname module_teal_module
67		ui_teal_module <- function(id, modules) {
68	!	ns <- NS(id)
69	!	active_module_id <- restoreInput(
70	!	ns("active_module_id"),
71	!	unlist(modules_slot(modules, "path"), use.names = FALSE)[1]
72		)
73
74	!	module_items <- .ui_teal_module(id = ns("nav"), modules = modules, active_module_id = active_module_id)
75
76	!	tags$div(
77	!	class = "teal-modules-wrapper",
78	!	htmltools::htmlDependency(
79	!	name = "module-navigation",
80	!	version = utils::packageVersion("teal"),
81	!	package = "teal",
82	!	src = "module-navigation",
83	!	stylesheet = "module-navigation.css"
84		),
85	!	tags$ul(
86	!	id = ns("active_module_id"),
87	!	style = "align-items: center; gap: 1em; font-size: large;",
88	!	class = "teal-navbar nav shiny-tab-input", # to mimic nav and mimic tabsetPanel
89	!	`data-tabsetid` = "test",
90	!	.teal_navbar_menu(
91	!	!!!module_items$link,
92	!	label = sprintf("Module (%d)", length(unlist(modules_slot(modules, "label")))),
93	!	class = "teal-modules-tree",
94	!	icon = "diagram-3-fill"
95		)
96		),
97	!	tags$div(class = "tab-content", module_items$tab_pane)
98		)
99		}
100
101		#' @rdname module_teal_module
102		srv_teal_module <- function(id,
103		data,
104		modules,
105		datasets = NULL,
106		slices_global,
107		reporter = teal.reporter::Reporter$new(),
108		data_load_status = reactive("ok")) {
109	87x	moduleServer(id, function(input, output, session) {
110	87x	.srv_teal_module(
111	87x	id = "nav",
112	87x	data = data,
113	87x	modules = modules,
114	87x	datasets = datasets,
115	87x	slices_global = slices_global,
116	87x	reporter = reporter,
117	87x	data_load_status = data_load_status,
118	87x	active_module_id = reactive(input$active_module_id)
119		)
120		})
121		}
122
123		#' @rdname module_teal_module
124		.teal_navbar_append <- function(navbar, child) {
125	!	tagAppendChild(tag = navbar, child = child, .cssSelector = ".teal-navbar")
126		}
127
128		#' @rdname module_teal_module
129		.teal_navbar_insert_ui <- function(ui, where = "afterBegin", session = getDefaultReactiveDomain()) {
130	9x	insertUI(
131	9x	selector = ".teal-navbar",
132	9x	where = where,
133	9x	ui = ui,
134	9x	session = session
135		)
136		}
137
138		#' @rdname module_teal_module
139		.teal_navbar_menu <- function(..., id = NULL, label = NULL, class = NULL, icon = NULL) {
140	!	tags$div(
141	!	class = "dropdown nav-item-custom",
142	!	.dropdown_button(
143	!	id = id,
144	!	label = label,
145	!	icon = icon
146		),
147	!	tags$div(
148	!	class = "dropdown-menu",
149	!	tags$ul(class = class, !!!rlang::list2(...))
150		)
151		)
152		}
153
154		#' @rdname module_teal_module
155		.ui_teal_module <- function(id, modules, active_module_id) {
156	!	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module", "shiny.tag"))
157	!	UseMethod(".ui_teal_module", modules)
158		}
159
160		#' @rdname module_teal_module
161		#' @export
162		.ui_teal_module.default <- function(id, modules, active_module_id) {
163	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
164		}
165
166		#' @rdname module_teal_module
167		#' @export
168		.ui_teal_module.teal_modules <- function(id, modules, active_module_id) {
169	!	items <- mapply(
170	!	FUN = .ui_teal_module,
171	!	id = NS(id, .label_to_id(sapply(modules$children, `[[`, "label"))),
172	!	modules = modules$children,
173	!	active_module_id = active_module_id,
174	!	SIMPLIFY = FALSE
175		)
176
177	!	list(
178	!	link = tagList(
179	!	if (length(modules$label)) tags$li(tags$span(modules$label, class = "module-group-label")),
180	!	tags$li(tags$ul(lapply(items, `[[`, "link")))
181		),
182	!	tab_pane = tagList(lapply(items, `[[`, "tab_pane"))
183		)
184		}
185
186		#' @rdname module_teal_module
187		#' @export
188		.ui_teal_module.teal_module <- function(id, modules, active_module_id) {
189	!	ns <- NS(id)
190	!	args <- c(list(id = ns("module")), modules$ui_args)
191	!	ui_teal <- tags$div(
192	!	shinyjs::hidden(
193	!	tags$div(
194	!	id = ns("transform_failure_info"),
195	!	class = "teal_validated",
196	!	div(
197	!	class = "teal-output-warning",
198	!	"One of transformators failed. Please check its inputs."
199		)
200		)
201		),
202	!	tags$div(
203	!	id = ns("teal_module_ui"),
204	!	tags$div(
205	!	class = "teal_validated",
206	!	ui_check_module_datanames(ns("validate_datanames"))
207		),
208	!	do.call(what = modules$ui, args = args, quote = TRUE)
209		)
210		)
211	!	container_id <- ns("wrapper")
212	!	module_id <- modules$path
213
214	!	link <- tags$li(
215	!	tags$a(
216	!	href = paste0("#", container_id), # links button with module content in `tab-content` with same id.
217	!	`data-bs-toggle` = "tab", # signals shiny to treat this element as bootstrap tab buttons for toggle.
218	!	`data-value` = module_id, # this data is set as the shiny input.
219	!	class = c("nav-link", "module-button", "btn-default", if (identical(module_id, active_module_id)) "active"),
220		# `nav-link` is required to mimic bslib tab panel.
221	!	modules$label
222		)
223		)
224
225	!	tab_pane <- div(
226	!	id = container_id,
227	!	class = c("tab-pane", "teal_module", if (identical(module_id, active_module_id)) "active"),
228	!	ui_add_reporter(ns("add_reporter_wrapper")),
229	!	tagList(
230	!	.modules_breadcrumb(modules),
231	!	if (!is.null(modules$datanames)) {
232	!	tagList(
233	!	bslib::layout_sidebar(
234	!	class = "teal-sidebar-layout",
235	!	sidebar = bslib::sidebar(
236	!	id = ns("teal_module_sidebar"),
237	!	class = "teal-sidebar",
238	!	position = getOption("teal.sidebar.position", "left"),
239	!	width = getOption("teal.sidebar.width", 250),
240	!	tags$div(
241	!	tags$div(
242	!	class = "teal-active-data-summary-panel",
243	!	bslib::accordion(
244	!	id = ns("data_summary_accordion"),
245	!	bslib::accordion_panel(
246	!	"Active Data Summary",
247	!	tags$div(
248	!	class = "teal-active-data-summary",
249	!	ui_data_summary(ns("data_summary"))
250		)
251		)
252		)
253		),
254	!	tags$br(),
255	!	tags$div(
256	!	class = "teal-filter-panel",
257	!	ui_filter_data(ns("filter_panel"))
258		),
259	!	if (length(modules$transformators) > 0 && !isTRUE(attr(modules$transformators, "custom_ui"))) {
260	!	tags$div(
261	!	tags$br(),
262	!	tags$div(
263	!	class = "teal-transform-panel",
264	!	bslib::accordion(
265	!	id = ns("data_transform_accordion"),
266	!	bslib::accordion_panel(
267	!	"Transform Data",
268	!	ui_transform_teal_data(
269	!	ns("data_transform"),
270	!	transformators = modules$transformators
271		)
272		)
273		)
274		)
275		)
276		}
277		)
278		),
279	!	ui_teal
280		),
281	!	div(
282	!	id = ns("sidebar_toggle_buttons"),
283	!	class = "sidebar-toggle-buttons",
284	!	actionButton(
285	!	class = "data-summary-toggle btn-outline-primary",
286	!	ns("data_summary_toggle"),
287	!	icon("fas fa-list")
288		),
289	!	actionButton(
290	!	class = "data-filters-toggle btn-outline-secondary",
291	!	ns("data_filters_toggle"),
292	!	icon("fas fa-filter")
293		),
294	!	if (length(modules$transformators) > 0) {
295	!	actionButton(
296	!	class = "data-transforms-toggle btn-outline-primary",
297	!	ns("data_transforms_toggle"),
298	!	icon("fas fa-pen-to-square")
299		)
300		}
301		),
302	!	tags$script(
303	!	HTML(
304	!	sprintf(
305		"
306	!	$(document).ready(function() {
307	!	$('#%s').insertAfter('#%s > .bslib-sidebar-layout > button.collapse-toggle');
308		});
309		",
310	!	ns("sidebar_toggle_buttons"),
311	!	ns("wrapper")
312		)
313		)
314		)
315		)
316		} else {
317	!	ui_teal
318		}
319		)
320		)
321
322	!	list(link = link, tab_pane = tab_pane)
323		}
324
325		#' @rdname module_teal_module
326		.srv_teal_module <- function(id,
327		data,
328		modules,
329		datasets = NULL,
330		slices_global,
331		reporter = teal.reporter::Reporter$new(),
332		data_load_status = reactive("ok"),
333		active_module_id = reactive(TRUE)) {
334	200x	checkmate::assert_string(id)
335	200x	assert_reactive(data)
336	200x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
337	200x	assert_reactive(datasets, null.ok = TRUE)
338	200x	checkmate::assert_class(slices_global, ".slicesGlobal")
339	200x	checkmate::assert_class(reporter, "Reporter", null.ok = TRUE)
340	200x	assert_reactive(data_load_status)
341	200x	UseMethod(".srv_teal_module", modules)
342		}
343
344		#' @rdname module_teal_module
345		#' @export
346		.srv_teal_module.default <- function(id,
347		data,
348		modules,
349		datasets = NULL,
350		slices_global,
351		reporter = teal.reporter::Reporter$new(),
352		data_load_status = reactive("ok"),
353		active_module_id = reactive(TRUE)) {
354	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
355		}
356
357		#' @rdname module_teal_module
358		#' @export
359		.srv_teal_module.teal_modules <- function(id,
360		data,
361		modules,
362		datasets = NULL,
363		slices_global,
364		reporter = teal.reporter::Reporter$new(),
365		data_load_status = reactive("ok"),
366		active_module_id = reactive(TRUE)) {
367	87x	moduleServer(id = id, module = function(input, output, session) {
368	87x	logger::log_debug("srv_teal_module.teal_modules initializing the module { deparse1(modules$label) }.")
369	87x	modules_output <- mapply(
370	87x	function(id, modules) {
371	113x	.srv_teal_module(
372	113x	id = id,
373	113x	modules = modules,
374	113x	data = data,
375	113x	datasets = datasets,
376	113x	slices_global = slices_global,
377	113x	reporter = reporter,
378	113x	data_load_status = data_load_status,
379	113x	active_module_id = active_module_id
380		)
381		},
382	87x	id = .label_to_id(sapply(modules$children, `[[`, "label")),
383	87x	modules = modules$children,
384	87x	SIMPLIFY = FALSE
385		)
386
387	87x	modules_output
388		})
389		}
390
391		#' @rdname module_teal_module
392		#' @export
393		.srv_teal_module.teal_module <- function(id,
394		data,
395		modules,
396		datasets = NULL,
397		slices_global,
398		reporter = teal.reporter::Reporter$new(),
399		data_load_status = reactive("ok"),
400		active_module_id = reactive(TRUE)) {
401	113x	logger::log_debug("srv_teal_module.teal_module initializing the module: { deparse1(modules$label) }.")
402	113x	moduleServer(id = id, module = function(input, output, session) {
403	113x	module_out <- reactiveVal()
404	113x	module_id <- modules$path
405	113x	is_active <- reactive({
406	129x	identical(data_load_status(), "ok") && identical(module_id, active_module_id())
407		})
408	113x	active_datanames <- reactive({
409	90x	.resolve_module_datanames(data = data(), modules = modules)
410		})
411	113x	if (is.null(datasets)) {
412	20x	datasets <- eventReactive(data(), {
413	16x	req(inherits(data(), "teal_data"))
414	16x	logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
415	16x	teal_data_to_filtered_data(data(), datanames = active_datanames())
416		})
417		}
418
419		# manage module filters on the module level
420		# important:
421		# filter_manager_module_srv needs to be called before filter_panel_srv
422		# Because available_teal_slices is used in FilteredData$srv_available_slices (via srv_filter_panel)
423		# and if it is not set, then it won't be available in the srv_filter_panel
424	113x	srv_module_filter_manager(modules$label, module_fd = datasets, slices_global = slices_global)
425
426	113x	.call_once_when(is_active(), {
427	87x	filtered_teal_data <- srv_filter_data(
428	87x	"filter_panel",
429	87x	datasets = datasets,
430	87x	active_datanames = active_datanames,
431	87x	data = data,
432	87x	is_active = is_active
433		)
434	87x	is_transform_failed <- reactiveValues()
435	87x	transformed_teal_data <- srv_transform_teal_data(
436	87x	"data_transform",
437	87x	data = filtered_teal_data,
438	87x	transformators = modules$transformators,
439	87x	modules = modules,
440	87x	is_transform_failed = is_transform_failed
441		)
442	87x	any_transform_failed <- reactive({
443	96x	any(unlist(reactiveValuesToList(is_transform_failed)))
444		})
445
446	87x	observeEvent(any_transform_failed(), {
447	96x	if (isTRUE(any_transform_failed())) {
448	6x	shinyjs::hide("teal_module_ui")
449	6x	shinyjs::show("transform_failure_info")
450		} else {
451	90x	shinyjs::show("teal_module_ui")
452	90x	shinyjs::hide("transform_failure_info")
453		}
454		})
455
456	87x	module_teal_data <- reactive({
457	106x	req(inherits(transformed_teal_data(), "teal_data"))
458	89x	all_teal_data <- transformed_teal_data()
459	89x	module_datanames <- .resolve_module_datanames(data = all_teal_data, modules = modules)
460	89x	all_teal_data[c(module_datanames, ".raw_data")]
461		})
462
463	87x	srv_check_module_datanames(
464	87x	"validate_datanames",
465	87x	data = module_teal_data,
466	87x	modules = modules
467		)
468
469	87x	summary_table <- srv_data_summary("data_summary", module_teal_data)
470
471	87x	observeEvent(input$data_summary_toggle, {
472	!	bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
473	!	bslib::accordion_panel_open(id = "data_summary_accordion", values = TRUE)
474	!	bslib::accordion_panel_close(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
475	!	bslib::accordion_panel_close(id = "data_transform_accordion", values = TRUE)
476		})
477
478	87x	observeEvent(input$data_filters_toggle, {
479	!	bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
480	!	bslib::accordion_panel_close(id = "data_summary_accordion", values = TRUE)
481	!	bslib::accordion_panel_open(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
482	!	bslib::accordion_panel_close(id = "data_transform_accordion", values = TRUE)
483		})
484
485	87x	observeEvent(input$data_transforms_toggle, {
486	!	bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
487	!	bslib::accordion_panel_close(id = "data_summary_accordion", values = TRUE)
488	!	bslib::accordion_panel_close(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
489	!	bslib::accordion_panel_open(id = "data_transform_accordion", values = TRUE)
490		})
491
492		# Call modules.
493	87x	obs_module <- .call_once_when(
494	87x	!is.null(module_teal_data()),
495	87x	ignoreNULL = TRUE,
496	87x	handlerExpr = {
497	81x	out <- .call_teal_module(modules, datasets, module_teal_data, reporter)
498	81x	srv_add_reporter("add_reporter_wrapper", out, reporter)
499	81x	module_out(out)
500		}
501		)
502		})
503	113x	module_out
504		})
505		}
506
507		# This function calls a module server function.
508		.call_teal_module <- function(modules, datasets, data, reporter) {
509	81x	assert_reactive(data)
510
511		# collect arguments to run teal_module
512	81x	args <- c(list(id = "module"), modules$server_args)
513	81x	if (is_arg_used(modules$server, "reporter") && !is.null(reporter)) {
514	1x	args <- c(args, list(reporter = reporter))
515		}
516
517	81x	if (is_arg_used(modules$server, "datasets")) {
518	1x	args <- c(args, datasets = datasets())
519	1x	warning("datasets argument is not reactive and therefore it won't be updated when data is refreshed.")
520		}
521
522	81x	if (is_arg_used(modules$server, "data")) {
523	77x	args <- c(args, data = list(data))
524		}
525
526	81x	if (is_arg_used(modules$server, "filter_panel_api")) {
527	1x	args <- c(args, filter_panel_api = teal.slice::FilterPanelAPI$new(datasets()))
528		}
529
530	81x	if (is_arg_used(modules$server, "id")) {
531	81x	do.call(what = modules$server, args = args, quote = TRUE)
532		} else {
533	!	do.call(what = callModule, args = c(args, list(module = modules$server)), quote = TRUE)
534		}
535		}
536
537		.resolve_module_datanames <- function(data, modules) {
538	179x	stopifnot("data must be teal_data object." = inherits(data, "teal_data"))
539	179x	if (is.null(modules$datanames) \|\| identical(modules$datanames, "all")) {
540	147x	names(data)
541		} else {
542	32x	intersect(
543	32x	names(data), # Keep topological order from teal.data::names()
544	32x	.include_parent_datanames(modules$datanames, teal.data::join_keys(data))
545		)
546		}
547		}
548
549		#' Calls expression when condition is met
550		#'
551		#' Function postpones `handlerExpr` to the moment when `eventExpr` (condition) returns `TRUE`,
552		#' otherwise nothing happens.
553		#' @param eventExpr A (quoted or unquoted) logical expression that represents the event;
554		#' this can be a simple reactive value like input$click, a call to a reactive expression
555		#' like dataset(), or even a complex expression inside curly braces.
556		#' @param ... additional arguments passed to `observeEvent` with the exception of `eventExpr` that is not allowed.
557		#' @inheritParams shiny::observeEvent
558		#'
559		#' @return An observer.
560		#'
561		#' @keywords internal
562		.call_once_when <- function(eventExpr, # nolint: object_name.
563		handlerExpr, # nolint: object_name.
564		event.env = parent.frame(), # nolint: object_name.
565		handler.env = parent.frame(), # nolint: object_name.
566		...) {
567	307x	event_quo <- rlang::new_quosure(substitute(eventExpr), env = event.env)
568	307x	handler_quo <- rlang::new_quosure(substitute(handlerExpr), env = handler.env)
569
570		# When `condExpr` is TRUE, then `handlerExpr` is evaluated once.
571	307x	activator <- reactive({
572	329x	if (isTRUE(rlang::eval_tidy(event_quo))) {
573	257x	TRUE
574		}
575		})
576
577	307x	observeEvent(
578	307x	eventExpr = activator(),
579	307x	once = TRUE,
580	307x	handlerExpr = rlang::eval_tidy(handler_quo),
581		...
582		)
583		}
584
585		.modules_breadcrumb <- function(module) {
586	!	tags$div(
587	!	style = "color: var(--bs-secondary); font-size: large; opacity: 0.6; margin: 0 0.5em 0.5em 0.5em;",
588	!	paste("Home", module$path, sep = " / ")
589		)
590		}

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

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

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

1		#' `teal_data` utils
2		#'
3		#' In `teal` we need to recreate the `teal_data` object due to two operations:
4		#' - we need to append filter-data code and objects which have been evaluated in `FilteredData` and
5		#' we want to avoid double-evaluation.
6		#' - we need to subset `teal_data` to `datanames` used by the module, to shorten obtainable R-code
7		#'
8		#' Due to above recreation of `teal_data` object can't be done simply by using public
9		#' `teal.code` and `teal.data` methods.
10		#'
11		#' @param data (`teal_data`)
12		#' @param code (`character`) code to append to the object's code slot.
13		#' @param objects (`list`) objects to append to object's environment.
14		#' @return modified `teal_data`
15		#' @keywords internal
16		#' @name teal_data_utilities
17		NULL
18
19		#' @rdname teal_data_utilities
20		.append_evaluated_code <- function(data, code) {
21	95x	checkmate::assert_class(data, "teal_data")
22	95x	if (length(code) && !identical(code, "")) {
23	19x	data@code <- c(data@code, code2list(code))
24	19x	teal.reporter::teal_card(data) <- c(
25	19x	teal.reporter::teal_card(data),
26	19x	"## Data filtering",
27	19x	teal.reporter::code_chunk(code)
28		)
29	19x	methods::validObject(data)
30		}
31	95x	data
32		}
33
34		#' @rdname teal_data_utilities
35		.append_modified_data <- function(data, objects) {
36	95x	checkmate::assert_class(data, "teal_data")
37	95x	checkmate::assert_class(objects, "list")
38	95x	new_env <- list2env(objects, parent = .GlobalEnv)
39	95x	rlang::env_coalesce(new_env, as.environment(data))
40	95x	data@.xData <- new_env
41	95x	data
42		}
43
44		#' @rdname teal_data_utilities
45		.collapse_subsequent_chunks <- function(report) {
46	70x	Reduce(
47	70x	function(x, this) {
48	359x	l <- length(x)
49	70x	if (
50	359x	l &&
51	359x	inherits(x[[l]], "code_chunk") &&
52	359x	inherits(this, "code_chunk") &&
53	359x	identical(attr(x[[l]], "params"), attr(this, "params"))
54		) {
55	178x	x[[length(x)]] <- do.call(
56	178x	teal.reporter::code_chunk,
57	178x	args = c(
58	178x	list(code = paste(x[[l]], this, sep = "\n")),
59	178x	attr(x[[l]], "params")
60		)
61		)
62	178x	x
63		} else {
64	181x	c(x, this)
65		}
66		},
67	70x	init = teal.reporter::teal_card(),
68	70x	x = report
69		)
70		}

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

1		#' Check that argument is reactive.
2		#'
3		#' @inherit checkmate::check_class params return
4		#'
5		#' @keywords internal
6		check_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
7	1142x	if (!isTRUE(checkmate::test_class(x, classes = "reactive", null.ok = null.ok))) {
8	4x	cl <- class(x)
9	4x	return(sprintf(
10	4x	"Must be a reactive (i.e. inherit from 'reactive' class) but has class%s '%s'",
11	4x	if (length(cl) > 1L) "es" else "",
12	4x	paste0(cl, collapse = "','")
13		))
14		}
15	1138x	return(TRUE)
16		}
17		#' @rdname check_reactive
18		test_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
19	30x	isTRUE(check_reactive(x, null.ok = null.ok))
20		}
21		#' @rdname check_reactive
22		assert_reactive <- checkmate::makeAssertionFunction(check_reactive)
23
24		#' Capture error and decorate error message.
25		#'
26		#' @param x object to evaluate
27		#' @param pre (`character(1)`) A string to prepend to error message
28		#' @param post (`character(1)`) A string to append to error message
29		#'
30		#' @return `x` if no error, otherwise throws error with decorated message
31		#'
32		#' @keywords internal
33		decorate_err_msg <- function(x, pre = character(0), post = character(0)) {
34	47x	tryCatch(
35	47x	x,
36	47x	error = function(e) {
37	2x	stop(
38	2x	"\n",
39	2x	pre,
40	2x	"\n",
41	2x	e$message,
42	2x	"\n",
43	2x	post,
44	2x	call. = FALSE
45		)
46		}
47		)
48	45x	x
49		}

1		#' Data module for `teal` transformations and output customization
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' `teal_transform_module` provides a `shiny` module that enables data transformations within a `teal` application
7		#' and allows for customization of outputs generated by modules.
8		#'
9		#' # Transforming Module Inputs in `teal`
10		#'
11		#' Data transformations occur after data has been filtered in `teal`.
12		#' The transformed data is then passed to the `server` of [`teal_module()`] and managed by `teal`'s internal processes.
13		#' The primary advantage of `teal_transform_module` over custom modules is in its error handling, where all warnings and
14		#' errors are managed by `teal`, allowing developers to focus on transformation logic.
15		#'
16		#' For more details, see the vignette: `vignette("transform-input-data", package = "teal")`.
17		#'
18		#' # Customizing Module Outputs
19		#'
20		#' `teal_transform_module` also allows developers to modify any object created within [`teal.data::teal_data`].
21		#' This means you can use it to customize not only datasets but also tables, listings, and graphs.
22		#' Some [`teal_modules`] permit developers to inject custom `shiny` modules to enhance displayed outputs.
23		#' To manage these `decorators` within your module, use [`ui_transform_teal_data()`] and [`srv_transform_teal_data()`].
24		#' (For further guidance on managing decorators, refer to `ui_args` and `srv_args` in the vignette documentation.)
25		#'
26		#' See the vignette `vignette("transform-module-output", package = "teal")` for additional examples.
27		#'
28		#' # `server` as a language
29		#'
30		#' The `server` function in `teal_transform_module` must return a reactive [`teal.data::teal_data`] object.
31		#' For simple transformations without complex reactivity, the `server` function might look like this:s
32		#'
33		#' ```
34		#' function(id, data) {
35		#' moduleServer(id, function(input, output, session) {
36		#' reactive({
37		#' within(
38		#' data(),
39		#' expr = x <- subset(x, col == level),
40		#' level = input$level
41		#' )
42		#' })
43		#' })
44		#' }
45		#' ```
46		#'
47		#' The example above can be simplified using `make_teal_transform_server`, where `level` is automatically matched to the
48		#' corresponding `input` parameter:
49		#'
50		#' ```
51		#' make_teal_transform_server(expr = expression(x <- subset(x, col == level)))
52		#' ```
53		#' @inheritParams teal_data_module
54		#' @param server (`function(id, data)` or `expression`)
55		#' A `shiny` module server function that takes `id` and `data` as arguments, where `id` is the module id and `data`
56		#' is the reactive `teal_data` input. The `server` function must return a reactive expression containing a `teal_data`
57		#' object. For simplified syntax, use [`make_teal_transform_server()`].
58		#' @param datanames (`character`)
59		#' Specifies the names of datasets relevant to the module. Only filters for the specified `datanames` will be displayed
60		#' in the filter panel. The keyword `"all"` can be used to display filters for all datasets. `datanames` are
61		#' automatically appended to the [`modules()`] `datanames`.
62		#'
63		#' @examplesShinylive
64		#' library(teal)
65		#' interactive <- function() TRUE
66		#' {{ next_example }}
67		#' @examples
68		#' data_transformators <- list(
69		#' teal_transform_module(
70		#' label = "Static transformator for iris",
71		#' datanames = "iris",
72		#' server = function(id, data) {
73		#' moduleServer(id, function(input, output, session) {
74		#' reactive({
75		#' within(data(), {
76		#' iris <- head(iris, 5)
77		#' })
78		#' })
79		#' })
80		#' }
81		#' ),
82		#' teal_transform_module(
83		#' label = "Interactive transformator for iris",
84		#' datanames = "iris",
85		#' ui = function(id) {
86		#' ns <- NS(id)
87		#' tags$div(
88		#' numericInput(ns("n_cols"), "Show n columns", value = 5, min = 1, max = 5, step = 1)
89		#' )
90		#' },
91		#' server = function(id, data) {
92		#' moduleServer(id, function(input, output, session) {
93		#' reactive({
94		#' within(data(),
95		#' {
96		#' iris <- iris[, 1:n_cols]
97		#' },
98		#' n_cols = input$n_cols
99		#' )
100		#' })
101		#' })
102		#' }
103		#' )
104		#' )
105		#'
106		#' output_decorator <- teal_transform_module(
107		#' server = make_teal_transform_server(
108		#' expression(
109		#' object <- rev(object)
110		#' )
111		#' )
112		#' )
113		#'
114		#' app <- init(
115		#' data = teal_data(iris = iris),
116		#' modules = example_module(
117		#' transformators = data_transformators,
118		#' decorators = list(output_decorator)
119		#' )
120		#' )
121		#' if (interactive()) {
122		#' shinyApp(app$ui, app$server)
123		#' }
124		#'
125		#' @name teal_transform_module
126		#'
127		#' @export
128		teal_transform_module <- function(ui = NULL,
129		server = function(id, data) data,
130		label = "transform module",
131		datanames = "all") {
132	25x	structure(
133	25x	list(
134	25x	ui = ui,
135	25x	server = function(id, data) {
136	26x	data_out <- server(id, data)
137
138	26x	if (inherits(data_out, "reactive.event")) {
139		# This warning message partially detects when `eventReactive` is used in `data_module`.
140	1x	warning(
141	1x	"teal_transform_module() ",
142	1x	"Using eventReactive in teal_transform module server code should be avoided as it ",
143	1x	"may lead to unexpected behavior. See the vignettes for more information ",
144	1x	"(`vignette(\"transform-input-data\", package = \"teal\")`).",
145	1x	call. = FALSE
146		)
147		}
148
149
150	26x	decorate_err_msg(
151	26x	assert_reactive(data_out),
152	26x	pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
153	26x	post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
154		)
155		}
156		),
157	25x	label = label,
158	25x	datanames = datanames,
159	25x	class = c("teal_transform_module", "teal_data_module")
160		)
161		}
162
163		#' Make teal_transform_module's server
164		#'
165		#' A factory function to simplify creation of a [`teal_transform_module`]'s server. Specified `expr`
166		#' is wrapped in a shiny module function and output can be passed to the `server` argument in
167		#' [teal_transform_module()] call. Such a server function can be linked with ui and values from the
168		#' inputs can be used in the expression. Object names specified in the expression will be substituted
169		#' with the value of the respective input (matched by the name) - for example in
170		#' `expression(graph <- graph + ggtitle(title))` object `title` will be replaced with the value of
171		#' `input$title`.
172		#' @param expr (`language`)
173		#' An R call which will be evaluated within [`teal.data::teal_data`] environment.
174		#' @return `function(id, data)` returning `shiny` module
175		#'
176		#' @examplesShinylive
177		#' library(teal)
178		#' interactive <- function() TRUE
179		#' {{ next_example }}
180		#' @examples
181		#'
182		#' trim_iris <- teal_transform_module(
183		#' label = "Simplified interactive transformator for iris",
184		#' datanames = "iris",
185		#' ui = function(id) {
186		#' ns <- NS(id)
187		#' numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
188		#' },
189		#' server = make_teal_transform_server(expression(iris <- head(iris, n_rows)))
190		#' )
191		#'
192		#' app <- init(
193		#' data = teal_data(iris = iris),
194		#' modules = example_module(transformators = trim_iris)
195		#' )
196		#' if (interactive()) {
197		#' shinyApp(app$ui, app$server)
198		#' }
199		#'
200		#' @export
201		make_teal_transform_server <- function(expr) {
202	3x	if (is.call(expr)) {
203	1x	expr <- as.expression(expr)
204		}
205	3x	checkmate::assert_multi_class(expr, c("call", "expression"))
206
207	3x	function(id, data) {
208	3x	moduleServer(id, function(input, output, session) {
209	3x	list_env <- reactive(
210	3x	lapply(rlang::set_names(names(input)), function(x) input[[x]])
211		)
212
213	3x	reactive({
214	3x	call_with_inputs <- lapply(expr, function(x) {
215	3x	do.call(what = substitute, args = list(expr = x, env = list_env()))
216		})
217	3x	eval_code(object = data(), code = as.expression(call_with_inputs))
218		})
219		})
220		}
221		}
222
223		#' Extract all `transformators` from `modules`.
224		#'
225		#' @param modules `teal_modules` or `teal_module`
226		#' @return A list of `teal_transform_module` nested in the same way as input `modules`.
227		#' @keywords internal
228		extract_transformators <- function(modules) {
229	10x	if (inherits(modules, "teal_module")) {
230	5x	modules$transformators
231	5x	} else if (inherits(modules, "teal_modules")) {
232	5x	lapply(modules$children, extract_transformators)
233		}
234		}

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

1		#' Data module for `teal` applications
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' Create a `teal_data_module` object and evaluate code on it with history tracking.
7		#'
8		#' @details
9		#' `teal_data_module` creates a `shiny` module to interactively supply or modify data in a `teal` application.
10		#' The module allows for running any code (creation _and_ some modification) after the app starts or reloads.
11		#' The body of the server function will be run in the app rather than in the global environment.
12		#' This means it will be run every time the app starts, so use sparingly.
13		#'
14		#' Pass this module instead of a `teal_data` object in a call to [init()].
15		#' Note that the server function must always return a `teal_data` object wrapped in a reactive expression.
16		#'
17		#' See vignette `vignette("data-as-shiny-module", package = "teal")` for more details.
18		#'
19		#' @param ui (`function(id)`)
20		#' `shiny` module UI function; must only take `id` argument
21		#' @param server (`function(id)`)
22		#' `shiny` module server function; must only take `id` argument;
23		#' must return reactive expression containing `teal_data` object
24		#' @param label (`character(1)`) Label of the module.
25		#' @param once (`logical(1)`)
26		#' If `TRUE`, the data module will be shown only once and will disappear after successful data loading.
27		#' App user will no longer be able to interact with this module anymore.
28		#' If `FALSE`, the data module can be reused multiple times.
29		#' App user will be able to interact and change the data output from the module multiple times.
30		#'
31		#' @return
32		#' `teal_data_module` returns a list of class `teal_data_module` containing two elements, `ui` and
33		#' `server` provided via arguments.
34		#'
35		#' @examples
36		#' tdm <- teal_data_module(
37		#' ui = function(id) {
38		#' ns <- NS(id)
39		#' actionButton(ns("submit"), label = "Load data")
40		#' },
41		#' server = function(id) {
42		#' moduleServer(id, function(input, output, session) {
43		#' eventReactive(input$submit, {
44		#' data <- within(
45		#' teal_data(),
46		#' {
47		#' dataset1 <- iris
48		#' dataset2 <- mtcars
49		#' }
50		#' )
51		#'
52		#' data
53		#' })
54		#' })
55		#' }
56		#' )
57		#'
58		#' @name teal_data_module
59		#' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]
60		#'
61		#' @export
62		teal_data_module <- function(ui, server, label = "data module", once = TRUE) {
63	41x	checkmate::assert_function(ui, args = "id", nargs = 1)
64	40x	checkmate::assert_function(server, args = "id", nargs = 1)
65	38x	checkmate::assert_string(label)
66	38x	checkmate::assert_flag(once)
67	38x	structure(
68	38x	list(
69	38x	ui = ui,
70	38x	server = function(id) {
71	23x	data_out <- server(id)
72	22x	decorate_err_msg(
73	22x	assert_reactive(data_out),
74	22x	pre = sprintf("From: 'teal_data_module()':\nA 'teal_data_module' with \"%s\" label:", label),
75	22x	post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
76		)
77		}
78		),
79	38x	label = label,
80	38x	class = "teal_data_module",
81	38x	once = once
82		)
83		}

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

1		#' `teal` user session info module
2		#'
3		#' Module to display the user session info popup and to download a lockfile. Module is included
4		#' when running [init()] but skipped when using [`module_teal`]. Please be aware that session info
5		#' contains R session information, so multiple module's calls will share the same information.
6		#'
7		#' @rdname module_session_info
8		#' @name module_session_info
9		#'
10		#' @inheritParams module_teal
11		#'
12		#' @examplesShinylive
13		#' library(teal)
14		#' interactive <- function() TRUE
15		#' {{ next_example }}
16		#' @examples
17		#' ui <- fluidPage(
18		#' ui_session_info("session_info")
19		#' )
20		#'
21		#' server <- function(input, output, session) {
22		#' srv_session_info("session_info")
23		#' }
24		#'
25		#' if (interactive()) {
26		#' shinyApp(ui, server)
27		#' }
28		#'
29		#' @return `NULL` invisibly
30		NULL
31
32		#' @rdname module_session_info
33		#' @export
34		ui_session_info <- function(id) {
35	!	ns <- NS(id)
36	!	tags$div(
37	!	teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
38	!	br(),
39	!	ui_teal_lockfile(ns("lockfile")),
40	!	textOutput(ns("identifier"))
41		)
42		}
43
44		#' @rdname module_session_info
45		#' @export
46		srv_session_info <- function(id) {
47	2x	moduleServer(id, function(input, output, session) {
48	2x	srv_teal_lockfile("lockfile")
49
50	2x	output$identifier <- renderText(
51	2x	paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
52		)
53
54	2x	teal.widgets::verbatim_popup_srv(
55	2x	"sessionInfo",
56	2x	verbatim_content = utils::capture.output(utils::sessionInfo()),
57	2x	title = "SessionInfo"
58		)
59		})
60		}

1		#' Include `CSS` files from `/inst/css/` package directory to application header
2		#'
3		#' `system.file` should not be used to access files in other packages, it does
4		#' not work with `devtools`. Therefore, we redefine this method in each package
5		#' as needed. Thus, we do not export this method.
6		#'
7		#' @param pattern (`character`) pattern of files to be included
8		#'
9		#' @return HTML code that includes `CSS` files.
10		#' @keywords internal
11		include_css_files <- function(pattern = "*") {
12	!	css_files <- list.files(
13	!	system.file("css", package = "teal", mustWork = TRUE),
14	!	pattern = pattern, full.names = TRUE
15		)
16
17	!	singleton(
18	!	tags$head(lapply(css_files, includeCSS))
19		)
20		}
21
22		#' Code to include `teal` `CSS` and `JavaScript` files
23		#'
24		#' This is useful when you want to use the same `JavaScript` and `CSS` files that are
25		#' used with the `teal` application.
26		#' This is also useful for running standalone modules in `teal` with the correct
27		#' styles.
28		#' Also initializes `shinyjs` so you can use it.
29		#'
30		#' Simply add `include_teal_css_js()` as one of the UI elements.
31		#' @return A `shiny.tag.list`.
32		#' @keywords internal
33		include_teal_css_js <- function() {
34	!	tagList(
35	!	shinyjs::useShinyjs(),
36	!	include_css_files()
37		)
38		}