teal coverage - 59.18%

Files
Source

#' 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
#'           }
#'         )
#'         datanames(data) <- c("dataset1", "dataset2")
#'
#'         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
  )
}

#' Data module for `teal` transformers.
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' Create a `teal_data_module` object for custom transformation of data for pre-processing
#' before passing the data into the module.
#'
#' @details
#' `teal_transform_module` creates a [`teal_data_module`] object to transform data in a `teal`
#' application. This transformation happens after the data has passed through the filtering activity
#' in teal. The transformed data is then sent to the server of the [teal_module()].
#'
#' See vignette `vignette("data-transform-as-shiny-module", package = "teal")` for more details.
#'
#'
#' @inheritParams teal_data_module
#' @param server (`function(id, data)`)
#' `shiny` module server function; that takes `id` and `data` argument,
#' where the `id` is the module id and `data` is the reactive `teal_data` input.
#' The server function must return reactive expression containing `teal_data` object.
#' @param datanames (`character`)
#'  Names of the datasets that are relevant for the module. The
#'  filter panel will only display filters for specified `datanames`. The keyword `"all"` will show
#'  filters of all datasets. `datanames` will be automatically appended to the [modules()] `datanames`.
#' @examples
#' my_transformers <- list(
#'   teal_transform_module(
#'     label = "Custom transform for iris",
#'     datanames = "iris",
#'     ui = function(id) {
#'       ns <- NS(id)
#'       tags$div(
#'         numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
#'       )
#'     },
#'     server = function(id, data) {
#'       moduleServer(id, function(input, output, session) {
#'         reactive({
#'           within(data(),
#'             {
#'               iris <- head(iris, num_rows)
#'             },
#'             num_rows = input$n_rows
#'           )
#'         })
#'       })
#'     }
#'   )
#' )
#'
#' @name teal_transform_module
#'
#' @export
teal_transform_module <- function(ui = function(id) NULL,
                                  server = function(id, data) data,
                                  label = "transform module",
                                  datanames = "all") {
  checkmate::assert_function(ui, args = "id", nargs = 1)
  checkmate::assert_function(server, args = c("id", "data"), nargs = 2)
  checkmate::assert_string(label)
  structure(
    list(
      ui = ui,
      server = function(id, data) {
        data_out <- server(id, data)
        decorate_err_msg(
          assert_reactive(data_out),
          pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
          post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
        )
      }
    ),
    label = label,
    datanames = datanames,
    class = c("teal_transform_module", "teal_data_module")
  )
}


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

#' 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_object_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`.
#'
#' @param id (`character(1)`)
#'  `shiny` module instance id.
#' @param teal_data (`reactive` returning `teal_data`)
#'
#'
#' @name module_data_summary
#' @rdname module_data_summary
#' @keywords internal
#' @return `NULL`.
NULL

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

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

      summary_table <- reactive({
        req(inherits(teal_data(), "teal_data"))
        if (!length(ls(teal.code::get_env(teal_data())))) {
          return(NULL)
        }

        filter_overview <- get_filter_overview(teal_data)
        names(filter_overview)[[1]] <- "Data Name"

        filter_overview$Obs <- ifelse(
          !is.na(filter_overview$obs),
          sprintf("%s/%s", filter_overview$obs_filtered, filter_overview$obs),
          ifelse(!is.na(filter_overview$obs_filtered), sprintf("%s", filter_overview$obs_filtered), "")
        )

        filter_overview$Subjects <- ifelse(
          !is.na(filter_overview$subjects),
          sprintf("%s/%s", filter_overview$subjects_filtered, filter_overview$subjects),
          ""
        )

        filter_overview <- filter_overview[, colnames(filter_overview) %in% c("Data Name", "Obs", "Subjects")]
        Filter(function(col) !all(col == ""), filter_overview)
      })

      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 {
          body_html <- apply(
            summary_table_out,
            1,
            function(x) {
              tags$tr(
                tagList(
                  tags$td(
                    if (all(x[-1] == "")) {
                      icon(
                        name = "fas fa-exclamation-triangle",
                        title = "Unsupported dataset",
                        `data-container` = "body",
                        `data-toggle` = "popover",
                        `data-content` = "object not supported by the data_summary module"
                      )
                    },
                    x[1]
                  ),
                  lapply(x[-1], tags$td)
                )
              )
            }
          )

          header_labels <- names(summary_table())
          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)
          )
          table_html
        }
      })

      summary_table # testing purpose
    }
  )
}

#' @rdname module_data_summary
get_filter_overview <- function(teal_data) {
  datanames <- teal.data::datanames(teal_data())
  joinkeys <- teal.data::join_keys(teal_data())

  filtered_data_objs <- sapply(
    datanames,
    function(name) teal.code::get_var(teal_data(), name),
    simplify = FALSE
  )
  unfiltered_data_objs <- teal.code::get_var(teal_data(), ".raw_data")

  rows <- lapply(
    datanames,
    function(dataname) {
      parent <- teal.data::parent(joinkeys, dataname)
      # todo: what should we display for a parent dataset?
      #     - Obs and Subjects
      #     - Obs only
      #     - Subjects only
      # todo (for later): summary table should be displayed in a way that child datasets
      #       are indented under their parent dataset to form a tree structure
      subject_keys <- if (length(parent) > 0) {
        names(joinkeys[dataname, parent])
      } else {
        joinkeys[dataname, dataname]
      }
      get_object_filter_overview(
        filtered_data = filtered_data_objs[[dataname]],
        unfiltered_data = unfiltered_data_objs[[dataname]],
        dataname = dataname,
        subject_keys = subject_keys
      )
    }
  )

  unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1)) # this is mainly for vectors
  do.call(rbind, c(rows[!unssuported_idx], rows[unssuported_idx]))
}

