teal coverage - 57.50%

Files
Source

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

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

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

  if ("datasets" %in% server_formals) {
    warning(
      sprintf("Called from module(label = \"%s\", ...)\n  ", label),
      "`datasets` argument in the server is deprecated and will be removed in the next release. ",
      "Please use `data` instead.",
      call. = FALSE
    )
  }

  ## UI
  checkmate::assert_function(ui)
  ui_formals <- names(formals(ui))
  if (!"id" %in% ui_formals) {
    stop(
      "\nmodule() `ui` argument requires a function with following arguments:",
      "\n - id - `teal` will set proper `shiny` namespace for this module.",
      "\n\nFollowing arguments can be used optionally:",
      "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"
    )
  }

  if (any(c("data", "datasets") %in% ui_formals)) {
    stop(
      sprintf("Called from module(label = \"%s\", ...)\n  ", label),
      "UI with `data` or `datasets` argument is no longer accepted.\n  ",
      "If some UI inputs depend on data, please move the logic to your server instead.\n  ",
      "Possible solutions are renderUI() or updateXyzInput() functions."
    )
  }

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

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

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

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

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

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

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

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

# printing methods ----

#' @rdname teal_modules
#' @param is_last (`logical(1)`) Whether this is the last item in its parent's children list.
#'   Affects the tree branch character used (L- vs |-)
#' @param parent_prefix (`character(1)`) The prefix inherited from parent nodes,
#'   used to maintain the tree structure in nested levels
#' @param is_root (`logical(1)`) Whether this is the root node of the tree. Only used in
#'   format.teal_modules(). Determines whether to show "TEAL ROOT" header
#' @param what (`character`) Specifies which metadata to display.
#'   Possible values: "datasets", "properties", "ui_args", "server_args", "transformators"
#' @examples
#' mod <- module(
#'   label = "My Custom Module",
#'   server = function(id, data, ...) {},
#'   ui = function(id, ...) {},
#'   datanames = c("ADSL", "ADTTE"),
#'   transformators = list(),
#'   ui_args = list(a = 1, b = "b"),
#'   server_args = list(x = 5, y = list(p = 1))
#' )
#' cat(format(mod))
#' @export
format.teal_module <- function(
    x,
    is_last = FALSE,
    parent_prefix = "",
    what = c("datasets", "properties", "ui_args", "server_args", "decorators", "transformators"),
    ...) {
  empty_text <- ""
  branch <- if (is_last) "L-" else "|-"
  current_prefix <- paste0(parent_prefix, branch, " ")
  content_prefix <- paste0(parent_prefix, if (is_last) "   " else "|  ")

  format_list <- function(lst, empty = empty_text, label_width = 0) {
    if (is.null(lst) || length(lst) == 0) {
      empty
    } else {
      colon_space <- paste(rep(" ", label_width), collapse = "")

      first_item <- sprintf("%s (%s)", names(lst)[1], cli::col_silver(class(lst[[1]])[1]))
      rest_items <- if (length(lst) > 1) {
        paste(
          vapply(
            names(lst)[-1],
            function(name) {
              sprintf(
                "%s%s (%s)",
                paste0(content_prefix, "|  ", colon_space),
                name,
                cli::col_silver(class(lst[[name]])[1])
              )
            },
            character(1)
          ),
          collapse = "\n"
        )
      }
      if (length(lst) > 1) paste0(first_item, "\n", rest_items) else first_item
    }
  }

  bookmarkable <- isTRUE(attr(x, "teal_bookmarkable"))
  reportable <- "reporter" %in% names(formals(x$server))

  transformators <- if (length(x$transformators) > 0) {
    paste(sapply(x$transformators, function(t) attr(t, "label")), collapse = ", ")
  } else {
    empty_text
  }

  decorators <- if (length(x$server_args$decorators) > 0) {
    paste(sapply(x$server_args$decorators, function(t) attr(t, "label")), collapse = ", ")
  } else {
    empty_text
  }

  output <- pasten(current_prefix, cli::bg_white(cli::col_black(x$label)))

  if ("datasets" %in% what) {
    output <- paste0(
      output,
      content_prefix, "|- ", cli::col_yellow("Datasets         : "), paste(x$datanames, collapse = ", "), "\n"
    )
  }
  if ("properties" %in% what) {
    output <- paste0(
      output,
      content_prefix, "|- ", cli::col_blue("Properties:"), "\n",
      content_prefix, "|  |- ", cli::col_cyan("Bookmarkable  : "), bookmarkable, "\n",
      content_prefix, "|  L- ", cli::col_cyan("Reportable    : "), reportable, "\n"
    )
  }
  if ("ui_args" %in% what) {
    x$ui_args$decorators <- NULL
    ui_args_formatted <- format_list(x$ui_args, label_width = 19)
    output <- paste0(
      output,
      content_prefix, "|- ", cli::col_green("UI Arguments     : "), ui_args_formatted, "\n"
    )
  }
  if ("server_args" %in% what) {
    x$server_args$decorators <- NULL
    server_args_formatted <- format_list(x$server_args, label_width = 19)
    output <- paste0(
      output,
      content_prefix, "|- ", cli::col_green("Server Arguments : "), server_args_formatted, "\n"
    )
  }
  if ("decorators" %in% what) {
    output <- paste0(
      output,
      content_prefix, "|- ", cli::col_magenta("Decorators       : "), decorators, "\n"
    )
  }
  if ("transformators" %in% what) {
    output <- paste0(
      output,
      content_prefix, "L- ", cli::col_magenta("Transformators   : "), transformators, "\n"
    )
  }

  output
}

#' @rdname teal_modules
#' @examples
#' custom_module <- function(
#'     label = "label", ui_args = NULL, server_args = NULL,
#'     datanames = "all", transformators = list(), bk = FALSE) {
#'   ans <- module(
#'     label,
#'     server = function(id, data, ...) {},
#'     ui = function(id, ...) {
#'     },
#'     datanames = datanames,
#'     transformators = transformators,
#'     ui_args = ui_args,
#'     server_args = server_args
#'   )
#'   attr(ans, "teal_bookmarkable") <- bk
#'   ans
#' }
#'
#' dummy_transformator <- teal_transform_module(
#'   label = "Dummy Transform",
#'   ui = function(id) div("(does nothing)"),
#'   server = function(id, data) {
#'     moduleServer(id, function(input, output, session) data)
#'   }
#' )
#'
#' plot_transformator <- teal_transform_module(
#'   label = "Plot Settings",
#'   ui = function(id) div("(does nothing)"),
#'   server = function(id, data) {
#'     moduleServer(id, function(input, output, session) data)
#'   }
#' )
#'
#' static_decorator <- teal_transform_module(
#'   label = "Static decorator",
#'   server = function(id, data) {
#'     moduleServer(id, function(input, output, session) {
#'       reactive({
#'         req(data())
#'         within(data(), {
#'           plot <- plot +
#'             ggtitle("This is title") +
#'             xlab("x axis")
#'         })
#'       })
#'     })
#'   }
#' )
#'
#' complete_modules <- modules(
#'   custom_module(
#'     label = "Data Overview",
#'     datanames = c("ADSL", "ADAE", "ADVS"),
#'     ui_args = list(
#'       view_type = "table",
#'       page_size = 10,
#'       filters = c("ARM", "SEX", "RACE"),
#'       decorators = list(static_decorator)
#'     ),
#'     server_args = list(
#'       cache = TRUE,
#'       debounce = 1000,
#'       decorators = list(static_decorator)
#'     ),
#'     transformators = list(dummy_transformator),
#'     bk = TRUE
#'   ),
#'   modules(
#'     label = "Nested 1",
#'     custom_module(
#'       label = "Interactive Plots",
#'       datanames = c("ADSL", "ADVS"),
#'       ui_args = list(
#'         plot_type = c("scatter", "box", "line"),
#'         height = 600,
#'         width = 800,
#'         color_scheme = "viridis"
#'       ),
#'       server_args = list(
#'         render_type = "svg",
#'         cache_plots = TRUE
#'       ),
#'       transformators = list(dummy_transformator, plot_transformator),
#'       bk = TRUE
#'     ),
#'     modules(
#'       label = "Nested 2",
#'       custom_module(
#'         label = "Summary Statistics",
#'         datanames = "ADSL",
#'         ui_args = list(
#'           stats = c("mean", "median", "sd", "range"),
#'           grouping = c("ARM", "SEX")
#'         )
#'       ),
#'       modules(
#'         label = "Labeled nested modules",
#'         custom_module(
#'           label = "Subgroup Analysis",
#'           datanames = c("ADSL", "ADAE"),
#'           ui_args = list(
#'             subgroups = c("AGE", "SEX", "RACE"),
#'             analysis_type = "stratified"
#'           ),
#'           bk = TRUE
#'         )
#'       ),
#'       modules(custom_module(label = "Subgroup Analysis in non-labled modules"))
#'     )
#'   ),
#'   custom_module("Non-nested module")
#' )
#'
#' cat(format(complete_modules))
#' cat(format(complete_modules, what = c("ui_args", "server_args", "transformators")))
#' cat(format(complete_modules, what = c("decorators", "transformators")))
#' @export
format.teal_modules <- function(x, is_root = TRUE, is_last = FALSE, parent_prefix = "", ...) {
  if (is_root) {
    header <- pasten(cli::style_bold("TEAL ROOT"))
    new_parent_prefix <- "  " #' Initial indent for root level
  } else {
    if (!is.null(x$label)) {
      branch <- if (is_last) "L-" else "|-"
      header <- pasten(parent_prefix, branch, " ", cli::style_bold(x$label))
      new_parent_prefix <- paste0(parent_prefix, if (is_last) "   " else "|  ")
    } else {
      header <- ""
      new_parent_prefix <- parent_prefix
    }
  }

  if (length(x$children) > 0) {
    children_output <- character(0)
    n_children <- length(x$children)

    for (i in seq_along(x$children)) {
      child <- x$children[[i]]
      is_last_child <- (i == n_children)

      if (inherits(child, "teal_modules")) {
        children_output <- c(
          children_output,
          format(child,
            is_root = FALSE,
            is_last = is_last_child,
            parent_prefix = new_parent_prefix,
            ...
          )
        )
      } else {
        children_output <- c(
          children_output,
          format(child,
            is_last = is_last_child,
            parent_prefix = new_parent_prefix,
            ...
          )
        )
      }
    }

    paste0(header, paste(children_output, collapse = ""))
  } else {
    header
  }
}

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

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

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

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

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

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

