teal coverage - 57.62%

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

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

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

#' 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/`
#' @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 = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
  checkmate::assert_multi_class(x, "teal_app")
  checkmate::assert_multi_class(title, c("shiny.tag", "shiny.tag.list", "html", "character"))
  checkmate::assert_string(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
}

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

#' 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") {
  checkmate::assert_string(title, null.ok = TRUE)
  checkmate::assert_string(favicon, null.ok = TRUE)
  lifecycle::deprecate_soft(
    when = "0.15.3",
    what = "build_app_title()",
    details = "Use `modify_title()` on the object created using the `init`."
  )
  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
    }
  }
}

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

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

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

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

# FilteredData ------

#' Drive a `teal` application
#'
#' Extension of the `shinytest2::AppDriver` class with methods for
#' driving a teal application for performing interactions for `shinytest2` tests.
#'
#' @keywords internal
#'
TealAppDriver <- R6::R6Class( # nolint: object_name.
  "TealAppDriver",
  inherit = {
    lapply(c("testthat", "shinytest2", "rvest"), function(.x, use_testthat) {
      if (!requireNamespace(.x, quietly = TRUE)) {
        if (use_testthat) {
          testthat::skip(sprintf("%s is not installed", .x))
        } else {
          stop("Please install '", .x, "' package to use this class.", call. = FALSE)
        }
      }
    }, use_testthat = requireNamespace("testthat", quietly = TRUE) && testthat::is_testing())
    shinytest2::AppDriver
  },
  # public methods ----
  public = list(
    #' @description
    #' Initialize a `TealAppDriver` object for testing a `teal` application.
    #'
    #' @param data,modules,filter arguments passed to `init`
    #' @param title_args,header,footer,landing_popup_args to pass into the modifier functions.
    #' @param timeout (`numeric`) Default number of milliseconds for any timeout or
    #' timeout_ parameter in the `TealAppDriver` class.
    #' Defaults to 20s.
    #'
    #' See [`shinytest2::AppDriver`] `new` method for more details on how to change it
    #' via options or environment variables.
    #' @param load_timeout (`numeric`) How long to wait for the app to load, in ms.
    #' This includes the time to start R. Defaults to 100s.
    #'
    #' See [`shinytest2::AppDriver`] `new` method for more details on how to change it
    #' via options or environment variables
    #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$new`
    #'
    #'
    #' @return  Object of class `TealAppDriver`
    initialize = function(data,
                          modules,
                          filter = teal_slices(),
                          title_args = list(),
                          header = tags$p(),
                          footer = tags$p(),
                          landing_popup_args = NULL,
                          timeout = rlang::missing_arg(),
                          load_timeout = rlang::missing_arg(),
                          ...) {
      private$data <- data
      private$modules <- modules
      private$filter <- filter

      new_title <- modifyList(
        list(
          title = "Custom Teal App Title",
          favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/teal.png"
        ),
        title_args
      )
      app <- init(
        data = data,
        modules = modules,
        filter = filter
      ) |>
        modify_title(title = new_title$title, favicon = new_title$favicon) |>
        modify_header(header) |>
        modify_footer(footer)

      if (!is.null(landing_popup_args)) {
        default_args <- list(
          title = NULL,
          content = NULL,
          footer = modalButton("Accept")
        )
        landing_popup_args[names(default_args)] <- Map(
          function(x, y) if (is.null(y)) x else y,
          default_args,
          landing_popup_args[names(default_args)]
        )
        app <- add_landing_modal(
          app,
          title = landing_popup_args$title,
          content = landing_popup_args$content,
          footer = landing_popup_args$footer
        )
      }

      # Default timeout is hardcoded to 4s in shinytest2:::resolve_timeout
      # It must be set as parameter to the AppDriver
      suppressWarnings(
        super$initialize(
          app_dir = shinyApp(app$ui, app$server),
          name = "teal",
          variant = shinytest2::platform_variant(),
          timeout = rlang::maybe_missing(timeout, 20 * 1000),
          load_timeout = rlang::maybe_missing(load_timeout, 100 * 1000),
          ...
        )
      )

      # Check for minimum version of Chrome that supports the tests
      #  - Element.checkVisibility was added on 105
      chrome_version <- numeric_version(
        gsub(
          "[[:alnum:]_]+/", # Prefix that ends with forward slash

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

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

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		# FilteredData ------
2
3		#' Drive a `teal` application
4		#'
5		#' Extension of the `shinytest2::AppDriver` class with methods for
6		#' driving a teal application for performing interactions for `shinytest2` tests.
7		#'
8		#' @keywords internal
9		#'
10		TealAppDriver <- R6::R6Class( # nolint: object_name.
11		"TealAppDriver",
12		inherit = {
13		lapply(c("testthat", "shinytest2", "rvest"), function(.x, use_testthat) {
14		if (!requireNamespace(.x, quietly = TRUE)) {
15		if (use_testthat) {
16		testthat::skip(sprintf("%s is not installed", .x))
17		} else {
18		stop("Please install '", .x, "' package to use this class.", call. = FALSE)
19		}
20		}
21		}, use_testthat = requireNamespace("testthat", quietly = TRUE) && testthat::is_testing())
22		shinytest2::AppDriver
23		},
24		# public methods ----
25		public = list(
26		#' @description
27		#' Initialize a `TealAppDriver` object for testing a `teal` application.
28		#'
29		#' @param data,modules,filter arguments passed to `init`
30		#' @param title_args,header,footer,landing_popup_args to pass into the modifier functions.
31		#' @param timeout (`numeric`) Default number of milliseconds for any timeout or
32		#' timeout_ parameter in the `TealAppDriver` class.
33		#' Defaults to 20s.
34		#'
35		#' See [`shinytest2::AppDriver`] `new` method for more details on how to change it
36		#' via options or environment variables.
37		#' @param load_timeout (`numeric`) How long to wait for the app to load, in ms.
38		#' This includes the time to start R. Defaults to 100s.
39		#'
40		#' See [`shinytest2::AppDriver`] `new` method for more details on how to change it
41		#' via options or environment variables
42		#' @param ... Additional arguments to be passed to `shinytest2::AppDriver$new`
43		#'
44		#'
45		#' @return Object of class `TealAppDriver`
46		initialize = function(data,
47		modules,
48		filter = teal_slices(),
49		title_args = list(),
50		header = tags$p(),
51		footer = tags$p(),
52		landing_popup_args = NULL,
53		timeout = rlang::missing_arg(),
54		load_timeout = rlang::missing_arg(),
55		...) {
56	!	private$data <- data
57	!	private$modules <- modules
58	!	private$filter <- filter
59
60	!	new_title <- modifyList(
61	!	list(
62	!	title = "Custom Teal App Title",
63	!	favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/teal.png"
64		),
65	!	title_args
66		)
67	!	app <- init(
68	!	data = data,
69	!	modules = modules,
70	!	filter = filter
71		) \|>
72	!	modify_title(title = new_title$title, favicon = new_title$favicon) \|>
73	!	modify_header(header) \|>
74	!	modify_footer(footer)
75
76	!	if (!is.null(landing_popup_args)) {
77	!	default_args <- list(
78	!	title = NULL,
79	!	content = NULL,
80	!	footer = modalButton("Accept")
81		)
82	!	landing_popup_args[names(default_args)] <- Map(
83	!	function(x, y) if (is.null(y)) x else y,
84	!	default_args,
85	!	landing_popup_args[names(default_args)]
86		)
87	!	app <- add_landing_modal(
88	!	app,
89	!	title = landing_popup_args$title,
90	!	content = landing_popup_args$content,
91	!	footer = landing_popup_args$footer
92		)
93		}
94
95		# Default timeout is hardcoded to 4s in shinytest2:::resolve_timeout
96		# It must be set as parameter to the AppDriver
97	!	suppressWarnings(
98	!	super$initialize(
99	!	app_dir = shinyApp(app$ui, app$server),
100	!	name = "teal",
101	!	variant = shinytest2::platform_variant(),
102	!	timeout = rlang::maybe_missing(timeout, 20 * 1000),
103	!	load_timeout = rlang::maybe_missing(load_timeout, 100 * 1000),
104		...
105		)
106		)
107
108		# Check for minimum version of Chrome that supports the tests
109		# - Element.checkVisibility was added on 105
110	!	chrome_version <- numeric_version(
111	!	gsub(
112	!	"[[:alnum:]_]+/", # Prefix that ends with forward slash