teal coverage - 84.37%

Files
Source

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

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

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

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

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

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

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

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

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

        mm
      })
    })

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

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

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

    mapping_table # for testing purpose
  })
}

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

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

    module_fd_previous <- reactiveVal(NULL)

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

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

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

      module_fd()$set_filter_state(slices)

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

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

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

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

    slices_module # returned for testing purpose
  })
}

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

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

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

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

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

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

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

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

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

  message("Initializing reporter_previewer_module")

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

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

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

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

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

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

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

  opts
}

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

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

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

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

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

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


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

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

    invisible(NULL)
  })
}


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

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


# utilities ----

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

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

#' Apply `teal_transform_module` decorators to reactive `teal_data`
#'
#' @description
#' Shiny module pair (`srv_transform_teal_data` / `ui_transform_teal_data`) that runs a sequence
#' of [teal_transform_module()] decorators against a reactive `teal_data` object.
#' Decorators are applied one after another via `Reduce`, so each one receives the output of the
#' previous as its `data` argument.
#' Failed transformators are tracked and any downstream transformator is automatically disabled
#' until the failure is resolved.
#' An optional `expr` argument allows additional code to be evaluated on the final decorated output.
#'
#' @inheritParams module_validate_error
#' @inheritParams teal_modules
#' @param transformators (`list` of `teal_transform_module`) decorator modules to apply sequentially
#'   to `data`. Each transformator receives the output of the previous one as input.
#' @return `reactive` `teal_data`
#' @seealso [assert_decorators()]
#' @examples
#' library(shiny)
#' library(teal.data)
#'
#' # A decorator that sets a fixed title on a ggplot2 object named `plot`
#' 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 + ggplot2::ggtitle("Decorated title")
#'         })
#'       })
#'     })
#'   }
#' )
#'
#' if (interactive()) {
#'   shinyApp(
#'     ui = fluidPage(
#'       ui_transform_teal_data("decorate", transformators = list(static_decorator)),
#'       plotOutput("plot")
#'     ),
#'     server = function(input, output, session) {
#'       data <- reactive(
#'         teal_data(
#'           plot = ggplot2::ggplot(iris, ggplot2::aes(Sepal.Length, Sepal.Width)) +
#'             ggplot2::geom_point()
#'         )
#'       )
#'       decorated <- srv_transform_teal_data(
#'         "decorate",
#'         data = data,
#'         transformators = list(static_decorator)
#'       )
#'       output$plot <- renderPlot(decorated()[["plot"]])
#'     }
#'   )
#' }
#' @name module_transform_data
NULL

#' @rdname module_transform_data
#' @param expr (`expression` or `reactive`) optional expression evaluated on top of the decorated
#'   output. Useful for post-processing after all transformators have run.
#' @param modules `r lifecycle::badge("deprecated")` No longer used.
#' @param is_transform_failed `r lifecycle::badge("deprecated")` No longer used.
#' @export
srv_transform_teal_data <- function(id,
                                    data,
                                    transformators,
                                    modules = NULL,
                                    is_transform_failed = reactiveValues(),
                                    expr) {
  checkmate::assert_class(data, classes = "reactive")

  if (!missing(modules)) {
    lifecycle::deprecate_warn(
      when = "1.2.0",
      what = "srv_transform_teal_data(modules)",
      details = "Argument is used only in the internal of teal and will be removed in the next release."
    )
  }

  if (!missing(is_transform_failed)) {
    lifecycle::deprecate_warn(
      when = "1.2.0",
      what = "srv_transform_teal_data(is_transform_failed)",
      details = "Argument is used only in the internal of teal and will be removed in the next release."
    )
  }

  decorated_output <- .srv_transform_teal_data(
    id,
    data = data,
    transformators = transformators,
    modules = modules,
    is_transform_failed = is_transform_failed
  )

  no_expr <- missing(expr)

  reactive({
    data_out <- try(data(), silent = TRUE)
    # Report error on data to the user
    if (inherits(data_out, "qenv.error")) {
      validate("Data passed has errors.")
    }

    # ensure errors on transformators are displayed
    do <- req(decorated_output())
    if (inherits(do, "qenv.error")) {
      validate(as.character(do))
    }

    # Append expr if needed
    if (no_expr) {
      do
    } else {
      expr_r <- if (is.reactive(expr)) expr else reactive(expr)
      teal.code::eval_code(do, expr_r())
    }
  })
}


#' @rdname module_transform_data
#' @param class `r lifecycle::badge("deprecated")` No longer used.
#' @param ... additional arguments passed to `.ui_transform_teal_data` (e.g. `class`).
#' @return A `list` of `bslib::accordion` UI elements, one per transformator, or `NULL` if
#'   `transformators` is empty.
#' @export
ui_transform_teal_data <- function(id, transformators, class = "well", ...) {
  if (!missing(class)) {
    lifecycle::deprecate_warn(
      when = "1.2.0",
      what = "ui_transform_teal_data(class)",
      details = "Ability to choose class will be removed in the next release."
    )
  }
  .ui_transform_teal_data(
    id,
    transformators = transformators,
    class = class,
    ...
  )
}

#' Internal module handling list of [teal_transform_module()]
#'
#' This module calls [teal_transform_module()] sequentially by passing output from one step to the next.
#' Modules have error/warning handling feature and highlight containers when something goes wrong.
#' @name module_transform_teal_data_impl
NULL

#' @rdname module_transform_teal_data_impl
#' @inheritParams srv_transform_teal_data
#' @return `shiny.tag`
#' @keywords internal
.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_along(transformators))

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

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

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

#' @rdname module_transform_teal_data_impl
#' @inheritParams ui_transform_teal_data
#' @return `reactive` `teal_data` object
#' @keywords internal
.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_along(transformators))

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

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

            observeEvent(data_handled(), {
              dh <- data_handled()
              if (inherits(dh, "teal_data") && !identical(dh, data_out())) {
                data_out(dh)
              }
            })

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

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

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

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

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

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

    module_output
  })
}

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

#' @rdname module_snapshot_manager
ui_snapshot_manager_panel <- function(id) {
  if (!isTRUE(getOption("teal.snapshot_manager.enable", TRUE))) {
    return(NULL)
  }
  ns <- NS(id)
  .expand_button(
    id = ns("show_snapshot_manager"),
    label = "Snapshot Manager",
    icon = "camera-fill"
  )
}

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

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

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

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

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

    ns <- session$ns

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

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

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

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

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

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

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

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

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

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

    snapshot_history
  })
}

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

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

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

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

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

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

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

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

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

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

      NULL
    }
  )
}

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

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

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

  do.call(.smart_rbind, out)
}


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    onSessionEnded(function() {
      if (!is.null(reporter)) {
        shiny::isolate(reporter$reset())
      }
    })

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

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

    data_ui <- if (inherits(data, "teal_data_module")) data$ui(id = session$ns(.teal_data_module_id))

    has_ui <- !is.null(data_ui)
    is_once <- isTRUE(attr(data, "once"))

    validate_ui <- tags$div(
      id = session$ns("validate_messages"),
      class = "teal_validated",
      ui_check_class_teal_data(session$ns("class_teal_data")),
      ui_validate_error(session$ns("silent_error")),
      ui_check_module_datanames(session$ns("datanames_warning"))
    )


    modal_ui <- reactive({
      # reactive as data_load_status determines if modal opens/reopens with disabled "dismiss" btn
      div(
        class = "teal teal-data-module-popup",
        modalDialog(
          id = session$ns("teal_data_module_ui"),
          size = "xl",
          tags$div(
            data_ui,
            validate_ui
          ),
          easyClose = FALSE,
          footer = tags$div(
            id = session$ns("close_teal_data_module_modal"),
            if (identical(data_load_status(), "ok")) {
              modalButton("Dismiss")
            } else {
              shinyjs::disabled(modalButton("Dismiss"))
            }
          )
        )
      )
    })

    data_reactive <- if (inherits(data, "teal_data_module")) {
      data$server(.teal_data_module_id)
    } else if (inherits(data, "teal_data")) {
      reactiveVal(data)
    } else if (test_reactive(data)) {
      data
    }
    data_handled <- reactive(tryCatch(data_reactive(), error = function(e) e))
    data_validated <- .trigger_on_success(data_handled)
    data_signatured <- reactive({
      req(inherits(data_validated(), "teal_data"))
      is_filter_ok <- check_filter_datanames(filter, names(data_validated()))
      if (!isTRUE(is_filter_ok)) {
        showNotification(
          "Some filters were not applied because of incompatibility with data. Contact app developer.",
          type = "warning",
          duration = 10
        )
        warning(is_filter_ok)
      }
      .add_signature_to_data(data_validated())
    })

    srv_check_class_teal_data("class_teal_data", data_handled)
    srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
    srv_check_module_datanames("datanames_warning", data_handled, modules)


    if (!has_ui) {
      showNotification(
        "Loading data...",
        id = "data_loading",
        duration = NULL,
        type = "message"
      )
    }

    data_load_status <- reactiveVal(NULL)
    observeEvent(data_handled(), {
      removeNotification(id = "data_loading")
      status <- if (inherits(data_handled(), "teal_data")) {
        shinyjs::enable(id = "close_teal_data_module_modal")
        "ok"
      } else if (inherits(data, "teal_data_module")) {
        shinyjs::disable(id = "close_teal_data_module_modal")
        "teal_data_module failed"
      } else {
        "external failed"
      }
      data_load_status(status)
    })

    if (has_ui) {
      showModal(shiny::isolate(modal_ui()))
      # 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 = sprintf("%s-", .teal_data_module_id),
                x = names(reactiveValuesToList(input)),
                value = TRUE
              )
            ),
            session = app_session
          )
        }
      })

      observeEvent(data_signatured(), once = TRUE, {
        logger::log_debug("srv_teal@2 removing data tab.")
        shiny::removeModal()
      })

      if (!is_once) {
        setBookmarkExclude(c("teal_data_module_ui", "open_teal_data_module_ui"))
        .teal_navbar_insert_ui(
          ui = .expand_button(
            id = session$ns("open_teal_data_module_ui"),
            label = "Load Data",
            icon = "database-fill"
          )
        )
        observeEvent(
          input$open_teal_data_module_ui,
          ignoreInit = TRUE,
          ignoreNULL = TRUE,
          {
            showModal(modal_ui())
            if (identical(data_load_status(), "ok")) {
              shinyjs::enable(id = "close_teal_data_module_modal")
            } else {
              shinyjs::disable(id = "close_teal_data_module_modal")
            }
          }
        )
      }
    } else {
      # when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)
      insertUI(
        selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
        where = "beforeBegin",
        ui = tags$div(validate_ui)
      )
    }

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

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

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

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

  invisible(NULL)
}


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

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

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


.teal_data_module_id <- "teal_data_module"

#' Filter panel module in teal
#'
#' Creates filter panel module from `teal_data` object and returns `teal_data`. It is build in a way
#' filter panel recalculates data only when filter-panel-state or loaded-data changes and when
#' panel 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, code = filtered_code, filter_states = datasets$get_filter_state())
  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
  }
}

#' Check decorators list
#'
#' Check if a decorators list is valid and matches the expected output names.
#'
#' @param x (named `list`) of [teal_transform_module()] objects, or nested lists thereof.
#' @param names (`character`) optional vector of valid output names. When provided, all names
#'   in `x` must be one of these names, and names must be unique.
#'
#' @return `TRUE` if valid, otherwise a `character(1)` string describing the problem.
#' @seealso [module_transform_data()]
#' @export
#' @examples
#' decorator <- teal_transform_module(server = function(id, data) data)
#' check_decorators(decorator)
#' check_decorators(list(all = decorator))
#' check_decorators(list(all = decorator, output = decorator))
#' check_decorators(list(all = decorator, output = list(decorator, decorator)))
check_decorators <- function(x, names = NULL) { # nolint: object_name.

  check_message <- checkmate::check_list(x, names = "named")

  if (!is.null(names) && isTRUE(check_message)) {
    if (length(names(x)) != length(unique(names(x)))) {
      check_message <- sprintf(
        "The `decorators` must contain unique names from these names: %s",
        paste(sQuote(names), collapse = ", ")
      )
    } else if (!all(unique(names(x)) %in% c("all", names))) {
      check_message <- sprintf(
        paste0(
          "The `decorators` must be a named list with:\n",
          " * 'all' for decorating all objects and/or\n",
          " * A name from these: %s"
        ),
        paste(sQuote(names), collapse = ", ")
      )
    }
  }

  if (!isTRUE(check_message)) {
    return(check_message)
  }

  valid_elements <- vapply(
    x,
    checkmate::test_class,
    classes = "teal_transform_module",
    FUN.VALUE = logical(1L)
  )

  # Nested list
  if (any(!valid_elements)) {
    valid_nested <- vapply(
      x[!valid_elements], function(subdecorators) {
        checks <- vapply(subdecorators,
          checkmate::test_class,
          classes = "teal_transform_module",
          logical(1L)
        )
        all(checks)
      },
      FUN.VALUE = logical(1L)
    )
    valid_elements[!valid_elements] <- valid_nested
  }

  if (all(valid_elements)) {
    return(TRUE)
  }

  paste(
    "The named list can contain a list of 'teal_transform_module' objects created",
    "using `teal_transform_module()` or be a `teal_transform_module` object."
  )
}

