teal coverage - 56.50%

Files
Source

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

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

  modules <- append_reporter_module(modules)

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

  bslib::page_fluid(
    id = id,
    theme = get_teal_bs_theme(),
    include_teal_css_js(),
    shiny_busy_message_panel,
    tags$div(
      id = ns("tabpanel_wrapper"),
      class = "teal-body",
      ui_teal_module(id = ns("teal_modules"), modules = modules)
    ),
    tags$div(
      id = ns("options_buttons"),
      style = "position: absolute; right: 10px;",
      ui_bookmark_panel(ns("bookmark_manager"), modules),
      ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
      ui_filter_manager_panel(ns("filter_manager_panel"))
    ),
    tags$script(
      HTML(
        sprintf(
          "
            $(document).ready(function() {
              $('#%s').appendTo('#%s');
            });
          ",
          ns("options_buttons"),
          ns("teal_modules-active_tab")
        )
      )
    ),
    tags$hr(style = "margin: 1rem 0 0.5rem 0;")
  )
}

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

  modules <- append_reporter_module(modules)

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

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

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

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

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

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

    data_validated <- .trigger_on_success(data_handled)

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

    data_load_status <- reactive({
      if (inherits(data_handled(), "teal_data")) {
        "ok"
      } else if (inherits(data, "teal_data_module")) {
        "teal_data_module failed"
      } else {
        "external failed"
      }
    })

    datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
      eventReactive(data_signatured(), {
        req(inherits(data_signatured(), "teal_data"))
        logger::log_debug("srv_teal@1 initializing FilteredData")
        teal_data_to_filtered_data(data_signatured())
      })
    }



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

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

    reporter <- teal.reporter::Reporter$new()$set_id(attr(filter, "app_id"))
    module_labels <- unlist(module_labels(modules), use.names = FALSE)
    slices_global <- methods::new(".slicesGlobal", filter, module_labels)
    modules_output <- srv_teal_module(
      id = "teal_modules",
      data = data_signatured,
      datasets = datasets_rv,
      modules = modules,
      slices_global = slices_global,
      data_load_status = data_load_status,
      reporter = reporter
    )
    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)
}

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

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

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

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

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

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

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

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

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

        mm
      })
    })

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

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

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

    mapping_table # for testing purpose
  })
}

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

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

    module_fd_previous <- reactiveVal(NULL)

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

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

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

      module_fd()$set_filter_state(slices)

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

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

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

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

    slices_module # returned for testing purpose
  })
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    module_output
  })
}

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

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

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

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

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

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

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

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

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

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

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

    .trigger_on_success(data)
  })
}

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

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


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

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

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

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

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

  out
}

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

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

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

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

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

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


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

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

    invisible(NULL)
  })
}


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

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


# utilities ----

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

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

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

  ans <- TRUE

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

    ns <- session$ns

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

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

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

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

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

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

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

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

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

    snapshot_history
  })
}

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

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

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

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

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

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

  div(
    id = id,
    class = "teal_module",
    uiOutput(ns("data_reactive"), inline = TRUE),
    tagList(
      if (depth >= 2L) tags$div(),
      if (!is.null(modules$datanames)) {
        tagList(
          bslib::layout_sidebar(
            class = "teal-sidebar-layout",
            sidebar = bslib::sidebar(
              id = ns("teal_module_sidebar"),
              class = "teal-sidebar",
              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"),
                id
              )
            )
          )
        )
      } else {
        ui_teal
      }
    )
  )
}

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

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

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

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

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

    modules_output
  })
}

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

    active_datanames <- reactive({
      .resolve_module_datanames(data = data(), modules = modules)
    })
    if (is.null(datasets)) {
      datasets <- eventReactive(data(), {
        req(inherits(data(), "teal_data"))
        logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
        teal_data_to_filtered_data(data(), datanames = active_datanames())
      })
    }

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

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

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

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

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

      summary_table <- srv_data_summary("data_summary", module_teal_data)

      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_accordian", 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_accordian", 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_accordian", values = TRUE)
        bslib::accordion_panel_open(id = "data_transform_accordion", values = TRUE)
      })

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

    module_out
  })
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  trigger_data
}

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

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

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

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

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

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

  bs_theme
}

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

  unique(ordered_datanames)
}

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


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

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


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

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

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

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

  reserved_datanames <- check_reserved_datanames(datanames)

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

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

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


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

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


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

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

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

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

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

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

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

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

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