## read modules ----

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


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

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

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

#' 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(
        div(
          # class .teal_validated changes the color of the boarder on error in ui_validate_reactive_teal_data
          #   For details see tealValidate.js file.
          id = ns("wrapper"),
          class = c(class, "teal_validated"),
          title = attr(data_mod, "label"),
          tags$span(
            class = "text-primary mb-4",
            icon("fas fa-square-pen"),
            attr(data_mod, "label")
          ),
          tags$i(
            class = "remove pull-right fa fa-angle-down",
            style = "cursor: pointer;",
            title = "fold/expand transformator panel",
            onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", transform_wrapper_id)
          ),
          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 initializing for { name }.")
          is_transform_failed[[name]] <- FALSE
          data_out <- transformators[[name]]$server("transform", data = data_previous)
          data_handled <- reactive(tryCatch(data_out(), error = function(e) e))
          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"))
              )
            }
          })

          .trigger_on_success(data_handled)
        })
      },
      x = names(transformators),
      init = data
    )
    module_output
  })
}

#' 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)
  tdata <- do.call(
    teal.data::teal_data,
    c(
      list(code = trimws(c(teal.code::get_code(data), hashes), which = "right")),
      list(join_keys = teal.data::join_keys(data)),
      sapply(
        names(data),
        teal.code::get_var,
        object = data,
        simplify = FALSE
      )
    )
  )

  tdata@verified <- data@verified
  tdata
}

#' Get code that tests the integrity of the reproducible data
#'
#' @param data (`teal_data`) object holding the data
#' @param datanames (`character`) names of `datasets`
#'
#' @return A character vector with the code lines.
#' @keywords internal
#'
.get_hashes_code <- function(data, datanames = 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
  )
}

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

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

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

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

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

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

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

    invisible(NULL)
  })
}


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

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


# utilities ----

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

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

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

  ans <- TRUE

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

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

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

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

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

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

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

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

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


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

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

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

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

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

  invisible()
}

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

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

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

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

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

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

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

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

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

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

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

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

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

        mm
      })
    })

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

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

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

    mapping_table # for testing purpose
  })
}

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

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

    module_fd_previous <- reactiveVal(NULL)

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

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

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

      module_fd()$set_filter_state(slices)

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

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

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

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

    slices_module # returned for testing purpose
  })
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