#' @rdname module_data_summary
#' @param filtered_data (`list`) of filtered objects
#' @param unfiltered_data (`list`) of unfiltered objects
#' @param dataname (`character(1)`)
get_object_filter_overview <- function(filtered_data, unfiltered_data, dataname, subject_keys) {
  if (inherits(filtered_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
    get_object_filter_overview_array(filtered_data, unfiltered_data, dataname, subject_keys)
  } else if (inherits(filtered_data, "MultiAssayExperiment")) {
    get_object_filter_overview_MultiAssayExperiment(filtered_data, unfiltered_data, dataname)
  } else {
    data.frame(
      dataname = dataname,
      obs = NA,
      obs_filtered = NA,
      subjects = NA,
      subjects_filtered = NA
    )
  }
}

#' @rdname module_data_summary
get_object_filter_overview_array <- function(filtered_data, # nolint: object_length.
                                             unfiltered_data,
                                             dataname,
                                             subject_keys) {
  if (length(subject_keys) == 0) {
    data.frame(
      dataname = dataname,
      obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
      obs_filtered = nrow(filtered_data),
      subjects = NA,
      subjects_filtered = NA
    )
  } else {
    data.frame(
      dataname = dataname,
      obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
      obs_filtered = nrow(filtered_data),
      subjects = nrow(unique(unfiltered_data[subject_keys])),
      subjects_filtered = nrow(unique(filtered_data[subject_keys]))
    )
  }
}

#' @rdname module_data_summary
get_object_filter_overview_MultiAssayExperiment <- function(filtered_data, # nolint: object_length, object_name.
                                                            unfiltered_data,
                                                            dataname) {
  experiment_names <- names(unfiltered_data)
  mae_info <- data.frame(
    dataname = dataname,
    obs = NA,
    obs_filtered = NA,
    subjects = nrow(unfiltered_data@colData),
    subjects_filtered = nrow(filtered_data@colData)
  )

  experiment_obs_info <- do.call("rbind", lapply(
    experiment_names,
    function(experiment_name) {
      transform(
        get_object_filter_overview(
          filtered_data[[experiment_name]],
          unfiltered_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 = get_experiment_keys(filtered_data, unfiltered_data[[experiment_name]]),
        subjects_filtered = get_experiment_keys(filtered_data, filtered_data[[experiment_name]])
      )
    }
  ))

  experiment_info <- cbind(experiment_obs_info[, c("dataname", "obs", "obs_filtered")], experiment_subjects_info)
  rbind(mae_info, experiment_info)
}

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

    eventReactive(trigger_data(), {
      .make_filtered_teal_data(modules, data = data_rv(), 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", datanames)),
      "))\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_rv) {
  previous_signature <- reactiveVal(NULL)
  filter_changed <- reactive({
    req(inherits(datasets(), "FilteredData"))
    new_signature <- c(
      teal.data::get_code(data_rv()),
      .get_filter_expr(datasets = datasets(), datanames = active_datanames())
    )
    if (!identical(previous_signature(), new_signature)) {
      previous_signature(new_signature)
      TRUE
    } else {
      FALSE
    }
  })

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

  trigger_data
}

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

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

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

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

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

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

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

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

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

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

        mm
      })
    })

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

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

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

    mapping_table # for testing purpose
  })
}

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

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

    module_fd_previous <- reactiveVal(NULL)

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

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

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

      module_fd()$set_filter_state(slices)

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

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

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

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

    slices_module # returned for testing purpose
  })
}

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

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

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

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

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

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

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

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

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

#' 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 init
#'
#' @return Invisible `NULL`.
#'
#' @aliases bookmark bookmark_manager bookmark_manager_module
#'
#' @name module_bookmark_manager
#' @rdname module_bookmark_manager
#'
#' @keywords internal
#'
NULL

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

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

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

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

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

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

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

    invisible(NULL)
  })
}


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

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


# utilities ----

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

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

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

  ans <- TRUE

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

    NULL
  })
}

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

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

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

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

  process
}

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

  list(out = out, res = res)
}

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

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

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

#' @rdname module_snapshot_manager
ui_snapshot_manager_panel <- function(id) {
  ns <- NS(id)
  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]]
      # todo: as.teal_slices looses module-mapping if is not global
      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_rv (`reactive` returning `teal_data`)
#'
#' @param slices_global (`reactiveVal` returning `modules_teal_slices`)
#'   see [`module_filter_manager`]
#'
#' @param depth (`integer(1)`)
#'  number which helps to determine depth of the modules nesting.
#'
#' @param datasets (`reactive` returning `FilteredData` or `NULL`)
#'  When `datasets` is passed from the parent module (`srv_teal`) then `dataset` is a singleton
#'  which implies in filter-panel to be "global". When `NULL` then filter-panel is "module-specific".
#'
#' @param data_load_status (`reactive` returning `character`)
#'  Determines action dependent on a data loading status:
#'  - `"ok"` when `teal_data` is returned from the data loading.
#'  - `"teal_data_module failed"` when [teal_data_module()] didn't return  `teal_data`. Disables tabs buttons.
#'  - `"external failed"` when a `reactive` passed to `srv_teal(data)` didn't return `teal_data`. Hides the whole tab
#'    panel.
#'
#' @return
#' output of currently active module.
#' - `srv_teal_module.teal_module` returns `reactiveVal` containing output of the called module.
#' - `srv_teal_module.teal_modules` returns output of module selected by `input$active_tab`.
#'
#' @keywords internal
NULL

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

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

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

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

  ui_teal <- tagList(
    div(
      id = ns("validate_datanames"),
      ui_validate_reactive_teal_data(ns("validate_datanames"))
    ),
    shinyjs::hidden(
      tags$div(
        id = ns("transformer_failure_info"),
        class = "teal_validated",
        div(
          class = "teal-output-warning",
          "One of transformers failed. Please fix and continue."
        )
      )
    ),
    tags$div(
      id = ns("teal_module_ui"),
      do.call(modules$ui, args)
    )
  )

  div(
    id = id,
    class = "teal_module",
    uiOutput(ns("data_reactive"), inline = TRUE),
    tagList(
      if (depth >= 2L) tags$div(style = "mt-6"),
      if (!is.null(modules$datanames)) {
        fluidRow(
          column(width = 9, ui_teal, class = "teal_primary_col"),
          column(
            width = 3,
            ui_data_summary(ns("data_summary")),
            ui_filter_data(ns("filter_panel")),
            if (length(modules$transformers) > 0 && !isTRUE(attr(modules$transformers, "custom_ui"))) {
              ui_transform_data(ns("data_transform"), transforms = modules$transformers, class = "well")
            },
            class = "teal_secondary_col"
          )
        )
      } else {
        div(
          div(
            class = "teal_validated",
            uiOutput(ns("data_input_error"))
          ),
          ui_teal
        )
      }
    )
  )
}

#' @rdname module_teal_module
srv_teal_module <- function(id,
                            data_rv,
                            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_rv)
  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_rv,
                                    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_rv,
                                         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_rv = data_rv,
          modules = modules$children[[module_id]],
          datasets = datasets,
          slices_global = slices_global,
          reporter = reporter,
          is_active = reactive(is_active() && input$active_tab == module_id)
        )
      },
      simplify = FALSE
    )

    modules_output
  })
}