#' @title `TealReportCard`
#' @description `r lifecycle::badge("experimental")`
#' Child class of [`teal.reporter::ReportCard`] that is used for `teal` specific applications.
#' In addition to the parent methods, it supports rendering `teal` specific elements such as
#' the source code, the encodings panel content and the filter panel content as part of the
#' meta data.
#' @export
#'
TealReportCard <- R6::R6Class( # nolint: object_name.
  classname = "TealReportCard",
  inherit = teal.reporter::ReportCard,
  public = list(
    #' @description Appends the source code to the `content` meta data of this `TealReportCard`.
    #'
    #' @param src (`character(1)`) code as text.
    #' @param ... any `rmarkdown` `R` chunk parameter and its value.
    #' But `eval` parameter is always set to `FALSE`.
    #' @return Object of class `TealReportCard`, invisibly.
    #' @examples
    #' card <- TealReportCard$new()$append_src(
    #'   "plot(iris)"
    #' )
    #' card$get_content()[[1]]$get_content()
    append_src = function(src, ...) {
      checkmate::assert_character(src, min.len = 0, max.len = 1)
      params <- list(...)
      params$eval <- FALSE
      rblock <- RcodeBlock$new(src)
      rblock$set_params(params)
      self$append_content(rblock)
      self$append_metadata("SRC", src)
      invisible(self)
    },
    #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.
    #'  If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses
    #'  the default `yaml::as.yaml` to format the list.
    #'  If the filter state list is empty, nothing is appended to the `content`.
    #'
    #' @param fs (`teal_slices`) object returned from [teal_slices()] function.
    #' @return `self`, invisibly.
    append_fs = function(fs) {
      checkmate::assert_class(fs, "teal_slices")
      self$append_text("Filter State", "header3")
      if (length(fs)) {
        self$append_content(TealSlicesBlock$new(fs))
      } else {
        self$append_text("No filters specified.")
      }
      invisible(self)
    },
    #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.
    #'
    #' @param encodings (`list`) list of encodings selections of the `teal` app.
    #' @return `self`, invisibly.
    #' @examples
    #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))
    #' card$get_content()[[1]]$get_content()
    #'
    append_encodings = function(encodings) {
      checkmate::assert_list(encodings)
      self$append_text("Selected Options", "header3")
      if (requireNamespace("yaml", quietly = TRUE)) {
        self$append_text(yaml::as.yaml(encodings, handlers = list(
          POSIXct = function(x) format(x, "%Y-%m-%d"),
          POSIXlt = function(x) format(x, "%Y-%m-%d"),
          Date = function(x) format(x, "%Y-%m-%d")
        )), "verbatim")
      } else {
        stop("yaml package is required to format the encodings list")
      }
      self$append_metadata("Encodings", encodings)
      invisible(self)
    }
  ),
  private = list(
    dispatch_block = function(block_class) {
      if (exists(block_class, getNamespace("teal"))) {
        # for block classes which are in teal (TealSlicesBlock)
        get(block_class)
      } else {
        # other block classes are in teal.reporter so we need to use super (ReporterCard) class
        super$dispatch_block(block_class)
      }
    }
  )
)

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

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

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

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

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

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

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

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

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

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

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

    data_handled
  })
}

#' Adds signature protection to the `datanames` in the data
#' @param data (`teal_data`)
#' @return `teal_data` with additional code that has signature of the `datanames`
#' @keywords internal
.add_signature_to_data <- function(data) {
  hashes <- .get_hashes_code(data)
  tdata <- do.call(
    teal.data::teal_data,
    c(
      list(code = trimws(c(teal.code::get_code(data), hashes), which = "right")),
      list(join_keys = teal.data::join_keys(data)),
      sapply(
        names(data),
        teal.code::get_var,
        object = data,
        simplify = FALSE
      )
    )
  )

  tdata@verified <- data@verified
  tdata
}

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

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

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

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

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

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

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

  singleton(lapply(js_files, includeScript))
}

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

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

setOldClass("teal_data_module")

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

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

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

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

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

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

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

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

  invisible()
}

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

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

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

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

#' @rdname teal_data_utilities
.append_evaluated_code <- function(data, code) {
  checkmate::assert_class(data, "teal_data")
  data@code <- c(data@code, code2list(code))
  methods::validObject(data)
  data
}

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

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

  message("Initializing reporter_previewer_module")

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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	1165x	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	1161x	return(TRUE)
16		}
17		#' @rdname check_reactive
18		test_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
19	30x	isTRUE(check_reactive(x, null.ok = null.ok))
20		}
21		#' @rdname check_reactive
22		assert_reactive <- checkmate::makeAssertionFunction(check_reactive)
23
24		#' Capture error and decorate error message.
25		#'
26		#' @param x object to evaluate
27		#' @param pre (`character(1)`) A string to prepend to error message
28		#' @param post (`character(1)`) A string to append to error message
29		#'
30		#' @return `x` if no error, otherwise throws error with decorated message
31		#'
32		#' @keywords internal
33		decorate_err_msg <- function(x, pre = character(0), post = character(0)) {
34	47x	tryCatch(
35	47x	x,
36	47x	error = function(e) {
37	2x	stop(
38	2x	"\n",
39	2x	pre,
40	2x	"\n",
41	2x	e$message,
42	2x	"\n",
43	2x	post,
44	2x	call. = FALSE
45		)
46		}
47		)
48	45x	x
49		}

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

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

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

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

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

1		#' `teal_data` utils
2		#'
3		#' In `teal` we need to recreate the `teal_data` object due to two operations:
4		#' - we need to append filter-data code and objects which have been evaluated in `FilteredData` and
5		#' we want to avoid double-evaluation.
6		#' - we need to subset `teal_data` to `datanames` used by the module, to shorten obtainable R-code
7		#'
8		#' Due to above recreation of `teal_data` object can't be done simply by using public
9		#' `teal.code` and `teal.data` methods.
10		#'
11		#' @param data (`teal_data`)
12		#' @param code (`character`) code to append to the object's code slot.
13		#' @param objects (`list`) objects to append to object's environment.
14		#' @return modified `teal_data`
15		#' @keywords internal
16		#' @name teal_data_utilities
17		NULL
18
19		#' @rdname teal_data_utilities
20		.append_evaluated_code <- function(data, code) {
21	96x	checkmate::assert_class(data, "teal_data")
22	96x	data@code <- c(data@code, code2list(code))
23	96x	methods::validObject(data)
24	96x	data
25		}
26
27		#' @rdname teal_data_utilities
28		.append_modified_data <- function(data, objects) {
29	96x	checkmate::assert_class(data, "teal_data")
30	96x	checkmate::assert_class(objects, "list")
31	96x	new_env <- list2env(objects, parent = .GlobalEnv)
32	96x	rlang::env_coalesce(new_env, as.environment(data))
33	96x	[email protected] <- new_env
34	96x	data
35		}

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

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

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

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

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

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