#' Data module for `teal` transformations and output customization
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' `teal_transform_module` provides a `shiny` module that enables data transformations within a `teal` application
#' and allows for customization of outputs generated by modules.
#'
#' # Transforming Module Inputs in `teal`
#'
#' Data transformations occur after data has been filtered in `teal`.
#' The transformed data is then passed to the `server` of [`teal_module()`] and managed by `teal`'s internal processes.
#' The primary advantage of `teal_transform_module` over custom modules is in its error handling, where all warnings and
#' errors are managed by `teal`, allowing developers to focus on transformation logic.
#'
#' For more details, see the vignette: `vignette("data-transform-as-shiny-module", package = "teal")`.
#'
#' # Customizing Module Outputs
#'
#' `teal_transform_module` also allows developers to modify any object created within [`teal.data::teal_data`].
#' This means you can use it to customize not only datasets but also tables, listings, and graphs.
#' Some [`teal_modules`] permit developers to inject custom `shiny` modules to enhance displayed outputs.
#' To manage these `decorators` within your module, use [`ui_transform_teal_data()`] and [`srv_transform_teal_data()`].
#' (For further guidance on managing decorators, refer to `ui_args` and `srv_args` in the vignette documentation.)
#'
#' See the vignette `vignette("decorate-modules-output", package = "teal")` for additional examples.
#'
#' # `server` as a language
#'
#' The `server` function in `teal_transform_module` must return a reactive [`teal.data::teal_data`] object.
#' For simple transformations without complex reactivity, the `server` function might look like this:s
#'
#' ```
#' function(id, data) {
#'   moduleServer(id, function(input, output, session) {
#'     reactive({
#'       within(
#'         data(),
#'         expr = x <- subset(x, col == level),
#'         level = input$level
#'       )
#'     })
#'   })
#' }
#' ```
#'
#' The example above can be simplified using `make_teal_transform_server`, where `level` is automatically matched to the
#' corresponding `input` parameter:
#'
#' ```
#' make_teal_transform_server(expr = expression(x <- subset(x, col == level)))
#' ```
#' @inheritParams teal_data_module
#' @param server (`function(id, data)` or `expression`)
#' A `shiny` module server function that takes `id` and `data` as arguments, where `id` is the module id and `data`
#' is the reactive `teal_data` input. The `server` function must return a reactive expression containing a `teal_data`
#' object. For simplified syntax, use [`make_teal_transform_server()`].
#' @param datanames (`character`)
#' Specifies the names of datasets relevant to the module. Only filters for the specified `datanames` will be displayed
#' in the filter panel. The keyword `"all"` can be used to display filters for all datasets. `datanames` are
#' automatically appended to the [`modules()`] `datanames`.
#'
#'
#' @examples
#' data_transformators <- list(
#'   teal_transform_module(
#'     label = "Static transformator for iris",
#'     datanames = "iris",
#'     server = function(id, data) {
#'       moduleServer(id, function(input, output, session) {
#'         reactive({
#'           within(data(), {
#'             iris <- head(iris, 5)
#'           })
#'         })
#'       })
#'     }
#'   ),
#'   teal_transform_module(
#'     label = "Interactive transformator for iris",
#'     datanames = "iris",
#'     ui = function(id) {
#'       ns <- NS(id)
#'       tags$div(
#'         numericInput(ns("n_cols"), "Show n columns", value = 5, min = 1, max = 5, step = 1)
#'       )
#'     },
#'     server = function(id, data) {
#'       moduleServer(id, function(input, output, session) {
#'         reactive({
#'           within(data(),
#'             {
#'               iris <- iris[, 1:n_cols]
#'             },
#'             n_cols = input$n_cols
#'           )
#'         })
#'       })
#'     }
#'   )
#' )
#'
#' output_decorator <- teal_transform_module(
#'   server = make_teal_transform_server(
#'     expression(
#'       object <- rev(object)
#'     )
#'   )
#' )
#'
#' app <- init(
#'   data = teal_data(iris = iris),
#'   modules = example_module(
#'     transformators = data_transformators,
#'     decorators = list(output_decorator)
#'   )
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @name teal_transform_module
#'
#' @export
teal_transform_module <- function(ui = NULL,
                                  server = function(id, data) data,
                                  label = "transform module",
                                  datanames = "all") {
  structure(
    list(
      ui = ui,
      server = function(id, data) {
        data_out <- server(id, data)

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


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

#' Make teal_transform_module's server
#'
#' A factory function to simplify creation of a [`teal_transform_module`]'s server. Specified `expr`
#' is wrapped in a shiny module function and output can be passed to the `server` argument in
#' [teal_transform_module()] call. Such a server function can be linked with ui and values from the
#' inputs can be used in the expression. Object names specified in the expression will be substituted
#' with the value of the respective input (matched by the name) - for example in
#' `expression(graph <- graph + ggtitle(title))` object `title` will be replaced with the value of
#' `input$title`.
#' @param expr (`language`)
#'  An R call which will be evaluated within [`teal.data::teal_data`] environment.
#' @return `function(id, data)` returning `shiny` module
#' @examples
#'
#' trim_iris <- teal_transform_module(
#'   label = "Simplified interactive transformator for iris",
#'   datanames = "iris",
#'   ui = function(id) {
#'     ns <- NS(id)
#'     numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
#'   },
#'   server = make_teal_transform_server(expression(iris <- head(iris, n_rows)))
#' )
#'
#' app <- init(
#'   data = teal_data(iris = iris),
#'   modules = example_module(transformators = trim_iris)
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#'
#' @export
make_teal_transform_server <- function(expr) {
  if (is.call(expr)) {
    expr <- as.expression(expr)
  }
  checkmate::assert_multi_class(expr, c("call", "expression"))

  function(id, data) {
    moduleServer(id, function(input, output, session) {
      list_env <- reactive(
        lapply(rlang::set_names(names(input)), function(x) input[[x]])
      )

      reactive({
        call_with_inputs <- lapply(expr, function(x) {
          do.call(what = substitute, args = list(expr = x, env = list_env()))
        })
        eval_code(object = data(), code = as.expression(call_with_inputs))
      })
    })
  }
}

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

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

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

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

  # argument checking (independent)
  ## `data`
  checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))

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

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

  # log
  teal.logger::log_system_info()

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

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

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

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

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

    is_modules_ok <- check_modules_datanames(modules, names(data))
    if (!isTRUE(is_modules_ok) && length(unlist(extract_transformators(modules))) == 0) {
      warning(is_modules_ok, call. = FALSE)
    }

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

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

  # argument transformations
  ## `modules` - landing module
  landing <- extract_module(modules, "teal_module_landing")
  modules <- drop_module(modules, "teal_module_landing")


  if (lifecycle::is_present(id)) {
    lifecycle::deprecate_soft(
      when = "0.15.3",
      what = "init(id)",
      details = paste(
        "To wrap `teal` application within other shiny application please use",
        "`ui_teal()` and `srv_teal()` and call them as regular shiny modules."
      )
    )
    checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
  } else {
    id <- character(0)
  }
  ns <- NS(id)

  # Note: UI must be a function to support bookmarking.
  res <- structure(
    list(
      ui = function(request) {
        fluidPage(
          title = tags$div(
            id = "teal-app-title",
            tags$head(
              tags$title("teal app"),
              tags$link(
                rel = "icon",
                href = .teal_favicon,
                sizes = "any"
              )
            )
          ),
          tags$header(
            id = "teal-header",
            tags$div(id = "teal-header-content")
          ),
          ui_teal(
            id = "teal",
            modules = modules
          ),
          tags$footer(
            id = "teal-footer",
            tags$div(id = "teal-footer-content"),
            ui_session_info("teal-footer-session_info")
          )
        )
      },
      server = function(input, output, session) {
        srv_teal(id = "teal", data = data, modules = modules, filter = deep_copy_filter(filter))
        srv_session_info("teal-footer-session_info")
      }
    ),
    class = c("teal_app", "list")
  )

  if (lifecycle::is_present(title)) {
    lifecycle::deprecate_soft(
      when = "0.15.3",
      what = "init(title)",
      details = paste(
        "Use `modify_title()` on the teal app object instead.",
        "See ?modify_title for examples and more details."
      )
    )
    checkmate::assert_multi_class(title, c("shiny.tag", "shiny.tag.list", "html", "character"))
    res <- modify_title(res, title)
  }
  if (lifecycle::is_present(header)) {
    lifecycle::deprecate_soft(
      when = "0.15.3",
      what = "init(header)",
      details = paste(
        "Use `modify_header()` on the teal app object instead.",
        "See ?modify_header for examples and more details."
      )
    )
    checkmate::assert_multi_class(header, c("shiny.tag", "shiny.tag.list", "html", "character"))
    res <- modify_header(res, header)
  }
  if (lifecycle::is_present(footer)) {
    lifecycle::deprecate_soft(
      when = "0.15.3",
      what = "init(footer)",
      details = paste(
        "Use `modify_footer()` on the teal app object instead.",
        "See ?modify_footer for examples and more details."
      )
    )
    checkmate::assert_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html", "character"))
    res <- modify_footer(res, footer)
  }

  if (length(landing) == 1L) {
    lifecycle::deprecate_soft(
      when = "0.15.3",
      what = "landing_popup_module()",
      details = paste(
        "`landing_popup_module()` is deprecated.",
        "Use add_landing_modal() on the teal app object instead."
      )
    )
    res <- teal_extend_server(res, function(input, output, session) {
      do.call(landing[[1L]]$server, c(list(id = "landing_module_shiny_id")))
    })
  } else if (length(landing) > 1L) {
    stop("Only one `landing_popup_module` can be used.")
  }

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

  res
}

#' Replace UI Elements in `teal` UI objects
#'
#' @param x (`teal_app`) A `teal_app` object created using the `init` function.
#' @param element Replacement UI element (shiny tag or HTML)
#' @param title (`shiny.tag` or `character(1)`) The new title to be used.
#' @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/`.
#' If the favicon is `NULL` the `teal` logo will be used as the favicon.
#' @name teal_modifiers
#' @rdname teal_modifiers
#'
#' @keywords internal
#'
NULL


#' @rdname teal_modifiers
#' @keywords internal
#' @noRd
#' @param x One of:
#'   - A `teal_app` object created using the `init` function.
#'   - A `teal_module`, `teal_data_module`, or `teal_transform_module` object.
#'   - A Shiny module UI function with `id` parameter
#' @param selector (`character(1)`) CSS selector to find elements to replace
teal_replace_ui <- function(x, selector, element) {
  if (inherits(x, c("teal_app", "teal_module", "teal_data_module", "teal_transform_module"))) {
    x$ui <- teal_replace_ui(x$ui, selector, element)
    x
  } else if (checkmate::test_function(x, args = "request")) {
    # shiny ui function from teal_app
    function(request) {
      ui_tq <- htmltools::tagQuery(x(request = request))
      ui_tq$find(selector)$empty()$append(element)$allTags()
    }
  } else if (checkmate::test_function(x, args = "id")) {
    # shiny module ui function
    function(id, ...) {
      ui_tq <- htmltools::tagQuery(x(id = id, ...))
      if (grepl("^#[a-zA-Z0-9_-]+$", selector)) {
        selector <- paste0("#", NS(id, gsub("^#", "", selector)))
      }
      ui_tq$find(selector)$empty()$append(element)$allTags()
    }
  } else {
    stop("Invalid UI object")
  }
}

#' @rdname teal_modifiers
#' @export
#' @examples
#' app <- init(
#'   data = teal_data(IRIS = iris, MTCARS = mtcars),
#'   modules = modules(example_module())
#' ) |>
#'   modify_title(title = "Custom title")
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
modify_title <- function(
    x,
    title = "teal app",
    favicon = NULL) {
  checkmate::assert_multi_class(x, "teal_app")
  checkmate::assert_multi_class(title, c("shiny.tag", "shiny.tag.list", "html", "character"))
  checkmate::assert_string(favicon, null.ok = TRUE)
  if (is.null(favicon)) {
    favicon <- .teal_favicon
  }
  teal_replace_ui(
    x,
    "#teal-app-title",
    tags$head(
      tags$title(title),
      tags$link(
        rel = "icon",
        href = favicon,
        sizes = "any"
      )
    )
  )
}

#' @rdname teal_modifiers
#' @export
#' @examples
#' app <- init(
#'   data = teal_data(IRIS = iris),
#'   modules = modules(example_module())
#' ) |>
#'   modify_header(element = tags$div(h3("Custom header")))
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
modify_header <- function(x, element = tags$p()) {
  checkmate::assert_multi_class(x, "teal_app")
  checkmate::assert_multi_class(element, c("shiny.tag", "shiny.tag.list", "html", "character"))
  teal_replace_ui(x, "#teal-header-content", element)
}

#' @rdname teal_modifiers
#' @export
#' @examples
#' app <- init(
#'   data = teal_data(IRIS = iris),
#'   modules = modules(example_module())
#' ) |>
#'   modify_footer(element = "Custom footer")
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
modify_footer <- function(x, element = tags$p()) {
  checkmate::assert_multi_class(x, "teal_app")
  checkmate::assert_multi_class(element, c("shiny.tag", "shiny.tag.list", "html", "character"))
  teal_replace_ui(x, "#teal-footer-content", element)
}

#' Add a Landing Popup to `teal` Application
#'
#' @description Adds a landing popup to the `teal` app. This popup will be shown when the app starts.
#' The dialog must be closed by the app user to proceed to the main application.
#'
#' @param x (`teal_app`) A `teal_app` object created using the `init` function.
#' @inheritParams shiny::modalDialog
#' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup.
#' @param ... Additional arguments to [shiny::modalDialog()].
#' @export
#' @examples
#' app <- init(
#'   data = teal_data(IRIS = iris, MTCARS = mtcars),
#'   modules = modules(example_module())
#' ) |>
#'   add_landing_modal(
#'     title = "Welcome",
#'     content = "This is a landing popup.",
#'     buttons = modalButton("Accept")
#'   )
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
add_landing_modal <- function(
    x,
    title = NULL,
    content = NULL,
    footer = modalButton("Accept"),
    ...) {
  checkmate::assert_class(x, "teal_app")
  custom_server <- function(input, output, session) {
    checkmate::assert_string(title, null.ok = TRUE)
    checkmate::assert_multi_class(
      content,
      classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
    )
    checkmate::assert_multi_class(footer, classes = c("shiny.tag", "shiny.tag.list"))
    showModal(
      modalDialog(
        id = "landingpopup",
        title = title,
        content,
        footer = footer,
        ...
      )
    )
  }
  teal_extend_server(x, custom_server)
}

#' Add a Custom Server Logic to `teal` Application
#'
#' @description Adds a custom server function to the `teal` app. This function can define additional server logic.
#'
#' @param x (`teal_app`) A `teal_app` object created using the `init` function.
#' @param custom_server (`function(input, output, session)` or `function(id, ...)`)
#'    The custom server function or server module to set.
#' @param module_id (`character(1)`) The ID of the module when a module server function is passed.
#' @keywords internal
teal_extend_server <- function(x, custom_server, module_id = character(0)) {
  checkmate::assert_class(x, "teal_app")
  checkmate::assert_function(custom_server)
  old_server <- x$server

  x$server <- function(input, output, session) {
    old_server(input, output, session)
    if (all(c("input", "output", "session") %in% names(formals(custom_server)))) {
      callModule(custom_server, module_id)
    } else if ("id" %in% names(formals(custom_server))) {
      custom_server(module_id)
    }
  }
  x
}

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

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

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

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

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

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

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

    ns <- session$ns

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

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

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

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

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

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

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

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

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

    snapshot_history
  })
}

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