#' @rdname check_decorators
#' @inheritParams checkmate::makeAssertionFunction
#' @param add If an `AssertCollection` is provided, the error message is stored in it.
#' If `NULL`, an exception is raised if res is not `TRUE`.
#' @export
assert_decorators <- checkmate::makeAssertionFunction(check_decorators)

#' Subset decorators based on the scope
#'
#' Subset a named list of decorators, keeping only those matching the requested
#' `scope` together with any decorators registered under the `"all"` name. This is
#' a helper for module developers to resolve the decorators applied to a specific
#' output when a module produces several decorable outputs.
#'
#' @param scope (`character(1)`) a decorator name to include.
#' @param decorators (named `list`) a named list of decorators to subset.
#'
#' @return A `list` of `teal_transform_module` objects matching the given `scope` and `all`.
#' Returns an empty list if `scope` and `all` is not found in `decorators`.
#' @seealso [check_decorators()]
#' @export
#' @examples
#' plot_decorator <- teal_transform_module(server = function(id, data) data)
#' table_decorator <- teal_transform_module(server = function(id, data) data)
#' decorators <- list(all = plot_decorator, table = table_decorator)
#'
#' # Decorators for the "table" output: both "all" and "table" scoped decorators.
#' str(select_decorators(decorators, "table"))
#'
#' # An unknown scope keeps only the "all" decorators.
#' str(select_decorators(decorators, "plot"))
select_decorators <- function(decorators, scope) {
  checkmate::assert_string(scope, null.ok = FALSE)
  assert_decorators(decorators)
  decorators <- decorators[names(decorators) %in% c("all", scope)]
  if (!length(decorators)) {
    return(list())
  }
  Reduce(
    function(acc, el) {
      if (inherits(el, "teal_transform_module")) {
        c(acc, list(el))
      } else {
        c(acc, el)
      }
    },
    x = decorators[names(decorators) %in% c("all", scope)],
    init = list()
  )
}

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


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

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

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

#' @rdname module_teal_module
srv_teal_module <- function(id,
                            data,
                            modules,
                            datasets = NULL,
                            slices_global,
                            reporter = teal.reporter::Reporter$new(),
                            data_load_status = reactive("ok")) {
  moduleServer(id, function(input, output, session) {
    # Send message to JS to get document title
    session$sendCustomMessage("teal-get-document-title", list(inputId = session$ns("app_title")))

    # Wait for both title and active_module_id to be available
    observeEvent(list(input$active_module_id, input$app_title), {
      req(input$app_title)

      app_title <- if (!is.null(input$app_title) && nzchar(input$app_title)) {
        input$app_title
      } else {
        "Teal Application"
      }

      message(
        sprintf(
          "Active module changed: app=\"%s\", module=\"%s\"",
          app_title,
          input$active_module_id
        )
      )
    })

    if (isTRUE(getOption("teal.enable_deep_linking", FALSE))) {
      observeEvent(input$active_module_id, {
        current_query <- shiny::parseQueryString(session$clientData$url_search)
        if (!identical(current_query[["active_module"]], input$active_module_id)) {
          shiny::updateQueryString(
            paste0("?active_module=", input$active_module_id),
            mode = "push",
            session = session
          )
        }
      })
      observeEvent(session$clientData$url_search,
        {
          query <- shiny::parseQueryString(session$clientData$url_search)
          if (
            !is.null(query[["active_module"]]) &&
              !identical(query[["active_module"]], isolate(input$active_module_id))
          ) {
            # updateTabsetPanel works here because the navbar <ul> has class "shiny-tab-input"
            # (see ui_teal_module), which makes Shiny treat it as a tabsetPanel input.
            shiny::updateTabsetPanel(session, "active_module_id", selected = query[["active_module"]])
          }
        },
        ignoreNULL = FALSE
      )
    }
    .srv_teal_module(
      id = "nav",
      data = data,
      modules = modules,
      datasets = datasets,
      slices_global = slices_global,
      reporter = reporter,
      data_load_status = data_load_status,
      active_module_id = reactive(input$active_module_id)
    )
  })
}

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

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

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

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

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

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

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

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

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

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

  list(link = link, tab_pane = tab_pane)
}

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

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

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

    modules_output
  })
}

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

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

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

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

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

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

      summary_table <- srv_data_summary("data_summary", module_teal_data)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#' Set the default bslib theme for teal apps
#' @noRd
#' @keywords internal
.default_teal_bslib_theming <- function() bslib::bs_theme(`font-size-base` = "0.875rem")

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

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

  bs_theme
}

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

  unique(ordered_datanames)
}

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


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

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


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

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

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

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

  reserved_datanames <- check_reserved_datanames(datanames)

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

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

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


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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

  out
}

#' Executes modifications to the result of a module
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Exported to be able to use methods not to be used directly by module-developers or app-users.
#' Primarily used to modify the output object of module.
#' @seealso [disable_src()], [disable_report()]
#' @param x (`teal_module` or `teal_modules`).
#' @param server (`function(input, output, session, data, ...)`) function to receive output data from `tm$server`.
#'  Must return data
#' @param ... Additional arguments passed to the server wrapper function by matching their formal names.
#' @return A `teal_module` or `teal_modules` object with a wrapped server.
#' @export
#' @keywords internal
#' @examples
#' library("teal.reporter")
#' hide_code <- function(input, output, session, data) {
#'   teal_card(data) <- Filter(function(x) !inherits(x, "code_chunk"), teal_card(data))
#'   data
#' }
#' app <- init(
#'   data = teal_data(IRIS = iris, MTCARS = mtcars),
#'   modules = example_module() |>
#'     after(server = hide_code)
#' )
#'
#' if (interactive()) {
#'   runApp(app)
#' }
after <- function(x,
                  server = function(input, output, session, data) data,
                  ...) {
  UseMethod("after")
}


#' @export
after.default <- function(x,
                          server = function(input, output, session, data) data,
                          ...) {
  stop("`after` is only implemented for `teal_module` and `teal_modules` objects.")
}

#' @export
after.teal_modules <- function(x,
                               server = function(input, output, session, data) data,
                               ...) {
  x$children <- lapply(x$children, after,
    server = server, ...
  )
  x
}

#' @export
after.teal_module <- function(x,
                              server = function(input, output, session, data) data,
                              ...) {
  checkmate::assert_multi_class(x, "teal_module")

  names_srv <- names(formals(server))
  args_callModule <- c("input", "output", "session", "data") # nolint object_name_linter.
  if (!is.function(server) || !(!all(identical(names_srv, c("id", "data"))) || !all(names_srv %in% args_callModule))) {
    stop("`server` must be a function whose arguments are a subset of c('input', 'output', 'session', 'data'), or exactly 'id' AND 'data'.") # nolint line_length_lint
  }

  additional_args <- list(...)
  x$ui <- after_ui(x$ui, function(id, elem) {
    elem
  }, additional_args)
  x$server <- after_srv(x$server, server, additional_args)
  x
}

after_ui <- function(old, new, additional_args) {
  new_ui <- function(id, ...) {
    original_args <- as.list(environment())
    if ("..." %in% names(formals(old))) {
      original_args <- c(original_args, list(...))
    }
    ns <- NS(id)
    original_args$id <- ns("wrapped")
    original_out <- do.call(old, original_args, quote = TRUE)

    wrapper_args <- c(
      additional_args,
      list(id = ns("wrapper"), elem = original_out)
    )
    do.call(new, args = wrapper_args[names(formals(new))])
  }
  formals(new_ui) <- formals(old)
  new_ui
}

after_srv <- function(old, new, additional_args) {
  new_srv <- function(id, ...) {
    original_args <- as.list(environment())
    original_args$id <- "wrapped"
    if ("..." %in% names(formals(old))) {
      original_args <- c(original_args, list(...))
    }
    moduleServer(id, function(input, output, session) {
      original_out <- if (all(c("input", "output", "session") %in% names(formals(old)))) {
        original_args$module <- old
        do.call(shiny::callModule, args = original_args)
      } else {
        do.call(old, original_args)
      }

      wrapper_args <- utils::modifyList(
        additional_args,
        list(id = "wrapper", input = input, output = output, session = session)
      )
      reactive({
        req(original_out())
        wrapper_args$data <- original_out()
        do.call(new, wrapper_args[names(formals(new))], quote = TRUE)
      })
    })
  }
  formals(new_srv) <- formals(old)
  new_srv
}

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

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

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

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

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

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

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

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

#' @rdname teal_data_utilities
.append_evaluated_code <- function(data, code, filter_states) {
  checkmate::assert_class(data, "teal_data")
  checkmate::assert_class(filter_states, "teal_slices", null.ok = TRUE)
  if (length(code) && !identical(code, "")) {
    data@code <- c(data@code, code2list(code))
    teal.reporter::teal_card(data) <- c(
      teal.reporter::teal_card(data),
      "### Filter settings",
      teal.reporter::code_chunk(
        .teal_slice_to_yaml(filter_states),
        lang = "filters",
        echo = TRUE # to not hide chunk when `global_knitr$echo` is set to `FALSE`
      ),
      teal.reporter::code_chunk(code)
    )
    methods::validObject(data)
  }
  data
}

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

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

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

setOldClass("teal_data_module")

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

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

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

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

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

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

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

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

# Use non-exported function(s) from teal.reporter
# This one is here because .action_button_busy is an internal function that should not be exported
.action_button_busy <- getFromNamespace(".action_button_busy", "teal.reporter")

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

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

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

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

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

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

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

1		#' @noRd
2		verbatim_popup_srv <- teal.widgets::verbatim_popup_srv
3
4		#' @noRd
5		verbatim_popup_ui <- function(id) {
6		# we replace teal.widgets::verbarbatim_popup_ui with own button. `inputId="button"` is necessary
7	7x	.action_button_busy(
8	7x	shiny::NS(id, "button"), "Show R code",
9	7x	type = "primary", outline = TRUE
10		)
11		}
12
13		#' @noRd
14		ui_source_code <- function(id) {
15	7x	ns <- shiny::NS(id)
16	7x	if (getOption("teal.show_src", TRUE)) {
17	7x	bslib::tooltip(
18	7x	id = ns("source_code_tooltip"),
19	7x	trigger = shinyjs::disabled(
20	7x	shiny::tags$div(
21	7x	id = ns("source_code_wrapper"),
22	7x	class = "cursor-helper",
23	7x	verbatim_popup_ui(ns("source_code"))
24		)
25		),
26	7x	shiny::div(
27	7x	"Click here to show R code that generated this module's output.",
28	7x	shiny::uiOutput(ns("source_code_reason"))
29		)
30		)
31		}
32		}
33
34		#' @noRd
35		srv_source_code <- function(id, module_out) {
36	103x	moduleServer(id, function(input, output, session) {
37	103x	mod_out_r <- reactive({
38	116x	if (!is.null(module_out) && is.reactive(module_out)) {
39	92x	tryCatch(module_out(), error = function(e) e)
40		}
41		})
42
43	103x	code_out <- reactive({
44	81x	teal_data_handled <- mod_out_r()
45	81x	if (inherits(teal_data_handled, "qenv")) {
46	81x	teal.code::get_code(teal_data_handled)
47		}
48		})
49
50	103x	reason_r <- reactive({
51	116x	if (is.null(mod_out_r())) {
52	24x	"No source code is available for this module."
53	92x	} else if (isFALSE(attr(mod_out_r(), "teal.enable_src"))) {
54	1x	"The source code functionality is disabled for this module."
55	91x	} else if (inherits(mod_out_r(), "error")) {
56	10x	"The module returned an error, check it for errors."
57	81x	} else if (!nzchar(code_out())) {
58	2x	"The module does not support source code functionality."
59		}
60		})
61
62	103x	if (getOption("teal.show_src", TRUE)) {
63	103x	output$source_code_reason <- shiny::renderUI({
64	114x	reason <- trimws(reason_r())
65	114x	if (length(reason)) {
66	35x	icon <- if (grepl("error", reason)) "exclamation-triangle-fill" else "info-circle-fill"
67	35x	shiny::div(
68	35x	class = if (grepl("error", reason)) "text-warning" else "text-info",
69	35x	style = "padding-top: 0.5em;",
70	35x	bsicons::bs_icon(name = icon),
71	35x	reason
72		)
73		}
74		})
75
76	103x	verbatim_popup_srv(
77	103x	id = "source_code",
78	103x	verbatim_content = code_out,
79	103x	title = "Show R Code",
80	103x	disabled = reactive(!is.null(reason_r()))
81		)
82		}
83		})
84		}
85
86		#' Disable the "Show R Code" global button in the UI
87		#'
88		#' Convenience function that disables the user's ability to see the code of the module.
89		#'
90		#' This is equivalent to setting the attribute `teal.enable_src` to `FALSE` on the
91		#' data object returned by the module.
92		#' @param x (`teal_module`) a `teal_module` object.
93		#' @return modified data object that indicates that it should not show the "Show R Code"
94		#' button in the UI.
95		#' @seealso [disable_report()]
96		#' @examplesShinylive
97		#' library(teal)
98		#' interactive <- function() TRUE
99		#' {{ next_example }}
100		#' @examples
101		#' # Disabling source on a single module
102		#' app <- init(
103		#' data = within(teal_data(), iris <- iris),
104		#' modules = modules(
105		#' example_module(label = "example teal module") \|> disable_src()
106		#' )
107		#' )
108		#' if (interactive()) {
109		#' shinyApp(app$ui, app$server)
110		#' }
111		#' @examplesShinylive
112		#' library(teal)
113		#' interactive <- function() TRUE
114		#' {{ next_example }}
115		#' @examples
116		#' # Multiple modules
117		#' app <- init(
118		#' data = within(teal_data(), iris <- iris),
119		#' modules = modules(
120		#' example_module(label = "example 1"),
121		#' example_module(label = "example 2")
122		#' ) \|> disable_src()
123		#' )
124		#'
125		#' if (interactive()) {
126		#' shinyApp(app$ui, app$server)
127		#' }
128		#' @export
129		disable_src <- function(x) {
130	1x	checkmate::assert_multi_class(x, c("teal_module", "teal_modules"))
131	1x	after(x, server = function(data) {
132	1x	attr(data, "teal.enable_src") <- FALSE
133	1x	data
134		})
135		}

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

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

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

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

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

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