#' @rdname module_teal_module
#' @export
srv_teal_module.teal_module <- function(id,
                                        data_rv,
                                        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) {
    active_datanames <- reactive({
      .resolve_module_datanames(data = data_rv(), modules = modules)
    })
    if (is.null(datasets)) {
      datasets <- eventReactive(data_rv(), {
        req(inherits(data_rv(), "teal_data"))
        logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
        teal_data_to_filtered_data(data_rv(), 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)
    filtered_teal_data <- srv_filter_data(
      "filter_panel",
      datasets = datasets,
      active_datanames = active_datanames,
      data_rv = data_rv,
      is_active = is_active
    )

    is_transformer_failed <- reactiveValues()
    transformed_teal_data <- srv_transform_data(
      "data_transform",
      data = filtered_teal_data,
      transforms = modules$transformers,
      modules = modules,
      is_transformer_failed = is_transformer_failed
    )
    any_transformer_failed <- reactive({
      any(unlist(reactiveValuesToList(is_transformer_failed)))
    })
    observeEvent(any_transformer_failed(), {
      if (isTRUE(any_transformer_failed())) {
        shinyjs::hide("teal_module_ui")
        shinyjs::hide("validate_datanames")
        shinyjs::show("transformer_failure_info")
      } else {
        shinyjs::show("teal_module_ui")
        shinyjs::show("validate_datanames")
        shinyjs::hide("transformer_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)
      .subset_teal_data(all_teal_data, module_datanames)
    })

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

    summary_table <- srv_data_summary("data_summary", module_teal_data)

    # Call modules.
    module_out <- reactiveVal(NULL)
    if (!inherits(modules, "teal_module_previewer")) {
      obs_module <- observeEvent(
        # wait for module_teal_data() to be not NULL but only once:
        ignoreNULL = TRUE,
        once = TRUE,
        eventExpr = module_teal_data(),
        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))
    }

    # todo: (feature request) add a ReporterCard to the reporter as an output from the teal_module
    #       how to determine if module returns a ReporterCard so that reportPreviewer is needed?
    #       Should we insertUI of the ReportPreviewer then?
    #       What about attr(module, "reportable") - similar to attr(module, "bookmarkable")
    if ("report" %in% names(module_out)) {
      # (reactively) add card to the reporter
    }

    module_out
  })
}

# This function calls a module server function.
.call_teal_module <- function(modules, datasets, filtered_teal_data, reporter) {
  # 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(filtered_teal_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(modules$server, args)
  } else {
    do.call(callModule, c(args, list(module = modules$server)))
  }
}

.resolve_module_datanames <- function(data, modules) {
  stopifnot("data_rv must be teal_data object." = inherits(data, "teal_data"))
  if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
    .topologically_sort_datanames(ls(teal.code::get_env(data)), teal.data::join_keys(data))
  } else {
    intersect(
      .include_parent_datanames(modules$datanames, teal.data::join_keys(data)),
      ls(teal.code::get_env(data))
    )
  }
}

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

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

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

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

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

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

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

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

  if (is.null(bs_theme)) {
    return(NULL)
  }

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

  bs_theme
}

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

#' Return topologicaly sorted datanames
#' @noRd
#' @keywords internal
.topologically_sort_datanames <- function(datanames, join_keys) {
  datanames_with_parents <- .include_parent_datanames(datanames, join_keys)
  intersect(datanames, datanames_with_parents)
}