#' @rdname module_data_summary
srv_data_summary <- function(id, 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)),
                icon(
                  name = "far fa-circle-question",
                  title = 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)
}

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

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

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

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

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

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

#' 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_module
#' @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)
  tagList(
    div(
      id = ns("validate_messages"),
      class = "teal_validated",
      ui_validate_error(ns("silent_error")),
      ui_check_class_teal_data(ns("class_teal_data")),
      ui_check_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
}

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

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

  bs_theme
}

#' Return parentnames along with datanames.
#' @noRd
#' @keywords internal
.include_parent_datanames <- function(datanames, join_keys) {
  ordered_datanames <- datanames
  for (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.15.3",
    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)

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

#' `teal` main module
#'
#' @description
#' `r lifecycle::badge("stable")`
#' 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 `reporter_previewer_module`, `module_session_info`, or UI components like
#' `header`, `footer`, and `title` which can be added separately in the Shiny app consuming this module.
#'
#' 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)

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

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

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

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

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

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

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

    data_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")) {
        "ok"
      } else if (inherits(data, "teal_data_module")) {
        "teal_data_module failed"
      } else {
        "external failed"
      }
    })

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



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

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

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

  invisible(NULL)
}

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

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

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

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

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

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

  ui_teal <- tagList(
    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)
    )
  )

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