1		#' Send input validation messages to output
2		#'
3		#' Captures messages from `InputValidator` objects and collates them
4		#' into one message passed to `validate`.
5		#'
6		#' `shiny::validate` is used to withhold rendering of an output element until
7		#' certain conditions are met and to print a validation message in place
8		#' of the output element.
9		#' `shinyvalidate::InputValidator` allows to validate input elements
10		#' and to display specific messages in their respective input widgets.
11		#' `validate_inputs` provides a hybrid solution.
12		#' Given an `InputValidator` object, messages corresponding to inputs that fail validation
13		#' are extracted and placed in one validation message that is passed to a `validate`/`need` call.
14		#' This way the input `validator` messages are repeated in the output.
15		#'
16		#' The `...` argument accepts any number of `InputValidator` objects
17		#' or a nested list of such objects.
18		#' If `validators` are passed directly, all their messages are printed together
19		#' under one (optional) header message specified by `header`. If a list is passed,
20		#' messages are grouped by `validator`. The list's names are used as headers
21		#' for their respective message groups.
22		#' If neither of the nested list elements is named, a header message is taken from `header`.
23		#'
24		#' @param ... either any number of `InputValidator` objects
25		#' or an optionally named, possibly nested `list` of `InputValidator`
26		#' objects, see `Details`
27		#' @param header (`character(1)`) generic validation message; set to NULL to omit
28		#'
29		#' @return
30		#' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails.
31		#'
32		#' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`]
33		#' @family validations
34		#'
35		#' @examplesShinylive
36		#' library(teal)
37		#' interactive <- function() TRUE
38		#' {{ next_example }}
39		#' @examplesIf require("shinyvalidate")
40		#' library(shiny)
41		#' library(shinyvalidate)
42		#'
43		#' ui <- fluidPage(
44		#' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
45		#' sidebarLayout(
46		#' sidebarPanel(
47		#' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
48		#' selectInput("number", "select a number:", 1:6),
49		#' tags$br(),
50		#' selectInput("color", "select a color:",
51		#' c("black", "indianred2", "springgreen2", "cornflowerblue"),
52		#' multiple = TRUE
53		#' ),
54		#' sliderInput("size", "select point size:",
55		#' min = 0.1, max = 4, value = 0.25
56		#' )
57		#' ),
58		#' mainPanel(plotOutput("plot"))
59		#' )
60		#' )
61		#'
62		#' server <- function(input, output) {
63		#' # set up input validation
64		#' iv <- InputValidator$new()
65		#' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
66		#' iv$add_rule("number", function(x) {
67		#' if (as.integer(x) %% 2L == 1L) "choose an even number"
68		#' })
69		#' iv$enable()
70		#' # more input validation
71		#' iv_par <- InputValidator$new()
72		#' iv_par$add_rule("color", sv_required(message = "choose a color"))
73		#' iv_par$add_rule("color", function(x) {
74		#' if (length(x) > 1L) "choose only one color"
75		#' })
76		#' iv_par$add_rule(
77		#' "size",
78		#' sv_between(
79		#' left = 0.5, right = 3,
80		#' message_fmt = "choose a value between {left} and {right}"
81		#' )
82		#' )
83		#' iv_par$enable()
84		#'
85		#' output$plot <- renderPlot({
86		#' # validate output
87		#' switch(input[["method"]],
88		#' "sequential" = {
89		#' validate_inputs(iv)
90		#' validate_inputs(iv_par, header = "Set proper graphical parameters")
91		#' },
92		#' "combined" = validate_inputs(iv, iv_par),
93		#' "grouped" = validate_inputs(list(
94		#' "Some inputs require attention" = iv,
95		#' "Set proper graphical parameters" = iv_par
96		#' ))
97		#' )
98		#'
99		#' plot(faithful$eruptions ~ faithful$waiting,
100		#' las = 1, pch = 16,
101		#' col = input[["color"]], cex = input[["size"]]
102		#' )
103		#' })
104		#' }
105		#'
106		#' if (interactive()) {
107		#' shinyApp(ui, server)
108		#' }
109		#'
110		#' @export
111		#'
112		validate_inputs <- function(..., header = "Some inputs require attention") {
113	36x	dots <- list(...)
114	2x	if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
115
116	34x	messages <- extract_validator(dots, header)
117	34x	failings <- if (!any_names(dots)) {
118	29x	add_header(messages, header)
119		} else {
120	5x	unlist(messages)
121		}
122
123	34x	shiny::validate(shiny::need(is.null(failings), failings))
124		}
125
126		### internal functions
127
128		#' @noRd
129		#' @keywords internal
130		# recursive object type test
131		# returns logical of length 1
132		is_validators <- function(x) {
133	118x	all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))
134		}
135
136		#' @noRd
137		#' @keywords internal
138		# test if an InputValidator object is enabled
139		# returns logical of length 1
140		# official method requested at https://github.com/rstudio/shinyvalidate/issues/64
141		validator_enabled <- function(x) {
142	49x	x$.__enclos_env__$private$enabled
143		}
144
145		#' Recursively extract messages from validator list
146		#' @return A character vector or a list of character vectors, possibly nested and named.
147		#' @noRd
148		#' @keywords internal
149		extract_validator <- function(iv, header) {
150	113x	if (inherits(iv, "InputValidator")) {
151	49x	add_header(gather_messages(iv), header)
152		} else {
153	58x	if (is.null(names(iv))) names(iv) <- rep("", length(iv))
154	64x	mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)
155		}
156		}
157
158		#' Collate failing messages from validator.
159		#' @return `list`
160		#' @noRd
161		#' @keywords internal
162		gather_messages <- function(iv) {
163	49x	if (validator_enabled(iv)) {
164	46x	status <- iv$validate()
165	46x	failing_inputs <- Filter(Negate(is.null), status)
166	46x	unique(lapply(failing_inputs, function(x) x[["message"]]))
167		} else {
168	3x	warning("Validator is disabled and will be omitted.")
169	3x	list()
170		}
171		}
172
173		#' Add optional header to failing messages
174		#' @noRd
175		#' @keywords internal
176		add_header <- function(messages, header = "") {
177	78x	ans <- unlist(messages)
178	78x	if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
179	31x	ans <- c(paste0(header, "\n"), ans, "\n")
180		}
181	78x	ans
182		}
183
184		#' Recursively check if the object contains a named list
185		#' @noRd
186		#' @keywords internal
187		any_names <- function(x) {
188	103x	any(
189	103x	if (is.list(x)) {
190	58x	if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))
191		} else {
192	40x	FALSE
193		}
194		)
195		}
196
197		#' Validate input
198		#'
199		#' Validate a Shiny input and send validation messages to the client.
200		#' The message appears both in the input widget and in the output element
201		#' that calls `validate_input`.
202		#' @details
203		#' - `validate_input():`
204		#'
205		#' Validate a Shiny input and send validation messages to the client.
206		#' The message appears both in the input widget and in the output element
207		#' that calls `validate_input`.
208		#'
209		#' @param inputId (`character`) Character of input ID(s) to validate
210		#' @param condition (`logical(1)`, `function(x)`) Logical value or function returning logical value.
211		#' Condition should determine expected state, `FALSE` throws.
212		#' @param message (`character(1)`) Character string of validation message to display.
213		#' @param session Shiny session object
214		#' @family validations
215		#' @return `NULL` or `shiny.silent.error` when condition is not met
216		#'
217		#' @examples
218		#' # Only run examples in interactive R sessions
219		#' options(device.ask.default = FALSE)
220		#'
221		#' ui <- fluidPage(
222		#' checkboxGroupInput("in1", "Check some letters", choices = head(LETTERS)),
223		#' selectizeInput("in2", "Select a state", choices = c("", state.name)),
224		#' use_validate_input_js(),
225		#' plotOutput("plot")
226		#' )
227		#'
228		#' server <- function(input, output) {
229		#' output$plot <- renderPlot({
230		#' validate_input("in1", condition = function(x) length(x) > 0, "Check at least one letter!")
231		#' validate_input("in2", condition = function(x) x != "", "Please choose a state.")
232		#' plot(1:10, main = paste(c(input$in1, input$in2), collapse = ", "))
233		#' })
234		#' }
235		#'
236		#' if (interactive()) {
237		#' shinyApp(ui, server)
238		#' }
239		#'
240		#' my_module <- module(
241		#' label = "My Module",
242		#' datanames = NULL,
243		#' ui = function(id) {
244		#' ns <- NS(id)
245		#' tagList(
246		#' checkboxGroupInput(ns("letters"), "Select letters:", choices = head(LETTERS), inline = TRUE),
247		#' checkboxGroupInput(ns("letters2"), "Select letters:", choices = head(LETTERS), inline = TRUE),
248		#' tags$h3("Sample plot"),
249		#' plotOutput(ns("plot"))
250		#' )
251		#' },
252		#' server = function(id, data) {
253		#' moduleServer(id, function(input, output, session) {
254		#' output$plot <- renderPlot({
255		#' validate_input(
256		#' "letters",
257		#' condition = function(x) length(x) > 0,
258		#' message = "Select at least one letter."
259		#' )
260		#' validate_input(
261		#' c("letters", "letters2"),
262		#' condition = function(x, y) all(!x %in% y),
263		#' message = "Letters in the first group should not be in the second group."
264		#' )
265		#' tab <- rbind(
266		#' Group1 = as.integer(head(LETTERS) %in% input$letters),
267		#' Group2 = as.integer(head(LETTERS) %in% input$letters2)
268		#' )
269		#' colnames(tab) <- head(LETTERS)
270		#' barplot(
271		#' tab,
272		#' beside = TRUE, legend.text = TRUE, main = "Selected letters per group",
273		#' col = c("steelblue", "tomato")
274		#' )
275		#' })
276		#' })
277		#' }
278		#' )
279		#'
280		#' app <- init(
281		#' data = within(teal_data(), iris <- iris),
282		#' modules = my_module
283		#' )
284		#'
285		#' if (interactive()) {
286		#' shinyApp(app$ui, app$server)
287		#' }
288		#' @export
289		validate_input <- function(inputId, # nolint
290		condition = function(x) TRUE,
291		message = "Check the input",
292		session = shiny::getDefaultReactiveDomain()) {
293	15x	validate(need_input(inputId, condition, message, session))
294		}
295
296		#' @rdname validate_input
297		#' @details
298		#' - `need_input()`: Validate a Shiny input and returns a message to be used in a [`shiny::validate()`] call.
299		#' The message is sent to the client and appears both in the input widget.
300		#' To observe the message in the output element, `need_input()` should be called inside a
301		#' `shiny::validate()` call, e.g. via `validate(validate_input(...))`.
302		#' @export
303		#' @examples
304		#' my_module <- module(
305		#' label = "My Module",
306		#' datanames = NULL,
307		#' ui = function(id) {
308		#' ns <- NS(id)
309		#' tagList(
310		#' checkboxGroupInput(ns("letters1"), "Select letters:", choices = head(LETTERS), inline = TRUE),
311		#' checkboxGroupInput(ns("letters2"), "Select letters:", choices = head(LETTERS), inline = TRUE),
312		#' tags$h3("Sample plot"),
313		#' plotOutput(ns("plot"))
314		#' )
315		#' },
316		#' server = function(id, data) {
317		#' moduleServer(id, function(input, output, session) {
318		#' output$plot <- renderPlot({
319		#' validate(
320		#' need_input(
321		#' "letters1",
322		#' condition = function(x) length(x) > 0,
323		#' message = "Select at least one letter."
324		#' ),
325		#' need_input(
326		#' c("letters1", "letters2"),
327		#' condition = function(x, y) all(!x %in% y),
328		#' message = "Letters in the first group should not be in the second group."
329		#' )
330		#' )
331		#' tab <- rbind(
332		#' Group1 = as.integer(head(LETTERS) %in% input$letters1),
333		#' Group2 = as.integer(head(LETTERS) %in% input$letters2)
334		#' )
335		#' colnames(tab) <- head(LETTERS)
336		#' barplot(
337		#' tab,
338		#' beside = TRUE, legend.text = TRUE, main = "Selected letters per group",
339		#' col = c("steelblue", "tomato")
340		#' )
341		#' })
342		#' })
343		#' }
344		#' )
345		#'
346		#' app <- init(
347		#' data = within(teal_data(), iris <- iris),
348		#' modules = my_module
349		#' )
350		#'
351		#' if (interactive()) {
352		#' shinyApp(app$ui, app$server)
353		#' }
354		need_input <- function(inputId, # nolint
355		condition = function(x) TRUE,
356		message = "Check the input",
357		session = shiny::getDefaultReactiveDomain()) {
358		# Simple fingerprint based on inputId and message to ensure validation messages
359		# in Javascript are not incorrectly removed.
360	38x	fingerprint <- paste0(c(inputId, rlang::hash(message)), collapse = "\|")
361
362	38x	checkmate::assert_character(inputId, min.len = 1)
363	35x	checkmate::assert(
364	35x	checkmate::check_flag(condition),
365	35x	checkmate::check_function(condition, nargs = length(inputId))
366		)
367	31x	checkmate::assert_string(message)
368
369		# Evaluate condition if it's a function
370	29x	condition_result <- if (is.function(condition)) {
371	16x	input_value <- lapply(inputId, function(id) session$input[[id]])
372	16x	checkmate::assert_flag(do.call(condition, input_value))
373		} else {
374	13x	condition
375		}
376
377		# Send custom message to JavaScript handler
378	29x	lapply(inputId, function(id) {
379	35x	session$sendCustomMessage("validateInput", list(
380	35x	inputId = session$ns(id),
381	35x	isValid = condition_result,
382	35x	message = message,
383	35x	fingerprint = fingerprint
384		))
385		})
386
387	29x	need(condition_result, message)
388		}
389
390		#' @rdname validate_input
391		#' @details
392		#' - `use_validate_input_js()`:
393		#'
394		#' Include JavaScript for client-side input validation.
395		#' @export
396		use_validate_input_js <- function() {
397	7x	addResourcePath("js", system.file("js", package = "teal"))
398	7x	tagList(
399	7x	include_css_files("validation.css"),
400	7x	singleton(tags$script(src = "js/input-validator.js"))
401		)
402		}

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	7x	ns <- NS(id)
48
49	7x	bookmark_option <- get_bookmarking_option()
50	7x	is_unbookmarkable <- need_bookmarking(modules)
51	7x	shinyOptions(bookmarkStore = bookmark_option)
52
53	7x	if (!all(is_unbookmarkable) && identical(bookmark_option, "server")) {
54	5x	.expand_button(
55	5x	id = ns("do_bookmark"),
56	5x	label = "Bookmark",
57	5x	icon = "bookmark-fill"
58		)
59		}
60		}
61
62		#' @rdname module_bookmark_manager
63		srv_bookmark_panel <- function(id, modules) {
64	144x	checkmate::assert_character(id)
65	144x	checkmate::assert_class(modules, "teal_modules")
66	144x	moduleServer(id, function(input, output, session) {
67	144x	logger::log_debug("bookmark_manager_srv initializing")
68	144x	ns <- session$ns
69	144x	bookmark_option <- get_bookmarking_option()
70	144x	is_unbookmarkable <- need_bookmarking(modules)
71
72		# Set up bookmarking callbacks ----
73		# Register bookmark exclusions: do_bookmark button to avoid re-bookmarking
74	144x	setBookmarkExclude(c("do_bookmark"))
75		# This bookmark can only be used on the app session.
76	144x	app_session <- .subset2(session, "parent")
77	144x	app_session$onBookmarked(function(url) {
78	!	logger::log_debug("bookmark_manager_srv@onBookmarked: bookmark button clicked, registering bookmark")
79	!	modal_content <- if (bookmark_option != "server") {
80	!	msg <- sprintf(
81	!	"Bookmarking has been set to \"%s\".\n%s\n%s",
82	!	bookmark_option,
83	!	"Only server-side bookmarking is supported.",
84	!	"Please contact your app developer."
85		)
86	!	tags$div(
87	!	tags$p(msg, class = "text-warning")
88		)
89		} else {
90	!	tags$div(
91	!	tags$span(
92	!	tags$pre(url)
93		),
94	!	if (any(is_unbookmarkable)) {
95	!	bkmb_summary <- rapply2(
96	!	modules_bookmarkable(modules),
97	!	function(x) {
98	!	if (isTRUE(x)) {
99	!	"\u2705" # check mark
100	!	} else if (isFALSE(x)) {
101	!	"\u274C" # cross mark
102		} else {
103	!	"\u2753" # question mark
104		}
105		}
106		)
107	!	tags$div(
108	!	tags$p(
109	!	icon("fas fa-exclamation-triangle"),
110	!	"Some modules will not be restored when using this bookmark.",
111	!	tags$br(),
112	!	"Check the list below to see which modules are not bookmarkable.",
113	!	class = "text-warning"
114		),
115	!	tags$pre(yaml::as.yaml(bkmb_summary))
116		)
117		}
118		)
119		}
120
121
122	!	showModal(
123	!	div(
124	!	class = "teal bookmark-popup",
125	!	modalDialog(
126	!	id = ns("bookmark_modal"),
127	!	title = "Bookmarked teal app url",
128	!	modal_content,
129	!	easyClose = TRUE,
130	!	footer = NULL
131		)
132		)
133		)
134		})
135
136		# manually trigger bookmarking because of the problems reported on windows with bookmarkButton in teal
137	144x	observeEvent(input$do_bookmark, {
138	1x	logger::log_debug("bookmark_manager_srv@1 do_bookmark module clicked.")
139	1x	session$doBookmark()
140		})
141
142	144x	invisible(NULL)
143		})
144		}
145
146
147		#' @rdname module_bookmark_manager
148		get_bookmarking_option <- function() {
149	155x	bookmark_option <- getShinyOption("bookmarkStore")
150	155x	if (is.null(bookmark_option) && identical(getOption("shiny.bookmarkStore"), "server")) {
151	143x	bookmark_option <- getOption("shiny.bookmarkStore")
152		}
153	155x	bookmark_option
154		}
155
156		#' @rdname module_bookmark_manager
157		need_bookmarking <- function(modules) {
158	155x	unlist(rapply2(
159	155x	modules_bookmarkable(modules),
160	155x	Negate(isTRUE)
161		))
162		}
163
164
165		# utilities ----
166
167		#' Restore value from bookmark.
168		#'
169		#' Get value from bookmark or return default.
170		#'
171		#' Bookmarks can store not only inputs but also arbitrary values.
172		#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks,
173		#' and they are placed in the `values` environment in the `session$restoreContext` field.
174		#' Using `teal_data_module` makes it impossible to run the callbacks
175		#' because the app becomes ready before modules execute and callbacks are registered.
176		#' In those cases the stored values can still be recovered from the `session` object directly.
177		#'
178		#' Note that variable names in the `values` environment are prefixed with module name space names,
179		#' therefore, when using this function in modules, `value` must be run through the name space function.
180		#'
181		#' @param value (`character(1)`) name of value to restore
182		#' @param default fallback value
183		#'
184		#' @return
185		#' In an application restored from a server-side bookmark,
186		#' the variable specified by `value` from the `values` environment.
187		#' Otherwise `default`.
188		#'
189		#' @keywords internal
190		#'
191		restoreValue <- function(value, default) { # nolint: object_name.
192	322x	checkmate::assert_character(value)
193	322x	session_default <- shiny::getDefaultReactiveDomain()
194	322x	session_parent <- .subset2(session_default, "parent")
195	322x	session <- if (is.null(session_parent)) session_default else session_parent
196	322x	if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
197	2x	session$restoreContext$values[[value]]
198		} else {
199	320x	default
200		}
201		}
202
203		# Replacement for [base::rapply] which doesn't handle NULL values - skips the evaluation
204		# of the function and returns NULL for given element.
205		rapply2 <- function(x, f) {
206	346x	if (inherits(x, "list")) {
207	156x	lapply(x, rapply2, f = f)
208		} else {
209	190x	f(x)
210		}
211		}