#' 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 `datanames(x)`
#' @return A `FilteredData` object.
#' @keywords internal
teal_data_to_filtered_data <- function(x, datanames = ls(teal.code::get_env(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
#'
#' This function ensures specified `datanames` in modules match those in the data object,
#' returning error messages or `TRUE` for successful validation.
#'
#' @param modules (`teal_modules`) 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_modules_datanames <- function(modules, datanames) {
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  checkmate::assert_character(datanames)

  recursive_check_datanames <- function(modules, datanames) {
    # check teal_modules against datanames
    if (inherits(modules, "teal_modules")) {
      result <- lapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))
      result <- result[vapply(result, Negate(is.null), logical(1L))]
      if (length(result) == 0) {
        return(NULL)
      }
      list(
        string = do.call(c, as.list(unname(sapply(result, function(x) x$string)))),
        html = function(with_module_name = TRUE) {
          tagList(
            lapply(
              result,
              function(x) x$html(with_module_name = with_module_name)
            )
          )
        }
      )
    } else {
      extra_datanames <- setdiff(modules$datanames, c("all", datanames))
      if (length(extra_datanames)) {
        list(
          string = build_datanames_error_message(
            modules$label,
            datanames,
            extra_datanames,
            tags = list(

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_rv, is_active) {
28	95x	assert_reactive(datasets)
29	95x	moduleServer(id, function(input, output, session) {
30	95x	active_corrected <- reactive(intersect(active_datanames(), datasets()$datanames()))
31
32	95x	output$panel <- renderUI({
33	83x	req(inherits(datasets(), "FilteredData"))
34	75x	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	75x	logger::log_debug("srv_filter_panel rendering filter panel.")
38	75x	if (length(active_corrected())) {
39	74x	datasets()$srv_active("filters", active_datanames = active_corrected)
40	74x	datasets()$ui_active(session$ns("filters"), active_datanames = active_corrected)
41		}
42		})
43		})
44
45	95x	trigger_data <- .observe_active_filter_changed(datasets, is_active, active_corrected, data_rv)
46
47	95x	eventReactive(trigger_data(), {
48	73x	.make_filtered_teal_data(modules, data = data_rv(), 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	73x	data <- eval_code(
56	73x	data,
57	73x	paste0(
58	73x	".raw_data <- list2env(list(",
59	73x	toString(sprintf("%1$s = %1$s", datanames)),
60	73x	"))\n",
61	73x	"lockEnvironment(.raw_data) #@linksto .raw_data" # this is environment and it is shared by qenvs. CAN'T MODIFY!
62		)
63		)
64	73x	filtered_code <- .get_filter_expr(datasets = datasets, datanames = datanames)
65	73x	filtered_teal_data <- .append_evaluated_code(data, filtered_code)
66	73x	filtered_datasets <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)
67	73x	filtered_teal_data <- .append_modified_data(filtered_teal_data, filtered_datasets)
68	73x	filtered_teal_data
69		}
70
71		#' @rdname module_filter_data
72		.observe_active_filter_changed <- function(datasets, is_active, active_datanames, data_rv) {
73	95x	previous_signature <- reactiveVal(NULL)
74	95x	filter_changed <- reactive({
75	163x	req(inherits(datasets(), "FilteredData"))
76	159x	new_signature <- c(
77	159x	teal.data::get_code(data_rv()),
78	159x	.get_filter_expr(datasets = datasets(), datanames = active_datanames())
79		)
80	159x	if (!identical(previous_signature(), new_signature)) {
81	76x	previous_signature(new_signature)
82	76x	TRUE
83		} else {
84	83x	FALSE
85		}
86		})
87
88	95x	trigger_data <- reactiveVal(NULL)
89	95x	observe({
90	197x	if (isTRUE(is_active() && filter_changed())) {
91	76x	isolate({
92	76x	if (is.null(trigger_data())) {
93	68x	trigger_data(0)
94		} else {
95	8x	trigger_data(trigger_data() + 1)
96		}
97		})
98		}
99		})
100
101	95x	trigger_data
102		}
103
104		#' @rdname module_filter_data
105		.get_filter_expr <- function(datasets, datanames) {
106	232x	if (length(datanames)) {
107	229x	teal.slice::get_filter_expr(datasets = datasets, datanames = datanames)
108		} else {
109	3x	NULL
110		}
111		}

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

1		#' Get client timezone
2		#'
3		#' User timezone in the browser may be different to the one on the server.
4		#' This script can be run to register a `shiny` input which contains information about the timezone in the browser.
5		#'
6		#' @param ns (`function`) namespace function passed from the `session` object in the `shiny` server.
7		#' For `shiny` modules this will allow for proper name spacing of the registered input.
8		#'
9		#' @return `NULL`, invisibly.
10		#'
11		#' @keywords internal
12		#'
13		get_client_timezone <- function(ns) {
14	71x	script <- sprintf(
15	71x	"Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",
16	71x	ns("timezone")
17		)
18	71x	shinyjs::runjs(script) # function does not return anything
19	71x	invisible(NULL)
20		}
21
22		#' Resolve the expected bootstrap theme
23		#' @noRd
24		#' @keywords internal
25		get_teal_bs_theme <- function() {
26	4x	bs_theme <- getOption("teal.bs_theme")
27
28	4x	if (is.null(bs_theme)) {
29	1x	return(NULL)
30		}
31
32	3x	if (!checkmate::test_class(bs_theme, "bs_theme")) {
33	2x	warning(
34	2x	"Assertion on 'teal.bs_theme' option value failed: ",
35	2x	checkmate::check_class(bs_theme, "bs_theme"),
36	2x	". The default Shiny Bootstrap theme will be used."
37		)
38	2x	return(NULL)
39		}
40
41	1x	bs_theme
42		}
43
44		#' Return parentnames along with datanames.
45		#' @noRd
46		#' @keywords internal
47		.include_parent_datanames <- function(datanames, join_keys) {
48	147x	ordered_datanames <- datanames
49	147x	for (i in datanames) {
50	264x	parents <- character(0)
51	264x	while (length(i) > 0) {
52	277x	parent_i <- teal.data::parent(join_keys, i)
53	277x	parents <- c(parent_i, parents)
54	277x	i <- parent_i
55		}
56	264x	ordered_datanames <- c(parents, ordered_datanames)
57		}
58	147x	unique(ordered_datanames)
59		}
60
61		#' Return topologicaly sorted datanames
62		#' @noRd
63		#' @keywords internal
64		.topologically_sort_datanames <- function(datanames, join_keys) {
65	125x	datanames_with_parents <- .include_parent_datanames(datanames, join_keys)
66	125x	intersect(datanames, datanames_with_parents)
67		}
68
69		#' Create a `FilteredData`
70		#'
71		#' Create a `FilteredData` object from a `teal_data` object.
72		#'
73		#' @param x (`teal_data`) object
74		#' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)`
75		#' @return A `FilteredData` object.
76		#' @keywords internal
77		teal_data_to_filtered_data <- function(x, datanames = ls(teal.code::get_env(x))) {
78	65x	checkmate::assert_class(x, "teal_data")
79	65x	checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)
80		# Otherwise, FilteredData will be created in the modules' scope later
81	65x	teal.slice::init_filtered_data(
82	65x	x = Filter(
83	65x	length,
84	65x	sapply(datanames, function(dn) x[[dn]], simplify = FALSE)
85		),
86	65x	join_keys = teal.data::join_keys(x)
87		)
88		}
89
90
91		#' Template function for `TealReportCard` creation and customization
92		#'
93		#' This function generates a report card with a title,
94		#' an optional description, and the option to append the filter state list.
95		#'
96		#' @param title (`character(1)`) title of the card (unless overwritten by label)
97		#' @param label (`character(1)`) label provided by the user when adding the card
98		#' @param description (`character(1)`) optional, additional description
99		#' @param with_filter (`logical(1)`) flag indicating to add filter state
100		#' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation
101		#' of the filter state in the report
102		#'
103		#' @return (`TealReportCard`) populated with a title, description and filter state.
104		#'
105		#' @export
106		report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
107	2x	checkmate::assert_string(title)
108	2x	checkmate::assert_string(label)
109	2x	checkmate::assert_string(description, null.ok = TRUE)
110	2x	checkmate::assert_flag(with_filter)
111	2x	checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")
112
113	2x	card <- teal::TealReportCard$new()
114	2x	title <- if (label == "") title else label
115	2x	card$set_name(title)
116	2x	card$append_text(title, "header2")
117	1x	if (!is.null(description)) card$append_text(description, "header3")
118	1x	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
119	2x	card
120		}
121
122
123		#' Check `datanames` in modules
124		#'
125		#' This function ensures specified `datanames` in modules match those in the data object,
126		#' returning error messages or `TRUE` for successful validation.
127		#'
128		#' @param modules (`teal_modules`) object
129		#' @param datanames (`character`) names of datasets available in the `data` object
130		#'
131		#' @return A `character(1)` containing error message or `TRUE` if validation passes.
132		#' @keywords internal
133		check_modules_datanames <- function(modules, datanames) {
134	152x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
135	152x	checkmate::assert_character(datanames)
136
137	152x	recursive_check_datanames <- function(modules, datanames) {
138		# check teal_modules against datanames
139	237x	if (inherits(modules, "teal_modules")) {
140	65x	result <- lapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))
141	65x	result <- result[vapply(result, Negate(is.null), logical(1L))]
142	65x	if (length(result) == 0) {
143	58x	return(NULL)
144		}
145	7x	list(
146	7x	string = do.call(c, as.list(unname(sapply(result, function(x) x$string)))),
147	7x	html = function(with_module_name = TRUE) {
148	6x	tagList(
149	6x	lapply(
150	6x	result,
151	6x	function(x) x$html(with_module_name = with_module_name)
152		)
153		)
154		}
155		)
156		} else {
157	172x	extra_datanames <- setdiff(modules$datanames, c("all", datanames))
158	172x	if (length(extra_datanames)) {
159	10x	list(
160	10x	string = build_datanames_error_message(
161	10x	modules$label,
162	10x	datanames,
163	10x	extra_datanames,
164	10x	tags = list(

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		#' datanames(data) <- c("dataset1", "dataset2")
52		#'
53		#' data
54		#' })
55		#' })
56		#' }
57		#' )
58		#'
59		#' @name teal_data_module
60		#' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]
61		#'
62		#' @export
63		teal_data_module <- function(ui, server, label = "data module", once = TRUE) {
64	32x	checkmate::assert_function(ui, args = "id", nargs = 1)
65	31x	checkmate::assert_function(server, args = "id", nargs = 1)
66	29x	checkmate::assert_string(label)
67	29x	checkmate::assert_flag(once)
68	29x	structure(
69	29x	list(
70	29x	ui = ui,
71	29x	server = function(id) {
72	22x	data_out <- server(id)
73	21x	decorate_err_msg(
74	21x	assert_reactive(data_out),
75	21x	pre = sprintf("From: 'teal_data_module()':\nA 'teal_data_module' with \"%s\" label:", label),
76	21x	post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
77		)
78		}
79		),
80	29x	label = label,
81	29x	class = "teal_data_module",
82	29x	once = once
83		)
84		}
85
86		#' Data module for `teal` transformers.
87		#'
88		#' @description
89		#' `r lifecycle::badge("experimental")`
90		#'
91		#' Create a `teal_data_module` object for custom transformation of data for pre-processing
92		#' before passing the data into the module.
93		#'
94		#' @details
95		#' `teal_transform_module` creates a [`teal_data_module`] object to transform data in a `teal`
96		#' application. This transformation happens after the data has passed through the filtering activity
97		#' in teal. The transformed data is then sent to the server of the [teal_module()].
98		#'
99		#' See vignette `vignette("data-transform-as-shiny-module", package = "teal")` for more details.
100		#'
101		#'
102		#' @inheritParams teal_data_module
103		#' @param server (`function(id, data)`)
104		#' `shiny` module server function; that takes `id` and `data` argument,
105		#' where the `id` is the module id and `data` is the reactive `teal_data` input.
106		#' The server function must return reactive expression containing `teal_data` object.
107		#' @param datanames (`character`)
108		#' Names of the datasets that are relevant for the module. The
109		#' filter panel will only display filters for specified `datanames`. The keyword `"all"` will show
110		#' filters of all datasets. `datanames` will be automatically appended to the [modules()] `datanames`.
111		#' @examples
112		#' my_transformers <- list(
113		#' teal_transform_module(
114		#' label = "Custom transform for iris",
115		#' datanames = "iris",
116		#' ui = function(id) {
117		#' ns <- NS(id)
118		#' tags$div(
119		#' numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
120		#' )
121		#' },
122		#' server = function(id, data) {
123		#' moduleServer(id, function(input, output, session) {
124		#' reactive({
125		#' within(data(),
126		#' {
127		#' iris <- head(iris, num_rows)
128		#' },
129		#' num_rows = input$n_rows
130		#' )
131		#' })
132		#' })
133		#' }
134		#' )
135		#' )
136		#'
137		#' @name teal_transform_module
138		#'
139		#' @export
140		teal_transform_module <- function(ui = function(id) NULL,
141		server = function(id, data) data,
142		label = "transform module",
143		datanames = "all") {
144	18x	checkmate::assert_function(ui, args = "id", nargs = 1)
145	18x	checkmate::assert_function(server, args = c("id", "data"), nargs = 2)
146	18x	checkmate::assert_string(label)
147	18x	structure(
148	18x	list(
149	18x	ui = ui,
150	18x	server = function(id, data) {
151	18x	data_out <- server(id, data)
152	18x	decorate_err_msg(
153	18x	assert_reactive(data_out),
154	18x	pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
155	18x	post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.
156		)
157		}
158		),
159	18x	label = label,
160	18x	datanames = datanames,
161	18x	class = c("teal_transform_module", "teal_data_module")
162		)
163		}
164
165
166		#' Extract all `transformers` from `modules`.
167		#'
168		#' @param modules `teal_modules` or `teal_module`
169		#' @return A list of `teal_transform_module` nested in the same way as input `modules`.
170		#' @keywords internal
171		extract_transformers <- function(modules) {
172	2x	if (inherits(modules, "teal_module")) {
173	1x	modules$transformers
174	1x	} else if (inherits(modules, "teal_modules")) {
175	1x	lapply(modules$children, extract_transformers)
176		}
177		}

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_object_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		#'
11		#' @param id (`character(1)`)
12		#' `shiny` module instance id.
13		#' @param teal_data (`reactive` returning `teal_data`)
14		#'
15		#'
16		#' @name module_data_summary
17		#' @rdname module_data_summary
18		#' @keywords internal
19		#' @return `NULL`.
20		NULL
21
22		#' @rdname module_data_summary
23		ui_data_summary <- function(id) {
24	!	ns <- NS(id)
25	!	content_id <- ns("filters_overview_contents")
26	!	tags$div(
27	!	id = id,
28	!	class = "well",
29	!	tags$div(
30	!	class = "row",
31	!	tags$div(
32	!	class = "col-sm-9",
33	!	tags$label("Active Filter Summary", class = "text-primary mb-4")
34		),
35	!	tags$div(
36	!	class = "col-sm-3",
37	!	tags$i(
38	!	class = "remove pull-right fa fa-angle-down",
39	!	style = "cursor: pointer;",
40	!	title = "fold/expand data summary panel",
41	!	onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", content_id)
42		)
43		)
44		),
45	!	tags$div(
46	!	id = content_id,
47	!	tags$div(
48	!	class = "teal_active_summary_filter_panel",
49	!	tableOutput(ns("table"))
50		)
51		)
52		)
53		}
54
55		#' @rdname module_data_summary
56		srv_data_summary <- function(id, teal_data) {
57	94x	assert_reactive(teal_data)
58	94x	moduleServer(
59	94x	id = id,
60	94x	function(input, output, session) {
61	94x	logger::log_debug("srv_data_summary initializing")
62
63	94x	summary_table <- reactive({
64	101x	req(inherits(teal_data(), "teal_data"))
65	72x	if (!length(ls(teal.code::get_env(teal_data())))) {
66	1x	return(NULL)
67		}
68
69	71x	filter_overview <- get_filter_overview(teal_data)
70	71x	names(filter_overview)[[1]] <- "Data Name"
71
72	71x	filter_overview$Obs <- ifelse(
73	71x	!is.na(filter_overview$obs),
74	71x	sprintf("%s/%s", filter_overview$obs_filtered, filter_overview$obs),
75	71x	ifelse(!is.na(filter_overview$obs_filtered), sprintf("%s", filter_overview$obs_filtered), "")
76		)
77
78	71x	filter_overview$Subjects <- ifelse(
79	71x	!is.na(filter_overview$subjects),
80	71x	sprintf("%s/%s", filter_overview$subjects_filtered, filter_overview$subjects),
81		""
82		)
83
84	71x	filter_overview <- filter_overview[, colnames(filter_overview) %in% c("Data Name", "Obs", "Subjects")]
85	71x	Filter(function(col) !all(col == ""), filter_overview)
86		})
87
88	94x	output$table <- renderUI({
89	101x	summary_table_out <- try(summary_table(), silent = TRUE)
90	101x	if (inherits(summary_table_out, "try-error")) {
91		# Ignore silent shiny error
92	29x	if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
93	!	stop("Error occurred during data processing. See details in the main panel.")
94		}
95	72x	} else if (is.null(summary_table_out)) {
96	1x	"no datasets to show"
97		} else {
98	71x	body_html <- apply(
99	71x	summary_table_out,
100	71x	1,
101	71x	function(x) {
102	131x	tags$tr(
103	131x	tagList(
104	131x	tags$td(
105	131x	if (all(x[-1] == "")) {
106	1x	icon(
107	1x	name = "fas fa-exclamation-triangle",
108	1x	title = "Unsupported dataset",
109	1x	`data-container` = "body",
110	1x	`data-toggle` = "popover",
111	1x	`data-content` = "object not supported by the data_summary module"
112		)
113		},
114	131x	x[1]
115		),
116	131x	lapply(x[-1], tags$td)
117		)
118		)
119		}
120		)
121
122	71x	header_labels <- names(summary_table())
123	71x	header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))
124
125	71x	table_html <- tags$table(
126	71x	class = "table custom-table",
127	71x	tags$thead(header_html),
128	71x	tags$tbody(body_html)
129		)
130	71x	table_html
131		}
132		})
133
134	94x	summary_table # testing purpose
135		}
136		)
137		}
138
139		#' @rdname module_data_summary
140		get_filter_overview <- function(teal_data) {
141	71x	datanames <- teal.data::datanames(teal_data())
142	71x	joinkeys <- teal.data::join_keys(teal_data())
143
144	71x	filtered_data_objs <- sapply(
145	71x	datanames,
146	71x	function(name) teal.code::get_var(teal_data(), name),
147	71x	simplify = FALSE
148		)
149	71x	unfiltered_data_objs <- teal.code::get_var(teal_data(), ".raw_data")
150
151	71x	rows <- lapply(
152	71x	datanames,
153	71x	function(dataname) {
154	131x	parent <- teal.data::parent(joinkeys, dataname)
155		# todo: what should we display for a parent dataset?
156		# - Obs and Subjects
157		# - Obs only
158		# - Subjects only
159		# todo (for later): summary table should be displayed in a way that child datasets
160		# are indented under their parent dataset to form a tree structure
161	131x	subject_keys <- if (length(parent) > 0) {
162	7x	names(joinkeys[dataname, parent])
163		} else {
164	124x	joinkeys[dataname, dataname]
165		}
166	131x	get_object_filter_overview(
167	131x	filtered_data = filtered_data_objs[[dataname]],
168	131x	unfiltered_data = unfiltered_data_objs[[dataname]],
169	131x	dataname = dataname,
170	131x	subject_keys = subject_keys
171		)
172		}
173		)
174
175	71x	unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1)) # this is mainly for vectors
176	71x	do.call(rbind, c(rows[!unssuported_idx], rows[unssuported_idx]))
177		}
178
179		#' @rdname module_data_summary
180		#' @param filtered_data (`list`) of filtered objects
181		#' @param unfiltered_data (`list`) of unfiltered objects
182		#' @param dataname (`character(1)`)
183		get_object_filter_overview <- function(filtered_data, unfiltered_data, dataname, subject_keys) {
184	131x	if (inherits(filtered_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
185	130x	get_object_filter_overview_array(filtered_data, unfiltered_data, dataname, subject_keys)
186	1x	} else if (inherits(filtered_data, "MultiAssayExperiment")) {
187	!	get_object_filter_overview_MultiAssayExperiment(filtered_data, unfiltered_data, dataname)
188		} else {
189	1x	data.frame(
190	1x	dataname = dataname,
191	1x	obs = NA,
192	1x	obs_filtered = NA,
193	1x	subjects = NA,
194	1x	subjects_filtered = NA
195		)
196		}
197		}
198
199		#' @rdname module_data_summary
200		get_object_filter_overview_array <- function(filtered_data, # nolint: object_length.
201		unfiltered_data,
202		dataname,
203		subject_keys) {
204	130x	if (length(subject_keys) == 0) {
205	117x	data.frame(
206	117x	dataname = dataname,
207	117x	obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
208	117x	obs_filtered = nrow(filtered_data),
209	117x	subjects = NA,
210	117x	subjects_filtered = NA
211		)
212		} else {
213	13x	data.frame(
214	13x	dataname = dataname,
215	13x	obs = ifelse(!is.null(nrow(unfiltered_data)), nrow(unfiltered_data), NA),
216	13x	obs_filtered = nrow(filtered_data),
217	13x	subjects = nrow(unique(unfiltered_data[subject_keys])),
218	13x	subjects_filtered = nrow(unique(filtered_data[subject_keys]))
219		)
220		}
221		}
222
223		#' @rdname module_data_summary
224		get_object_filter_overview_MultiAssayExperiment <- function(filtered_data, # nolint: object_length, object_name.
225		unfiltered_data,
226		dataname) {
227	!	experiment_names <- names(unfiltered_data)
228	!	mae_info <- data.frame(
229	!	dataname = dataname,
230	!	obs = NA,
231	!	obs_filtered = NA,
232	!	subjects = nrow(unfiltered_data@colData),
233	!	subjects_filtered = nrow(filtered_data@colData)
234		)
235
236	!	experiment_obs_info <- do.call("rbind", lapply(
237	!	experiment_names,
238	!	function(experiment_name) {
239	!	transform(
240	!	get_object_filter_overview(
241	!	filtered_data[[experiment_name]],
242	!	unfiltered_data[[experiment_name]],
243	!	dataname = experiment_name,
244	!	subject_keys = join_keys() # empty join keys
245		),
246	!	dataname = paste0(" - ", experiment_name)
247		)
248		}
249		))
250
251	!	get_experiment_keys <- function(mae, experiment) {
252	!	sample_subset <- mae@sampleMap[mae@sampleMap$colname %in% colnames(experiment), ]
253	!	length(unique(sample_subset$primary))
254		}
255
256	!	experiment_subjects_info <- do.call("rbind", lapply(
257	!	experiment_names,
258	!	function(experiment_name) {
259	!	data.frame(
260	!	subjects = get_experiment_keys(filtered_data, unfiltered_data[[experiment_name]]),
261	!	subjects_filtered = get_experiment_keys(filtered_data, filtered_data[[experiment_name]])
262		)
263		}
264		))
265
266	!	experiment_info <- cbind(experiment_obs_info[, c("dataname", "obs", "obs_filtered")], experiment_subjects_info)
267	!	rbind(mae_info, experiment_info)
268		}

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	69x	checkmate::assert_string(id)
69	69x	checkmate::assert_class(slices_global, ".slicesGlobal")
70	69x	moduleServer(id, function(input, output, session) {
71	69x	setBookmarkExclude(c("show_filter_manager"))
72	69x	observeEvent(input$show_filter_manager, {
73	!	logger::log_debug("srv_filter_manager_panel@1 show_filter_manager button has been clicked.")
74	!	showModal(
75	!	modalDialog(
76	!	ui_filter_manager(session$ns("filter_manager")),
77	!	class = "filter_manager_modal",
78	!	size = "l",
79	!	footer = NULL,
80	!	easyClose = TRUE
81		)
82		)
83		})
84	69x	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	69x	checkmate::assert_string(id)
101	69x	checkmate::assert_class(slices_global, ".slicesGlobal")
102
103	69x	moduleServer(id, function(input, output, session) {
104	69x	logger::log_debug("filter_manager_srv initializing.")
105
106		# Bookmark slices global with mapping.
107	69x	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	69x	bookmarked_slices <- restoreValue(session$ns("filter_state_on_bookmark"), NULL)
116	69x	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	69x	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	77x	module_labels <- setdiff(
125	77x	names(attr(slices_global$all_slices(), "mapping")),
126	77x	"Report previewer"
127		)
128	77x	isolate({
129	77x	mm <- as.data.frame(
130	77x	sapply(
131	77x	module_labels,
132	77x	simplify = FALSE,
133	77x	function(module_label) {
134	90x	available_slices <- slices_global$module_slices_api[[module_label]]$get_available_teal_slices()
135	83x	global_ids <- sapply(slices_global$all_slices(), `[[`, "id", simplify = FALSE)
136	83x	module_ids <- sapply(slices_global$slices_get(module_label), `[[`, "id", simplify = FALSE)
137	83x	allowed_ids <- vapply(available_slices, `[[`, character(1L), "id")
138	83x	active_ids <- global_ids %in% module_ids
139	83x	setNames(nm = global_ids, ifelse(global_ids %in% allowed_ids, active_ids, NA))
140		}
141		),
142	77x	check.names = FALSE
143		)
144	70x	colnames(mm)[colnames(mm) == "global_filters"] <- "Global filters"
145
146	70x	mm
147		})
148		})
149
150	69x	output$slices_table <- renderTable(
151	69x	expr = {
152	77x	logger::log_debug("filter_manager_srv@1 rendering slices_table.")
153	77x	mm <- mapping_table()
154
155		# Display logical values as UTF characters.
156	70x	mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))
157	70x	mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))
158
159		# Display placeholder if no filters defined.
160	70x	if (nrow(mm) == 0L) {
161	46x	mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)
162	46x	rownames(mm) <- ""
163		}
164	70x	mm
165		},
166	69x	rownames = TRUE
167		)
168
169	69x	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	95x	checkmate::assert_string(id)
176	95x	assert_reactive(module_fd)
177	95x	checkmate::assert_class(slices_global, ".slicesGlobal")
178
179	95x	moduleServer(id, function(input, output, session) {
180	95x	logger::log_debug("srv_module_filter_manager initializing for module: { id }.")
181		# Track filter global and local states.
182	95x	slices_global_module <- reactive({
183	169x	slices_global$slices_get(module_label = id)
184		})
185	95x	slices_module <- reactive(req(module_fd())$get_filter_state())
186
187	95x	module_fd_previous <- reactiveVal(NULL)
188
189		# Set (reactively) available filters for the module.
190	95x	obs1 <- observeEvent(module_fd(), priority = 1, {
191	75x	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	75x	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	75x	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	75x	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	75x	module_fd()$set_available_teal_slices(slices_global$all_slices)
208
209		# this needed in filter_manager_srv
210	75x	slices_global$module_slices_api_set(
211	75x	id,
212	75x	list(
213	75x	get_available_teal_slices = module_fd()$get_available_teal_slices(),
214	75x	set_filter_state = module_fd()$set_filter_state, # for testing purpose
215	75x	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	95x	obs2 <- observeEvent(slices_module(), priority = 0, {
222	99x	this_slices <- slices_module()
223	99x	slices_global$slices_append(this_slices) # append new slices to the all_slices list
224	99x	mapping_elem <- setNames(nm = id, list(vapply(this_slices, `[[`, character(1L), "id")))
225	99x	slices_global$slices_active(mapping_elem)
226		})
227
228	95x	obs3 <- observeEvent(slices_global_module(), {
229	116x	global_vs_module <- setdiff_teal_slices(slices_global_module(), slices_module())
230	116x	module_vs_global <- setdiff_teal_slices(slices_module(), slices_global_module())
231	108x	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	95x	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	70x	shiny::isolate({
260	70x	checkmate::assert_class(slices, "teal_slices")
261		# needed on init to not mix "global_filters" with module-specific-slots
262	70x	if (isTRUE(attr(slices, "module_specific"))) {
263	9x	old_mapping <- attr(slices, "mapping")
264	9x	new_mapping <- sapply(module_labels, simplify = FALSE, function(module_label) {
265	18x	unique(unlist(old_mapping[c(module_label, "global_filters")]))
266		})
267	9x	attr(slices, "mapping") <- new_mapping
268		}
269	70x	.self$all_slices <<- shiny::reactiveVal(slices)
270	70x	.self$module_slices_api <<- shiny::reactiveValues()
271	70x	.self$slices_append(slices)
272	70x	.self$slices_active(attr(slices, "mapping"))
273	70x	invisible(.self)
274		})
275		},
276		is_module_specific = function() {
277	247x	isTRUE(attr(.self$all_slices(), "module_specific"))
278		},
279		module_slices_api_set = function(module_label, functions_list) {
280	75x	shiny::isolate({
281	75x	if (!.self$is_module_specific()) {
282	61x	module_label <- "global_filters"
283		}
284	75x	if (!identical(.self$module_slices_api[[module_label]], functions_list)) {
285	75x	.self$module_slices_api[[module_label]] <- functions_list
286		}
287	75x	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	172x	shiny::isolate({
318	172x	if (.self$is_module_specific()) {
319	32x	new_mapping <- modifyList(attr(.self$all_slices(), "mapping"), mapping_elem)
320		} else {
321	140x	new_mapping <- setNames(nm = "global_filters", list(unique(unlist(mapping_elem))))
322		}
323
324	172x	if (!identical(new_mapping, attr(.self$all_slices(), "mapping"))) {
325	115x	mapping_modules <- toString(names(new_mapping))
326	115x	logger::log_debug(".slicesGlobal@slices_active: changing mapping for module(s): { mapping_modules }.")
327	115x	new_slices <- .self$all_slices()
328	115x	attr(new_slices, "mapping") <- new_mapping
329	115x	.self$all_slices(new_slices)
330		}
331
332	172x	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	172x	shiny::isolate({
339	172x	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	172x	new_slices <- setdiff_teal_slices(slices, .self$all_slices())
345	172x	old_mapping <- attr(.self$all_slices(), "mapping")
346	172x	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	172x	invisible(.self)
363		})
364		},
365		slices_get = function(module_label) {
366	252x	if (missing(module_label)) {
367	!	.self$all_slices()
368		} else {
369	252x	module_ids <- unlist(attr(.self$all_slices(), "mapping")[c(module_label, "global_filters")])
370	252x	Filter(
371	252x	function(slice) slice$id %in% module_ids,
372	252x	.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		)
391		# todo: prevent any teal_slices attribute except mapping

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

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

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	69x	moduleServer(id, function(input, output, session) {
101	69x	logger::log_debug("srv_snapshot_manager_panel initializing")
102	69x	setBookmarkExclude(c("show_snapshot_manager"))
103	69x	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	69x	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	69x	checkmate::assert_character(id)
139
140	69x	moduleServer(id, function(input, output, session) {
141	69x	logger::log_debug("srv_snapshot_manager initializing")
142
143		# Set up bookmarking callbacks ----
144		# Register bookmark exclusions (all buttons and text fields).
145	69x	setBookmarkExclude(c(
146	69x	"snapshot_add", "snapshot_load", "snapshot_reset",
147	69x	"snapshot_name_accept", "snaphot_file_accept",
148	69x	"snapshot_name", "snapshot_file"
149		))
150		# Add snapshot history to bookmark.
151	69x	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	69x	ns <- session$ns
157
158		# Track global filter states ----
159	69x	snapshot_history <- reactiveVal({
160		# Restore directly from bookmarked state, if applicable.
161	69x	restoreValue(
162	69x	ns("snapshot_history"),
163	69x	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	69x	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	69x	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	69x	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	69x	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	69x	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		# todo: as.teal_slices looses module-mapping if is not global
287	2x	snapshot_state <- as.teal_slices(snapshot)
288	2x	slices_global$slices_set(snapshot_state)
289	2x	removeModal()
290		### End restore procedure. ###
291		})
292
293		# Build snapshot table ----
294		# Create UI elements and server logic for the snapshot table.
295		# Observers must be tracked to avoid duplication and excess reactivity.
296		# Remaining elements are tracked likewise for consistency and a slight speed margin.
297	69x	observers <- reactiveValues()
298	69x	handlers <- reactiveValues()
299	69x	divs <- reactiveValues()
300
301	69x	observeEvent(snapshot_history(), {
302	59x	logger::log_debug("srv_snapshot_manager: snapshot history modified, updating snapshot list")
303	59x	lapply(names(snapshot_history())[-1L], function(s) {
304	!	id_pickme <- sprintf("pickme_%s", make.names(s))
305	!	id_saveme <- sprintf("saveme_%s", make.names(s))
306	!	id_rowme <- sprintf("rowme_%s", make.names(s))
307
308		# Observer for restoring snapshot.
309	!	if (!is.element(id_pickme, names(observers))) {
310	!	observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
311		### Begin restore procedure. ###
312	!	snapshot <- snapshot_history()[[s]]
313	!	snapshot_state <- as.teal_slices(snapshot)
314
315	!	slices_global$slices_set(snapshot_state)
316	!	removeModal()
317		### End restore procedure. ###
318		})
319		}
320		# Create handler for downloading snapshot.
321	!	if (!is.element(id_saveme, names(handlers))) {
322	!	output[[id_saveme]] <- downloadHandler(
323	!	filename = function() {
324	!	sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
325		},
326	!	content = function(file) {
327	!	snapshot <- snapshot_history()[[s]]
328	!	snapshot_state <- as.teal_slices(snapshot)
329	!	slices_store(tss = snapshot_state, file = file)
330		}
331		)
332	!	handlers[[id_saveme]] <- id_saveme
333		}
334		# Create a row for the snapshot table.
335	!	if (!is.element(id_rowme, names(divs))) {
336	!	divs[[id_rowme]] <- tags$div(
337	!	class = "manager_table_row",
338	!	tags$span(tags$h5(s)),
339	!	actionLink(inputId = ns(id_pickme), label = icon("far fa-circle-check"), title = "select"),
340	!	downloadLink(outputId = ns(id_saveme), label = icon("far fa-save"), title = "save to file")
341		)
342		}
343		})
344		})
345
346		# Create table to display list of snapshots and their actions.
347	69x	output$snapshot_list <- renderUI({
348	59x	rows <- rev(reactiveValuesToList(divs))
349	59x	if (length(rows) == 0L) {
350	59x	tags$div(
351	59x	class = "manager_placeholder",
352	59x	"Snapshots will appear here."
353		)
354		} else {
355	!	rows
356		}
357		})
358
359	69x	snapshot_history
360		})
361		}

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