#' @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"),
                            is_active = 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")
  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"),
                                    is_active = reactive(TRUE)) {
  stop("Modules class not supported: ", paste(class(modules), collapse = " "))
}

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

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

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

    modules_output
  })
}

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

    active_datanames <- reactive({
      .resolve_module_datanames(data = data(), 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)

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

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

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

  message("Initializing reporter_previewer_module")

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

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

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

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

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

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

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

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

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


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

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


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

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

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


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

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


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

setOldClass("teal_data_module")

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

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

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

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

#' An example `teal` module
#'
#' `r lifecycle::badge("experimental")`
#'
#' This module creates an object called `object` that can be modified with decorators.
#' The `object` is determined by what's selected in `Choose a dataset` input in UI.
#' The object can be anything that can be handled by `renderPrint()`.
#' See the `vignette("decorate-modules-output", package = "teal")` or [`teal_transform_module`]
#' to read more about decorators.
#'
#' @inheritParams teal_modules
#' @param decorators `r lifecycle::badge("experimental")` (`list` of `teal_transform_module`) optional,
#' decorator for `object` included in the module.
#'
#' @return A `teal` module which can be included in the `modules` argument to [init()].
#' @examples
#' app <- init(
#'   data = teal_data(IRIS = iris, MTCARS = mtcars),
#'   modules = example_module()
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#' @export
example_module <- function(label = "example teal module",
                           datanames = "all",
                           transformators = list(),
                           decorators = list()) {
  checkmate::assert_string(label)
  checkmate::assert_list(decorators, "teal_transform_module")

  ans <- module(
    label,
    server = function(id, data, decorators) {
      checkmate::assert_class(isolate(data()), "teal_data")
      moduleServer(id, function(input, output, session) {
        datanames_rv <- reactive(names(req(data())))
        observeEvent(datanames_rv(), {
          selected <- input$dataname
          if (identical(selected, "")) {
            selected <- restoreInput(session$ns("dataname"), NULL)
          } else if (isFALSE(selected %in% datanames_rv())) {
            selected <- datanames_rv()[1]
          }
          updateSelectInput(
            session = session,
            inputId = "dataname",
            choices = datanames_rv(),
            selected = selected
          )
        })

        table_data <- reactive({
          req(input$dataname)
          within(data(),
            {
              object <- dataname
            },
            dataname = as.name(input$dataname)
          )
        })

        table_data_decorated_no_print <- srv_transform_teal_data(
          "decorate",
          data = table_data,
          transformators = decorators
        )
        table_data_decorated <- reactive(within(req(table_data_decorated_no_print()), expr = object))

        output$text <- renderPrint({
          req(table_data()) # Ensure original errors from module are displayed
          table_data_decorated()[["object"]]
        })

        teal.widgets::verbatim_popup_srv(
          id = "rcode",
          verbatim_content = reactive(teal.code::get_code(req(table_data_decorated()))),
          title = "Example Code"
        )

        table_data_decorated
      })
    },
    ui = function(id, decorators) {
      ns <- NS(id)
      teal.widgets::standard_layout(
        output = verbatimTextOutput(ns("text")),
        encoding = tags$div(
          selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
          ui_transform_teal_data(ns("decorate"), transformators = decorators),
          teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
        )
      )
    },
    ui_args = list(decorators = decorators),
    server_args = list(decorators = decorators),
    datanames = datanames,
    transformators = transformators
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

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

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

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

### internal functions

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

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

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

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

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

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

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

#' `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")
  data@code <- c(data@code, code2list(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
}

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

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

#' Include `JS` files from `/inst/js/` package directory to application header
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`. Therefore, we redefine this method in each package
#' as needed. Thus, we do not export this method
#'
#' @param pattern (`character`) pattern of files to be included, passed to `system.file`
#' @param except (`character`) vector of basename filenames to be excluded
#'
#' @return HTML code that includes `JS` files.
#' @keywords internal
include_js_files <- function(pattern = NULL, except = NULL) {
  checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)
  js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
  js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL

  singleton(lapply(js_files, includeScript))
}

#' Run `JS` file from `/inst/js/` package directory
#'
#' This is triggered from the server to execute on the client
#' rather than triggered directly on the client.
#' Unlike `include_js_files` which includes `JavaScript` functions,
#' the `run_js` actually executes `JavaScript` functions.
#'
#' `system.file` should not be used to access files in other packages, it does
#' not work with `devtools`. Therefore, we redefine this method in each package
#' as needed. Thus, we do not export this method.
#'
#' @param files (`character`) vector of filenames.
#'
#' @return `NULL`, invisibly.
#' @keywords internal
run_js_files <- function(files) {
  checkmate::assert_character(files, min.len = 1, any.missing = FALSE)
  lapply(files, function(file) {
    shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
  })
  invisible(NULL)
}

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

#' 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.15.3",
    what = "ui_teal_with_splash()",
    details = "Deprecated, 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.15.3",
    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")
}

#' `teal` user session info module
#'
#' Module to display the user session info popup and to download a lockfile.
#'
#' @rdname module_session_info
#' @name module_session_info
#'
#' @inheritParams module_teal
#'
#' @examples
#' ui <- fluidPage(
#'   ui_session_info("session_info")
#' )
#'
#' server <- function(input, output, session) {
#'   srv_session_info("session_info")
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @return `NULL` invisibly
NULL

#' @rdname module_session_info
#' @export
ui_session_info <- function(id) {
  ns <- NS(id)
  tags$div(
    teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
    br(),
    ui_teal_lockfile(ns("lockfile")),
    textOutput(ns("identifier"))
  )
}

#' @rdname module_session_info
#' @export
srv_session_info <- function(id) {
  moduleServer(id, function(input, output, session) {
    srv_teal_lockfile("lockfile")

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

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

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

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	div(
40		# class .teal_validated changes the color of the boarder on error in ui_validate_reactive_teal_data
41		# For details see tealValidate.js file.
42	1x	id = ns("wrapper"),
43	1x	class = c(class, "teal_validated"),
44	1x	title = attr(data_mod, "label"),
45	1x	tags$span(
46	1x	class = "text-primary mb-4",
47	1x	icon("fas fa-square-pen"),
48	1x	attr(data_mod, "label")
49		),
50	1x	tags$i(
51	1x	class = "remove pull-right fa fa-angle-down",
52	1x	style = "cursor: pointer;",
53	1x	title = "fold/expand transformator panel",
54	1x	onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", transform_wrapper_id)
55		),
56	1x	tags$div(
57	1x	id = transform_wrapper_id,
58	1x	if (is.null(data_mod$ui)) {
59	!	return(NULL)
60		} else {
61	1x	data_mod$ui(id = ns("transform"))
62		},
63	1x	div(
64	1x	id = ns("validate_messages"),
65	1x	class = "teal_validated",
66	1x	uiOutput(ns("error_wrapper"))
67		)
68		)
69		)
70		)
71		}
72		)
73		}
74
75		#' @export
76		#' @rdname module_transform_data
77		srv_transform_teal_data <- function(id, data, transformators, modules = NULL, is_transform_failed = reactiveValues()) {
78	95x	checkmate::assert_string(id)
79	95x	assert_reactive(data)
80	95x	checkmate::assert_class(modules, "teal_module", null.ok = TRUE)
81	95x	if (length(transformators) == 0L) {
82	72x	return(data)
83		}
84	23x	if (inherits(transformators, "teal_transform_module")) {
85	3x	transformators <- list(transformators)
86		}
87	23x	checkmate::assert_list(transformators, "teal_transform_module", null.ok = TRUE)
88	23x	names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))
89
90	23x	moduleServer(id, function(input, output, session) {
91	23x	module_output <- Reduce(
92	23x	function(data_previous, name) {
93	26x	moduleServer(name, function(input, output, session) {
94	26x	logger::log_debug("srv_transform_teal_data initializing for { name }.")
95	26x	is_transform_failed[[name]] <- FALSE
96	26x	data_out <- transformators[[name]]$server("transform", data = data_previous)
97	26x	data_handled <- reactive(tryCatch(data_out(), error = function(e) e))
98	26x	observeEvent(data_handled(), {
99	32x	if (inherits(data_handled(), "teal_data")) {
100	22x	is_transform_failed[[name]] <- FALSE
101		} else {
102	10x	is_transform_failed[[name]] <- TRUE
103		}
104		})
105
106	26x	is_previous_failed <- reactive({
107	29x	idx_this <- which(names(is_transform_failed) == name)
108	29x	is_transform_failed_list <- reactiveValuesToList(is_transform_failed)
109	29x	idx_failures <- which(unlist(is_transform_failed_list))
110	29x	any(idx_failures < idx_this)
111		})
112
113	26x	srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
114	26x	srv_check_class_teal_data("class_teal_data", data_handled)
115	26x	if (!is.null(modules)) {
116	20x	srv_check_module_datanames("datanames_warning", data_handled, modules)
117		}
118
119		# When there is no UI (`ui = NULL`) it should still show the errors
120	26x	observe({
121	32x	if (!inherits(data_handled(), "teal_data") && !is_previous_failed()) {
122	10x	shinyjs::show("wrapper")
123		}
124		})
125
126	26x	transform_wrapper_id <- sprintf("wrapper_%s", name)
127	26x	output$error_wrapper <- renderUI({
128	29x	if (is_previous_failed()) {
129	!	shinyjs::disable(transform_wrapper_id)
130	!	tags$div("One of previous transformators failed. Please check its inputs.", class = "teal-output-warning")
131		} else {
132	29x	shinyjs::enable(transform_wrapper_id)
133	29x	shiny::tagList(
134	29x	ui_validate_error(session$ns("silent_error")),
135	29x	ui_check_class_teal_data(session$ns("class_teal_data")),
136	29x	ui_check_module_datanames(session$ns("datanames_warning"))
137		)
138		}
139		})
140
141	26x	.trigger_on_success(data_handled)
142		})
143		},
144	23x	x = names(transformators),
145	23x	init = data
146		)
147	23x	module_output
148		})
149		}

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.15.3",
19	!	what = "show_rcode_modal()",
20	!	details = "This function will be removed in the next release."
21		)
22
23	!	rcode <- paste(rcode, collapse = "\n")
24
25	!	ns <- session$ns
26	!	showModal(modalDialog(
27	!	tagList(
28	!	tags$div(
29	!	actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
30	!	modalButton("Dismiss"),
31	!	style = "mb-4"
32		),
33	!	tags$div(tags$pre(id = ns("r_code"), rcode)),
34		),
35	!	title = title,
36	!	footer = tagList(
37	!	actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
38	!	modalButton("Dismiss")
39		),
40	!	size = "l",
41	!	easyClose = TRUE
42		))
43		}

1		#' 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	9x	ns <- shiny::NS(id)
39	9x	shiny::div(
40	9x	id = ns("content"),
41	9x	style = "display: inline-block; width: 100%;",
42	9x	uiOutput(ns("data"))
43		)
44		}
45
46		#' @rdname module_init_data
47		srv_init_data <- function(id, data) {
48	87x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
49	87x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
50
51	87x	moduleServer(id, function(input, output, session) {
52	87x	logger::log_debug("srv_data initializing.")
53	87x	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	87x	} else if (inherits(data, "teal_data")) {
57	47x	reactiveVal(data)
58	87x	} else if (test_reactive(data)) {
59	30x	data
60		}
61
62	86x	data_handled <- reactive({
63	81x	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	86x	observeEvent(data_handled(), {
68	81x	if (inherits(data_handled(), "teal_data")) {
69	76x	app_session <- .subset2(shiny::getDefaultReactiveDomain(), "parent")
70	76x	setBookmarkExclude(
71	76x	session$ns(
72	76x	grep(
73	76x	pattern = "teal_data_module-",
74	76x	x = names(reactiveValuesToList(input)),
75	76x	value = TRUE
76		)
77		),
78	76x	session = app_session
79		)
80		}
81		})
82
83	86x	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	76x	hashes <- .get_hashes_code(data)
93	76x	tdata <- do.call(
94	76x	teal.data::teal_data,
95	76x	c(
96	76x	list(code = trimws(c(teal.code::get_code(data), hashes), which = "right")),
97	76x	list(join_keys = teal.data::join_keys(data)),
98	76x	sapply(
99	76x	names(data),
100	76x	teal.code::get_var,
101	76x	object = data,
102	76x	simplify = FALSE
103		)
104		)
105		)
106
107	76x	tdata@verified <- data@verified
108	76x	tdata
109		}
110
111		#' Get code that tests the integrity of the reproducible data
112		#'
113		#' @param data (`teal_data`) object holding the data
114		#' @param datanames (`character`) names of `datasets`
115		#'
116		#' @return A character vector with the code lines.
117		#' @keywords internal
118		#'
119		.get_hashes_code <- function(data, datanames = names(data)) {
120	76x	vapply(
121	76x	datanames,
122	76x	function(dataname, datasets) {
123	134x	x <- data[[dataname]]
124
125	134x	code <- if (is.function(x) && !is.primitive(x)) {
126	6x	x <- deparse1(x)
127	6x	bquote(rlang::hash(deparse1(.(as.name(dataname)))))
128		} else {
129	128x	bquote(rlang::hash(.(as.name(dataname))))
130		}
131	134x	sprintf(
132	134x	"stopifnot(%s == %s) # @linksto %s",
133	134x	deparse1(code),
134	134x	deparse1(rlang::hash(x)),
135	134x	dataname
136		)
137		},
138	76x	character(1L),
139	76x	USE.NAMES = TRUE
140		)
141		}

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

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

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	90x	.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	90x	data <- eval_code(
56	90x	data,
57	90x	paste0(
58	90x	".raw_data <- list2env(list(",
59	90x	toString(sprintf("%1$s = %1$s", sapply(datanames, as.name))),
60	90x	"))\n",
61	90x	"lockEnvironment(.raw_data) # @linksto .raw_data" # this is environment and it is shared by qenvs. CAN'T MODIFY!
62		)
63		)
64	90x	filtered_code <- .get_filter_expr(datasets = datasets, datanames = datanames)
65	90x	filtered_teal_data <- .append_evaluated_code(data, filtered_code)
66	90x	filtered_datasets <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)
67	90x	filtered_teal_data <- .append_modified_data(filtered_teal_data, filtered_datasets)
68	90x	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	287x	if (length(datanames)) {
107	281x	teal.slice::get_filter_expr(datasets = datasets, datanames = datanames)
108		} else {
109	6x	NULL
110		}
111		}

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

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

1		#' 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("data-transform-as-shiny-module", 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("decorate-modules-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		#'
64		#' @examples
65		#' data_transformators <- list(
66		#' teal_transform_module(
67		#' label = "Static transformator for iris",
68		#' datanames = "iris",
69		#' server = function(id, data) {
70		#' moduleServer(id, function(input, output, session) {
71		#' reactive({
72		#' within(data(), {
73		#' iris <- head(iris, 5)
74		#' })
75		#' })
76		#' })
77		#' }
78		#' ),
79		#' teal_transform_module(
80		#' label = "Interactive transformator for iris",
81		#' datanames = "iris",
82		#' ui = function(id) {
83		#' ns <- NS(id)
84		#' tags$div(
85		#' numericInput(ns("n_cols"), "Show n columns", value = 5, min = 1, max = 5, step = 1)
86		#' )
87		#' },
88		#' server = function(id, data) {
89		#' moduleServer(id, function(input, output, session) {
90		#' reactive({
91		#' within(data(),
92		#' {
93		#' iris <- iris[, 1:n_cols]
94		#' },
95		#' n_cols = input$n_cols
96		#' )
97		#' })
98		#' })
99		#' }
100		#' )
101		#' )
102		#'
103		#' output_decorator <- teal_transform_module(
104		#' server = make_teal_transform_server(
105		#' expression(
106		#' object <- rev(object)
107		#' )
108		#' )
109		#' )
110		#'
111		#' app <- init(
112		#' data = teal_data(iris = iris),
113		#' modules = example_module(
114		#' transformators = data_transformators,
115		#' decorators = list(output_decorator)
116		#' )
117		#' )
118		#' if (interactive()) {
119		#' shinyApp(app$ui, app$server)
120		#' }
121		#'
122		#' @name teal_transform_module
123		#'
124		#' @export
125		teal_transform_module <- function(ui = NULL,
126		server = function(id, data) data,
127		label = "transform module",
128		datanames = "all") {
129	25x	structure(
130	25x	list(
131	25x	ui = ui,
132	25x	server = function(id, data) {
133	26x	data_out <- server(id, data)
134
135	26x	if (inherits(data_out, "reactive.event")) {
136		# This warning message partially detects when `eventReactive` is used in `data_module`.
137	1x	warning(
138	1x	"teal_transform_module() ",
139	1x	"Using eventReactive in teal_transform module server code should be avoided as it ",
140	1x	"may lead to unexpected behavior. See the vignettes for more information ",
141	1x	"(`vignette(\"data-transform-as-shiny-module\", package = \"teal\")`).",
142	1x	call. = FALSE
143		)
144		}
145
146
147	26x	decorate_err_msg(
148	26x	assert_reactive(data_out),
149	26x	pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
150	26x	post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
151		)
152		}
153		),
154	25x	label = label,
155	25x	datanames = datanames,
156	25x	class = c("teal_transform_module", "teal_data_module")
157		)
158		}
159
160		#' Make teal_transform_module's server
161		#'
162		#' A factory function to simplify creation of a [`teal_transform_module`]'s server. Specified `expr`
163		#' is wrapped in a shiny module function and output can be passed to the `server` argument in
164		#' [teal_transform_module()] call. Such a server function can be linked with ui and values from the
165		#' inputs can be used in the expression. Object names specified in the expression will be substituted
166		#' with the value of the respective input (matched by the name) - for example in
167		#' `expression(graph <- graph + ggtitle(title))` object `title` will be replaced with the value of
168		#' `input$title`.
169		#' @param expr (`language`)
170		#' An R call which will be evaluated within [`teal.data::teal_data`] environment.
171		#' @return `function(id, data)` returning `shiny` module
172		#' @examples
173		#'
174		#' trim_iris <- teal_transform_module(
175		#' label = "Simplified interactive transformator for iris",
176		#' datanames = "iris",
177		#' ui = function(id) {
178		#' ns <- NS(id)
179		#' numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
180		#' },
181		#' server = make_teal_transform_server(expression(iris <- head(iris, n_rows)))
182		#' )
183		#'
184		#' app <- init(
185		#' data = teal_data(iris = iris),
186		#' modules = example_module(transformators = trim_iris)
187		#' )
188		#' if (interactive()) {
189		#' shinyApp(app$ui, app$server)
190		#' }
191		#'
192		#' @export
193		make_teal_transform_server <- function(expr) {
194	3x	if (is.call(expr)) {
195	1x	expr <- as.expression(expr)
196		}
197	3x	checkmate::assert_multi_class(expr, c("call", "expression"))
198
199	3x	function(id, data) {
200	3x	moduleServer(id, function(input, output, session) {
201	3x	list_env <- reactive(
202	3x	lapply(rlang::set_names(names(input)), function(x) input[[x]])
203		)
204
205	3x	reactive({
206	4x	call_with_inputs <- lapply(expr, function(x) {
207	4x	do.call(what = substitute, args = list(expr = x, env = list_env()))
208		})
209	4x	eval_code(object = data(), code = as.expression(call_with_inputs))
210		})
211		})
212		}
213		}
214
215		#' Extract all `transformators` from `modules`.
216		#'
217		#' @param modules `teal_modules` or `teal_module`
218		#' @return A list of `teal_transform_module` nested in the same way as input `modules`.
219		#' @keywords internal
220		extract_transformators <- function(modules) {
221	10x	if (inherits(modules, "teal_module")) {
222	5x	modules$transformators
223	5x	} else if (inherits(modules, "teal_modules")) {
224	5x	lapply(modules$children, extract_transformators)
225		}
226		}

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

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		#' @examples
52		#' app <- init(
53		#' data = teal_data(IRIS = iris, MTCARS = mtcars),
54		#' modules = modules(example_module())
55		#' ) \|>
56		#' modify_title(title = "Custom title")
57		#'
58		#' if (interactive()) {
59		#' shinyApp(app$ui, app$server)
60		#' }
61		modify_title <- function(
62		x,
63		title = "teal app",
64		favicon = NULL) {
65	!	checkmate::assert_multi_class(x, "teal_app")
66	!	checkmate::assert_multi_class(title, c("shiny.tag", "shiny.tag.list", "html", "character"))
67	!	checkmate::assert_string(favicon, null.ok = TRUE)
68	!	if (is.null(favicon)) {
69	!	favicon <- .teal_favicon
70		}
71	!	teal_replace_ui(
72	!	x,
73	!	"#teal-app-title",
74	!	tags$head(
75	!	tags$title(title),
76	!	tags$link(
77	!	rel = "icon",
78	!	href = favicon,
79	!	sizes = "any"
80		)
81		)
82		)
83		}
84
85		#' @rdname teal_modifiers
86		#' @export
87		#' @examples
88		#' app <- init(
89		#' data = teal_data(IRIS = iris),
90		#' modules = modules(example_module())
91		#' ) \|>
92		#' modify_header(element = tags$div(h3("Custom header")))
93		#'
94		#' if (interactive()) {
95		#' shinyApp(app$ui, app$server)
96		#' }
97		modify_header <- function(x, element = tags$p()) {
98	!	checkmate::assert_multi_class(x, "teal_app")
99	!	checkmate::assert_multi_class(element, c("shiny.tag", "shiny.tag.list", "html", "character"))
100	!	teal_replace_ui(x, "#teal-header-content", element)
101		}
102
103		#' @rdname teal_modifiers
104		#' @export
105		#' @examples
106		#' app <- init(
107		#' data = teal_data(IRIS = iris),
108		#' modules = modules(example_module())
109		#' ) \|>
110		#' modify_footer(element = "Custom footer")
111		#'
112		#' if (interactive()) {
113		#' shinyApp(app$ui, app$server)
114		#' }
115		modify_footer <- function(x, element = tags$p()) {
116	!	checkmate::assert_multi_class(x, "teal_app")
117	!	checkmate::assert_multi_class(element, c("shiny.tag", "shiny.tag.list", "html", "character"))
118	!	teal_replace_ui(x, "#teal-footer-content", element)
119		}
120
121		#' Add a Landing Popup to `teal` Application
122		#'
123		#' @description Adds a landing popup to the `teal` app. This popup will be shown when the app starts.
124		#' The dialog must be closed by the app user to proceed to the main application.
125		#'
126		#' @param x (`teal_app`) A `teal_app` object created using the `init` function.
127		#' @inheritParams shiny::modalDialog
128		#' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup.
129		#' @param ... Additional arguments to [shiny::modalDialog()].
130		#' @export
131		#' @examples
132		#' app <- init(
133		#' data = teal_data(IRIS = iris, MTCARS = mtcars),
134		#' modules = modules(example_module())
135		#' ) \|>
136		#' add_landing_modal(
137		#' title = "Welcome",
138		#' content = "This is a landing popup.",
139		#' buttons = modalButton("Accept")
140		#' )
141		#'
142		#' if (interactive()) {
143		#' shinyApp(app$ui, app$server)
144		#' }
145		add_landing_modal <- function(
146		x,
147		title = NULL,
148		content = NULL,
149		footer = modalButton("Accept"),
150		...) {
151	!	checkmate::assert_class(x, "teal_app")
152	!	custom_server <- function(input, output, session) {
153	!	checkmate::assert_string(title, null.ok = TRUE)
154	!	checkmate::assert_multi_class(
155	!	content,
156	!	classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
157		)
158	!	checkmate::assert_multi_class(footer, classes = c("shiny.tag", "shiny.tag.list"))
159	!	showModal(
160	!	modalDialog(
161	!	id = "landingpopup",
162	!	title = title,
163	!	content,
164	!	footer = footer,
165		...
166		)
167		)
168		}
169	!	teal_extend_server(x, custom_server)
170		}
171
172		#' Add a Custom Server Logic to `teal` Application
173		#'
174		#' @description Adds a custom server function to the `teal` app. This function can define additional server logic.
175		#'
176		#' @param x (`teal_app`) A `teal_app` object created using the `init` function.
177		#' @param custom_server (`function(input, output, session)` or `function(id, ...)`)
178		#' The custom server function or server module to set.
179		#' @param module_id (`character(1)`) The ID of the module when a module server function is passed.
180		#' @keywords internal
181		teal_extend_server <- function(x, custom_server, module_id = character(0)) {
182	!	checkmate::assert_class(x, "teal_app")
183	!	checkmate::assert_function(custom_server)
184	!	old_server <- x$server
185
186	!	x$server <- function(input, output, session) {
187	!	old_server(input, output, session)
188	!	if (all(c("input", "output", "session") %in% names(formals(custom_server)))) {
189	!	callModule(custom_server, module_id)
190	!	} else if ("id" %in% names(formals(custom_server))) {
191	!	custom_server(module_id)
192		}
193		}
194	!	x
195		}

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

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	!	content_id <- ns("filters_overview_contents")
27	!	tags$div(
28	!	id = id,
29	!	class = "well",
30	!	tags$div(
31	!	class = "row",
32	!	tags$div(
33	!	class = "col-sm-9",
34	!	tags$label("Active Filter Summary", class = "text-primary mb-4")
35		),
36	!	tags$div(
37	!	class = "col-sm-3",
38	!	tags$i(
39	!	class = "remove pull-right fa fa-angle-down",
40	!	style = "cursor: pointer;",
41	!	title = "fold/expand data summary panel",
42	!	onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", content_id)
43		)
44		)
45		),
46	!	tags$div(
47	!	id = content_id,
48	!	tags$div(
49	!	class = "teal_active_summary_filter_panel",
50	!	tableOutput(ns("table"))
51		)
52		)
53		)
54		}
55
56		#' @rdname module_data_summary
57		srv_data_summary <- function(id, data) {
58	87x	assert_reactive(data)
59	87x	moduleServer(
60	87x	id = id,
61	87x	function(input, output, session) {
62	87x	logger::log_debug("srv_data_summary initializing")
63
64	87x	summary_table <- reactive({
65	95x	req(inherits(data(), "teal_data"))
66	89x	if (!length(data())) {
67	!	return(NULL)
68		}
69	89x	get_filter_overview_wrapper(data)
70		})
71
72	87x	output$table <- renderUI({
73	95x	summary_table_out <- try(summary_table(), silent = TRUE)
74	95x	if (inherits(summary_table_out, "try-error")) {
75		# Ignore silent shiny error
76	6x	if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
77	!	stop("Error occurred during data processing. See details in the main panel.")
78		}
79	89x	} else if (is.null(summary_table_out)) {
80	2x	"no datasets to show"
81		} else {
82	87x	is_unsupported <- apply(summary_table(), 1, function(x) all(is.na(x[-1])))
83	87x	summary_table_out[is.na(summary_table_out)] <- ""
84	87x	body_html <- apply(
85	87x	summary_table_out,
86	87x	1,
87	87x	function(x) {
88	163x	is_supported <- !all(x[-1] == "")
89	163x	if (is_supported) {
90	154x	tags$tr(
91	154x	tagList(
92	154x	tags$td(x[1]),
93	154x	lapply(x[-1], tags$td)
94		)
95		)
96		}
97		}
98		)
99
100	87x	header_labels <- tools::toTitleCase(names(summary_table_out))
101	87x	header_labels[header_labels == "Dataname"] <- "Data Name"
102	87x	header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))
103
104	87x	table_html <- tags$table(
105	87x	class = "table custom-table",
106	87x	tags$thead(header_html),
107	87x	tags$tbody(body_html)
108		)
109	87x	div(
110	87x	table_html,
111	87x	if (any(is_unsupported)) {
112	9x	p(
113	9x	class = c("pull-right", "float-right", "text-secondary"),
114	9x	style = "font-size: 0.8em;",
115	9x	sprintf("And %s more unfilterable object(s)", sum(is_unsupported)),
116	9x	icon(
117	9x	name = "far fa-circle-question",
118	9x	title = paste(
119	9x	sep = "",
120	9x	collapse = "\n",
121	9x	shQuote(summary_table()[is_unsupported, "dataname"]),
122		" (",
123	9x	vapply(
124	9x	summary_table()[is_unsupported, "dataname"],
125	9x	function(x) class(data()[[x]])[1],
126	9x	character(1L)
127		),
128		")"
129		)
130		)
131		)
132		}
133		)
134		}
135		})
136
137	87x	NULL
138		}
139		)
140		}
141
142		#' @rdname module_data_summary
143		get_filter_overview_wrapper <- function(teal_data) {
144		# Sort datanames in topological order
145	89x	datanames <- names(teal_data())
146	89x	joinkeys <- teal.data::join_keys(teal_data())
147
148	89x	current_data_objs <- sapply(
149	89x	datanames,
150	89x	function(name) teal_data()[[name]],
151	89x	simplify = FALSE
152		)
153	89x	initial_data_objs <- teal_data()[[".raw_data"]]
154
155	89x	out <- lapply(
156	89x	datanames,
157	89x	function(dataname) {
158	158x	parent <- teal.data::parent(joinkeys, dataname)
159	158x	subject_keys <- if (length(parent) > 0) {
160	8x	names(joinkeys[dataname, parent])
161		} else {
162	150x	joinkeys[dataname, dataname]
163		}
164	158x	get_filter_overview(
165	158x	current_data = current_data_objs[[dataname]],
166	158x	initial_data = initial_data_objs[[dataname]],
167	158x	dataname = dataname,
168	158x	subject_keys = subject_keys
169		)
170		}
171		)
172
173	89x	do.call(.smart_rbind, out)
174		}
175
176
177		#' @rdname module_data_summary
178		#' @param current_data (`object`) current object (after filtering and transforming).
179		#' @param initial_data (`object`) initial object.
180		#' @param dataname (`character(1)`)
181		#' @param subject_keys (`character`) names of the columns which determine a single unique subjects
182		get_filter_overview <- function(current_data, initial_data, dataname, subject_keys) {
183	163x	if (inherits(current_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
184	153x	get_filter_overview_array(current_data, initial_data, dataname, subject_keys)
185	10x	} else if (inherits(current_data, "MultiAssayExperiment")) {
186	1x	get_filter_overview_MultiAssayExperiment(current_data, initial_data, dataname)
187		} else {
188	9x	data.frame(dataname = dataname)
189		}
190		}
191
192		#' @rdname module_data_summary
193		get_filter_overview_array <- function(current_data,
194		initial_data,
195		dataname,
196		subject_keys) {
197	153x	if (length(subject_keys) == 0) {
198	139x	data.frame(
199	139x	dataname = dataname,
200	139x	obs = if (!is.null(initial_data)) {
201	128x	sprintf("%s/%s", nrow(current_data), nrow(initial_data))
202		} else {
203	11x	nrow(current_data)
204		}
205		)
206		} else {
207	14x	data.frame(
208	14x	dataname = dataname,
209	14x	obs = if (!is.null(initial_data)) {
210	13x	sprintf("%s/%s", nrow(current_data), nrow(initial_data))
211		} else {
212	1x	nrow(current_data)
213		},
214	14x	subjects = if (!is.null(initial_data)) {
215	13x	sprintf("%s/%s", nrow(unique(current_data[subject_keys])), nrow(unique(initial_data[subject_keys])))
216		} else {
217	1x	nrow(unique(current_data[subject_keys]))
218		}
219		)
220		}
221		}
222
223		#' @rdname module_data_summary
224		get_filter_overview_MultiAssayExperiment <- function(current_data, # nolint: object_length, object_name.
225		initial_data,
226		dataname) {
227	1x	experiment_names <- names(current_data)
228	1x	mae_info <- data.frame(
229	1x	dataname = dataname,
230	1x	subjects = if (!is.null(initial_data)) {
231	!	sprintf("%s/%s", nrow(current_data@colData), nrow(initial_data@colData))
232		} else {
233	1x	nrow(current_data@colData)
234		}
235		)
236
237	1x	experiment_obs_info <- do.call("rbind", lapply(
238	1x	experiment_names,
239	1x	function(experiment_name) {
240	5x	transform(
241	5x	get_filter_overview(
242	5x	current_data[[experiment_name]],
243	5x	initial_data[[experiment_name]],
244	5x	dataname = experiment_name,
245	5x	subject_keys = join_keys() # empty join keys
246		),
247	5x	dataname = paste0(" - ", experiment_name)
248		)
249		}
250		))
251
252	1x	get_experiment_keys <- function(mae, experiment) {
253	5x	sample_subset <- mae@sampleMap[mae@sampleMap$colname %in% colnames(experiment), ]
254	5x	length(unique(sample_subset$primary))
255		}
256
257	1x	experiment_subjects_info <- do.call("rbind", lapply(
258	1x	experiment_names,
259	1x	function(experiment_name) {
260	5x	data.frame(
261	5x	subjects = if (!is.null(initial_data)) {
262	!	sprintf(
263	!	"%s/%s",
264	!	get_experiment_keys(current_data, current_data[[experiment_name]]),
265	!	get_experiment_keys(current_data, initial_data[[experiment_name]])
266		)
267		} else {
268	5x	get_experiment_keys(current_data, current_data[[experiment_name]])
269		}
270		)
271		}
272		))
273
274	1x	experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)
275	1x	.smart_rbind(mae_info, experiment_info)
276		}

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