1		#' Apply `teal_transform_module` decorators to reactive `teal_data`
2		#'
3		#' @description
4		#' Shiny module pair (`srv_transform_teal_data` / `ui_transform_teal_data`) that runs a sequence
5		#' of [teal_transform_module()] decorators against a reactive `teal_data` object.
6		#' Decorators are applied one after another via `Reduce`, so each one receives the output of the
7		#' previous as its `data` argument.
8		#' Failed transformators are tracked and any downstream transformator is automatically disabled
9		#' until the failure is resolved.
10		#' An optional `expr` argument allows additional code to be evaluated on the final decorated output.
11		#'
12		#' @inheritParams module_validate_error
13		#' @inheritParams teal_modules
14		#' @param transformators (`list` of `teal_transform_module`) decorator modules to apply sequentially
15		#' to `data`. Each transformator receives the output of the previous one as input.
16		#' @return `reactive` `teal_data`
17		#' @seealso [assert_decorators()]
18		#' @examples
19		#' library(shiny)
20		#' library(teal.data)
21		#'
22		#' # A decorator that sets a fixed title on a ggplot2 object named `plot`
23		#' static_decorator <- teal_transform_module(
24		#' label = "Static decorator",
25		#' server = function(id, data) {
26		#' moduleServer(id, function(input, output, session) {
27		#' reactive({
28		#' req(data())
29		#' within(data(), {
30		#' plot <- plot + ggplot2::ggtitle("Decorated title")
31		#' })
32		#' })
33		#' })
34		#' }
35		#' )
36		#'
37		#' if (interactive()) {
38		#' shinyApp(
39		#' ui = fluidPage(
40		#' ui_transform_teal_data("decorate", transformators = list(static_decorator)),
41		#' plotOutput("plot")
42		#' ),
43		#' server = function(input, output, session) {
44		#' data <- reactive(
45		#' teal_data(
46		#' plot = ggplot2::ggplot(iris, ggplot2::aes(Sepal.Length, Sepal.Width)) +
47		#' ggplot2::geom_point()
48		#' )
49		#' )
50		#' decorated <- srv_transform_teal_data(
51		#' "decorate",
52		#' data = data,
53		#' transformators = list(static_decorator)
54		#' )
55		#' output$plot <- renderPlot(decorated()[["plot"]])
56		#' }
57		#' )
58		#' }
59		#' @name module_transform_data
60		NULL
61
62		#' @rdname module_transform_data
63		#' @param expr (`expression` or `reactive`) optional expression evaluated on top of the decorated
64		#' output. Useful for post-processing after all transformators have run.
65		#' @param modules `r lifecycle::badge("deprecated")` No longer used.
66		#' @param is_transform_failed `r lifecycle::badge("deprecated")` No longer used.
67		#' @export
68		srv_transform_teal_data <- function(id,
69		data,
70		transformators,
71		modules = NULL,
72		is_transform_failed = reactiveValues(),
73		expr) {
74	8x	checkmate::assert_class(data, classes = "reactive")
75
76	8x	if (!missing(modules)) {
77	!	lifecycle::deprecate_warn(
78	!	when = "1.2.0",
79	!	what = "srv_transform_teal_data(modules)",
80	!	details = "Argument is used only in the internal of teal and will be removed in the next release."
81		)
82		}
83
84	8x	if (!missing(is_transform_failed)) {
85	!	lifecycle::deprecate_warn(
86	!	when = "1.2.0",
87	!	what = "srv_transform_teal_data(is_transform_failed)",
88	!	details = "Argument is used only in the internal of teal and will be removed in the next release."
89		)
90		}
91
92	8x	decorated_output <- .srv_transform_teal_data(
93	8x	id,
94	8x	data = data,
95	8x	transformators = transformators,
96	8x	modules = modules,
97	8x	is_transform_failed = is_transform_failed
98		)
99
100	8x	no_expr <- missing(expr)
101
102	8x	reactive({
103	11x	data_out <- try(data(), silent = TRUE)
104		# Report error on data to the user
105	11x	if (inherits(data_out, "qenv.error")) {
106	!	validate("Data passed has errors.")
107		}
108
109		# ensure errors on transformators are displayed
110	11x	do <- req(decorated_output())
111	3x	if (inherits(do, "qenv.error")) {
112	!	validate(as.character(do))
113		}
114
115		# Append expr if needed
116	3x	if (no_expr) {
117	3x	do
118		} else {
119	!	expr_r <- if (is.reactive(expr)) expr else reactive(expr)
120	!	teal.code::eval_code(do, expr_r())
121		}
122		})
123		}
124
125
126		#' @rdname module_transform_data
127		#' @param class `r lifecycle::badge("deprecated")` No longer used.
128		#' @param ... additional arguments passed to `.ui_transform_teal_data` (e.g. `class`).
129		#' @return A `list` of `bslib::accordion` UI elements, one per transformator, or `NULL` if
130		#' `transformators` is empty.
131		#' @export
132		ui_transform_teal_data <- function(id, transformators, class = "well", ...) {
133	6x	if (!missing(class)) {
134	!	lifecycle::deprecate_warn(
135	!	when = "1.2.0",
136	!	what = "ui_transform_teal_data(class)",
137	!	details = "Ability to choose class will be removed in the next release."
138		)
139		}
140	6x	.ui_transform_teal_data(
141	6x	id,
142	6x	transformators = transformators,
143	6x	class = class,
144		...
145		)
146		}
147
148		#' Internal module handling list of [teal_transform_module()]
149		#'
150		#' This module calls [teal_transform_module()] sequentially by passing output from one step to the next.
151		#' Modules have error/warning handling feature and highlight containers when something goes wrong.
152		#' @name module_transform_teal_data_impl
153		NULL
154
155		#' @rdname module_transform_teal_data_impl
156		#' @inheritParams srv_transform_teal_data
157		#' @return `shiny.tag`
158		#' @keywords internal
159		.ui_transform_teal_data <- function(id, transformators, class = "well") {
160	6x	checkmate::assert_string(id)
161	6x	if (length(transformators) == 0L) {
162	5x	return(NULL)
163		}
164	1x	if (inherits(transformators, "teal_transform_module")) {
165	1x	transformators <- list(transformators)
166		}
167	1x	checkmate::assert_list(transformators, "teal_transform_module")
168	1x	names(transformators) <- sprintf("transform_%d", seq_along(transformators))
169
170	1x	lapply(
171	1x	names(transformators),
172	1x	function(name) {
173	1x	child_id <- NS(id, name)
174	1x	ns <- NS(child_id)
175	1x	data_mod <- transformators[[name]]
176	1x	transform_wrapper_id <- ns(sprintf("wrapper_%s", name))
177
178	1x	display_fun <- if (is.null(data_mod$ui)) shinyjs::hidden else function(x) x
179
180	1x	display_fun(
181	1x	bslib::accordion(
182	1x	bslib::accordion_panel(
183	1x	attr(data_mod, "label"),
184	1x	icon = bsicons::bs_icon("palette-fill"),
185	1x	tags$div(
186	1x	id = transform_wrapper_id,
187	1x	if (is.null(data_mod$ui)) {
188	!	return(NULL)
189		} else {
190	1x	data_mod$ui(id = ns("transform"))
191		},
192	1x	div(
193	1x	id = ns("validate_messages"),
194	1x	class = "teal_validated",
195	1x	uiOutput(ns("error_wrapper"))
196		)
197		)
198		)
199		)
200		)
201		}
202		)
203		}
204
205		#' @rdname module_transform_teal_data_impl
206		#' @inheritParams ui_transform_teal_data
207		#' @return `reactive` `teal_data` object
208		#' @keywords internal
209		.srv_transform_teal_data <- function(id, data, transformators, modules = NULL, is_transform_failed = reactiveValues()) {
210	117x	checkmate::assert_string(id)
211	117x	assert_reactive(data)
212	117x	checkmate::assert_class(modules, "teal_module", null.ok = TRUE)
213	117x	if (length(transformators) == 0L) {
214	94x	return(data)
215		}
216	23x	if (inherits(transformators, "teal_transform_module")) {
217	3x	transformators <- list(transformators)
218		}
219	23x	checkmate::assert_list(transformators, "teal_transform_module", null.ok = TRUE)
220	23x	names(transformators) <- sprintf("transform_%d", seq_along(transformators))
221
222	23x	moduleServer(id, function(input, output, session) {
223	23x	module_output <- Reduce(
224	23x	function(data_previous, name) {
225	26x	moduleServer(name, function(input, output, session) {
226	26x	logger::log_debug("srv_transform_teal_data@1 initializing module for { name }.")
227
228	26x	data_out <- reactiveVal()
229	26x	.call_once_when(inherits(data_previous(), "teal_data"), {
230	26x	logger::log_debug("srv_teal_transform_teal_data@2 triggering a transform module call for { name }.")
231	26x	data_unhandled <- transformators[[name]]$server("transform", data = data_previous)
232	26x	data_handled <- reactive(tryCatch(data_unhandled(), error = function(e) e))
233
234	26x	observeEvent(data_handled(), {
235	29x	dh <- data_handled()
236	29x	if (inherits(dh, "teal_data") && !identical(dh, data_out())) {
237	22x	data_out(dh)
238		}
239		})
240
241	26x	is_transform_failed[[name]] <- FALSE
242	26x	observeEvent(data_handled(), {
243	29x	if (inherits(data_handled(), "teal_data")) {
244	22x	is_transform_failed[[name]] <- FALSE
245		} else {
246	7x	is_transform_failed[[name]] <- TRUE
247		}
248		})
249
250	26x	is_previous_failed <- reactive({
251	30x	idx_this <- which(names(is_transform_failed) == name)
252	30x	is_transform_failed_list <- reactiveValuesToList(is_transform_failed)
253	30x	idx_failures <- which(unlist(is_transform_failed_list))
254	30x	any(idx_failures < idx_this)
255		})
256
257	26x	srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
258	26x	srv_check_class_teal_data("class_teal_data", data_handled)
259	26x	if (!is.null(modules)) {
260	20x	srv_check_module_datanames("datanames_warning", data_handled, modules)
261		}
262
263		# When there is no UI (`ui = NULL`) it should still show the errors
264	26x	observe({
265	29x	if (!inherits(data_handled(), "teal_data") && !is_previous_failed()) {
266	7x	shinyjs::show("wrapper")
267		}
268		})
269
270	26x	transform_wrapper_id <- sprintf("wrapper_%s", name)
271	26x	output$error_wrapper <- renderUI({
272	30x	if (is_previous_failed()) {
273	!	shinyjs::disable(transform_wrapper_id)
274	!	tags$div(
275	!	"One of previous transformators failed. Please check its inputs.",
276	!	class = "teal-output-warning"
277		)
278		} else {
279	30x	shinyjs::enable(transform_wrapper_id)
280	30x	shiny::tagList(
281	30x	ui_validate_error(session$ns("silent_error")),
282	30x	ui_check_class_teal_data(session$ns("class_teal_data")),
283	30x	ui_check_module_datanames(session$ns("datanames_warning"))
284		)
285		}
286		})
287		})
288
289		# Ignoring unwanted reactivity breaks during initialization
290	26x	reactive({
291	45x	req(data_out())
292		})
293		})
294		},
295	23x	x = names(transformators),
296	23x	init = data
297		)
298
299	23x	module_output
300		})
301		}

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

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

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

1		#' `teal` main module
2		#'
3		#' @description
4		#' Module to create a `teal` app as a Shiny Module.
5		#'
6		#' @details
7		#' This module can be used instead of [init()] in custom Shiny applications. Unlike [init()], it doesn't
8		#' automatically include [`module_session_info`].
9		#'
10		#' Module is responsible for creating the main `shiny` app layout and initializing all the necessary
11		#' components. This module establishes reactive connection between the input `data` and every other
12		#' component in the app. Reactive change of the `data` passed as an argument, reloads the app and
13		#' possibly keeps all input settings the same so the user can continue where one left off.
14		#'
15		#' ## data flow in `teal` application
16		#'
17		#' This module supports multiple data inputs but eventually, they are all converted to `reactive`
18		#' returning `teal_data` in this module. On this `reactive teal_data` object several actions are
19		#' performed:
20		#' - data loading
21		#' - data filtering
22		#' - data transformation
23		#'
24		#' ## Fallback on failure
25		#'
26		#' `teal` is designed in such way that app will never crash if the error is introduced in any
27		#' custom `shiny` module provided by app developer (e.g. [teal_data_module()], [teal_transform_module()]).
28		#' If any module returns a failing object, the app will halt the evaluation and display a warning message.
29		#' App user should always have a chance to fix the improper input and continue without restarting the session.
30		#'
31		#' @rdname module_teal
32		#' @name module_teal
33		#'
34		#' @inheritParams init
35		#' @param id (`character(1)`) `shiny` module instance id.
36		#' @param data (`teal_data`, `teal_data_module`, or `reactive` returning `teal_data`)
37		#' The data which application will depend on.
38		#' @param modules (`teal_modules`)
39		#' `teal_modules` object. These are the specific output modules which
40		#' will be displayed in the `teal` application. See [modules()] and [module()] for
41		#' more details.
42		#'
43		#' @return `NULL` invisibly
44		NULL
45
46		#' @rdname module_teal
47		#' @export
48		ui_teal <- function(id, modules) {
49	7x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
50	7x	checkmate::assert_class(modules, "teal_modules")
51	7x	ns <- NS(id)
52
53	7x	mod <- extract_module(modules, class = "teal_module_previewer")
54	7x	reporter_opts <- if (length(mod)) .get_reporter_options(mod[[1]]$server_args)
55
56		# show busy icon when `shiny` session is busy computing stuff
57		# based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length.
58	7x	shiny_busy_message_panel <- conditionalPanel(
59	7x	condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
60	7x	tags$div(
61	7x	icon("arrows-rotate", class = "fa-spin", prefer_type = "solid"),
62	7x	"Computing ...",
63	7x	style = "position: fixed; bottom: 0; right: 0;
64	7x	width: 140px; margin: 15px; padding: 5px 0 5px 10px;
65	7x	text-align: left; font-weight: bold; font-size: 100%;
66	7x	color: #ffffff; background-color: #347ab7; z-index: 105;"
67		)
68		)
69
70	7x	reporter_opts <- reporter_opts %\|\|% structure(list(), names = character(0L))
71	7x	navbar <- ui_teal_module(id = ns("teal_modules"), modules = modules)
72	7x	nav_elements <- list(
73	7x	rlang::with_options(!!!reporter_opts, .expr = { # for backwards compatibility of report_previewer_module$server_args
74	7x	tags$div(
75	7x	id = ns("reporter_menu_container"),
76	7x	.teal_navbar_menu(
77	7x	label = "Report",
78	7x	icon = "file-text-fill",
79	7x	class = "reporter-menu",
80	7x	if ("preview" %in% getOption("teal.reporter.nav_buttons")) {
81	7x	teal.reporter::preview_report_button_ui(ns("preview_report"), label = "Preview Report")
82		},
83	7x	tags$hr(style = "margin: 0.5rem;"),
84	7x	if ("download" %in% getOption("teal.reporter.nav_buttons")) {
85	7x	teal.reporter::download_report_button_ui(ns("download_report"), label = "Download Report")
86		},
87	7x	if ("load" %in% getOption("teal.reporter.nav_buttons")) {
88	7x	teal.reporter::report_load_ui(ns("load_report"), label = "Load Report")
89		},
90	7x	tags$hr(style = "margin: 0.5rem;"),
91	7x	if ("reset" %in% getOption("teal.reporter.nav_buttons")) {
92	7x	teal.reporter::reset_report_button_ui(ns("reset_reports"), label = "Reset Report")
93		}
94		)
95		)
96		}),
97	7x	tags$span(style = "margin-left: auto;"),
98	7x	ui_bookmark_panel(ns("bookmark_manager"), modules),
99	7x	ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
100	7x	ui_filter_manager_panel(ns("filter_manager_panel"))
101		)
102	7x	navbar <- .teal_navbar_append(navbar, nav_elements)
103
104	7x	teal_options_class <- getOption("teal.ui.class")
105	7x	bslib::page_fluid(
106	7x	id = id,
107	7x	class = teal_options_class,
108	7x	theme = get_teal_bs_theme(),
109	7x	include_teal_css_js(),
110	7x	shinyjs::useShinyjs(),
111	7x	shiny::includeScript(system.file("js/extendShinyJs.js", package = "teal")),
112	7x	use_validate_input_js(),
113	7x	shiny_busy_message_panel,
114	7x	tags$div(id = ns("tabpanel_wrapper"), class = "teal-body", navbar),
115	7x	tags$hr(style = "margin: 1rem 0 0.5rem 0;")
116		)
117		}
118
119		#' @rdname module_teal
120		#' @export
121		srv_teal <- function(id, data, modules, filter = teal_slices(), reporter = teal.reporter::Reporter$new()) {
122	143x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
123	143x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
124	142x	checkmate::assert_class(modules, "teal_modules")
125	142x	checkmate::assert_class(filter, "teal_slices")
126
127	142x	moduleServer(id, function(input, output, session) {
128	142x	logger::log_debug("srv_teal initializing.")
129
130	142x	onSessionEnded(function() {
131	140x	if (!is.null(reporter)) {
132	139x	shiny::isolate(reporter$reset())
133		}
134		})
135
136	142x	if (getOption("teal.show_js_log", default = FALSE)) {
137	!	shinyjs::showLog()
138		}
139
140	142x	session$onBookmark(function(state) {
141	2x	logger::log_debug("srv_teal@onBookmark: storing report cards")
142	2x	state$values$report_cards <- shiny::isolate(reporter$get_cards())
143		})
144		# set timezone in shiny app
145		# timezone is set in the early beginning so it will be available also
146		# for `DDL` and all shiny modules
147	142x	get_client_timezone(session$ns)
148	142x	observeEvent(
149	142x	eventExpr = input$timezone,
150	142x	once = TRUE,
151	142x	handlerExpr = {
152	2x	session$userData$timezone <- input$timezone
153	2x	logger::log_debug("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
154		}
155		)
156
157	142x	data_ui <- if (inherits(data, "teal_data_module")) data$ui(id = session$ns(.teal_data_module_id))
158
159	142x	has_ui <- !is.null(data_ui)
160	142x	is_once <- isTRUE(attr(data, "once"))
161
162	142x	validate_ui <- tags$div(
163	142x	id = session$ns("validate_messages"),
164	142x	class = "teal_validated",
165	142x	ui_check_class_teal_data(session$ns("class_teal_data")),
166	142x	ui_validate_error(session$ns("silent_error")),
167	142x	ui_check_module_datanames(session$ns("datanames_warning"))
168		)
169
170
171	142x	modal_ui <- reactive({
172		# reactive as data_load_status determines if modal opens/reopens with disabled "dismiss" btn
173	2x	div(
174	2x	class = "teal teal-data-module-popup",
175	2x	modalDialog(
176	2x	id = session$ns("teal_data_module_ui"),
177	2x	size = "xl",
178	2x	tags$div(
179	2x	data_ui,
180	2x	validate_ui
181		),
182	2x	easyClose = FALSE,
183	2x	footer = tags$div(
184	2x	id = session$ns("close_teal_data_module_modal"),
185	2x	if (identical(data_load_status(), "ok")) {
186	!	modalButton("Dismiss")
187		} else {
188	2x	shinyjs::disabled(modalButton("Dismiss"))
189		}
190		)
191		)
192		)
193		})
194
195	142x	data_reactive <- if (inherits(data, "teal_data_module")) {
196	17x	data$server(.teal_data_module_id)
197	142x	} else if (inherits(data, "teal_data")) {
198	91x	reactiveVal(data)
199	142x	} else if (test_reactive(data)) {
200	34x	data
201		}
202	141x	data_handled <- reactive(tryCatch(data_reactive(), error = function(e) e))
203	141x	data_validated <- .trigger_on_success(data_handled)
204	141x	data_signatured <- reactive({
205	254x	req(inherits(data_validated(), "teal_data"))
206	124x	is_filter_ok <- check_filter_datanames(filter, names(data_validated()))
207	124x	if (!isTRUE(is_filter_ok)) {
208	2x	showNotification(
209	2x	"Some filters were not applied because of incompatibility with data. Contact app developer.",
210	2x	type = "warning",
211	2x	duration = 10
212		)
213	2x	warning(is_filter_ok)
214		}
215	124x	.add_signature_to_data(data_validated())
216		})
217
218	141x	srv_check_class_teal_data("class_teal_data", data_handled)
219	141x	srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
220	141x	srv_check_module_datanames("datanames_warning", data_handled, modules)
221
222
223	141x	if (!has_ui) {
224	139x	showNotification(
225	139x	"Loading data...",
226	139x	id = "data_loading",
227	139x	duration = NULL,
228	139x	type = "message"
229		)
230		}
231
232	141x	data_load_status <- reactiveVal(NULL)
233	141x	observeEvent(data_handled(), {
234	133x	removeNotification(id = "data_loading")
235	133x	status <- if (inherits(data_handled(), "teal_data")) {
236	124x	shinyjs::enable(id = "close_teal_data_module_modal")
237	124x	"ok"
238	133x	} else if (inherits(data, "teal_data_module")) {
239	9x	shinyjs::disable(id = "close_teal_data_module_modal")
240	9x	"teal_data_module failed"
241		} else {
242	!	"external failed"
243		}
244	133x	data_load_status(status)
245		})
246
247	141x	if (has_ui) {
248	2x	showModal(shiny::isolate(modal_ui()))
249		# We want to exclude teal_data_module elements from bookmarking as they might have some secrets
250	2x	observeEvent(data_handled(), {
251	3x	if (inherits(data_handled(), "teal_data")) {
252	1x	app_session <- .subset2(shiny::getDefaultReactiveDomain(), "parent")
253	1x	setBookmarkExclude(
254	1x	session$ns(
255	1x	grep(
256	1x	pattern = sprintf("%s-", .teal_data_module_id),
257	1x	x = names(reactiveValuesToList(input)),
258	1x	value = TRUE
259		)
260		),
261	1x	session = app_session
262		)
263		}
264		})
265
266	2x	observeEvent(data_signatured(), once = TRUE, {
267	1x	logger::log_debug("srv_teal@2 removing data tab.")
268	1x	shiny::removeModal()
269		})
270
271	2x	if (!is_once) {
272	!	setBookmarkExclude(c("teal_data_module_ui", "open_teal_data_module_ui"))
273	!	.teal_navbar_insert_ui(
274	!	ui = .expand_button(
275	!	id = session$ns("open_teal_data_module_ui"),
276	!	label = "Load Data",
277	!	icon = "database-fill"
278		)
279		)
280	!	observeEvent(
281	!	input$open_teal_data_module_ui,
282	!	ignoreInit = TRUE,
283	!	ignoreNULL = TRUE,
284		{
285	!	showModal(modal_ui())
286	!	if (identical(data_load_status(), "ok")) {
287	!	shinyjs::enable(id = "close_teal_data_module_modal")
288		} else {
289	!	shinyjs::disable(id = "close_teal_data_module_modal")
290		}
291		}
292		)
293		}
294		} else {
295		# when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)
296	139x	insertUI(
297	139x	selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
298	139x	where = "beforeBegin",
299	139x	ui = tags$div(validate_ui)
300		)
301		}
302
303		# Wait for UI to be rendered before showing/hiding reporter UI elements
304		# See: https://github.com/rstudio/shiny/issues/3348
305	141x	observeEvent(
306	141x	once = TRUE,
307	141x	ignoreInit = TRUE,
308	141x	reactiveValuesToList(session$input),
309		{
310	41x	if (!is.null(reporter)) {
311	41x	reporter$set_id(attr(filter, "app_id"))
312	41x	report_cards <- restoreValue(session$ns("report_cards"), NULL)
313	41x	if (length(report_cards)) {
314	1x	reporter$reset()
315	1x	reporter$append_cards(report_cards)
316		}
317	41x	teal.reporter::preview_report_button_srv("preview_report", reporter)
318	41x	teal.reporter::report_load_srv("load_report", reporter)
319	41x	teal.reporter::download_report_button_srv(id = "download_report", reporter = reporter)
320	41x	teal.reporter::reset_report_button_srv("reset_reports", reporter)
321		} else {
322	!	removeUI(selector = sprintf("#%s", session$ns("reporter_menu_container")), multiple = TRUE)
323	!	removeUI(selector = sprintf("#%s .report_add_wrapper", session$ns("tabpanel_wrapper")), multiple = TRUE)
324		}
325		}
326		)
327
328	141x	datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
329	130x	eventReactive(data_signatured(), {
330	115x	req(inherits(data_signatured(), "teal_data"))
331	115x	logger::log_debug("srv_teal@1 initializing FilteredData")
332	115x	teal_data_to_filtered_data(data_signatured())
333		})
334		}
335	141x	module_labels <- unlist(modules_slot(modules, "label"), use.names = FALSE)
336	141x	slices_global <- methods::new(".slicesGlobal", filter, module_labels)
337
338	141x	modules_output <- srv_teal_module(
339	141x	"teal_modules",
340	141x	data = data_signatured,
341	141x	modules = modules,
342	141x	datasets = datasets_rv,
343	141x	slices_global = slices_global,
344	141x	reporter = reporter,
345	141x	data_load_status = data_load_status
346		)
347
348	141x	mapping_table <- srv_filter_manager_panel("filter_manager_panel", slices_global = slices_global)
349	141x	snapshots <- srv_snapshot_manager_panel("snapshot_manager_panel", slices_global = slices_global)
350	141x	srv_bookmark_panel("bookmark_manager", modules)
351		})
352
353	141x	invisible(NULL)
354		}
355
356
357		#' Adds signature protection to the `datanames` in the data
358		#' @param data (`teal_data`)
359		#' @return `teal_data` with additional code that has signature of the `datanames`
360		#' @keywords internal
361		.add_signature_to_data <- function(data) {
362	124x	hashes <- .get_hashes_code(data)
363	124x	data_teal_report <- as(data, "teal_report")
364	124x	if (!inherits(data, "teal_report")) {
365	124x	teal.reporter::teal_card(data_teal_report) <- c(
366	124x	teal.reporter::teal_card(),
367	124x	"## Data preparation",
368	124x	teal.reporter::teal_card(data_teal_report)
369		)
370		}
371	124x	tdata <- do.call(
372	124x	teal.reporter::teal_report,
373	124x	c(
374	124x	list(
375	124x	code = trimws(c(teal.code::get_code(data_teal_report), hashes), which = "right"),
376	124x	join_keys = teal.data::join_keys(data_teal_report),
377	124x	teal_card = teal.reporter::teal_card(data_teal_report)
378		),
379	124x	sapply(
380	124x	names(data_teal_report),
381	124x	base::get,
382	124x	envir = data_teal_report,
383	124x	simplify = FALSE
384		)
385		)
386		)
387	124x	tdata@verified <- data_teal_report@verified
388	124x	tdata
389		}
390
391		#' Get code that tests the integrity of the reproducible data
392		#'
393		#' @param data (`teal_data`) object holding the data
394		#' @param datanames (`character`) names of `datasets`
395		#'
396		#' @return A character vector with the code lines.
397		#' @keywords internal
398		#'
399		.get_hashes_code <- function(data, datanames = names(data)) {
400	124x	vapply(
401	124x	datanames,
402	124x	function(dataname, datasets) {
403	188x	x <- data[[dataname]]
404
405	188x	code <- if (is.function(x) && !is.primitive(x)) {
406	6x	x <- deparse1(x)
407	6x	bquote(rlang::hash(deparse1(.(as.name(dataname)))))
408		} else {
409	182x	bquote(rlang::hash(.(as.name(dataname))))
410		}
411	188x	sprintf(
412	188x	"stopifnot(%s == %s) # @linksto %s",
413	188x	deparse1(code),
414	188x	deparse1(rlang::hash(x)),
415	188x	dataname
416		)
417		},
418	124x	character(1L),
419	124x	USE.NAMES = TRUE
420		)
421		}
422
423
424		.teal_data_module_id <- "teal_data_module"

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