1		#' 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_module
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	!	tagList(
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	115x	ns <- NS(id)
155	115x	uiOutput(ns("message"))
156		}
157
158		#' @keywords internal
159		srv_validate_error <- function(id, data, validate_shiny_silent_error) {
160	112x	checkmate::assert_string(id)
161	112x	checkmate::assert_flag(validate_shiny_silent_error)
162	112x	moduleServer(id, function(input, output, session) {
163	112x	output$message <- renderUI({
164	113x	is_shiny_silent_error <- inherits(data(), "shiny.silent.error") && identical(data()$message, "")
165	113x	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	111x	} else if (inherits(data(), "error")) {
178	11x	if (is_shiny_silent_error && !validate_shiny_silent_error) {
179	4x	return(NULL)
180		}
181	7x	validate(
182	7x	need(
183	7x	FALSE,
184	7x	sprintf(
185	7x	"Shiny error when executing the `data` module.\n%s\n%s",
186	7x	data()$message,
187	7x	"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	115x	ns <- NS(id)
200	115x	uiOutput(ns("message"))
201		}
202
203		#' @keywords internal
204		srv_check_class_teal_data <- function(id, data) {
205	112x	checkmate::assert_string(id)
206	112x	moduleServer(id, function(input, output, session) {
207	112x	output$message <- renderUI({
208	113x	validate(
209	113x	need(
210	113x	inherits(data(), c("teal_data", "error")),
211	113x	"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	115x	ns <- NS(id)
221	115x	uiOutput(NS(id, "message"))
222		}
223
224		#' @keywords internal
225		srv_check_module_datanames <- function(id, data, modules) {
226	193x	checkmate::assert_string(id)
227	193x	moduleServer(id, function(input, output, session) {
228	193x	output$message <- renderUI({
229	198x	if (inherits(data(), "teal_data")) {
230	181x	is_modules_ok <- check_modules_datanames_html(
231	181x	modules = modules, datanames = names(data())
232		)
233	181x	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	112x	out <- reactiveVal(NULL)
243	112x	observeEvent(data(), {
244	113x	if (inherits(data(), "teal_data")) {
245	98x	if (!identical(data(), out())) {
246	98x	out(data())
247		}
248		}
249		})
250
251	112x	out
252		}

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	87x	script <- sprintf(
19	87x	"Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",
20	87x	ns("timezone")
21		)
22	87x	shinyjs::runjs(script) # function does not return anything
23	87x	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	return(NULL)
34		}
35
36	3x	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 Shiny Bootstrap theme will be used."
41		)
42	2x	return(NULL)
43		}
44
45	1x	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	84x	checkmate::assert_class(x, "teal_data")
75	84x	checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)
76		# Otherwise, FilteredData will be created in the modules' scope later
77	84x	teal.slice::init_filtered_data(
78	84x	x = Filter(length, sapply(datanames, function(dn) x[[dn]], simplify = FALSE)),
79	84x	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	192x	reserved_datanames <- datanames[datanames %in% c("all", ".raw_data")]
143	192x	if (length(reserved_datanames) == 0L) {
144	186x	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	192x	check_datanames <- check_modules_datanames_recursive(modules, datanames)
161	192x	show_module_info <- inherits(modules, "teal_modules") # used in two contexts - module and app
162
163	192x	reserved_datanames <- check_reserved_datanames(datanames)
164
165	192x	if (!length(check_datanames)) {
166	174x	out <- if (is.null(reserved_datanames)) {
167	168x	TRUE
168		} else {
169	6x	shiny::tagList(reserved_datanames)
170		}
171	174x	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	299x	checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
216	299x	checkmate::assert_character(datanames)
217	299x	if (inherits(modules, "teal_modules")) {
218	87x	unlist(
219	87x	lapply(modules$children, check_modules_datanames_recursive, datanames = datanames),
220	87x	recursive = FALSE
221		)
222		} else {
223	212x	missing_datanames <- setdiff(modules$datanames, c("all", datanames))
224	212x	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	87x	checkmate::assert_class(filters, "teal_slices")
263	87x	checkmate::assert_character(datanames)
264
265		# check teal_slices against datanames
266	87x	out <- unlist(sapply(
267	87x	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	87x	if (length(out)) {
282	3x	paste(out, collapse = "\n")
283		} else {
284	84x	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.15.3",
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	21x	rlang::hash(list(data = data, modules = modules))
363		}
364
365		#' Go through list and extract bodies of encountered functions as string, recursively.
366		#' @keywords internal
367		#' @noRd
368		defunction <- function(x) {
369	297x	if (is.list(x)) {
370	169x	lapply(x, defunction)
371	128x	} else if (is.function(x)) {
372	54x	deparse1(body(x))
373		} else {
374	74x	x
375		}
376		}
377
378		#' Get unique labels
379		#'
380		#' Get unique labels for the modules to avoid namespace conflicts.
381		#'
382		#' @param labels (`character`) vector of labels
383		#'
384		#' @return (`character`) vector of unique labels
385		#'
386		#' @keywords internal
387		get_unique_labels <- function(labels) {
388	152x	make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
389		}
390
391		#' @keywords internal
392		#' @noRd
393	4x	pasten <- function(...) paste0(..., "\n")
394
395		#' Convert character list to human readable html with commas and "and"
396		#' @noRd
397		paste_datanames_character <- function(x,
398		tags = list(span = shiny::tags$span, code = shiny::tags$code),
399		tagList = shiny::tagList) { # nolint: object_name.
400	!	checkmate::assert_character(x)
401	!	do.call(
402	!	tagList,
403	!	lapply(seq_along(x), function(.ix) {
404	!	tagList(
405	!	tags$code(x[.ix]),
406	!	if (.ix != length(x)) {
407	!	tags$span(if (.ix == length(x) - 1) " and " else ", ")
408		}
409		)
410		})
411		)
412		}
413
414		#' Build datanames error string for error message
415		#'
416		#' tags and tagList are overwritten in arguments allowing to create strings for
417		#' logging purposes
418		#' @noRd
419		build_datanames_error_message <- function(label = NULL,
420		datanames,
421		extra_datanames,
422		tags = list(span = shiny::tags$span, code = shiny::tags$code),
423		tagList = shiny::tagList) { # nolint: object_name.
424	!	tags$span(
425	!	tags$span(pluralize(extra_datanames, "Dataset")),
426	!	paste_datanames_character(extra_datanames, tags, tagList),
427	!	tags$span(
428	!	sprintf(
429	!	"%s missing%s",
430	!	pluralize(extra_datanames, "is", "are"),
431	!	if (is.null(label)) "" else sprintf(" for tab '%s'", label)
432		)
433		),
434	!	if (length(datanames) >= 1) {
435	!	tagList(
436	!	tags$span(pluralize(datanames, "Dataset")),
437	!	tags$span("available in data:"),
438	!	tagList(
439	!	tags$span(
440	!	paste_datanames_character(datanames, tags, tagList),
441	!	tags$span(".", .noWS = "outside"),
442	!	.noWS = c("outside")
443		)
444		)
445		)
446		} else {
447	!	tags$span("No datasets are available in data.")
448		}
449		)
450		}
451
452		#' Smart `rbind`
453		#'
454		#' Combine `data.frame` objects which have different columns
455		#'
456		#' @param ... (`data.frame`)
457		#' @keywords internal
458		.smart_rbind <- function(...) {
459	90x	dots <- list(...)
460	90x	checkmate::assert_list(dots, "data.frame", .var.name = "...")
461	90x	Reduce(
462	90x	x = dots,
463	90x	function(x, y) {
464	72x	all_columns <- union(colnames(x), colnames(y))
465	72x	x[setdiff(all_columns, colnames(x))] <- NA
466	72x	y[setdiff(all_columns, colnames(y))] <- NA
467	72x	rbind(x, y)
468		}
469		)
470		}
471
472		#' Pluralize a word depending on the size of the input
473		#'
474		#' @param x (`object`) to check length for plural.
475		#' @param singular (`character`) singular form of the word.
476		#' @param plural (optional `character`) plural form of the word. If not given an "s"
477		#' is added to the singular form.
478		#'
479		#' @return A `character` that correctly represents the size of the `x` argument.
480		#' @keywords internal
481		pluralize <- function(x, singular, plural = NULL) {
482	70x	checkmate::assert_string(singular)
483	70x	checkmate::assert_string(plural, null.ok = TRUE)
484	70x	if (length(x) == 1L) { # Zero length object should use plural form.
485	42x	singular
486		} else {
487	28x	if (is.null(plural)) {
488	12x	sprintf("%ss", singular)
489		} else {
490	16x	plural
491		}
492		}
493		}

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

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	33x	checkmate::assert_function(ui, args = "id", nargs = 1)
64	32x	checkmate::assert_function(server, args = "id", nargs = 1)
65	30x	checkmate::assert_string(label)
66	30x	checkmate::assert_flag(once)
67	30x	structure(
68	30x	list(
69	30x	ui = ui,
70	30x	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	30x	label = label,
80	30x	class = "teal_data_module",
81	30x	once = once
82		)
83		}

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

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

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

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

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

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

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

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

1		#' 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	1131x	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	1127x	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		#' `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	90x	checkmate::assert_class(data, "teal_data")
22	90x	data@code <- c(data@code, code2list(code))
23	90x	methods::validObject(data)
24	90x	data
25		}
26
27		#' @rdname teal_data_utilities
28		.append_modified_data <- function(data, objects) {
29	90x	checkmate::assert_class(data, "teal_data")
30	90x	checkmate::assert_class(objects, "list")
31	90x	new_env <- list2env(objects, parent = .GlobalEnv)
32	90x	rlang::env_coalesce(new_env, as.environment(data))
33	90x	data@.xData <- new_env
34	90x	data
35		}

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