1		#' Check decorators list
2		#'
3		#' Check if a decorators list is valid and matches the expected output names.
4		#'
5		#' @param x (named `list`) of [teal_transform_module()] objects, or nested lists thereof.
6		#' @param names (`character`) optional vector of valid output names. When provided, all names
7		#' in `x` must be one of these names, and names must be unique.
8		#'
9		#' @return `TRUE` if valid, otherwise a `character(1)` string describing the problem.
10		#' @seealso [module_transform_data()]
11		#' @export
12		#' @examples
13		#' decorator <- teal_transform_module(server = function(id, data) data)
14		#' check_decorators(decorator)
15		#' check_decorators(list(all = decorator))
16		#' check_decorators(list(all = decorator, output = decorator))
17		#' check_decorators(list(all = decorator, output = list(decorator, decorator)))
18		check_decorators <- function(x, names = NULL) { # nolint: object_name.
19
20	33x	check_message <- checkmate::check_list(x, names = "named")
21
22	33x	if (!is.null(names) && isTRUE(check_message)) {
23	9x	if (length(names(x)) != length(unique(names(x)))) {
24	2x	check_message <- sprintf(
25	2x	"The `decorators` must contain unique names from these names: %s",
26	2x	paste(sQuote(names), collapse = ", ")
27		)
28	7x	} else if (!all(unique(names(x)) %in% c("all", names))) {
29	2x	check_message <- sprintf(
30	2x	paste0(
31	2x	"The `decorators` must be a named list with:\n",
32	2x	" * 'all' for decorating all objects and/or\n",
33	2x	" * A name from these: %s"
34		),
35	2x	paste(sQuote(names), collapse = ", ")
36		)
37		}
38		}
39
40	33x	if (!isTRUE(check_message)) {
41	8x	return(check_message)
42		}
43
44	25x	valid_elements <- vapply(
45	25x	x,
46	25x	checkmate::test_class,
47	25x	classes = "teal_transform_module",
48	25x	FUN.VALUE = logical(1L)
49		)
50
51		# Nested list
52	25x	if (any(!valid_elements)) {
53	11x	valid_nested <- vapply(
54	11x	x[!valid_elements], function(subdecorators) {
55	12x	checks <- vapply(subdecorators,
56	12x	checkmate::test_class,
57	12x	classes = "teal_transform_module",
58	12x	logical(1L)
59		)
60	12x	all(checks)
61		},
62	11x	FUN.VALUE = logical(1L)
63		)
64	11x	valid_elements[!valid_elements] <- valid_nested
65		}
66
67	25x	if (all(valid_elements)) {
68	21x	return(TRUE)
69		}
70
71	4x	paste(
72	4x	"The named list can contain a list of 'teal_transform_module' objects created",
73	4x	"using `teal_transform_module()` or be a `teal_transform_module` object."
74		)
75		}
76
77		#' @rdname check_decorators
78		#' @inheritParams checkmate::makeAssertionFunction
79		#' @param add If an `AssertCollection` is provided, the error message is stored in it.
80		#' If `NULL`, an exception is raised if res is not `TRUE`.
81		#' @export
82		assert_decorators <- checkmate::makeAssertionFunction(check_decorators)
83
84		#' Subset decorators based on the scope
85		#'
86		#' Subset a named list of decorators, keeping only those matching the requested
87		#' `scope` together with any decorators registered under the `"all"` name. This is
88		#' a helper for module developers to resolve the decorators applied to a specific
89		#' output when a module produces several decorable outputs.
90		#'
91		#' @param scope (`character(1)`) a decorator name to include.
92		#' @param decorators (named `list`) a named list of decorators to subset.
93		#'
94		#' @return A `list` of `teal_transform_module` objects matching the given `scope` and `all`.
95		#' Returns an empty list if `scope` and `all` is not found in `decorators`.
96		#' @seealso [check_decorators()]
97		#' @export
98		#' @examples
99		#' plot_decorator <- teal_transform_module(server = function(id, data) data)
100		#' table_decorator <- teal_transform_module(server = function(id, data) data)
101		#' decorators <- list(all = plot_decorator, table = table_decorator)
102		#'
103		#' # Decorators for the "table" output: both "all" and "table" scoped decorators.
104		#' str(select_decorators(decorators, "table"))
105		#'
106		#' # An unknown scope keeps only the "all" decorators.
107		#' str(select_decorators(decorators, "plot"))
108		select_decorators <- function(decorators, scope) {
109	8x	checkmate::assert_string(scope, null.ok = FALSE)
110	8x	assert_decorators(decorators)
111	8x	decorators <- decorators[names(decorators) %in% c("all", scope)]
112	8x	if (!length(decorators)) {
113	!	return(list())
114		}
115	8x	Reduce(
116	8x	function(acc, el) {
117	13x	if (inherits(el, "teal_transform_module")) {
118	8x	c(acc, list(el))
119		} else {
120	5x	c(acc, el)
121		}
122		},
123	8x	x = decorators[names(decorators) %in% c("all", scope)],
124	8x	init = list()
125		)
126		}

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

1		#' Execute and validate `teal_data_module`
2		#'
3		#' This is a low level module to handle `teal_data_module` execution and validation.
4		#' [teal_transform_module()] inherits from [teal_data_module()] so it is handled by this module too.
5		#' [srv_teal()] accepts various `data` objects and eventually they are all transformed to `reactive`
6		#' [teal.data::teal_data()] which is a standard data class in whole `teal` framework.
7		#'
8		#' @section data validation:
9		#'
10		#' Executed [teal_data_module()] is validated and output is validated for consistency.
11		#' Output `data` is invalid if:
12		#' 1. [teal_data_module()] is invalid if server doesn't return `reactive`. Immediately crashes an app!
13		#' 2. `reactive` throws a `shiny.error` - happens when module creating [teal.data::teal_data()] fails.
14		#' 3. `reactive` returns `qenv.error` - happens when [teal.data::teal_data()] evaluates a failing code.
15		#' 4. `reactive` object doesn't return [teal.data::teal_data()].
16		#' 5. [teal.data::teal_data()] object lacks any `datanames` specified in the `modules` argument.
17		#'
18		#' `teal` (observers in `srv_teal`) always waits to render an app until `reactive` `teal_data` is
19		#' returned. If error 2-4 occurs, relevant error message is displayed to the app user. Once the issue is
20		#' resolved, the app will continue to run. `teal` guarantees that errors in data don't crash the app
21		#' (except error 1).
22		#'
23		#' @inheritParams module_teal
24		#' @param modules (`teal_modules` or `teal_module`) For `datanames` validation purpose
25		#' @param validate_shiny_silent_error (`logical`) If `TRUE`, then `shiny.silent.error` is validated and
26		#'
27		#' @return `reactive` `teal_data`
28		#'
29		#' @rdname module_validate_error
30		#' @name module_validate_error
31		#' @keywords internal
32		NULL
33
34		#' @rdname module_validate_error
35		#' @keywords internal
36		ui_validate_error <- function(id) {
37	172x	ns <- NS(id)
38	172x	uiOutput(ns("message"))
39		}
40
41		#' @rdname module_validate_error
42		#' @keywords internal
43		srv_validate_error <- function(id, data, validate_shiny_silent_error) {
44	167x	checkmate::assert_string(id)
45	167x	checkmate::assert_flag(validate_shiny_silent_error)
46	167x	moduleServer(id, function(input, output, session) {
47	167x	output$message <- renderUI({
48	162x	is_shiny_silent_error <- inherits(data(), "shiny.silent.error") && identical(data()$message, "")
49	162x	if (inherits(data(), "qenv.error")) {
50	3x	validate(
51	3x	need(
52	3x	FALSE,
53	3x	paste(
54	3x	"Error when executing the `data` module:",
55	3x	cli::ansi_strip(paste(data()$message, collapse = "\n")),
56	3x	"\nCheck your inputs or contact app developer if error persists.",
57	3x	collapse = "\n"
58		)
59		)
60		)
61	159x	} else if (inherits(data(), "error")) {
62	11x	if (is_shiny_silent_error && !validate_shiny_silent_error) {
63	3x	return(NULL)
64		}
65	8x	validate(
66	8x	need(
67	8x	FALSE,
68	8x	sprintf(
69	8x	"Shiny error when executing the `data` module.\n%s\n%s",
70	8x	data()$message,
71	8x	"Check your inputs or contact app developer if error persists."
72		)
73		)
74		)
75		}
76		})
77		})
78		}
79
80		#' @rdname module_validate_error
81		#' @keywords internal
82		ui_check_class_teal_data <- function(id) {
83	172x	ns <- NS(id)
84	172x	uiOutput(ns("message"))
85		}
86
87		#' @rdname module_validate_error
88		#' @keywords internal
89		srv_check_class_teal_data <- function(id, data) {
90	167x	checkmate::assert_string(id)
91	167x	moduleServer(id, function(input, output, session) {
92	167x	output$message <- renderUI({
93	162x	validate(
94	162x	need(
95	162x	inherits(data(), c("teal_data", "error")),
96	162x	"Did not receive `teal_data` object. Cannot proceed further."
97		)
98		)
99		})
100		})
101		}
102
103		#' @rdname module_validate_error
104		#' @keywords internal
105		ui_check_module_datanames <- function(id) {
106	179x	ns <- NS(id)
107	179x	uiOutput(NS(id, "message"))
108		}
109
110		#' @rdname module_validate_error
111		#' @keywords internal
112		srv_check_module_datanames <- function(id, data, modules) {
113	270x	checkmate::assert_string(id)
114	270x	moduleServer(id, function(input, output, session) {
115	270x	output$message <- renderUI({
116	283x	if (inherits(data(), "teal_data")) {
117	251x	is_modules_ok <- check_modules_datanames_html(
118	251x	modules = modules, datanames = names(data())
119		)
120	251x	if (!isTRUE(is_modules_ok)) {
121	19x	tags$div(is_modules_ok, class = "teal-output-warning")
122		}
123		}
124		})
125		})
126		}
127
128		.trigger_on_success <- function(data) {
129	141x	out <- reactiveVal(NULL)
130	141x	observeEvent(data(), {
131	133x	if (inherits(data(), "teal_data")) {
132	124x	if (!identical(data(), out())) {
133	124x	out(data())
134		}
135		}
136		})
137
138	141x	out
139		}

1		#' @title `TealReportCard`
2		#' @description `r lifecycle::badge("experimental")`
3		#' Child class of [`teal.reporter::ReportCard`] that is used for `teal` specific applications.
4		#' In addition to the parent methods, it supports rendering `teal` specific elements such as
5		#' the source code, the encodings panel content and the filter panel content as part of the
6		#' meta data.
7		#' @export
8		#' @importFrom methods as
9		#'
10		TealReportCard <- R6::R6Class( # nolint: object_name.
11		classname = "TealReportCard",
12		inherit = teal.reporter::ReportCard,
13		public = list(
14		#' @description Appends the source code to the `content` meta data of this `TealReportCard`.
15		#'
16		#' @param src (`character(1)`) code as text.
17		#' @param ... any `rmarkdown` `R` chunk parameter and its value.
18		#' But `eval` parameter is always set to `FALSE`.
19		#' @return Object of class `TealReportCard`, invisibly.
20		#' @examples
21		#' card <- TealReportCard$new()$append_src(
22		#' "plot(iris)"
23		#' )
24		#' card$get_content()[[1]]
25		append_src = function(src, ...) {
26	4x	super$append_rcode(text = src, ...)
27		},
28		#' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.
29		#' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses
30		#' the default `yaml::as.yaml` to format the list.
31		#' If the filter state list is empty, nothing is appended to the `content`.
32		#'
33		#' @param fs (`teal_slices`) object returned from [teal_slices()] function.
34		#' @return `self`, invisibly.
35		append_fs = function(fs) {
36	5x	checkmate::assert_class(fs, "teal_slices")
37	4x	if (length(fs) > 0) {
38	3x	self$append_content(teal.reporter::code_chunk(.teal_slice_to_yaml(fs), eval = FALSE, lang = "verbatim"))
39		}
40	4x	invisible(self)
41		},
42		#' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.
43		#'
44		#' @param encodings (`list`) list of encodings selections of the `teal` app.
45		#' @return `self`, invisibly.
46		#' @examples
47		#' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))
48		#' card$get_content()[[1]]
49		#'
50		append_encodings = function(encodings) {
51	4x	checkmate::assert_list(encodings)
52	4x	self$append_text("Selected Options", "header3")
53	4x	if (requireNamespace("yaml", quietly = TRUE)) {
54	4x	self$append_text(yaml::as.yaml(encodings, handlers = list(
55	4x	POSIXct = function(x) format(x, "%Y-%m-%d"),
56	4x	POSIXlt = function(x) format(x, "%Y-%m-%d"),
57	4x	Date = function(x) format(x, "%Y-%m-%d")
58	4x	)), "verbatim")
59		} else {
60	!	stop("yaml package is required to format the encodings list")
61		}
62	4x	self$append_metadata("Encodings", encodings)
63	4x	invisible(self)
64		}
65		)
66		)
67
68		.teal_slice_to_yaml <- function(fs) {
69	23x	checkmate::assert_class(fs, "teal_slices")
70	23x	states_list <- lapply(fs, function(x) {
71	20x	x_list <- shiny::isolate(as.list(x))
72	23x	if (
73	20x	inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
74	20x	length(x_list$choices) == 2 &&
75	20x	length(x_list$selected) == 2
76		) {
77	!	x_list$range <- paste(x_list$selected, collapse = " - ")
78	!	x_list["selected"] <- NULL
79		}
80	20x	if (!is.null(x_list$arg)) {
81	!	x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"
82		}
83
84	20x	x_list <- x_list[
85	20x	c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
86		]
87	20x	names(x_list) <- c(
88	20x	"Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",
89	20x	"Selected Values", "Selected range", "Include NA values", "Include Inf values"
90		)
91
92	20x	Filter(Negate(is.null), x_list)
93		})
94
95	23x	if (requireNamespace("yaml", quietly = TRUE)) {
96	23x	yaml::as.yaml(states_list)
97		} else {
98	!	stop("yaml package is required to format the filter state list")
99		}
100		}
101
102		#' @noRd
103		ui_add_reporter <- function(id) {
104	7x	ns <- shiny::NS(id)
105	7x	bslib::tooltip(
106	7x	id = ns("reporter_tooltip"),
107	7x	trigger = shinyjs::disabled(
108	7x	shiny::tags$div(
109	7x	id = ns("report_add_wrapper"),
110	7x	class = "report_add_wrapper",
111	7x	teal.reporter::add_card_button_ui(ns("reporter_add"), label = "Add to Report")
112		)
113		),
114	7x	class = "teal add-reporter-container",
115	7x	shiny::div(
116	7x	"Click here to add this module's output to the report.",
117	7x	shiny::uiOutput(ns("report_add_reason"))
118		)
119		)
120		}
121
122		#' @noRd
123		srv_add_reporter <- function(id, module_out, reporter, module_label = "") {
124	103x	checkmate::assert_string(id)
125	103x	checkmate::assert_class(reporter, "Reporter", null.ok = TRUE)
126	103x	checkmate::assert_string(module_label)
127	103x	if (is.null(reporter)) {
128	!	return(FALSE)
129		} # early exit
130	103x	moduleServer(id, function(input, output, session) {
131	103x	mod_out_r <- reactive({
132	116x	if (!is.null(module_out) && is.reactive(module_out)) {
133	92x	tryCatch(module_out(), error = function(e) e)
134		}
135		})
136
137	103x	doc_out <- reactive({
138	82x	teal_data_handled <- mod_out_r()
139	82x	tcard <- if (inherits(teal_data_handled, "teal_report")) {
140	81x	teal.reporter::teal_card(teal_data_handled)
141	82x	} else if (inherits(teal_data_handled, "teal_data")) {
142	!	teal.reporter::teal_card(as(teal_data_handled, "teal_report"))
143	82x	} else if (inherits(teal_data_handled, "teal_card")) {
144	!	teal_data_handled
145		}
146
147	80x	if (length(tcard)) .collapse_subsequent_chunks(tcard)
148		})
149
150	103x	reason_r <- reactive({
151	116x	if (is.null(mod_out_r())) {
152	24x	"No report content available from this module."
153	92x	} else if (inherits(mod_out_r(), "error")) {
154	10x	"The module returned an error, check it for errors."
155	82x	} else if (is.null(doc_out())) {
156	2x	"The module does not support reporter functionality."
157	80x	} else if (!inherits(doc_out(), "teal_card")) {
158	!	"Report content not in a valid format, check the module for errors."
159	80x	} else if (isFALSE(attr(mod_out_r(), "teal.enable_report"))) {
160	1x	"The report functionality is disabled for this module."
161		}
162		})
163
164	103x	if (!is.null(reporter)) {
165	103x	output$report_add_reason <- shiny::renderUI({
166	114x	reason <- trimws(reason_r())
167	114x	if (length(reason)) {
168	35x	icon <- if (grepl("error", reason)) "exclamation-triangle-fill" else "info-circle-fill"
169	35x	shiny::div(
170	35x	class = if (grepl("error", reason)) "text-warning" else "text-info",
171	35x	style = "padding-top: 0.5em;",
172	35x	bsicons::bs_icon(name = icon),
173	35x	reason
174		)
175		}
176		})
177
178	103x	observeEvent(reason_r(), ignoreNULL = FALSE, {
179	116x	shinyjs::toggleState("report_add_wrapper", condition = is.null(reason_r()))
180		})
181
182	103x	teal.reporter::add_card_button_srv(
183	103x	"reporter_add",
184	103x	reporter = reporter,
185	103x	card_fun = doc_out,
186	103x	card_title = module_label
187		)
188		}
189		})
190		}
191
192		#' Disable the report for a `teal_module`
193		#'
194		#' Convenience function that disables the user's ability to add the module
195		#' to the report previewer.
196		#' @param x (`teal_module`) a `teal_module` object.
197		#' @return modified data object that indicates that it should disable the reporter functionality.
198		#' @seealso [disable_src()]
199		#' @export
200		#' @examplesShinylive
201		#' library(teal)
202		#' interactive <- function() TRUE
203		#' {{ next_example }}
204		#' @examples
205		#' # Disabling report on a single module
206		#' app <- init(
207		#' data = within(teal_data(), iris <- iris),
208		#' modules = modules(
209		#' example_module(label = "example teal module") \|> disable_report()
210		#' )
211		#' )
212		#' if (interactive()) {
213		#' shinyApp(app$ui, app$server)
214		#' }
215		#'
216		#' @examplesShinylive
217		#' library(teal)
218		#' interactive <- function() TRUE
219		#' {{ next_example }}
220		#' @examples
221		#' # Disabling report on multiple modules
222		#' app <- init(
223		#' data = within(teal_data(), iris <- iris),
224		#' modules = modules(
225		#' example_module(label = "example 1"),
226		#' example_module(label = "example 2")
227		#' ) \|> disable_report()
228		#' )
229		#' if (interactive()) {
230		#' shinyApp(app$ui, app$server)
231		#' }
232		#' @examplesShinylive
233		#' library(teal)
234		#' interactive <- function() TRUE
235		#' {{ next_example }}
236		#' @examples
237		#' # Disabling reporting for the app
238		#' app <- init(
239		#' data = within(teal_data(), iris <- iris),
240		#' modules = modules(
241		#' example_module(label = "example teal module")
242		#' ),
243		#' reporter = NULL
244		#' )
245		#' if (interactive()) {
246		#' shinyApp(app$ui, app$server)
247		#' }
248		disable_report <- function(x) {
249	1x	checkmate::assert_multi_class(x, c("teal_module", "teal_modules"))
250	1x	after(x, server = function(data) {
251	1x	attr(data, "teal.enable_report") <- FALSE
252	1x	data
253		})
254		}

1		#' Executes modifications to the result of a module
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' Exported to be able to use methods not to be used directly by module-developers or app-users.
7		#' Primarily used to modify the output object of module.
8		#' @seealso [disable_src()], [disable_report()]
9		#' @param x (`teal_module` or `teal_modules`).
10		#' @param server (`function(input, output, session, data, ...)`) function to receive output data from `tm$server`.
11		#' Must return data
12		#' @param ... Additional arguments passed to the server wrapper function by matching their formal names.
13		#' @return A `teal_module` or `teal_modules` object with a wrapped server.
14		#' @export
15		#' @keywords internal
16		#' @examples
17		#' library("teal.reporter")
18		#' hide_code <- function(input, output, session, data) {
19		#' teal_card(data) <- Filter(function(x) !inherits(x, "code_chunk"), teal_card(data))
20		#' data
21		#' }
22		#' app <- init(
23		#' data = teal_data(IRIS = iris, MTCARS = mtcars),
24		#' modules = example_module() \|>
25		#' after(server = hide_code)
26		#' )
27		#'
28		#' if (interactive()) {
29		#' runApp(app)
30		#' }
31		after <- function(x,
32		server = function(input, output, session, data) data,
33		...) {
34	2x	UseMethod("after")
35		}
36
37
38		#' @export
39		after.default <- function(x,
40		server = function(input, output, session, data) data,
41		...) {
42	!	stop("`after` is only implemented for `teal_module` and `teal_modules` objects.")
43		}
44
45		#' @export
46		after.teal_modules <- function(x,
47		server = function(input, output, session, data) data,
48		...) {
49	!	x$children <- lapply(x$children, after,
50	!	server = server, ...
51		)
52	!	x
53		}
54
55		#' @export
56		after.teal_module <- function(x,
57		server = function(input, output, session, data) data,
58		...) {
59	2x	checkmate::assert_multi_class(x, "teal_module")
60
61	2x	names_srv <- names(formals(server))
62	2x	args_callModule <- c("input", "output", "session", "data") # nolint object_name_linter.
63	2x	if (!is.function(server) \|\| !(!all(identical(names_srv, c("id", "data"))) \|\| !all(names_srv %in% args_callModule))) {
64	!	stop("`server` must be a function whose arguments are a subset of c('input', 'output', 'session', 'data'), or exactly 'id' AND 'data'.") # nolint line_length_lint
65		}
66
67	2x	additional_args <- list(...)
68	2x	x$ui <- after_ui(x$ui, function(id, elem) {
69	!	elem
70	2x	}, additional_args)
71	2x	x$server <- after_srv(x$server, server, additional_args)
72	2x	x
73		}
74
75		after_ui <- function(old, new, additional_args) {
76	2x	new_ui <- function(id, ...) {
77	!	original_args <- as.list(environment())
78	!	if ("..." %in% names(formals(old))) {
79	!	original_args <- c(original_args, list(...))
80		}
81	!	ns <- NS(id)
82	!	original_args$id <- ns("wrapped")
83	!	original_out <- do.call(old, original_args, quote = TRUE)
84
85	!	wrapper_args <- c(
86	!	additional_args,
87	!	list(id = ns("wrapper"), elem = original_out)
88		)
89	!	do.call(new, args = wrapper_args[names(formals(new))])
90		}
91	2x	formals(new_ui) <- formals(old)
92	2x	new_ui
93		}
94
95		after_srv <- function(old, new, additional_args) {
96	2x	new_srv <- function(id, ...) {
97	2x	original_args <- as.list(environment())
98	2x	original_args$id <- "wrapped"
99	2x	if ("..." %in% names(formals(old))) {
100	!	original_args <- c(original_args, list(...))
101		}
102	2x	moduleServer(id, function(input, output, session) {
103	2x	original_out <- if (all(c("input", "output", "session") %in% names(formals(old)))) {
104	!	original_args$module <- old
105	!	do.call(shiny::callModule, args = original_args)
106		} else {
107	2x	do.call(old, original_args)
108		}
109
110	2x	wrapper_args <- utils::modifyList(
111	2x	additional_args,
112	2x	list(id = "wrapper", input = input, output = output, session = session)
113		)
114	2x	reactive({
115	2x	req(original_out())
116	2x	wrapper_args$data <- original_out()
117	2x	do.call(new, wrapper_args[names(formals(new))], quote = TRUE)
118		})
119		})
120		}
121	2x	formals(new_srv) <- formals(old)
122	2x	new_srv
123		}

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

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

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

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

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	5x	ns <- NS(id)
34	5x	shiny::tagList(
35	5x	tags$span("", id = ns("lockFileStatus")),
36	5x	shinyjs::disabled(downloadLink(ns("lockFileLink"), "Download lockfile"))
37		)
38		}
39
40		#' @rdname module_teal_lockfile
41		srv_teal_lockfile <- function(id) {
42	8x	moduleServer(id, function(input, output, session) {
43	8x	logger::log_debug("Initialize srv_teal_lockfile.")
44	8x	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	8x	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	8x	shiny::onStop(function() {
66	6x	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	8x	lockfile_path <- "teal_app.lock"
73	8x	mode <- getOption("teal.lockfile.mode", default = "")
74
75	8x	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	8x	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	7x	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	7x	if (mode == "auto" && .is_disabled_lockfile_scenario()) {
92	6x	logger::log_debug(
93	6x	"Automatic lockfile creation disabled. Execution scenario satisfies teal:::.is_disabled_lockfile_scenario()."
94		)
95	6x	shinyjs::hide("lockFileLink")
96	6x	return(NULL)
97		}
98
99	1x	if (!.is_lockfile_deps_installed()) {
100	!	warning("Automatic lockfile creation disabled. `mirai` and `renv` packages must be installed.")
101	!	shinyjs::hide("lockFileLink")
102	!	return(NULL)
103		}
104
105		# - Will be run only if the lockfile doesn't exist (see the if-s above)
106		# - We render to the tempfile because the process might last after session is closed and we don't
107		# want to make a "teal_app.renv" then. This is why we copy only during active session.
108	1x	process <- .teal_lockfile_process_invoke(lockfile_path)
109	1x	observeEvent(process$status(), {
110	!	if (process$status() %in% c("initial", "running")) {
111	!	shinyjs::html("lockFileStatus", "Creating lockfile...")
112	!	} else if (process$status() == "success") {
113	!	result <- process$result()
114	!	if (any(grepl("Lockfile written to", result$out))) {
115	!	logger::log_debug("Lockfile containing { length(result$res$Packages) } packages created.")
116	!	if (any(grepl("(WARNING\|ERROR):", result$out))) {
117	!	warning("Lockfile created with warning(s) or error(s):", call. = FALSE)
118	!	for (i in result$out) {
119	!	warning(i, call. = FALSE)
120		}
121		}
122	!	enable_lockfile_download()
123		} else {
124	!	disable_lockfile_download()
125		}
126	!	} else if (process$status() == "error") {
127	!	disable_lockfile_download()
128		}
129		})
130
131	1x	NULL
132		})
133		}
134
135		utils::globalVariables(c("opts", "sysenv", "libpaths", "wd", "lockfilepath", "run")) # needed for mirai call
136		#' @rdname module_teal_lockfile
137		.teal_lockfile_process_invoke <- function(lockfile_path) {
138	1x	mirai_obj <- NULL
139	1x	process <- shiny::ExtendedTask$new(function() {
140	1x	m <- mirai::mirai(
141		{
142	!	options(opts)
143	!	do.call(Sys.setenv, sysenv)
144	!	.libPaths(libpaths)
145	!	setwd(wd)
146	!	run(lockfile_path = lockfile_path)
147		},
148	1x	run = .renv_snapshot,
149	1x	lockfile_path = lockfile_path,
150	1x	opts = options(),
151	1x	libpaths = .libPaths(),
152	1x	sysenv = as.list(Sys.getenv()),
153	1x	wd = getwd()
154		)
155	1x	mirai_obj <<- m
156	1x	m
157		})
158
159	1x	shiny::onStop(function() {
160	1x	if (mirai::unresolved(mirai_obj)) {
161	!	logger::log_debug("Terminating a running lockfile process...")
162	!	mirai::stop_mirai(mirai_obj) # this doesn't stop running - renv will be created even if session is closed
163		}
164		})
165
166	1x	suppressWarnings({ # 'package:stats' may not be available when loading
167	1x	process$invoke()
168		})
169
170	1x	logger::log_debug("Lockfile creation started based on { getwd() }.")
171
172	1x	process
173		}
174
175		#' @rdname module_teal_lockfile
176		.renv_snapshot <- function(lockfile_path) {
177	!	out <- utils::capture.output(
178	!	res <- renv::snapshot(
179	!	lockfile = lockfile_path,
180	!	prompt = FALSE,
181	!	force = TRUE,
182	!	type = renv::settings$snapshot.type() # see the section "Different ways of creating lockfile" above here
183		)
184		)
185
186	!	list(out = out, res = res)
187		}
188
189		#' @rdname module_teal_lockfile
190		.is_lockfile_deps_installed <- function() {
191	1x	requireNamespace("mirai", quietly = TRUE) && requireNamespace("renv", quietly = TRUE)
192		}
193
194		#' @rdname module_teal_lockfile
195		.is_disabled_lockfile_scenario <- function() {
196	6x	identical(Sys.getenv("CALLR_IS_RUNNING"), "true") \|\| # inside callr process
197	6x	identical(Sys.getenv("TESTTHAT"), "true") \|\| # inside devtools::test
198	6x	!identical(Sys.getenv("QUARTO_PROJECT_ROOT"), "") \|\| # inside Quarto process
199		(
200	6x	("CheckExEnv" %in% search()) \|\| any(c("_R_CHECK_TIMINGS_", "_R_CHECK_LICENSE_") %in% names(Sys.getenv()))
201	6x	) # inside R CMD CHECK
202		}

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

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

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

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

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

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