teal coverage - 51.27%

Files
Source

# This module is the main teal module that puts everything together.

#' `teal` main app module
#'
#' This is the main `teal` app that puts everything together.
#'
#' It displays the splash UI which is used to fetch the data, possibly
#' prompting for a password input to fetch the data. Once the data is ready,
#' the splash screen is replaced by the actual `teal` UI that is tabsetted and
#' has a filter panel with `datanames` that are relevant for the current tab.
#' Nested tabs are possible, but we limit it to two nesting levels for reasons
#' of clarity of the UI.
#'
#' The splash screen functionality can also be used
#' for non-delayed data which takes time to load into memory, avoiding
#' `shiny` session timeouts.
#'
#' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the
#' `datasets` object that is shared across modules.
#' Once it is ready and non-`NULL`, the splash screen is replaced by the
#' main `teal` UI that depends on the data.
#' The currently active tab is tracked and the right filter panel
#' updates the displayed datasets to filter for according to the active `datanames`
#' of the tab.
#'
#' It is written as a `shiny` module so it can be added into other apps as well.
#'
#' @name module_teal
#'
#' @inheritParams module_teal_with_splash
#'
#' @param splash_ui (`shiny.tag`) UI to display initially,
#'   can be a splash screen or a `shiny` module UI. For the latter, see
#'   [init()] about how to call the corresponding server function.
#'
#' @param teal_data_rv (`reactive`)
#'   returns the `teal_data`, only evaluated once, `NULL` value is ignored
#'
#' @return
#' Returns a `reactive` expression which returns the currently active module.
#'
#' @keywords internal
#'
NULL

#' @rdname module_teal
ui_teal <- function(id,
                    splash_ui = tags$h2("Starting the Teal App"),
                    title = build_app_title(),
                    header = tags$p(),
                    footer = tags$p()) {
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)

  checkmate::assert_multi_class(splash_ui, c("shiny.tag", "shiny.tag.list", "html"))

  if (is.character(title)) {
    title <- build_app_title(title)
  } else {
    validate_app_title_tag(title)
  }

  checkmate::assert(
    .var.name = "header",
    checkmate::check_string(header),
    checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
  )
  if (checkmate::test_string(header)) {
    header <- tags$p(header)
  }

  checkmate::assert(
    .var.name = "footer",
    checkmate::check_string(footer),
    checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
  )
  if (checkmate::test_string(footer)) {
    footer <- tags$p(footer)
  }

  ns <- NS(id)

  # Once the data is loaded, we will remove this element and add the real teal UI instead
  splash_ui <- tags$div(
    # id so we can remove the splash screen once ready, which is the first child of this container
    id = ns("main_ui_container"),
    # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
    # just the first item of the tagList)
    tags$div(splash_ui)
  )

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

  fluidPage(
    title = title,
    theme = get_teal_bs_theme(),
    include_teal_css_js(),
    tags$header(header),
    tags$hr(class = "my-2"),
    shiny_busy_message_panel,
    splash_ui,
    tags$hr(),
    tags$footer(
      tags$div(
        footer,
        teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
        textOutput(ns("identifier"))
      )
    )
  )
}


#' @rdname module_teal
srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
  stopifnot(is.reactive(teal_data_rv))
  moduleServer(id, function(input, output, session) {
    logger::log_trace("srv_teal initializing the module.")

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

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

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

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

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

    env <- environment()
    datasets_reactive <- eventReactive(teal_data_rv(), {
      env$progress <- shiny::Progress$new(session)
      env$progress$set(0.25, message = "Setting data")

      # Restore filter from bookmarked state, if applicable.
      filter_restored <- restoreValue("filter_state_on_bookmark", filter)
      if (!is.teal_slices(filter_restored)) {
        filter_restored <- as.teal_slices(filter_restored)
      }
      # Create list of `FilteredData` objects that reflects structure of `modules`.
      modules_datasets(teal_data_rv(), modules, filter_restored, teal_data_to_filtered_data(teal_data_rv()))
    })

    # Replace splash / welcome screen once data is loaded ----
    # ignoreNULL to not trigger at the beginning when data is NULL
    # just handle it once because data obtained through delayed loading should
    # usually not change afterwards
    # if restored from bookmarked state, `filter` is ignored

    observeEvent(datasets_reactive(), once = TRUE, {
      logger::log_trace("srv_teal@5 setting main ui after data was pulled")
      on.exit(env$progress$close())
      env$progress$set(0.5, message = "Setting up main UI")
      datasets <- datasets_reactive()

      # main_ui_container contains splash screen first and we remove it and replace it by the real UI
      removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container")))
      insertUI(
        selector = paste0("#", session$ns("main_ui_container")),
        where = "beforeEnd",
        # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
        # just the first item of the tagList)
        ui = tags$div(ui_tabs_with_filters(
          session$ns("main_ui"),
          modules = modules,
          datasets = datasets,
          filter = filter
        )),
        # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not
        # have any effect as they are ignored when not present
        immediate = TRUE
      )

      # must make sure that this is only executed once as modules assume their observers are only
      # registered once (calling server functions twice would trigger observers twice each time)
      srv_tabs_with_filters(
        id = "main_ui",
        datasets = datasets,
        modules = modules,
        reporter = reporter,
        filter = filter
      )
    })
  })
}

# This file adds a splash screen for delayed data loading on top of teal

#' Add splash screen to `teal` application
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Displays custom splash screen during initial delayed data loading.
#'
#' @details
#' This module pauses app initialization pending delayed data loading.
#' This is necessary because the filter panel and modules depend on the data to initialize.
#'
#' `teal_with_splash` follows the `shiny` module convention.
#' [`init()`] is a wrapper around this that assumes that `teal` it is
#' the top-level module and cannot be embedded.
#'
#' Note: It is no longer recommended to embed `teal` in `shiny` apps as a module.
#' but rather use `init` to create a standalone application.
#'
#' @seealso [init()]
#'
#' @param id (`character(1)`)
#'   module id
#' @inheritParams init
#' @param modules (`teal_modules`) object containing the output modules which
#'   will be displayed in the `teal` application. See [modules()] and [module()] for
#'   more details.
#' @inheritParams shiny::moduleServer
#' @return
#' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not.
#' @name module_teal_with_splash
#' @examples
#' teal_modules <- modules(example_module())
#' # Shiny app with modular integration of teal
#' ui <- fluidPage(
#'   ui_teal_with_splash(id = "app1", data = teal_data())
#' )
#'
#' server <- function(input, output, session) {
#'   srv_teal_with_splash(
#'     id = "app1",
#'     data = teal_data(iris = iris),
#'     modules = teal_modules
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
NULL

#' @export
#' @rdname module_teal_with_splash
ui_teal_with_splash <- function(id,
                                data,
                                title = build_app_title(),
                                header = tags$p(),
                                footer = tags$p()) {
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
  checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
  checkmate::assert(
    .var.name = "title",
    checkmate::check_string(title),
    checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert(
    .var.name = "header",
    checkmate::check_string(header),
    checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert(
    .var.name = "footer",
    checkmate::check_string(footer),
    checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
  )

  ns <- NS(id)

  # Startup splash screen for delayed loading
  # We use delayed loading in all cases, even when the data does not need to be fetched.
  # This has the benefit that when filtering the data takes a lot of time initially, the
  # Shiny app does not time out.
  splash_ui <- if (inherits(data, "teal_data_module")) {
    data$ui(ns("teal_data_module"))
  } else if (inherits(data, "teal_data")) {
    tags$div()
  }
  ui_teal(
    id = ns("teal"),
    splash_ui = tags$div(splash_ui, uiOutput(ns("error"))),
    title = title,
    header = header,
    footer = footer
  )
}

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

  moduleServer(id, function(input, output, session) {
    logger::log_trace("srv_teal_with_splash initializing module with data.")

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

    # teal_data_rv contains teal_data object
    # either passed to teal::init or returned from teal_data_module
    teal_data_rv <- if (inherits(data, "teal_data_module")) {
      data <- data$server(id = "teal_data_module")
      if (!is.reactive(data)) {
        stop("The `teal_data_module` passed to `data` must return a reactive expression.", call. = FALSE)
      }
      data
    } else if (inherits(data, "teal_data")) {
      reactiveVal(data)
    }

    teal_data_rv_validate <- reactive({
      # custom module can return error
      data <- tryCatch(teal_data_rv(), error = function(e) e)

      # there is an empty reactive cycle on init!
      if (inherits(data, "shiny.silent.error") && identical(data$message, "")) {
        return(NULL)
      }

      # to handle qenv.error
      if (inherits(data, "qenv.error")) {
        validate(
          need(
            FALSE,
            paste(
              "Error when executing `teal_data_module` passed to `data`:\n ",
              paste(data$message, collapse = "\n"),
              "\n Check your inputs or contact app developer if error persists."
            )
          )
        )
      }

      # to handle module non-qenv errors
      if (inherits(data, "error")) {
        validate(
          need(
            FALSE,
            paste(
              "Error when executing `teal_data_module` passed to `data`:\n ",
              paste(data$message, collpase = "\n"),
              "\n Check your inputs or contact app developer if error persists."
            )
          )
        )
      }

      validate(
        need(
          inherits(data, "teal_data"),
          paste(
            "Error: `teal_data_module` passed to `data` failed to return `teal_data` object, returned",
            toString(sQuote(class(data))),
            "instead.",
            "\n Check your inputs or contact app developer if error persists."
          )
        )
      )

      if (!length(teal.data::datanames(data))) {
        warning("`data` object has no datanames. Default datanames are set using `teal_data`'s environment.")
      }

      is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
      if (!isTRUE(is_modules_ok)) {
        validate(need(isTRUE(is_modules_ok), sprintf("%s. Contact app developer.", is_modules_ok)))
      }

      is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
      if (!isTRUE(is_filter_ok)) {
        showNotification(
          "Some filters were not applied because of incompatibility with data. Contact app developer.",
          type = "warning",
          duration = 10
        )
        warning(is_filter_ok)
      }

      teal_data_rv()
    })

    output$error <- renderUI({
      teal_data_rv_validate()
      NULL
    })


    res <- srv_teal(id = "teal", modules = modules, teal_data_rv = teal_data_rv_validate, filter = filter)
    logger::log_trace("srv_teal_with_splash initialized module with data.")

    res
  })
}

#' 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 [`wunder_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.
#' @param mapping_matrix (`reactive`) that contains a `data.frame` representation
#'                       of the mapping of filter state ids (rows) to modules labels (columns);
#'                       all columns are `logical` vectors.
#' @param datasets non-nested (named `list`) of `FilteredData` objects.
#'
#' @return `list` containing the snapshot history, where each element is an unlisted `teal_slices` object.
#'
#' @name module_snapshot_manager
#' @aliases snapshot snapshot_manager snapshot_manager_module
#'
#' @author Aleksander Chlebowski
#'


#' @rdname module_snapshot_manager
#' @keywords internal
#'
snapshot_manager_ui <- 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("camera"), title = "add snapshot"),
      actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"),
      actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
      NULL
    ),
    uiOutput(ns("snapshot_list"))
  )
}

#' @rdname module_snapshot_manager
#' @keywords internal
#'
snapshot_manager_srv <- function(id, slices_global, mapping_matrix, datasets) {
  checkmate::assert_character(id)
  checkmate::assert_true(is.reactive(slices_global))
  checkmate::assert_class(isolate(slices_global()), "teal_slices")
  checkmate::assert_true(is.reactive(mapping_matrix))
  checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)
  checkmate::assert_list(datasets, types = "FilteredData", any.missing = FALSE, names = "named")

  moduleServer(id, function(input, output, session) {
    logger::log_trace("snapshot_manager_srv 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 current filter state to bookmark.
    # This is done on the app session because the value is restored in `module_teal`
    # and we don't want to have to use this module's name space there.
    app_session <- .subset2(shiny::getDefaultReactiveDomain(), "parent")
    app_session$onBookmark(function(state) {
      logger::log_trace("snapshot_manager_srv@onBookmark: storing filter state")
      snapshot <- as.list(slices_global(), recursive = TRUE)
      attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())
      state$values$filter_state_on_bookmark <- snapshot
    })
    # Add snapshot history to bookmark.
    session$onBookmark(function(state) {
      logger::log_trace("snapshot_manager_srv@onBookmark: storing snapshot and bookmark history")
      state$values$snapshot_history <- snapshot_history() # isolate this?
    })

    ns <- session$ns

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

    # Snapshot current application state ----
    # Name snaphsot.
    observeEvent(input$snapshot_add, {
      logger::log_trace("snapshot_manager_srv: 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("thumbs-up")),
            modalButton(label = "Cancel", icon = icon("thumbs-down"))
          ),
          size = "s"
        )
      )
    })
    # Store snaphsot.
    observeEvent(input$snapshot_name_accept, {
      logger::log_trace("snapshot_manager_srv: snapshot_name_accept button clicked")
      snapshot_name <- trimws(input$snapshot_name)
      if (identical(snapshot_name, "")) {
        logger::log_trace("snapshot_manager_srv: 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_trace("snapshot_manager_srv: 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_trace("snapshot_manager_srv: snapshot name accepted, adding snapshot")
        snapshot <- as.list(slices_global(), recursive = TRUE)
        attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())
        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-main_ui-wunder_bar-show_snapshot_manager", asis = TRUE)
      }
    })

    # Upload a snapshot file ----
    # Select file.
    observeEvent(input$snapshot_load, {
      logger::log_trace("snapshot_manager_srv: 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("thumbs-up")),
            modalButton(label = "Cancel", icon = icon("thumbs-down"))
          )
        )
      )
    })
    # Store new snapshot to list and restore filter states.
    observeEvent(input$snaphot_file_accept, {
      logger::log_trace("snapshot_manager_srv: snapshot_file_accept button clicked")
      snapshot_name <- trimws(input$snapshot_name)
      if (identical(snapshot_name, "")) {
        logger::log_trace("snapshot_manager_srv: 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_trace("snapshot_manager_srv: 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_trace("snapshot_manager_srv: snapshot name accepted, loading snapshot")
        snapshot_state <- try(slices_restore(input$snapshot_file$datapath))
        if (!inherits(snapshot_state, "modules_teal_slices")) {
          logger::log_trace("snapshot_manager_srv: snapshot file corrupt")
          showNotification(
            "File appears to be corrupt.",
            type = "error"
          )
        } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) {
          logger::log_trace("snapshot_manager_srv: 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_trace("snapshot_manager_srv: snapshot loaded, adding to history")
          snapshot <- as.list(snapshot_state, 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_trace("snapshot_manager_srv: restoring snapshot")
          mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(datasets))
          mapply(
            function(filtered_data, filter_ids) {
              filtered_data$clear_filter_states(force = TRUE)
              slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
              filtered_data$set_filter_state(slices)
            },
            filtered_data = datasets,
            filter_ids = mapping_unfolded
          )
          slices_global(snapshot_state)
          removeModal()
          ### End  simplified restore procedure. ###
        }
      }
    })
    # Apply newly added snapshot.

    # Restore initial state ----
    observeEvent(input$snapshot_reset, {
      logger::log_trace("snapshot_manager_srv: snapshot_reset button clicked, restoring snapshot")
      s <- "Initial application state"
      ### Begin restore procedure. ###
      snapshot <- snapshot_history()[[s]]
      snapshot_state <- as.teal_slices(snapshot)
      mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(datasets))
      mapply(
        function(filtered_data, filter_ids) {
          filtered_data$clear_filter_states(force = TRUE)
          slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
          filtered_data$set_filter_state(slices)
        },
        filtered_data = datasets,
        filter_ids = mapping_unfolded
      )
      slices_global(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_trace("snapshot_manager_srv: 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)
            mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(datasets))
            mapply(
              function(filtered_data, filter_ids) {
                filtered_data$clear_filter_states(force = TRUE)
                slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
                filtered_data$set_filter_state(slices)
              },
              filtered_data = datasets,
              filter_ids = mapping_unfolded
            )
            slices_global(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("circle-check"), title = "select"),
            downloadLink(outputId = ns(id_saveme), label = icon("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
  })
}

### utility functions ----

#' Explicitly enumerate global filters.
#'
#' Transform module mapping such that global filters are explicitly specified for every module.
#'
#' @param mapping (named `list`) as stored in mapping parameter of `teal_slices`
#' @param module_names (`character`) vector containing names of all modules in the app
#' @return A `named_list` with one element per module, each element containing all filters applied to that module.
#'
#' @keywords internal
#'
unfold_mapping <- function(mapping, module_names) {
  module_names <- structure(module_names, names = module_names)
  lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))
}

#' Convert mapping matrix to filter mapping specification.
#'
#' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,
#' to a list specification like the one used in the `mapping` attribute of `teal_slices`.
#' Global filters are gathered in one list element.
#' If a module has no active filters but the global ones, it will not be mentioned in the output.
#'
#' @param mapping_matrix (`data.frame`) of logical vectors where
#'                       columns represent modules and row represent `teal_slice`s
#' @return Named `list` like that in the `mapping` attribute of a `teal_slices` object.
#'
#' @keywords internal
#'
matrix_to_mapping <- function(mapping_matrix) {
  mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x))
  global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))
  global_filters <- names(global[global])
  local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]

  mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))
  Filter(function(x) length(x) != 0L, mapping)
}

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

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

  # argument checking (independent)
  ## `data`
  if (inherits(data, "TealData")) {
    lifecycle::deprecate_stop(
      when = "0.15.0",
      what = "init(data)",
      paste(
        "TealData is no longer supported. Use teal_data() instead.",
        "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/988."
      )
    )
  }
  checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))

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

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

  ## all other arguments
  checkmate::assert(
    .var.name = "title",
    checkmate::check_string(title),
    checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert(
    .var.name = "header",
    checkmate::check_string(header),
    checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert(
    .var.name = "footer",
    checkmate::check_string(footer),
    checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
  )
  checkmate::assert_character(id, max.len = 1, any.missing = FALSE)

  # log
  teal.logger::log_system_info()

  # argument transformations
  ## `modules` - landing module
  landing <- extract_module(modules, "teal_module_landing")
  landing_module <- NULL
  if (length(landing) == 1L) {
    landing_module <- landing[[1L]]
    modules <- drop_module(modules, "teal_module_landing")
  } else if (length(landing) > 1L) {
    stop("Only one `landing_popup_module` can be used.")
  }

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

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

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

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

  ## `data` - `modules`
  if (inherits(data, "teal_data")) {
    if (length(teal_data_datanames(data)) == 0) {
      stop("The environment of `data` is empty.")
    }
    # in case of teal_data_module this check is postponed to the srv_teal_with_splash
    is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
    if (!isTRUE(is_modules_ok)) {
      logger::log_error(is_modules_ok)
      checkmate::assert(is_modules_ok, .var.name = "modules")
    }

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

  # Note regarding case `id = character(0)`:
  # rather than creating a submodule of this module, we directly modify
  # the UI and server with `id = character(0)` and calling the server function directly
  # Note: UI must be a function to support bookmarking.
  res <- list(
    ui = function(request) ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
    server = function(input, output, session) {
      if (!is.null(landing_module)) {
        do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args))
      }
      srv_teal_with_splash(id = id, data = data, modules = modules, filter = deep_copy_filter(filter))
    }
  )

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

  res
}

#' Create a `tdata` object
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' Create a new object called `tdata` which contains `data`, a `reactive` list of `data.frames`
#' (or `MultiAssayExperiment`), with attributes:
#' - `code` (`reactive`) containing code used to generate the data
#' - join_keys (`join_keys`) containing the relationships between the data
#' - metadata (named `list`) containing any metadata associated with the data frames
#'
#' @name tdata
#' @param data (named `list`) A list of `data.frame` or `MultiAssayExperiment` objects,
#'  which optionally can be `reactive`.
#'   Inside this object all of these items will be made `reactive`.
#' @param code (`character` or `reactive` which evaluates to a `character`) containing
#'   the code used to generate the data. This should be `reactive` if the code is changing
#'   during a reactive context (e.g. if filtering changes the code). Inside this
#'   object `code` will be made reactive
#' @param join_keys (`teal.data::join_keys`) object containing relationships between the
#'   datasets.
#' @param metadata (named `list`) each element contains a list of metadata about the named `data.frame`
#' Each element of these list should be atomic and length one.
#' @return A `tdata` object.
#'
#' @seealso `as_tdata`
#'
#' @examples
#'
#' data <- new_tdata(
#'   data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),
#'   code = "iris <- iris
#'     mtcars <- mtcars
#'     dd <- data.frame(x = 1:10)",
#'   metadata = list(dd = list(author = "NEST"), iris = list(version = 1))
#' )
#'
#' # Extract a data.frame
#' isolate(data[["iris"]]())
#'
#' # Get code
#' isolate(get_code_tdata(data))
#'
#' # Get metadata
#' get_metadata(data, "iris")
#'
#' @export
new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
  lifecycle::deprecate_soft(
    when = "0.15.0",
    what = "tdata()",
    details = paste(
      "tdata is deprecated and will be removed in the next release. Use `teal_data` instead.\n",
      "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."
    )
  )
  checkmate::assert_list(
    data,
    any.missing = FALSE, names = "unique",
    types = c("data.frame", "reactive", "MultiAssayExperiment")
  )
  checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)
  checkmate::assert_multi_class(code, c("character", "reactive"))

  checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)
  checkmate::assert_subset(names(metadata), names(data))

  if (is.reactive(code)) {
    isolate(checkmate::assert_class(code(), "character", .var.name = "code"))
  }

  # create reactive data.frames
  for (x in names(data)) {
    if (!is.reactive(data[[x]])) {
      data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))
    }
  }

  # set attributes
  attr(data, "code") <- if (is.reactive(code)) code else reactive(code)
  attr(data, "join_keys") <- join_keys
  attr(data, "metadata") <- metadata

  # set class
  class(data) <- c("tdata", class(data))
  data
}

#' Function to convert a `tdata` object to an `environment`
#'
#' Any `reactive` expressions inside `tdata` are evaluated first.
#' @param data (`tdata`) object
#' @return An `environment`.
#' @examples
#'
#' data <- new_tdata(
#'   data = list(iris = iris, mtcars = reactive(mtcars)),
#'   code = "iris <- iris
#'     mtcars = mtcars"
#' )
#'
#' my_env <- isolate(tdata2env(data))
#'
#' @export
tdata2env <- function(data) {
  checkmate::assert_class(data, "tdata")
  list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))
}


#' Wrapper for `get_code.tdata`
#'
#' This wrapper is to be used by downstream packages to extract the code of a `tdata` object.
#'
#' @param data (`tdata`) object
#'
#' @return (`character`) code used in the `tdata` object.
#' @export
get_code_tdata <- function(data) {
  checkmate::assert_class(data, "tdata")
  attr(data, "code")()
}

#' Extract `join_keys` from `tdata`
#' @param data (`tdata`) object
#' @param ... Additional arguments (not used)
#' @export
join_keys.tdata <- function(data, ...) {
  attr(data, "join_keys")
}

#' Function to get metadata from a `tdata` object
#' @param data (`tdata` - object) to extract the data from
#' @param dataname (`character(1)`) the dataset name whose metadata is requested
#' @return Either list of metadata or NULL if no metadata.
#' @export
get_metadata <- function(data, dataname) {
  checkmate::assert_string(dataname)
  UseMethod("get_metadata", data)
}

#' @rdname get_metadata
#' @export
get_metadata.tdata <- function(data, dataname) {
  metadata <- attr(data, "metadata")
  if (is.null(metadata)) {
    return(NULL)
  }
  metadata[[dataname]]
}

#' @rdname get_metadata
#' @export
get_metadata.default <- function(data, dataname) {
  stop("get_metadata function not implemented for this object")
}


#' Downgrade `teal_data` objects in modules for compatibility
#'
#' Convert `teal_data` to `tdata` in `teal` modules.
#'
#' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object
#' to be passed to the `data` argument but instead they receive a `teal_data` object,
#' which is additionally wrapped in a reactive expression in the server functions.
#' In order to easily adapt such modules without a proper refactor,
#' use this function to downgrade the `data` argument.
#'
#' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression
#'
#' @return Object of class `tdata`.
#'
#' @examples
#' td <- teal_data()
#' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars)
#' td
#' as_tdata(td)
#' as_tdata(reactive(td))
#'
#' @export
#' @rdname tdata_deprecation
#'
as_tdata <- function(x) {
  if (inherits(x, "tdata")) {
    return(x)
  }
  if (is.reactive(x)) {
    checkmate::assert_class(isolate(x()), "teal_data")
    datanames <- isolate(teal_data_datanames(x()))
    datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)
    code <- reactive(teal.code::get_code(x()))
    join_keys <- isolate(teal.data::join_keys(x()))
  } else if (inherits(x, "teal_data")) {
    datanames <- teal_data_datanames(x)
    datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)
    code <- reactive(teal.code::get_code(x))
    join_keys <- isolate(teal.data::join_keys(x))
  }

  new_tdata(data = datasets, code = code, join_keys = join_keys)
}

#' Add right filter panel into each of the top-level `teal_modules` UIs
#'
#' The [ui_nested_tabs] function returns a nested tabbed UI corresponding
#' to the nested modules.
#' This function adds the right filter panel to each main tab.
#'
#' The right filter panel's filter choices affect the `datasets` object. Therefore,
#' all modules using the same `datasets` share the same filters.
#'
#' This works with nested modules of depth greater than 2, though the filter
#' panel is inserted at the right of the modules at depth 1 and not at the leaves.
#'
#' @name module_tabs_with_filters
#'
#' @inheritParams module_teal
#'
#' @param datasets (named `list` of `FilteredData`)
#'   object to store filter state and filtered datasets, shared across modules. For more
#'   details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure
#'   of the `modules` argument and list names must correspond to the labels in `modules`.
#'   When filter is not module-specific then list contains the same object in all elements.
#' @param reporter (`Reporter`) object from `teal.reporter`
#'
#' @return
#' A `shiny.tag.list` containing the main menu, placeholders for filters and placeholders for the `teal` modules.
#'
#' @keywords internal
#'
NULL

#' @rdname module_tabs_with_filters
ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
  checkmate::assert_class(modules, "teal_modules")
  checkmate::assert_list(datasets, types = c("list", "FilteredData"))
  checkmate::assert_class(filter, "teal_slices")

  ns <- NS(id)
  is_module_specific <- isTRUE(attr(filter, "module_specific"))

  teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
  filter_panel_btns <- tags$li(
    class = "flex-grow",
    tags$button(
      class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger
      href = "javascript:void(0)",
      onclick = "toggleFilterPanel();", # see sidebar.js
      title = "Toggle filter panel",
      icon("fas fa-bars")
    ),
    wunder_bar_ui(ns("wunder_bar"))
  )
  teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)

  if (!is_module_specific) {
    # need to rearrange html so that filter panel is within tabset
    tabset_bar <- teal_ui$children[[1]]
    teal_modules <- teal_ui$children[[2]]
    filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
    list(
      tabset_bar,
      tags$hr(class = "my-2"),
      fluidRow(
        column(width = 9, teal_modules, class = "teal_primary_col"),
        column(width = 3, filter_ui, class = "teal_secondary_col")
      )
    )
  } else {
    teal_ui
  }
}

#' @rdname module_tabs_with_filters
srv_tabs_with_filters <- function(id,
                                  datasets,
                                  modules,
                                  reporter = teal.reporter::Reporter$new(),
                                  filter = teal_slices()) {
  checkmate::assert_class(modules, "teal_modules")
  checkmate::assert_list(datasets, types = c("list", "FilteredData"))
  checkmate::assert_class(reporter, "Reporter")
  checkmate::assert_class(filter, "teal_slices")

  moduleServer(id, function(input, output, session) {
    logger::log_trace("srv_tabs_with_filters initializing the module.")

    is_module_specific <- isTRUE(attr(filter, "module_specific"))
    wunder_bar_out <- wunder_bar_srv("wunder_bar", datasets, filter, modules)

    active_module <- srv_nested_tabs(
      id = "root",
      datasets = datasets,
      modules = modules,
      reporter = reporter,
      is_module_specific = is_module_specific
    )

    if (!is_module_specific) {
      active_datanames <- reactive({
        if (identical(active_module()$datanames, "all")) {
          singleton$datanames()
        } else {
          include_parent_datanames(
            active_module()$datanames,
            singleton$get_join_keys()
          )
        }
      })
      singleton <- unlist(datasets)[[1]]
      singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)

      observeEvent(
        eventExpr = active_datanames(),
        handlerExpr = {
          script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
            # hide the filter panel and disable the burger button
            "handleNoActiveDatasets();"
          } else {
            # show the filter panel and enable the burger button
            "handleActiveDatasetsPresent();"
          }
          shinyjs::runjs(script)
        },
        ignoreNULL = FALSE
      )
    }

    showNotification("Data loaded - App fully started up")
    logger::log_trace("srv_tabs_with_filters initialized the module")

    active_module
  })
}

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

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

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

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

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

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

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

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

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

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

### internal functions

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

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

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

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

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

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

#' 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 (`shiny`) input variable accessible with `input$tz` which is a (`character`)
#'  string containing the timezone of the browser/client.
#'
#' @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)) {
    NULL
  } else if (!inherits(bs_theme, "bs_theme")) {
    warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
    NULL
  } else {
    bs_theme
  }
}

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

  unique(c(parents, dataname))
}

#' 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 = teal_data_datanames(x)) {
  checkmate::assert_class(x, "teal_data")
  checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)

  ans <- teal.slice::init_filtered_data(
    x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE),
    join_keys = teal.data::join_keys(x)
  )
  # Piggy-back pre-processing code for datasets of interest so that filtering code can be appended later.
  attr(ans, "preprocessing_code") <- teal.data::get_code(x, datanames = datanames, check_names = FALSE)
  attr(ans, "verification_status") <- x@verified
  ans
}

#' 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_class(modules, "teal_modules")
  checkmate::assert_character(datanames)

  recursive_check_datanames <- function(modules, datanames) {
    # check teal_modules against datanames
    if (inherits(modules, "teal_modules")) {
      sapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))
    } else {
      extra_datanames <- setdiff(modules$datanames, c("all", datanames))
      if (length(extra_datanames)) {
        sprintf(
          "- Module '%s' uses datanames not available in 'data': (%s) not in (%s)",
          modules$label,
          toString(dQuote(extra_datanames, q = FALSE)),
          toString(dQuote(datanames, q = FALSE))
        )
      }
    }
  }
  check_datanames <- unlist(recursive_check_datanames(modules, datanames))
  if (length(check_datanames)) {
    paste(check_datanames, collapse = "\n")
  } else {
    TRUE
  }
}

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

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


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


#' Create filterable data for modules
#'
#' Converts input data to a `FilteredData` object(s) to allow filtering before passing data to individual modules.
#'
#' @param data (`teal_data`)
#' @param modules (`teal_modules`) object
#' @param filters (`teal_slices`) object
#' @param filtered_data_singleton A result of `teal_data_to_filtered_data` applied to `data`.
#' @return Returns list of same shape as `modules`, containing `FilteredData` at every leaf.
#' If module specific, each leaf contains different instance, otherwise every leaf contains `filtered_data_singleton`.
#' @keywords internal
modules_datasets <- function(data, modules, filters, filtered_data_singleton = teal_data_to_filtered_data(data)) {
  checkmate::assert_class(data, "teal_data")
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  checkmate::assert_class(filters, "modules_teal_slices")
  checkmate::assert_r6(filtered_data_singleton, "FilteredData")

  if (!isTRUE(attr(filters, "module_specific"))) {
    # subset global filters
    slices <- shiny::isolate({
      Filter(function(x) x$id %in% attr(filters, "mapping")$global_filters, filters)
    })
    filtered_data_singleton$set_filter_state(slices)
    return(modules_structure(modules, filtered_data_singleton))
  }

  if (inherits(modules, "teal_module")) {
    # 1. get datanames
    datanames <-
      if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
        include_parent_datanames(
          teal_data_datanames(data),
          teal.data::join_keys(data)
        )
      } else {
        include_parent_datanames(
          modules$datanames,
          teal.data::join_keys(data)
        )
      }
    # 2. subset filters (global + dedicated)
    slices <- shiny::isolate({
      Filter(x = filters, f = function(x) {
        x$dataname %in% datanames &&
          (x$id %in% attr(filters, "mapping")$global_filters ||
            x$id %in% unique(unlist(attr(filters, "mapping")[modules$label]))) # nolint: indentation_linter.
      })
    })
    # 2a. subset include/exclude varnames
    slices$include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]
    slices$exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]

    # 3. instantiate FilteredData
    filtered_data <- teal_data_to_filtered_data(data, datanames)
    # 4. set state
    filtered_data$set_filter_state(slices)
    # 5. return
    return(filtered_data)
  } else if (inherits(modules, "teal_modules")) {
    ans <- lapply(
      modules$children,
      modules_datasets,
      data = data,
      filters = filters,
      filtered_data_singleton = filtered_data_singleton
    )
    names(ans) <- vapply(modules$children, `[[`, character(1), "label")

    return(ans)
  }

  stop("something is not right")
}

# Returns nested list of same shape as `modules` with `value` at every leaf.
modules_structure <- function(modules, value = TRUE) {
  if (inherits(modules, "teal_module")) {
    return(value)
  } else {
    stats::setNames(
      lapply(modules$children, modules_structure, value),
      vapply(modules$children, `[[`, character(1), "label")
    )
  }
}

#' Wrapper on `teal.data::datanames`
#'
#' Special function used in internals of `teal` to return names of datasets even if `datanames`
#' has not been set.
#' @param data (`teal_data`)
#' @return `character`
#' @keywords internal
teal_data_datanames <- function(data) {
  checkmate::assert_class(data, "teal_data")
  if (length(teal.data::datanames(data))) {
    teal.data::datanames(data)
  } else {
    ls(teal.code::get_env(data), all.names = TRUE)
  }
}

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

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

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

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

  rlang::hash(list(data = data, modules = modules))
}

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

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

#' Manager bar module
#'
#' Bar of buttons that open modal dialogs.
#'
#' Creates a bar of buttons that open modal dialogs where manager modules reside.
#' Currently contains three modules:
#' - [`module_filter_manager`]
#' - [`module_snapshot_manager`]
#' - [`module_bookmark_manager`]
#'
#' The bar is placed in the `teal` app UI, next to the filter panel hamburger.
#'
#' @name module_wunder_bar
#' @aliases wunder_bar wunder_bar_module
#'
#' @inheritParams module_tabs_with_filters
#'
#' @return Nothing is returned.

#' @rdname module_wunder_bar
#' @keywords internal
wunder_bar_ui <- function(id) {
  ns <- NS(id)
  rev(
    tagList(
      title = "",
      tags$button(
        id = ns("show_filter_manager"),
        class = "btn action-button wunder_bar_button",
        title = "View filter mapping",
        suppressMessages(icon("solid fa-grip"))
      ),
      tags$button(
        id = ns("show_snapshot_manager"),
        class = "btn action-button wunder_bar_button",
        title = "Manage filter state snapshots",
        icon("camera")
      ),
      bookmark_manager_ui(ns("bookmark_manager"))
    )
  )
}

#' @rdname module_wunder_bar
#' @keywords internal
wunder_bar_srv <- function(id, datasets, filter, modules) {
  moduleServer(id, function(input, output, session) {
    logger::log_trace("wunder_bar_srv initializing")

    setBookmarkExclude(c("show_filter_manager", "show_bookmark_manager", "show_bookmark_manager"))

    ns <- session$ns

    observeEvent(input$show_filter_manager, {
      logger::log_trace("wunder_bar_srv@1 show_filter_manager button has been clicked.")
      showModal(
        modalDialog(
          filter_manager_ui(ns("filter_manager")),
          class = "filter_manager_modal",
          size = "l",
          footer = NULL,
          easyClose = TRUE
        )
      )
    })

    observeEvent(input$show_snapshot_manager, {
      logger::log_trace("wunder_bar_srv@1 show_snapshot_manager button has been clicked.")
      showModal(
        modalDialog(
          snapshot_manager_ui(ns("snapshot_manager")),
          class = "snapshot_manager_modal",
          size = "m",
          footer = NULL,
          easyClose = TRUE
        )
      )
    })

    filter_manager_results <- filter_manager_srv(
      id = "filter_manager",
      datasets = datasets,
      filter = filter
    )
    snapshot_history <- snapshot_manager_srv(
      id = "snapshot_manager",
      slices_global = filter_manager_results$slices_global,
      mapping_matrix = filter_manager_results$mapping_matrix,
      datasets = filter_manager_results$datasets_flat
    )
    bookmark_manager_srv(id = "bookmark_manager", modules = modules)
  })
}

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

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

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

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

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


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

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


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

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

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


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

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

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

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

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

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

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


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

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

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

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

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

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

#' Get datasets code
#'
#' Retrieve complete code to create, verify, and filter a dataset.
#'
#' @param datanames (`character`) names of datasets to extract code from
#' @param datasets (`FilteredData`) object
#' @param hashes named (`list`) of hashes per dataset
#'
#' @return Character string concatenated from the following elements:
#'  - data pre-processing code (from `data` argument in `init`)
#'  - hash check of loaded objects
#'  - filter code (if any)
#'
#' @keywords internal
get_datasets_code <- function(datanames, datasets, hashes) {
  # preprocessing code
  str_prepro <- attr(datasets, "preprocessing_code")
  if (length(str_prepro) == 0) {
    str_prepro <- "message('Preprocessing is empty')"
  } else {
    str_prepro <- paste(str_prepro, collapse = "\n")
  }

  # hash checks
  str_hash <- vapply(datanames, function(dataname) {
    sprintf(
      "stopifnot(%s == %s)",
      deparse1(bquote(rlang::hash(.(as.name(dataname))))),
      deparse1(hashes[[dataname]])
    )
  }, character(1))
  str_hash <- paste(str_hash, collapse = "\n")

  # filter expressions
  str_filter <- teal.slice::get_filter_expr(datasets, datanames)
  if (str_filter == "") {
    str_filter <- character(0)
  }

  # concatenate all code
  str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n")
  sprintf("%s\n", str_code)
}

#' 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 [`wunder_bar`].
#' When clicked, the button creates a bookmark and opens a modal which displays the bookmark URL.
#'
#' `teal` does not guarantee that all modules (`teal_module` objects) are bookmarkable.
#' Those that are, have a `teal_bookmarkable` attribute set to `TRUE`. If any modules are not bookmarkable,
#' the bookmark manager modal displays a warning and the bookmark button displays a flag.
#' In order to communicate that a external module is bookmarkable, the module developer
#' should set the `teal_bookmarkable` attribute to `TRUE`.
#'
#' @section Server logic:
#' A bookmark is a URL that contains the app address with a `/?_state_id_=<bookmark_dir>` suffix.
#' `<bookmark_dir>` is a directory created on the server, where the state of the application is saved.
#' Accessing the bookmark URL opens a new session of the app that starts in the previously saved state.
#'
#' @section Note:
#' To enable bookmarking use either:
#' - `shiny` app by using `shinyApp(..., enableBookmarking = "server")` (not supported in `shinytest2`)
#' - set `options(shiny.bookmarkStore = "server")` before running the app
#'
#'
#' @inheritParams module_wunder_bar
#'
#' @return Invisible `NULL`.
#'
#' @aliases bookmark bookmark_manager bookmark_manager_module
#'
#' @name module_bookmark_manager
#' @keywords internal
#'
bookmark_manager_ui <- function(id) {
  ns <- NS(id)
  uiOutput(ns("bookmark_button"), inline = TRUE)
}

#' @rdname module_bookmark_manager
#' @keywords internal
#'
bookmark_manager_srv <- function(id, modules) {
  checkmate::assert_character(id)
  checkmate::assert_class(modules, "teal_modules")
  moduleServer(id, function(input, output, session) {
    logger::log_trace("bookmark_manager_srv initializing")
    ns <- session$ns
    bookmark_option <- getShinyOption("bookmarkStore")
    if (is.null(bookmark_option) && identical(getOption("shiny.bookmarkStore"), "server")) {
      bookmark_option <- getOption("shiny.bookmarkStore")
      # option alone doesn't activate bookmarking - we need to set shinyOptions
      shinyOptions(bookmarkStore = bookmark_option)
    }

    is_unbookmarkable <- unlist(rapply2(
      modules_bookmarkable(modules),
      Negate(isTRUE)
    ))

    # Render bookmark warnings count
    output$bookmark_button <- renderUI({
      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("solid fa-bookmark")),
            if (any(is_unbookmarkable)) {
              tags$span(
                sum(is_unbookmarkable),
                class = "badge-warning badge-count text-white bg-danger"
              )
            }
          )
        )
      }
    })

    # 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(shiny::getDefaultReactiveDomain(), "parent")
    app_session$onBookmarked(function(url) {
      logger::log_trace("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_trace("bookmark_manager_srv@1 do_bookmark module clicked.")
      session$doBookmark()
    })

    invisible(NULL)
  })
}

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

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

#' An example `teal` module
#'
#' `r lifecycle::badge("experimental")`
#'
#' @inheritParams teal_modules
#' @return A `teal` module which can be included in the `modules` argument to [init()].
#' @examples
#' app <- init(
#'   data = teal_data(IRIS = iris, MTCARS = mtcars),
#'   modules = example_module()
#' )
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }
#' @export
example_module <- function(label = "example teal module", datanames = "all") {
  checkmate::assert_string(label)
  ans <- module(
    label,
    server = function(id, data) {
      checkmate::assert_class(data(), "teal_data")
      moduleServer(id, function(input, output, session) {
        updateSelectInput(
          inputId = "dataname",
          choices = isolate(teal.data::datanames(data())),
          selected = restoreInput(session$ns("dataname"), NULL)
        )
        output$text <- renderPrint({
          req(input$dataname)
          data()[[input$dataname]]
        })
        teal.widgets::verbatim_popup_srv(
          id = "rcode",
          verbatim_content = reactive(teal.code::get_code(data())),
          title = "Example Code"
        )
      })
    },
    ui = function(id) {
      ns <- NS(id)
      teal.widgets::standard_layout(
        output = verbatimTextOutput(ns("text")),
        encoding = tags$div(
          selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
          teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
        )
      )
    },
    datanames = datanames
  )
  attr(ans, "teal_bookmarkable") <- TRUE
  ans
}

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

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

  options("shiny.sanitize.errors" = FALSE)

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

  invisible()
}

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

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

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

#' Create `teal_module` and `teal_modules` objects
#'
#' @description
#' `r lifecycle::badge("stable")`
#'
#' Create a nested tab structure to embed modules in a `teal` application.
#'
#' @details
#' `module()` creates an instance of a `teal_module` that can be placed in a `teal` application.
#' `modules()` shapes the structure of a the application by organizing `teal_module` within the navigation panel.
#' It wraps `teal_module` and `teal_modules` objects in a `teal_modules` object,
#' which results in a nested structure corresponding to the nested tabs in the final application.
#'
#' Note that for `modules()` `label` comes after `...`, so it must be passed as a named argument,
#' otherwise it will be captured by `...`.
#'
#' The labels `"global_filters"` and `"Report previewer"` are reserved
#' because they are used by the `mapping` argument of [teal_slices()]
#' and the report previewer module [reporter_previewer_module()], respectively.
#'
#' @param label (`character(1)`) Label shown in the navigation item for the module or module group.
#'   For `modules()` defaults to `"root"`. See `Details`.
#' @param server (`function`) `shiny` module with following arguments:
#'  - `id` - `teal` will set proper `shiny` namespace for this module (see [shiny::moduleServer()]).
#'  - `input`, `output`, `session` - (optional; not recommended) When provided, then [shiny::callModule()]
#'    will be used to call a module. From `shiny` 1.5.0, the recommended way is to use
#'    [shiny::moduleServer()] instead which doesn't require these arguments.
#'  - `data` (optional) When provided, the module will be called with `teal_data` object (i.e. a list of
#'    reactive (filtered) data specified in the `filters` argument) as the value of this argument.
#'  - `datasets` (optional) When provided, the module will be called with `FilteredData` object as the
#'    value of this argument. (See [`teal.slice::FilteredData`]).
#'  - `reporter` (optional) When provided, the module will be called with `Reporter` object as the value
#'    of this argument. (See [`teal.reporter::Reporter`]).
#'  - `filter_panel_api` (optional) When provided, the module will be called with `FilterPanelAPI` object
#'    as the value of this argument. (See [`teal.slice::FilterPanelAPI`]).
#'  - `...` (optional) When provided, `server_args` elements will be passed to the module named argument
#'    or to the `...`.
#' @param ui (`function`) `shiny` UI module function with following arguments:
#'  - `id` - `teal` will set proper `shiny` namespace for this module.
#'  - `...` (optional) When provided, `ui_args` elements will be passed to the module named argument
#'    or to the `...`.
#' @param filters (`character`) Deprecated. Use `datanames` instead.
#' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The
#'   filter panel will automatically update the shown filters to include only
#'   filters in the listed datasets. `NULL` will hide the filter panel,
#'   and the keyword `"all"` will show filters of all datasets. `datanames` also determines
#'   a subset of datasets which are appended to the `data` argument in server function.
#' @param server_args (named `list`) with additional arguments passed on to the server function.
#' @param ui_args (named `list`) with additional arguments passed on to the UI function.
#' @param x (`teal_module` or `teal_modules`) Object to format/print.
#' @param indent (`integer(1)`) Indention level; each nested element is indented one level more.
#' @param ...
#' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab.
#' - For `format()` and `print()`: Arguments passed to other methods.
#'
#' @return
#' `module()` returns an object of class `teal_module`.
#'
#' `modules()` returns a `teal_modules` object which contains following fields:
#' - `label`: taken from the `label` argument.
#' - `children`: a list containing objects passed in `...`. List elements are named after
#' their `label` attribute converted to a valid `shiny` id.
#'
#' @name teal_modules
#' @aliases teal_module
#'
#' @examples
#' library(shiny)
#'
#' module_1 <- module(
#'   label = "a module",
#'   server = function(id, data) {
#'     moduleServer(
#'       id,
#'       module = function(input, output, session) {
#'         output$data <- renderDataTable(data()[["iris"]])
#'       }
#'     )
#'   },
#'   ui = function(id) {
#'     ns <- NS(id)
#'     tagList(dataTableOutput(ns("data")))
#'   },
#'   datanames = "all"
#' )
#'
#' module_2 <- module(
#'   label = "another module",
#'   server = function(id) {
#'     moduleServer(
#'       id,
#'       module = function(input, output, session) {
#'         output$text <- renderText("Another Module")
#'       }
#'     )
#'   },
#'   ui = function(id) {
#'     ns <- NS(id)
#'     tagList(textOutput(ns("text")))
#'   },
#'   datanames = NULL
#' )
#'
#' modules <- modules(
#'   label = "modules",
#'   modules(
#'     label = "nested modules",
#'     module_1
#'   ),
#'   module_2
#' )
#'
#' app <- init(
#'   data = teal_data(iris = iris),
#'   modules = modules
#' )
#'
#' if (interactive()) {
#'   shinyApp(app$ui, app$server)
#' }

#' @rdname teal_modules
#' @export
#'
module <- function(label = "module",
                   server = function(id, ...) {
                     moduleServer(id, function(input, output, session) {})
                   },
                   ui = function(id, ...) {
                     tags$p(paste0("This module has no UI (id: ", id, " )"))
                   },
                   filters,
                   datanames = "all",
                   server_args = NULL,
                   ui_args = NULL) {
  # argument checking (independent)
  ## `label`
  checkmate::assert_string(label)
  if (label == "global_filters") {
    stop(
      sprintf("module(label = \"%s\", ...\n  ", label),
      "Label 'global_filters' is reserved in teal. Please change to something else.",
      call. = FALSE
    )
  }
  if (label == "Report previewer") {
    stop(
      sprintf("module(label = \"%s\", ...\n  ", label),
      "Label 'Report previewer' is reserved in teal. Please change to something else.",
      call. = FALSE
    )
  }

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


  ## UI
  checkmate::assert_function(ui)
  ui_formals <- names(formals(ui))
  if (!"id" %in% ui_formals) {
    stop(
      "\nmodule() `ui` argument requires a function with following arguments:",
      "\n - id - `teal` will set proper `shiny` namespace for this module.",
      "\n\nFollowing arguments can be used optionally:",
      "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"
    )
  }
  if (any(c("data", "datasets") %in% ui_formals)) {
    stop(
      sprintf("Called from module(label = \"%s\", ...)\n  ", label),
      "UI with `data` or `datasets` argument is no longer accepted.\n  ",
      "If some UI inputs depend on data, please move the logic to your server instead.\n  ",
      "Possible solutions are renderUI() or updateXyzInput() functions."
    )
  }


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

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

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

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

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

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

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

# printing methods ----

#' @rdname teal_modules
#' @export
format.teal_module <- function(x, indent = 0, ...) {
  paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, "\n", collapse = "")
}


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


#' @rdname teal_modules
#' @export
format.teal_modules <- function(x, indent = 0, ...) {
  paste(
    c(
      paste0(rep(" ", indent), "+ ", x$label, "\n"),
      unlist(lapply(x$children, format, indent = indent + 1, ...))
    ),
    collapse = ""
  )
}


#' @rdname teal_modules
#' @export
print.teal_modules <- print.teal_module


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

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

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

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

## read modules ----

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


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

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

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

#' Create a UI of nested tabs of `teal_modules`
#'
#' @section `ui_nested_tabs`:
#' Each `teal_modules` is translated to a `tabsetPanel` and each
#' of its children is another tab-module called recursively. The UI of a
#' `teal_module` is obtained by calling its UI function.
#'
#' The `datasets` argument is required to resolve the `teal` arguments in an
#' isolated context (with respect to reactivity).
#'
#' @section `srv_nested_tabs`:
#' This module recursively calls all elements of `modules` and returns currently active one.
#' - `teal_module` returns self as a active module.
#' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.
#'
#' @name module_nested_tabs
#'
#' @inheritParams module_tabs_with_filters
#'
#' @param depth (`integer(1)`)
#'  number which helps to determine depth of the modules nesting.
#' @param is_module_specific (`logical(1)`)
#'  flag determining if the filter panel is global or module-specific.
#'  When set to `TRUE`, a filter panel is called inside of each module tab.
#'
#' @return
#' Depending on the class of `modules`, `ui_nested_tabs` returns:
#'   - `teal_module`: instantiated UI of the module.
#'   - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively
#'     calling this function on it.
#'
#' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.
#'
#' @keywords internal
NULL

#' @rdname module_nested_tabs
ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  checkmate::assert_count(depth)
  UseMethod("ui_nested_tabs", modules)
}

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

#' @rdname module_nested_tabs
#' @export
ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
  checkmate::assert_list(datasets, types = c("list", "FilteredData"))
  ns <- NS(id)
  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
          tabPanel(
            title = module_label,
            value = module_id, # when clicked this tab value changes input$<tabset panel id>
            ui_nested_tabs(
              id = ns(module_id),
              modules = modules$children[[module_id]],
              datasets = datasets[[module_label]],
              depth = depth + 1L,
              is_module_specific = is_module_specific
            )
          )
        }
      )
    )
  )
}

#' @rdname module_nested_tabs
#' @export
ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
  checkmate::assert_class(datasets, classes = "FilteredData")
  ns <- NS(id)

  args <- c(list(id = ns("module")), modules$ui_args)

  teal_ui <- tags$div(
    id = id,
    class = "teal_module",
    uiOutput(ns("data_reactive"), inline = TRUE),
    tagList(
      if (depth >= 2L) tags$div(style = "mt-6"),
      do.call(modules$ui, args)
    )
  )

  if (!is.null(modules$datanames) && is_module_specific) {
    fluidRow(
      column(width = 9, teal_ui, class = "teal_primary_col"),
      column(
        width = 3,
        datasets$ui_filter_panel(ns("module_filter_panel")),
        class = "teal_secondary_col"
      )
    )
  } else {
    teal_ui
  }
}

#' @rdname module_nested_tabs
srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,
                            reporter = teal.reporter::Reporter$new()) {
  checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
  checkmate::assert_class(reporter, "Reporter")
  UseMethod("srv_nested_tabs", modules)
}

#' @rdname module_nested_tabs
#' @export
srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,
                                    reporter = teal.reporter::Reporter$new()) {
  stop("Modules class not supported: ", paste(class(modules), collapse = " "))
}

#' @rdname module_nested_tabs
#' @export
srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,
                                         reporter = teal.reporter::Reporter$new()) {
  checkmate::assert_list(datasets, types = c("list", "FilteredData"))

  moduleServer(id = id, module = function(input, output, session) {
    logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")

    labels <- vapply(modules$children, `[[`, character(1), "label")
    modules_reactive <- sapply(
      names(modules$children),
      function(module_id) {
        srv_nested_tabs(
          id = module_id,
          datasets = datasets[[labels[module_id]]],
          modules = modules$children[[module_id]],
          is_module_specific = is_module_specific,
          reporter = reporter
        )
      },
      simplify = FALSE
    )

    # when not ready input$active_tab would return NULL - this would fail next reactive
    input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)
    get_active_module <- reactive({
      if (length(modules$children) == 1L) {
        # single tab is active by default
        modules_reactive[[1]]()
      } else {
        # switch to active tab
        modules_reactive[[input_validated()]]()
      }
    })

    get_active_module
  })
}

#' @rdname module_nested_tabs
#' @export
srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,
                                        reporter = teal.reporter::Reporter$new()) {
  checkmate::assert_class(datasets, "FilteredData")
  logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")

  moduleServer(id = id, module = function(input, output, session) {
    if (!is.null(modules$datanames) && is_module_specific) {
      datasets$srv_filter_panel("module_filter_panel")
    }

    # Create two triggers to limit reactivity between filter-panel and modules.
    # We want to recalculate only visible modules
    # - trigger the data when the tab is selected
    # - trigger module to be called when the tab is selected for the first time
    trigger_data <- reactiveVal(1L)
    trigger_module <- reactiveVal(NULL)
    output$data_reactive <- renderUI({
      lapply(datasets$datanames(), function(x) {
        datasets$get_data(x, filtered = TRUE)
      })
      isolate(trigger_data(trigger_data() + 1))
      isolate(trigger_module(TRUE))

      NULL
    })

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

    if (is_arg_used(modules$server, "data")) {
      data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets))
      args <- c(args, data = list(data))
    }

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

    # This function calls a module server function.
    call_module <- function() {
      if (is_arg_used(modules$server, "id")) {
        do.call(modules$server, args)
      } else {
        do.call(callModule, c(args, list(module = modules$server)))
      }
    }

    # Call modules.
    if (isTRUE(session$restoreContext$active)) {
      # When restoring bookmark, all modules must be initialized on app start.
      # Delayed module initiation (below) precludes restoring state b/c inputs do not exist when restoring occurs.
      call_module()
    } else if (inherits(modules, "teal_module_previewer")) {
      # 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).
      call_module()
    } else {
      # When app starts normally, modules are initialized only when corresponding tabs are clicked.
      # Observing trigger_module() induces the module only when output$data_reactive is triggered (see above).
      observeEvent(
        ignoreNULL = TRUE,
        once = TRUE,
        eventExpr = trigger_module(),
        handlerExpr = call_module()
      )
    }

    reactive(modules)
  })
}

#' Convert `FilteredData` to reactive list of datasets of the `teal_data` type.
#'
#' Converts `FilteredData` object to `teal_data` object containing datasets needed for a specific module.
#' Please note that if a module needs a dataset which has a parent, then the parent will also be returned.
#' A hash per `dataset` is calculated internally and returned in the code.
#'
#' @param module (`teal_module`) module where needed filters are taken from
#' @param datasets (`FilteredData`) object where needed data are taken from
#'
#' @return A `teal_data` object.
#'
#' @keywords internal
.datasets_to_data <- function(module, datasets) {
  checkmate::assert_class(module, "teal_module")
  checkmate::assert_class(datasets, "FilteredData")

  datanames <- if (is.null(module$datanames) || identical(module$datanames, "all")) {
    datasets$datanames()
  } else {
    include_parent_datanames(
      module$datanames,
      datasets$get_join_keys()
    )
  }

  # list of reactive filtered data
  data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)

  hashes <- calculate_hashes(datanames, datasets)

  code <- c(
    get_rcode_str_install(),
    get_rcode_libraries(),
    get_datasets_code(datanames, datasets, hashes)
  )


  data <- do.call(
    teal.data::teal_data,
    args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames]))
  )

  data@verified <- attr(datasets, "verification_status")
  data
}

#' Get the hash of a dataset
#'
#' @param datanames (`character`) names of datasets
#' @param datasets (`FilteredData`) object holding the data
#'
#' @return A list of hashes per dataset.
#' @keywords internal
#'
calculate_hashes <- function(datanames, datasets) {
  sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)
}

#' Manage multiple `FilteredData` objects
#'
#' Oversee filter states across the entire application.
#'
#' This module observes changes in the filters of each `FilteredData` object
#' and keeps track of all filters used. A mapping of filters to modules
#' is kept in the `mapping_matrix` object (which is actually a `data.frame`)
#' that tracks which filters (rows) are active in which modules (columns).
#'
#' @param id (`character(1)`)
#'  `shiny` module instance id.
#' @param datasets (named `list`)
#'  A list, possibly nested, of `FilteredData` objects.
#'  Each `FilteredData` will be served to one module in the `teal` application.
#'  The structure of the list must reflect the nesting of modules in tabs
#'  and the names of the list must match the labels of their respective modules.
#' @inheritParams init
#'
#' @return
#' A `list` containing:
#'
#' objects used by other manager modules
#' - `datasets_flat`: named list of `FilteredData` objects,
#' - `mapping_matrix`: `reactive` containing a `data.frame`,
#' - `slices_global`: `reactiveVal` containing a `teal_slices` object,
#'
#' objects used for testing
#' - modules_out: `list` of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.
#'
#' @name module_filter_manager
#' @aliases filter_manager filter_manager_module
#'

#' @rdname module_filter_manager
#' @keywords internal
#'
filter_manager_ui <- function(id) {
  ns <- NS(id)
  tags$div(
    class = "filter_manager_content",
    tableOutput(ns("slices_table"))
  )
}

#' @rdname module_filter_manager
#' @keywords internal
#'
filter_manager_srv <- function(id, datasets, filter) {
  moduleServer(id, function(input, output, session) {
    logger::log_trace("filter_manager_srv initializing for: { paste(names(datasets), collapse = ', ')}.")

    is_module_specific <- isTRUE(attr(filter, "module_specific"))

    # Create a global list of slices.
    # Contains all available teal_slice objects available to all modules.
    # Passed whole to instances of FilteredData used for individual modules.
    # Down there a subset that pertains to the data sets used in that module is applied and displayed.
    slices_global <- reactiveVal(filter)

    datasets_flat <-
      if (!is_module_specific) {
        flatten_datasets(unlist(datasets)[[1]])
      } else {
        flatten_datasets(datasets)
      }

    # Create mapping of filters to modules in matrix form (presented as data.frame).
    # Modules get NAs for filters that cannot be set for them.
    mapping_matrix <- reactive({
      state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")
      mapping_smooth <- lapply(datasets_flat, function(x) {
        state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")
        state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")
        states_active <- state_ids_global %in% state_ids_local
        ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)
      })

      as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)
    })

    output$slices_table <- renderTable(
      expr = {
        # Display logical values as UTF characters.
        mm <- mapping_matrix()
        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) <- ""
        }

        # Report Previewer will not be displayed.
        mm[names(mm) != "Report previewer"]
      },
      align = paste(c("l", rep("c", sum(names(datasets_flat) != "Report previewer"))), collapse = ""),
      rownames = TRUE
    )

    # Create list of module calls.
    modules_out <- lapply(names(datasets_flat), function(module_name) {
      filter_manager_module_srv(
        id = module_name,
        module_fd = datasets_flat[[module_name]],
        slices_global = slices_global
      )
    })

    list(
      slices_global = slices_global,
      mapping_matrix = mapping_matrix,
      datasets_flat = datasets_flat,
      modules_out = modules_out # returned for testing purpose
    )
  })
}

#' Module specific filter manager
#'
#' Tracks filter states in a single module.
#'
#' This module tracks the state of a single `FilteredData` object and global `teal_slices`
#' and updates both objects as necessary. Filter states added in different modules
#' Filter states added any individual module are added to global `teal_slices`
#' and from there become available in other modules
#' by setting `private$available_teal_slices` in each `FilteredData`.
#'
#' @param id (`character(1)`)
#'  `shiny` module id.
#' @param module_fd (`FilteredData`)
#'   Object containing the data to be filtered in a single `teal` module.
#' @param slices_global (`reactiveVal`)
#'   stores `teal_slices` with all available filters; allows the following actions:
#'   - to disable/enable a specific filter in a module
#'   - to restore saved filter settings
#'   - to save current filter panel settings
#' @return A `reactive` expression containing a `teal_slices` with the slices active in this module.
#' @keywords internal
#'
filter_manager_module_srv <- function(id, module_fd, slices_global) {
  moduleServer(id, function(input, output, session) {
    # Only operate on slices that refer to data sets present in this module.
    module_fd$set_available_teal_slices(reactive(slices_global()))

    # Track filter state of this module.
    slices_module <- reactive(module_fd$get_filter_state())

    # Reactive values for comparing states.
    previous_slices <- reactiveVal(isolate(slices_module()))
    slices_added <- reactiveVal(NULL)

    # Observe changes in module filter state and trigger appropriate actions.
    observeEvent(slices_module(), ignoreNULL = FALSE, {
      logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
      added <- setdiff_teal_slices(slices_module(), slices_global())
      if (length(added)) slices_added(added)
      previous_slices(slices_module())
    })

    observeEvent(slices_added(), ignoreNULL = TRUE, {
      logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
      # In case the new state has the same id as an existing state, add a suffix to it.
      global_ids <- vapply(slices_global(), `[[`, character(1L), "id")
      lapply(
        slices_added(),
        function(slice) {
          if (slice$id %in% global_ids) {
            slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)
          }
        }
      )
      slices_global_new <- c(slices_global(), slices_added())
      slices_global(slices_global_new)
      slices_added(NULL)
    })

    slices_module # returned for testing purpose
  })
}



# utilities ----

#' Flatten potentially nested list of FilteredData objects while maintaining useful names.
#' Simply using `unlist` would result in concatenated names.
#' A single `FilteredData` will result in a list named "Global Filters"
#' because that name used in the mapping matrix display.
#' @param x `FilteredData` or a `list` thereof
#' @param name (`character(1)`) string used to name `x` in the resulting list
#' @return Unnested named list of `FilteredData` objects.
#' @keywords internal
#' @noRd
#'
flatten_datasets <- function(x, name = "Global Filters") {
  if (inherits(x, "FilteredData")) {
    setNames(list(x), name)
  } else {
    unlist(lapply(names(x), function(name) flatten_datasets(x[[name]], name)))
  }
}

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

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

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

  singleton(lapply(js_files, includeScript))
}

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

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

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

  message("Initializing reporter_previewer_module")

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

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

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

#' 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 supply or modify data in a `teal` application.
#' The module allows for running data pre-processing code (creation _and_ some modification) after the app starts.
#' 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
#'
#' @return
#' `teal_data_module` returns an object of class `teal_data_module`.
#'
#' @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) {
  checkmate::assert_function(ui, args = "id", nargs = 1)
  checkmate::assert_function(server, args = "id", nargs = 1)
  structure(
    list(ui = ui, server = server),
    class = "teal_data_module"
  )
}

setOldClass("teal_data_module")

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

        if (!is.reactive(teal_data_rv)) {
          stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
        }

        td <- eventReactive(teal_data_rv(),
          {
            if (inherits(teal_data_rv(), c("teal_data", "qenv.error"))) {
              eval_code(teal_data_rv(), code)
            } else {
              teal_data_rv()
            }
          },
          ignoreNULL = FALSE
        )
        td
      })
    }
  )
})

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

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

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

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

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

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

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

1		#' Landing popup module
2		#'
3		#' @description Creates a landing welcome popup for `teal` applications.
4		#'
5		#' This module is used to display a popup dialog when the application starts.
6		#' The dialog blocks access to the application and must be closed with a button before the application can be viewed.
7		#'
8		#' @param label (`character(1)`) Label of the module.
9		#' @param title (`character(1)`) Text to be displayed as popup title.
10		#' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup.
11		#' Passed to `...` of `shiny::modalDialog`. See examples.
12		#' @param buttons (`shiny.tag` or `shiny.tag.list`) Typically a `modalButton` or `actionButton`. See examples.
13		#'
14		#' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications.
15		#'
16		#' @examples
17		#' app1 <- init(
18		#' data = teal_data(iris = iris),
19		#' modules = modules(
20		#' landing_popup_module(
21		#' content = "A place for the welcome message or a disclaimer statement.",
22		#' buttons = modalButton("Proceed")
23		#' ),
24		#' example_module()
25		#' )
26		#' )
27		#' if (interactive()) {
28		#' shinyApp(app1$ui, app1$server)
29		#' }
30		#'
31		#' app2 <- init(
32		#' data = teal_data(iris = iris),
33		#' modules = modules(
34		#' landing_popup_module(
35		#' title = "Welcome",
36		#' content = tags$b(
37		#' "A place for the welcome message or a disclaimer statement.",
38		#' style = "color: red;"
39		#' ),
40		#' buttons = tagList(
41		#' modalButton("Proceed"),
42		#' actionButton("read", "Read more",
43		#' onclick = "window.open('http://google.com', '_blank')"
44		#' ),
45		#' actionButton("close", "Reject", onclick = "window.close()")
46		#' )
47		#' ),
48		#' example_module()
49		#' )
50		#' )
51		#'
52		#' if (interactive()) {
53		#' shinyApp(app2$ui, app2$server)
54		#' }
55		#'
56		#' @export
57		landing_popup_module <- function(label = "Landing Popup",
58		title = NULL,
59		content = NULL,
60		buttons = modalButton("Accept")) {
61	!	checkmate::assert_string(label)
62	!	checkmate::assert_string(title, null.ok = TRUE)
63	!	checkmate::assert_multi_class(
64	!	content,
65	!	classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
66		)
67	!	checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
68
69	!	message("Initializing landing_popup_module")
70
71	!	module <- module(
72	!	label = label,
73	!	server = function(id) {
74	!	moduleServer(id, function(input, output, session) {
75	!	showModal(
76	!	modalDialog(
77	!	id = "landingpopup",
78	!	title = title,
79	!	content,
80	!	footer = buttons
81		)
82		)
83		})
84		}
85		)
86	!	class(module) <- c("teal_module_landing", class(module))
87	!	module
88		}

1		# This module is the main teal module that puts everything together.
2
3		#' `teal` main app module
4		#'
5		#' This is the main `teal` app that puts everything together.
6		#'
7		#' It displays the splash UI which is used to fetch the data, possibly
8		#' prompting for a password input to fetch the data. Once the data is ready,
9		#' the splash screen is replaced by the actual `teal` UI that is tabsetted and
10		#' has a filter panel with `datanames` that are relevant for the current tab.
11		#' Nested tabs are possible, but we limit it to two nesting levels for reasons
12		#' of clarity of the UI.
13		#'
14		#' The splash screen functionality can also be used
15		#' for non-delayed data which takes time to load into memory, avoiding
16		#' `shiny` session timeouts.
17		#'
18		#' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the
19		#' `datasets` object that is shared across modules.
20		#' Once it is ready and non-`NULL`, the splash screen is replaced by the
21		#' main `teal` UI that depends on the data.
22		#' The currently active tab is tracked and the right filter panel
23		#' updates the displayed datasets to filter for according to the active `datanames`
24		#' of the tab.
25		#'
26		#' It is written as a `shiny` module so it can be added into other apps as well.
27		#'
28		#' @name module_teal
29		#'
30		#' @inheritParams module_teal_with_splash
31		#'
32		#' @param splash_ui (`shiny.tag`) UI to display initially,
33		#' can be a splash screen or a `shiny` module UI. For the latter, see
34		#' [init()] about how to call the corresponding server function.
35		#'
36		#' @param teal_data_rv (`reactive`)
37		#' returns the `teal_data`, only evaluated once, `NULL` value is ignored
38		#'
39		#' @return
40		#' Returns a `reactive` expression which returns the currently active module.
41		#'
42		#' @keywords internal
43		#'
44		NULL
45
46		#' @rdname module_teal
47		ui_teal <- function(id,
48		splash_ui = tags$h2("Starting the Teal App"),
49		title = build_app_title(),
50		header = tags$p(),
51		footer = tags$p()) {
52	!	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
53
54	!	checkmate::assert_multi_class(splash_ui, c("shiny.tag", "shiny.tag.list", "html"))
55
56	!	if (is.character(title)) {
57	!	title <- build_app_title(title)
58		} else {
59	!	validate_app_title_tag(title)
60		}
61
62	!	checkmate::assert(
63	!	.var.name = "header",
64	!	checkmate::check_string(header),
65	!	checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
66		)
67	!	if (checkmate::test_string(header)) {
68	!	header <- tags$p(header)
69		}
70
71	!	checkmate::assert(
72	!	.var.name = "footer",
73	!	checkmate::check_string(footer),
74	!	checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
75		)
76	!	if (checkmate::test_string(footer)) {
77	!	footer <- tags$p(footer)
78		}
79
80	!	ns <- NS(id)
81
82		# Once the data is loaded, we will remove this element and add the real teal UI instead
83	!	splash_ui <- tags$div(
84		# id so we can remove the splash screen once ready, which is the first child of this container
85	!	id = ns("main_ui_container"),
86		# we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
87		# just the first item of the tagList)
88	!	tags$div(splash_ui)
89		)
90
91		# show busy icon when `shiny` session is busy computing stuff
92		# based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length.
93	!	shiny_busy_message_panel <- conditionalPanel(
94	!	condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
95	!	tags$div(
96	!	icon("arrows-rotate", "spin fa-spin"),
97	!	"Computing ...",
98		# CSS defined in `custom.css`
99	!	class = "shinybusymessage"
100		)
101		)
102
103	!	fluidPage(
104	!	title = title,
105	!	theme = get_teal_bs_theme(),
106	!	include_teal_css_js(),
107	!	tags$header(header),
108	!	tags$hr(class = "my-2"),
109	!	shiny_busy_message_panel,
110	!	splash_ui,
111	!	tags$hr(),
112	!	tags$footer(
113	!	tags$div(
114	!	footer,
115	!	teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
116	!	textOutput(ns("identifier"))
117		)
118		)
119		)
120		}
121
122
123		#' @rdname module_teal
124		srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
125	19x	stopifnot(is.reactive(teal_data_rv))
126	18x	moduleServer(id, function(input, output, session) {
127	18x	logger::log_trace("srv_teal initializing the module.")
128
129	18x	output$identifier <- renderText(
130	18x	paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
131		)
132
133	18x	teal.widgets::verbatim_popup_srv(
134	18x	"sessionInfo",
135	18x	verbatim_content = utils::capture.output(utils::sessionInfo()),
136	18x	title = "SessionInfo"
137		)
138
139		# `JavaScript` code
140	18x	run_js_files(files = "init.js")
141
142		# set timezone in shiny app
143		# timezone is set in the early beginning so it will be available also
144		# for `DDL` and all shiny modules
145	18x	get_client_timezone(session$ns)
146	18x	observeEvent(
147	18x	eventExpr = input$timezone,
148	18x	once = TRUE,
149	18x	handlerExpr = {
150	!	session$userData$timezone <- input$timezone
151	!	logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
152		}
153		)
154
155	18x	reporter <- teal.reporter::Reporter$new()$set_id(attr(filter, "app_id"))
156	18x	if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
157	!	modules <- append_module(
158	!	modules,
159	!	reporter_previewer_module(server_args = list(previewer_buttons = c("download", "reset")))
160		)
161		}
162
163	18x	env <- environment()
164	18x	datasets_reactive <- eventReactive(teal_data_rv(), {
165	4x	env$progress <- shiny::Progress$new(session)
166	4x	env$progress$set(0.25, message = "Setting data")
167
168		# Restore filter from bookmarked state, if applicable.
169	4x	filter_restored <- restoreValue("filter_state_on_bookmark", filter)
170	4x	if (!is.teal_slices(filter_restored)) {
171	!	filter_restored <- as.teal_slices(filter_restored)
172		}
173		# Create list of `FilteredData` objects that reflects structure of `modules`.
174	4x	modules_datasets(teal_data_rv(), modules, filter_restored, teal_data_to_filtered_data(teal_data_rv()))
175		})
176
177		# Replace splash / welcome screen once data is loaded ----
178		# ignoreNULL to not trigger at the beginning when data is NULL
179		# just handle it once because data obtained through delayed loading should
180		# usually not change afterwards
181		# if restored from bookmarked state, `filter` is ignored
182
183	18x	observeEvent(datasets_reactive(), once = TRUE, {
184	!	logger::log_trace("srv_teal@5 setting main ui after data was pulled")
185	!	on.exit(env$progress$close())
186	!	env$progress$set(0.5, message = "Setting up main UI")
187	!	datasets <- datasets_reactive()
188
189		# main_ui_container contains splash screen first and we remove it and replace it by the real UI
190	!	removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container")))
191	!	insertUI(
192	!	selector = paste0("#", session$ns("main_ui_container")),
193	!	where = "beforeEnd",
194		# we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not
195		# just the first item of the tagList)
196	!	ui = tags$div(ui_tabs_with_filters(
197	!	session$ns("main_ui"),
198	!	modules = modules,
199	!	datasets = datasets,
200	!	filter = filter
201		)),
202		# needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not
203		# have any effect as they are ignored when not present
204	!	immediate = TRUE
205		)
206
207		# must make sure that this is only executed once as modules assume their observers are only
208		# registered once (calling server functions twice would trigger observers twice each time)
209	!	srv_tabs_with_filters(
210	!	id = "main_ui",
211	!	datasets = datasets,
212	!	modules = modules,
213	!	reporter = reporter,
214	!	filter = filter
215		)
216		})
217		})
218		}

1		# This file adds a splash screen for delayed data loading on top of teal
2
3		#' Add splash screen to `teal` application
4		#'
5		#' @description `r lifecycle::badge("stable")`
6		#'
7		#' Displays custom splash screen during initial delayed data loading.
8		#'
9		#' @details
10		#' This module pauses app initialization pending delayed data loading.
11		#' This is necessary because the filter panel and modules depend on the data to initialize.
12		#'
13		#' `teal_with_splash` follows the `shiny` module convention.
14		#' [`init()`] is a wrapper around this that assumes that `teal` it is
15		#' the top-level module and cannot be embedded.
16		#'
17		#' Note: It is no longer recommended to embed `teal` in `shiny` apps as a module.
18		#' but rather use `init` to create a standalone application.
19		#'
20		#' @seealso [init()]
21		#'
22		#' @param id (`character(1)`)
23		#' module id
24		#' @inheritParams init
25		#' @param modules (`teal_modules`) object containing the output modules which
26		#' will be displayed in the `teal` application. See [modules()] and [module()] for
27		#' more details.
28		#' @inheritParams shiny::moduleServer
29		#' @return
30		#' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not.
31		#' @name module_teal_with_splash
32		#' @examples
33		#' teal_modules <- modules(example_module())
34		#' # Shiny app with modular integration of teal
35		#' ui <- fluidPage(
36		#' ui_teal_with_splash(id = "app1", data = teal_data())
37		#' )
38		#'
39		#' server <- function(input, output, session) {
40		#' srv_teal_with_splash(
41		#' id = "app1",
42		#' data = teal_data(iris = iris),
43		#' modules = teal_modules
44		#' )
45		#' }
46		#'
47		#' if (interactive()) {
48		#' shinyApp(ui, server)
49		#' }
50		#'
51		NULL
52
53		#' @export
54		#' @rdname module_teal_with_splash
55		ui_teal_with_splash <- function(id,
56		data,
57		title = build_app_title(),
58		header = tags$p(),
59		footer = tags$p()) {
60	!	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
61	!	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
62	!	checkmate::assert(
63	!	.var.name = "title",
64	!	checkmate::check_string(title),
65	!	checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
66		)
67	!	checkmate::assert(
68	!	.var.name = "header",
69	!	checkmate::check_string(header),
70	!	checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
71		)
72	!	checkmate::assert(
73	!	.var.name = "footer",
74	!	checkmate::check_string(footer),
75	!	checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
76		)
77
78	!	ns <- NS(id)
79
80		# Startup splash screen for delayed loading
81		# We use delayed loading in all cases, even when the data does not need to be fetched.
82		# This has the benefit that when filtering the data takes a lot of time initially, the
83		# Shiny app does not time out.
84	!	splash_ui <- if (inherits(data, "teal_data_module")) {
85	!	data$ui(ns("teal_data_module"))
86	!	} else if (inherits(data, "teal_data")) {
87	!	tags$div()
88		}
89	!	ui_teal(
90	!	id = ns("teal"),
91	!	splash_ui = tags$div(splash_ui, uiOutput(ns("error"))),
92	!	title = title,
93	!	header = header,
94	!	footer = footer
95		)
96		}
97
98		#' @export
99		#' @rdname module_teal_with_splash
100		srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
101	15x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
102	15x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
103	15x	checkmate::assert_class(modules, "teal_modules")
104	15x	checkmate::assert_class(filter, "teal_slices")
105
106	15x	moduleServer(id, function(input, output, session) {
107	15x	logger::log_trace("srv_teal_with_splash initializing module with data.")
108
109	15x	if (getOption("teal.show_js_log", default = FALSE)) {
110	!	shinyjs::showLog()
111		}
112
113		# teal_data_rv contains teal_data object
114		# either passed to teal::init or returned from teal_data_module
115	15x	teal_data_rv <- if (inherits(data, "teal_data_module")) {
116	10x	data <- data$server(id = "teal_data_module")
117	10x	if (!is.reactive(data)) {
118	1x	stop("The `teal_data_module` passed to `data` must return a reactive expression.", call. = FALSE)
119		}
120	9x	data
121	15x	} else if (inherits(data, "teal_data")) {
122	5x	reactiveVal(data)
123		}
124
125	14x	teal_data_rv_validate <- reactive({
126		# custom module can return error
127	11x	data <- tryCatch(teal_data_rv(), error = function(e) e)
128
129		# there is an empty reactive cycle on init!
130	11x	if (inherits(data, "shiny.silent.error") && identical(data$message, "")) {
131	!	return(NULL)
132		}
133
134		# to handle qenv.error
135	11x	if (inherits(data, "qenv.error")) {
136	2x	validate(
137	2x	need(
138	2x	FALSE,
139	2x	paste(
140	2x	"Error when executing `teal_data_module` passed to `data`:\n ",
141	2x	paste(data$message, collapse = "\n"),
142	2x	"\n Check your inputs or contact app developer if error persists."
143		)
144		)
145		)
146		}
147
148		# to handle module non-qenv errors
149	9x	if (inherits(data, "error")) {
150	1x	validate(
151	1x	need(
152	1x	FALSE,
153	1x	paste(
154	1x	"Error when executing `teal_data_module` passed to `data`:\n ",
155	1x	paste(data$message, collpase = "\n"),
156	1x	"\n Check your inputs or contact app developer if error persists."
157		)
158		)
159		)
160		}
161
162	8x	validate(
163	8x	need(
164	8x	inherits(data, "teal_data"),
165	8x	paste(
166	8x	"Error: `teal_data_module` passed to `data` failed to return `teal_data` object, returned",
167	8x	toString(sQuote(class(data))),
168	8x	"instead.",
169	8x	"\n Check your inputs or contact app developer if error persists."
170		)
171		)
172		)
173
174	5x	if (!length(teal.data::datanames(data))) {
175	1x	warning("`data` object has no datanames. Default datanames are set using `teal_data`'s environment.")
176		}
177
178	5x	is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
179	5x	if (!isTRUE(is_modules_ok)) {
180	1x	validate(need(isTRUE(is_modules_ok), sprintf("%s. Contact app developer.", is_modules_ok)))
181		}
182
183	4x	is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
184	4x	if (!isTRUE(is_filter_ok)) {
185	1x	showNotification(
186	1x	"Some filters were not applied because of incompatibility with data. Contact app developer.",
187	1x	type = "warning",
188	1x	duration = 10
189		)
190	1x	warning(is_filter_ok)
191		}
192
193	4x	teal_data_rv()
194		})
195
196	14x	output$error <- renderUI({
197	!	teal_data_rv_validate()
198	!	NULL
199		})
200
201
202	14x	res <- srv_teal(id = "teal", modules = modules, teal_data_rv = teal_data_rv_validate, filter = filter)
203	14x	logger::log_trace("srv_teal_with_splash initialized module with data.")
204
205	14x	res
206		})
207		}

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 [`wunder_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		#' @param mapping_matrix (`reactive`) that contains a `data.frame` representation
78		#' of the mapping of filter state ids (rows) to modules labels (columns);
79		#' all columns are `logical` vectors.
80		#' @param datasets non-nested (named `list`) of `FilteredData` objects.
81		#'
82		#' @return `list` containing the snapshot history, where each element is an unlisted `teal_slices` object.
83		#'
84		#' @name module_snapshot_manager
85		#' @aliases snapshot snapshot_manager snapshot_manager_module
86		#'
87		#' @author Aleksander Chlebowski
88		#'
89
90
91		#' @rdname module_snapshot_manager
92		#' @keywords internal
93		#'
94		snapshot_manager_ui <- function(id) {
95	!	ns <- NS(id)
96	!	tags$div(
97	!	class = "manager_content",
98	!	tags$div(
99	!	class = "manager_table_row",
100	!	tags$span(tags$b("Snapshot manager")),
101	!	actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
102	!	actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"),
103	!	actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
104	!	NULL
105		),
106	!	uiOutput(ns("snapshot_list"))
107		)
108		}
109
110		#' @rdname module_snapshot_manager
111		#' @keywords internal
112		#'
113		snapshot_manager_srv <- function(id, slices_global, mapping_matrix, datasets) {
114	4x	checkmate::assert_character(id)
115	4x	checkmate::assert_true(is.reactive(slices_global))
116	4x	checkmate::assert_class(isolate(slices_global()), "teal_slices")
117	4x	checkmate::assert_true(is.reactive(mapping_matrix))
118	4x	checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)
119	4x	checkmate::assert_list(datasets, types = "FilteredData", any.missing = FALSE, names = "named")
120
121	4x	moduleServer(id, function(input, output, session) {
122	4x	logger::log_trace("snapshot_manager_srv initializing")
123
124		# Set up bookmarking callbacks ----
125		# Register bookmark exclusions (all buttons and text fields).
126	4x	setBookmarkExclude(c(
127	4x	"snapshot_add", "snapshot_load", "snapshot_reset",
128	4x	"snapshot_name_accept", "snaphot_file_accept",
129	4x	"snapshot_name", "snapshot_file"
130		))
131		# Add current filter state to bookmark.
132		# This is done on the app session because the value is restored in `module_teal`
133		# and we don't want to have to use this module's name space there.
134	4x	app_session <- .subset2(shiny::getDefaultReactiveDomain(), "parent")
135	4x	app_session$onBookmark(function(state) {
136	!	logger::log_trace("snapshot_manager_srv@onBookmark: storing filter state")
137	!	snapshot <- as.list(slices_global(), recursive = TRUE)
138	!	attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())
139	!	state$values$filter_state_on_bookmark <- snapshot
140		})
141		# Add snapshot history to bookmark.
142	4x	session$onBookmark(function(state) {
143	!	logger::log_trace("snapshot_manager_srv@onBookmark: storing snapshot and bookmark history")
144	!	state$values$snapshot_history <- snapshot_history() # isolate this?
145		})
146
147	4x	ns <- session$ns
148
149		# Track global filter states ----
150	4x	filter <- isolate(slices_global())
151	4x	snapshot_history <- reactiveVal({
152		# Restore directly from bookmarked state, if applicable.
153	4x	restoreValue(ns("snapshot_history"), list("Initial application state" = as.list(filter, recursive = TRUE)))
154		})
155
156		# Snapshot current application state ----
157		# Name snaphsot.
158	4x	observeEvent(input$snapshot_add, {
159	!	logger::log_trace("snapshot_manager_srv: snapshot_add button clicked")
160	!	showModal(
161	!	modalDialog(
162	!	textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
163	!	footer = tagList(
164	!	actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
165	!	modalButton(label = "Cancel", icon = icon("thumbs-down"))
166		),
167	!	size = "s"
168		)
169		)
170		})
171		# Store snaphsot.
172	4x	observeEvent(input$snapshot_name_accept, {
173	!	logger::log_trace("snapshot_manager_srv: snapshot_name_accept button clicked")
174	!	snapshot_name <- trimws(input$snapshot_name)
175	!	if (identical(snapshot_name, "")) {
176	!	logger::log_trace("snapshot_manager_srv: snapshot name rejected")
177	!	showNotification(
178	!	"Please name the snapshot.",
179	!	type = "message"
180		)
181	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
182	!	} else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
183	!	logger::log_trace("snapshot_manager_srv: snapshot name rejected")
184	!	showNotification(
185	!	"This name is in conflict with other snapshot names. Please choose a different one.",
186	!	type = "message"
187		)
188	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
189		} else {
190	!	logger::log_trace("snapshot_manager_srv: snapshot name accepted, adding snapshot")
191	!	snapshot <- as.list(slices_global(), recursive = TRUE)
192	!	attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())
193	!	snapshot_update <- c(snapshot_history(), list(snapshot))
194	!	names(snapshot_update)[length(snapshot_update)] <- snapshot_name
195	!	snapshot_history(snapshot_update)
196	!	removeModal()
197		# Reopen filter manager modal by clicking button in the main application.
198	!	shinyjs::click(id = "teal-main_ui-wunder_bar-show_snapshot_manager", asis = TRUE)
199		}
200		})
201
202		# Upload a snapshot file ----
203		# Select file.
204	4x	observeEvent(input$snapshot_load, {
205	!	logger::log_trace("snapshot_manager_srv: snapshot_load button clicked")
206	!	showModal(
207	!	modalDialog(
208	!	fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
209	!	textInput(
210	!	ns("snapshot_name"),
211	!	"Name the snapshot (optional)",
212	!	width = "100%",
213	!	placeholder = "Meaningful, unique name"
214		),
215	!	footer = tagList(
216	!	actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("thumbs-up")),
217	!	modalButton(label = "Cancel", icon = icon("thumbs-down"))
218		)
219		)
220		)
221		})
222		# Store new snapshot to list and restore filter states.
223	4x	observeEvent(input$snaphot_file_accept, {
224	!	logger::log_trace("snapshot_manager_srv: snapshot_file_accept button clicked")
225	!	snapshot_name <- trimws(input$snapshot_name)
226	!	if (identical(snapshot_name, "")) {
227	!	logger::log_trace("snapshot_manager_srv: no snapshot name provided, naming after file")
228	!	snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)
229		}
230	!	if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
231	!	logger::log_trace("snapshot_manager_srv: snapshot name rejected")
232	!	showNotification(
233	!	"This name is in conflict with other snapshot names. Please choose a different one.",
234	!	type = "message"
235		)
236	!	updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")
237		} else {
238		# Restore snapshot and verify app compatibility.
239	!	logger::log_trace("snapshot_manager_srv: snapshot name accepted, loading snapshot")
240	!	snapshot_state <- try(slices_restore(input$snapshot_file$datapath))
241	!	if (!inherits(snapshot_state, "modules_teal_slices")) {
242	!	logger::log_trace("snapshot_manager_srv: snapshot file corrupt")
243	!	showNotification(
244	!	"File appears to be corrupt.",
245	!	type = "error"
246		)
247	!	} else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) {
248	!	logger::log_trace("snapshot_manager_srv: snapshot not compatible with app")
249	!	showNotification(
250	!	"This snapshot file is not compatible with the app and cannot be loaded.",
251	!	type = "warning"
252		)
253		} else {
254		# Add to snapshot history.
255	!	logger::log_trace("snapshot_manager_srv: snapshot loaded, adding to history")
256	!	snapshot <- as.list(snapshot_state, recursive = TRUE)
257	!	snapshot_update <- c(snapshot_history(), list(snapshot))
258	!	names(snapshot_update)[length(snapshot_update)] <- snapshot_name
259	!	snapshot_history(snapshot_update)
260		### Begin simplified restore procedure. ###
261	!	logger::log_trace("snapshot_manager_srv: restoring snapshot")
262	!	mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(datasets))
263	!	mapply(
264	!	function(filtered_data, filter_ids) {
265	!	filtered_data$clear_filter_states(force = TRUE)
266	!	slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
267	!	filtered_data$set_filter_state(slices)
268		},
269	!	filtered_data = datasets,
270	!	filter_ids = mapping_unfolded
271		)
272	!	slices_global(snapshot_state)
273	!	removeModal()
274		### End simplified restore procedure. ###
275		}
276		}
277		})
278		# Apply newly added snapshot.
279
280		# Restore initial state ----
281	4x	observeEvent(input$snapshot_reset, {
282	!	logger::log_trace("snapshot_manager_srv: snapshot_reset button clicked, restoring snapshot")
283	!	s <- "Initial application state"
284		### Begin restore procedure. ###
285	!	snapshot <- snapshot_history()[[s]]
286	!	snapshot_state <- as.teal_slices(snapshot)
287	!	mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(datasets))
288	!	mapply(
289	!	function(filtered_data, filter_ids) {
290	!	filtered_data$clear_filter_states(force = TRUE)
291	!	slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
292	!	filtered_data$set_filter_state(slices)
293		},
294	!	filtered_data = datasets,
295	!	filter_ids = mapping_unfolded
296		)
297	!	slices_global(snapshot_state)
298	!	removeModal()
299		### End restore procedure. ###
300		})
301
302		# Build snapshot table ----
303		# Create UI elements and server logic for the snapshot table.
304		# Observers must be tracked to avoid duplication and excess reactivity.
305		# Remaining elements are tracked likewise for consistency and a slight speed margin.
306	4x	observers <- reactiveValues()
307	4x	handlers <- reactiveValues()
308	4x	divs <- reactiveValues()
309
310	4x	observeEvent(snapshot_history(), {
311	2x	logger::log_trace("snapshot_manager_srv: snapshot history modified, updating snapshot list")
312	2x	lapply(names(snapshot_history())[-1L], function(s) {
313	!	id_pickme <- sprintf("pickme_%s", make.names(s))
314	!	id_saveme <- sprintf("saveme_%s", make.names(s))
315	!	id_rowme <- sprintf("rowme_%s", make.names(s))
316
317		# Observer for restoring snapshot.
318	!	if (!is.element(id_pickme, names(observers))) {
319	!	observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
320		### Begin restore procedure. ###
321	!	snapshot <- snapshot_history()[[s]]
322	!	snapshot_state <- as.teal_slices(snapshot)
323	!	mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(datasets))
324	!	mapply(
325	!	function(filtered_data, filter_ids) {
326	!	filtered_data$clear_filter_states(force = TRUE)
327	!	slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)
328	!	filtered_data$set_filter_state(slices)
329		},
330	!	filtered_data = datasets,
331	!	filter_ids = mapping_unfolded
332		)
333	!	slices_global(snapshot_state)
334	!	removeModal()
335		### End restore procedure. ###
336		})
337		}
338		# Create handler for downloading snapshot.
339	!	if (!is.element(id_saveme, names(handlers))) {
340	!	output[[id_saveme]] <- downloadHandler(
341	!	filename = function() {
342	!	sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
343		},
344	!	content = function(file) {
345	!	snapshot <- snapshot_history()[[s]]
346	!	snapshot_state <- as.teal_slices(snapshot)
347	!	slices_store(tss = snapshot_state, file = file)
348		}
349		)
350	!	handlers[[id_saveme]] <- id_saveme
351		}
352		# Create a row for the snapshot table.
353	!	if (!is.element(id_rowme, names(divs))) {
354	!	divs[[id_rowme]] <- tags$div(
355	!	class = "manager_table_row",
356	!	tags$span(tags$h5(s)),
357	!	actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
358	!	downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
359		)
360		}
361		})
362		})
363
364		# Create table to display list of snapshots and their actions.
365	4x	output$snapshot_list <- renderUI({
366	2x	rows <- rev(reactiveValuesToList(divs))
367	2x	if (length(rows) == 0L) {
368	2x	tags$div(
369	2x	class = "manager_placeholder",
370	2x	"Snapshots will appear here."
371		)
372		} else {
373	!	rows
374		}
375		})
376
377	4x	snapshot_history
378		})
379		}
380
381		### utility functions ----
382
383		#' Explicitly enumerate global filters.
384		#'
385		#' Transform module mapping such that global filters are explicitly specified for every module.
386		#'
387		#' @param mapping (named `list`) as stored in mapping parameter of `teal_slices`
388		#' @param module_names (`character`) vector containing names of all modules in the app
389		#' @return A `named_list` with one element per module, each element containing all filters applied to that module.
390		#'
391		#' @keywords internal
392		#'
393		unfold_mapping <- function(mapping, module_names) {
394	!	module_names <- structure(module_names, names = module_names)
395	!	lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))
396		}
397
398		#' Convert mapping matrix to filter mapping specification.
399		#'
400		#' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,
401		#' to a list specification like the one used in the `mapping` attribute of `teal_slices`.
402		#' Global filters are gathered in one list element.
403		#' If a module has no active filters but the global ones, it will not be mentioned in the output.
404		#'
405		#' @param mapping_matrix (`data.frame`) of logical vectors where
406		#' columns represent modules and row represent `teal_slice`s
407		#' @return Named `list` like that in the `mapping` attribute of a `teal_slices` object.
408		#'
409		#' @keywords internal
410		#'
411		matrix_to_mapping <- function(mapping_matrix) {
412	!	mapping_matrix[] <- lapply(mapping_matrix, function(x) x \| is.na(x))
413	!	global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))
414	!	global_filters <- names(global[global])
415	!	local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]
416
417	!	mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))
418	!	Filter(function(x) length(x) != 0L, mapping)
419		}

1		# This is the main function from teal to be used by the end-users. Although it delegates
2		# directly to `module_teal_with_splash.R`, we keep it in a separate file because its documentation is quite large
3		# and it is very end-user oriented. It may also perform more argument checking with more informative
4		# error messages.
5
6		#' Create the server and UI function for the `shiny` app
7		#'
8		#' @description `r lifecycle::badge("stable")`
9		#'
10		#' End-users: This is the most important function for you to start a
11		#' `teal` app that is composed of `teal` modules.
12		#'
13		#' @details
14		#' When initializing the `teal` app, if `datanames` are not set for the `teal_data` object,
15		#' defaults from the `teal_data` environment will be used.
16		#'
17		#' @param data (`teal_data` or `teal_data_module`)
18		#' For constructing the data object, refer to [teal_data()] and [teal_data_module()].
19		#' @param modules (`list` or `teal_modules` or `teal_module`)
20		#' nested list of `teal_modules` or `teal_module` objects or a single
21		#' `teal_modules` or `teal_module` object. These are the specific output modules which
22		#' will be displayed in the `teal` application. See [modules()] and [module()] for
23		#' more details.
24		#' @param filter (`teal_slices`)
25		#' Specifies the initial filter using [teal_slices()].
26		#' @param title (`shiny.tag` or `character(1)`)
27		#' The browser window title. Defaults to a title "teal app" with the icon of NEST.
28		#' Can be created using the `build_app_title()` or
29		#' by passing a valid `shiny.tag` which is a head tag with title and link tag.
30		#' @param header (`shiny.tag` or `character(1)`)
31		#' The header of the app.
32		#' @param footer (`shiny.tag` or `character(1)`)
33		#' The footer of the app.
34		#' @param id (`character`) optional
35		#' string specifying the `shiny` module id in cases it is used as a `shiny` module
36		#' rather than a standalone `shiny` app. This is a legacy feature.
37		#'
38		#' @return Named list containing server and UI functions.
39		#'
40		#' @export
41		#'
42		#' @include modules.R
43		#'
44		#' @examples
45		#' app <- init(
46		#' data = teal_data(
47		#' new_iris = transform(iris, id = seq_len(nrow(iris))),
48		#' new_mtcars = transform(mtcars, id = seq_len(nrow(mtcars))),
49		#' code = "
50		#' new_iris <- transform(iris, id = seq_len(nrow(iris)))
51		#' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
52		#' "
53		#' ),
54		#' modules = modules(
55		#' module(
56		#' label = "data source",
57		#' server = function(input, output, session, data) {},
58		#' ui = function(id, ...) tags$div(p("information about data source")),
59		#' datanames = "all"
60		#' ),
61		#' example_module(label = "example teal module"),
62		#' module(
63		#' "Iris Sepal.Length histogram",
64		#' server = function(input, output, session, data) {
65		#' output$hist <- renderPlot(
66		#' hist(data()[["new_iris"]]$Sepal.Length)
67		#' )
68		#' },
69		#' ui = function(id, ...) {
70		#' ns <- NS(id)
71		#' plotOutput(ns("hist"))
72		#' },
73		#' datanames = "new_iris"
74		#' )
75		#' ),
76		#' filter = teal_slices(
77		#' teal_slice(dataname = "new_iris", varname = "Species"),
78		#' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),
79		#' teal_slice(dataname = "new_mtcars", varname = "cyl"),
80		#' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
81		#' module_specific = TRUE,
82		#' mapping = list(
83		#' `example teal module` = "new_iris Species",
84		#' `Iris Sepal.Length histogram` = "new_iris Species",
85		#' global_filters = "new_mtcars cyl"
86		#' )
87		#' ),
88		#' title = "App title",
89		#' header = tags$h1("Sample App"),
90		#' footer = tags$p("Copyright 2017 - 2023")
91		#' )
92		#' if (interactive()) {
93		#' shinyApp(app$ui, app$server)
94		#' }
95		#'
96		init <- function(data,
97		modules,
98		filter = teal_slices(),
99		title = build_app_title(),
100		header = tags$p(),
101		footer = tags$p(),
102		id = character(0)) {
103	10x	logger::log_trace("init initializing teal app with: data ('{ class(data) }').")
104
105		# argument checking (independent)
106		## `data`
107	10x	if (inherits(data, "TealData")) {
108	!	lifecycle::deprecate_stop(
109	!	when = "0.15.0",
110	!	what = "init(data)",
111	!	paste(
112	!	"TealData is no longer supported. Use teal_data() instead.",
113	!	"Please follow migration instructions https://github.com/insightsengineering/teal/discussions/988."
114		)
115		)
116		}
117	10x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
118
119		## `modules`
120	10x	checkmate::assert(
121	10x	.var.name = "modules",
122	10x	checkmate::check_multi_class(modules, c("teal_modules", "teal_module")),
123	10x	checkmate::check_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
124		)
125	10x	if (inherits(modules, "teal_module")) {
126	1x	modules <- list(modules)
127		}
128	10x	if (checkmate::test_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))) {
129	4x	modules <- do.call(teal::modules, modules)
130		}
131
132		## `filter`
133	10x	checkmate::assert_class(filter, "teal_slices")
134
135		## all other arguments
136	9x	checkmate::assert(
137	9x	.var.name = "title",
138	9x	checkmate::check_string(title),
139	9x	checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
140		)
141	9x	checkmate::assert(
142	9x	.var.name = "header",
143	9x	checkmate::check_string(header),
144	9x	checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
145		)
146	9x	checkmate::assert(
147	9x	.var.name = "footer",
148	9x	checkmate::check_string(footer),
149	9x	checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
150		)
151	9x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
152
153		# log
154	9x	teal.logger::log_system_info()
155
156		# argument transformations
157		## `modules` - landing module
158	9x	landing <- extract_module(modules, "teal_module_landing")
159	9x	landing_module <- NULL
160	9x	if (length(landing) == 1L) {
161	!	landing_module <- landing[[1L]]
162	!	modules <- drop_module(modules, "teal_module_landing")
163	9x	} else if (length(landing) > 1L) {
164	!	stop("Only one `landing_popup_module` can be used.")
165		}
166
167		## `filter` - set app_id attribute unless present (when restoring bookmark)
168	9x	if (is.null(attr(filter, "app_id", exact = TRUE))) attr(filter, "app_id") <- create_app_id(data, modules)
169
170		## `filter` - convert teal.slice::teal_slices to teal::teal_slices
171	9x	filter <- as.teal_slices(as.list(filter))
172
173		# argument checking (interdependent)
174		## `filter` - `modules`
175	9x	if (isTRUE(attr(filter, "module_specific"))) {
176	!	module_names <- unlist(c(module_labels(modules), "global_filters"))
177	!	failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)
178	!	if (length(failed_mod_names)) {
179	!	stop(
180	!	sprintf(
181	!	"Some module names in the mapping arguments don't match module labels.\n %s not in %s",
182	!	toString(failed_mod_names),
183	!	toString(unique(module_names))
184		)
185		)
186		}
187
188	!	if (anyDuplicated(module_names)) {
189		# In teal we are able to set nested modules with duplicated label.
190		# Because mapping argument bases on the relationship between module-label and filter-id,
191		# it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)
192	!	stop(
193	!	sprintf(
194	!	"Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",
195	!	toString(module_names[duplicated(module_names)])
196		)
197		)
198		}
199		}
200
201		## `data` - `modules`
202	9x	if (inherits(data, "teal_data")) {
203	8x	if (length(teal_data_datanames(data)) == 0) {
204	1x	stop("The environment of `data` is empty.")
205		}
206		# in case of teal_data_module this check is postponed to the srv_teal_with_splash
207	7x	is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))
208	7x	if (!isTRUE(is_modules_ok)) {
209	1x	logger::log_error(is_modules_ok)
210	1x	checkmate::assert(is_modules_ok, .var.name = "modules")
211		}
212
213	6x	is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))
214	6x	if (!isTRUE(is_filter_ok)) {
215	1x	warning(is_filter_ok)
216		# we allow app to continue if applied filters are outside
217		# of possible data range
218		}
219		}
220
221		# Note regarding case `id = character(0)`:
222		# rather than creating a submodule of this module, we directly modify
223		# the UI and server with `id = character(0)` and calling the server function directly
224		# Note: UI must be a function to support bookmarking.
225	7x	res <- list(
226	7x	ui = function(request) ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
227	7x	server = function(input, output, session) {
228	!	if (!is.null(landing_module)) {
229	!	do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args))
230		}
231	!	srv_teal_with_splash(id = id, data = data, modules = modules, filter = deep_copy_filter(filter))
232		}
233		)
234
235	7x	logger::log_trace("init teal app has been initialized.")
236
237	7x	res
238		}

1		#' Create a `tdata` object
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#'
5		#' Create a new object called `tdata` which contains `data`, a `reactive` list of `data.frames`
6		#' (or `MultiAssayExperiment`), with attributes:
7		#' - `code` (`reactive`) containing code used to generate the data
8		#' - join_keys (`join_keys`) containing the relationships between the data
9		#' - metadata (named `list`) containing any metadata associated with the data frames
10		#'
11		#' @name tdata
12		#' @param data (named `list`) A list of `data.frame` or `MultiAssayExperiment` objects,
13		#' which optionally can be `reactive`.
14		#' Inside this object all of these items will be made `reactive`.
15		#' @param code (`character` or `reactive` which evaluates to a `character`) containing
16		#' the code used to generate the data. This should be `reactive` if the code is changing
17		#' during a reactive context (e.g. if filtering changes the code). Inside this
18		#' object `code` will be made reactive
19		#' @param join_keys (`teal.data::join_keys`) object containing relationships between the
20		#' datasets.
21		#' @param metadata (named `list`) each element contains a list of metadata about the named `data.frame`
22		#' Each element of these list should be atomic and length one.
23		#' @return A `tdata` object.
24		#'
25		#' @seealso `as_tdata`
26		#'
27		#' @examples
28		#'
29		#' data <- new_tdata(
30		#' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),
31		#' code = "iris <- iris
32		#' mtcars <- mtcars
33		#' dd <- data.frame(x = 1:10)",
34		#' metadata = list(dd = list(author = "NEST"), iris = list(version = 1))
35		#' )
36		#'
37		#' # Extract a data.frame
38		#' isolate(data[["iris"]]())
39		#'
40		#' # Get code
41		#' isolate(get_code_tdata(data))
42		#'
43		#' # Get metadata
44		#' get_metadata(data, "iris")
45		#'
46		#' @export
47		new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
48	34x	lifecycle::deprecate_soft(
49	34x	when = "0.15.0",
50	34x	what = "tdata()",
51	34x	details = paste(
52	34x	"tdata is deprecated and will be removed in the next release. Use `teal_data` instead.\n",
53	34x	"Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."
54		)
55		)
56	34x	checkmate::assert_list(
57	34x	data,
58	34x	any.missing = FALSE, names = "unique",
59	34x	types = c("data.frame", "reactive", "MultiAssayExperiment")
60		)
61	30x	checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)
62	29x	checkmate::assert_multi_class(code, c("character", "reactive"))
63
64	28x	checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)
65	26x	checkmate::assert_subset(names(metadata), names(data))
66
67	25x	if (is.reactive(code)) {
68	9x	isolate(checkmate::assert_class(code(), "character", .var.name = "code"))
69		}
70
71		# create reactive data.frames
72	24x	for (x in names(data)) {
73	47x	if (!is.reactive(data[[x]])) {
74	31x	data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))
75		}
76		}
77
78		# set attributes
79	24x	attr(data, "code") <- if (is.reactive(code)) code else reactive(code)
80	24x	attr(data, "join_keys") <- join_keys
81	24x	attr(data, "metadata") <- metadata
82
83		# set class
84	24x	class(data) <- c("tdata", class(data))
85	24x	data
86		}
87
88		#' Function to convert a `tdata` object to an `environment`
89		#'
90		#' Any `reactive` expressions inside `tdata` are evaluated first.
91		#' @param data (`tdata`) object
92		#' @return An `environment`.
93		#' @examples
94		#'
95		#' data <- new_tdata(
96		#' data = list(iris = iris, mtcars = reactive(mtcars)),
97		#' code = "iris <- iris
98		#' mtcars = mtcars"
99		#' )
100		#'
101		#' my_env <- isolate(tdata2env(data))
102		#'
103		#' @export
104		tdata2env <- function(data) {
105	2x	checkmate::assert_class(data, "tdata")
106	1x	list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))
107		}
108
109
110		#' Wrapper for `get_code.tdata`
111		#'
112		#' This wrapper is to be used by downstream packages to extract the code of a `tdata` object.
113		#'
114		#' @param data (`tdata`) object
115		#'
116		#' @return (`character`) code used in the `tdata` object.
117		#' @export
118		get_code_tdata <- function(data) {
119	7x	checkmate::assert_class(data, "tdata")
120	5x	attr(data, "code")()
121		}
122
123		#' Extract `join_keys` from `tdata`
124		#' @param data (`tdata`) object
125		#' @param ... Additional arguments (not used)
126		#' @export
127		join_keys.tdata <- function(data, ...) {
128	2x	attr(data, "join_keys")
129		}
130
131		#' Function to get metadata from a `tdata` object
132		#' @param data (`tdata` - object) to extract the data from
133		#' @param dataname (`character(1)`) the dataset name whose metadata is requested
134		#' @return Either list of metadata or NULL if no metadata.
135		#' @export
136		get_metadata <- function(data, dataname) {
137	4x	checkmate::assert_string(dataname)
138	4x	UseMethod("get_metadata", data)
139		}
140
141		#' @rdname get_metadata
142		#' @export
143		get_metadata.tdata <- function(data, dataname) {
144	4x	metadata <- attr(data, "metadata")
145	4x	if (is.null(metadata)) {
146	1x	return(NULL)
147		}
148	3x	metadata[[dataname]]
149		}
150
151		#' @rdname get_metadata
152		#' @export
153		get_metadata.default <- function(data, dataname) {
154	!	stop("get_metadata function not implemented for this object")
155		}
156
157
158		#' Downgrade `teal_data` objects in modules for compatibility
159		#'
160		#' Convert `teal_data` to `tdata` in `teal` modules.
161		#'
162		#' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object
163		#' to be passed to the `data` argument but instead they receive a `teal_data` object,
164		#' which is additionally wrapped in a reactive expression in the server functions.
165		#' In order to easily adapt such modules without a proper refactor,
166		#' use this function to downgrade the `data` argument.
167		#'
168		#' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression
169		#'
170		#' @return Object of class `tdata`.
171		#'
172		#' @examples
173		#' td <- teal_data()
174		#' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars)
175		#' td
176		#' as_tdata(td)
177		#' as_tdata(reactive(td))
178		#'
179		#' @export
180		#' @rdname tdata_deprecation
181		#'
182		as_tdata <- function(x) {
183	8x	if (inherits(x, "tdata")) {
184	2x	return(x)
185		}
186	6x	if (is.reactive(x)) {
187	1x	checkmate::assert_class(isolate(x()), "teal_data")
188	1x	datanames <- isolate(teal_data_datanames(x()))
189	1x	datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)
190	1x	code <- reactive(teal.code::get_code(x()))
191	1x	join_keys <- isolate(teal.data::join_keys(x()))
192	5x	} else if (inherits(x, "teal_data")) {
193	5x	datanames <- teal_data_datanames(x)
194	5x	datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)
195	5x	code <- reactive(teal.code::get_code(x))
196	5x	join_keys <- isolate(teal.data::join_keys(x))
197		}
198
199	6x	new_tdata(data = datasets, code = code, join_keys = join_keys)
200		}

1		#' Add right filter panel into each of the top-level `teal_modules` UIs
2		#'
3		#' The [ui_nested_tabs] function returns a nested tabbed UI corresponding
4		#' to the nested modules.
5		#' This function adds the right filter panel to each main tab.
6		#'
7		#' The right filter panel's filter choices affect the `datasets` object. Therefore,
8		#' all modules using the same `datasets` share the same filters.
9		#'
10		#' This works with nested modules of depth greater than 2, though the filter
11		#' panel is inserted at the right of the modules at depth 1 and not at the leaves.
12		#'
13		#' @name module_tabs_with_filters
14		#'
15		#' @inheritParams module_teal
16		#'
17		#' @param datasets (named `list` of `FilteredData`)
18		#' object to store filter state and filtered datasets, shared across modules. For more
19		#' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure
20		#' of the `modules` argument and list names must correspond to the labels in `modules`.
21		#' When filter is not module-specific then list contains the same object in all elements.
22		#' @param reporter (`Reporter`) object from `teal.reporter`
23		#'
24		#' @return
25		#' A `shiny.tag.list` containing the main menu, placeholders for filters and placeholders for the `teal` modules.
26		#'
27		#' @keywords internal
28		#'
29		NULL
30
31		#' @rdname module_tabs_with_filters
32		ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
33	!	checkmate::assert_class(modules, "teal_modules")
34	!	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
35	!	checkmate::assert_class(filter, "teal_slices")
36
37	!	ns <- NS(id)
38	!	is_module_specific <- isTRUE(attr(filter, "module_specific"))
39
40	!	teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
41	!	filter_panel_btns <- tags$li(
42	!	class = "flex-grow",
43	!	tags$button(
44	!	class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger
45	!	href = "javascript:void(0)",
46	!	onclick = "toggleFilterPanel();", # see sidebar.js
47	!	title = "Toggle filter panel",
48	!	icon("fas fa-bars")
49		),
50	!	wunder_bar_ui(ns("wunder_bar"))
51		)
52	!	teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)
53
54	!	if (!is_module_specific) {
55		# need to rearrange html so that filter panel is within tabset
56	!	tabset_bar <- teal_ui$children[[1]]
57	!	teal_modules <- teal_ui$children[[2]]
58	!	filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
59	!	list(
60	!	tabset_bar,
61	!	tags$hr(class = "my-2"),
62	!	fluidRow(
63	!	column(width = 9, teal_modules, class = "teal_primary_col"),
64	!	column(width = 3, filter_ui, class = "teal_secondary_col")
65		)
66		)
67		} else {
68	!	teal_ui
69		}
70		}
71
72		#' @rdname module_tabs_with_filters
73		srv_tabs_with_filters <- function(id,
74		datasets,
75		modules,
76		reporter = teal.reporter::Reporter$new(),
77		filter = teal_slices()) {
78	5x	checkmate::assert_class(modules, "teal_modules")
79	5x	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
80	5x	checkmate::assert_class(reporter, "Reporter")
81	3x	checkmate::assert_class(filter, "teal_slices")
82
83	3x	moduleServer(id, function(input, output, session) {
84	3x	logger::log_trace("srv_tabs_with_filters initializing the module.")
85
86	3x	is_module_specific <- isTRUE(attr(filter, "module_specific"))
87	3x	wunder_bar_out <- wunder_bar_srv("wunder_bar", datasets, filter, modules)
88
89	3x	active_module <- srv_nested_tabs(
90	3x	id = "root",
91	3x	datasets = datasets,
92	3x	modules = modules,
93	3x	reporter = reporter,
94	3x	is_module_specific = is_module_specific
95		)
96
97	3x	if (!is_module_specific) {
98	3x	active_datanames <- reactive({
99	6x	if (identical(active_module()$datanames, "all")) {
100	!	singleton$datanames()
101		} else {
102	5x	include_parent_datanames(
103	5x	active_module()$datanames,
104	5x	singleton$get_join_keys()
105		)
106		}
107		})
108	3x	singleton <- unlist(datasets)[[1]]
109	3x	singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
110
111	3x	observeEvent(
112	3x	eventExpr = active_datanames(),
113	3x	handlerExpr = {
114	4x	script <- if (length(active_datanames()) == 0 \|\| is.null(active_datanames())) {
115		# hide the filter panel and disable the burger button
116	!	"handleNoActiveDatasets();"
117		} else {
118		# show the filter panel and enable the burger button
119	4x	"handleActiveDatasetsPresent();"
120		}
121	4x	shinyjs::runjs(script)
122		},
123	3x	ignoreNULL = FALSE
124		)
125		}
126
127	3x	showNotification("Data loaded - App fully started up")
128	3x	logger::log_trace("srv_tabs_with_filters initialized the module")
129
130	3x	active_module
131		})
132		}

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

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

1		#' 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 (`shiny`) input variable accessible with `input$tz` which is a (`character`)
10		#' string containing the timezone of the browser/client.
11		#'
12		#' @keywords internal
13		#'
14		get_client_timezone <- function(ns) {
15	18x	script <- sprintf(
16	18x	"Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",
17	18x	ns("timezone")
18		)
19	18x	shinyjs::runjs(script) # function does not return anything
20	18x	invisible(NULL)
21		}
22
23		#' Resolve the expected bootstrap theme
24		#' @noRd
25		#' @keywords internal
26		get_teal_bs_theme <- function() {
27	4x	bs_theme <- getOption("teal.bs_theme")
28	4x	if (is.null(bs_theme)) {
29	1x	NULL
30	3x	} else if (!inherits(bs_theme, "bs_theme")) {
31	2x	warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
32	2x	NULL
33		} else {
34	1x	bs_theme
35		}
36		}
37
38		#' Return parentnames along with datanames.
39		#' @noRd
40		#' @keywords internal
41		include_parent_datanames <- function(dataname, join_keys) {
42	15x	parents <- character(0)
43	15x	for (i in dataname) {
44	22x	while (length(i) > 0) {
45	24x	parent_i <- teal.data::parent(join_keys, i)
46	24x	parents <- c(parent_i, parents)
47	24x	i <- parent_i
48		}
49		}
50
51	15x	unique(c(parents, dataname))
52		}
53
54		#' Create a `FilteredData`
55		#'
56		#' Create a `FilteredData` object from a `teal_data` object.
57		#'
58		#' @param x (`teal_data`) object
59		#' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)`
60		#' @return A `FilteredData` object.
61		#' @keywords internal
62		teal_data_to_filtered_data <- function(x, datanames = teal_data_datanames(x)) {
63	18x	checkmate::assert_class(x, "teal_data")
64	18x	checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)
65
66	18x	ans <- teal.slice::init_filtered_data(
67	18x	x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE),
68	18x	join_keys = teal.data::join_keys(x)
69		)
70		# Piggy-back pre-processing code for datasets of interest so that filtering code can be appended later.
71	18x	attr(ans, "preprocessing_code") <- teal.data::get_code(x, datanames = datanames, check_names = FALSE)
72	18x	attr(ans, "verification_status") <- x@verified
73	18x	ans
74		}
75
76		#' Template function for `TealReportCard` creation and customization
77		#'
78		#' This function generates a report card with a title,
79		#' an optional description, and the option to append the filter state list.
80		#'
81		#' @param title (`character(1)`) title of the card (unless overwritten by label)
82		#' @param label (`character(1)`) label provided by the user when adding the card
83		#' @param description (`character(1)`) optional, additional description
84		#' @param with_filter (`logical(1)`) flag indicating to add filter state
85		#' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation
86		#' of the filter state in the report
87		#'
88		#' @return (`TealReportCard`) populated with a title, description and filter state.
89		#'
90		#' @export
91		report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
92	2x	checkmate::assert_string(title)
93	2x	checkmate::assert_string(label)
94	2x	checkmate::assert_string(description, null.ok = TRUE)
95	2x	checkmate::assert_flag(with_filter)
96	2x	checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")
97
98	2x	card <- teal::TealReportCard$new()
99	2x	title <- if (label == "") title else label
100	2x	card$set_name(title)
101	2x	card$append_text(title, "header2")
102	1x	if (!is.null(description)) card$append_text(description, "header3")
103	1x	if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
104	2x	card
105		}
106
107
108		#' Check `datanames` in modules
109		#'
110		#' This function ensures specified `datanames` in modules match those in the data object,
111		#' returning error messages or `TRUE` for successful validation.
112		#'
113		#' @param modules (`teal_modules`) object
114		#' @param datanames (`character`) names of datasets available in the `data` object
115		#'
116		#' @return A `character(1)` containing error message or `TRUE` if validation passes.
117		#' @keywords internal
118		check_modules_datanames <- function(modules, datanames) {
119	12x	checkmate::assert_class(modules, "teal_modules")
120	12x	checkmate::assert_character(datanames)
121
122	12x	recursive_check_datanames <- function(modules, datanames) {
123		# check teal_modules against datanames
124	26x	if (inherits(modules, "teal_modules")) {
125	12x	sapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))
126		} else {
127	14x	extra_datanames <- setdiff(modules$datanames, c("all", datanames))
128	14x	if (length(extra_datanames)) {
129	2x	sprintf(
130	2x	"- Module '%s' uses datanames not available in 'data': (%s) not in (%s)",
131	2x	modules$label,
132	2x	toString(dQuote(extra_datanames, q = FALSE)),
133	2x	toString(dQuote(datanames, q = FALSE))
134		)
135		}
136		}
137		}
138	12x	check_datanames <- unlist(recursive_check_datanames(modules, datanames))
139	12x	if (length(check_datanames)) {
140	2x	paste(check_datanames, collapse = "\n")
141		} else {
142	10x	TRUE
143		}
144		}
145
146		#' Check `datanames` in filters
147		#'
148		#' This function checks whether `datanames` in filters correspond to those in `data`,
149		#' returning character vector with error messages or `TRUE` if all checks pass.
150		#'
151		#' @param filters (`teal_slices`) object
152		#' @param datanames (`character`) names of datasets available in the `data` object
153		#'
154		#' @return A `character(1)` containing error message or TRUE if validation passes.
155		#' @keywords internal
156		check_filter_datanames <- function(filters, datanames) {
157	10x	checkmate::assert_class(filters, "teal_slices")
158	10x	checkmate::assert_character(datanames)
159
160		# check teal_slices against datanames
161	10x	out <- unlist(sapply(
162	10x	filters, function(filter) {
163	3x	dataname <- shiny::isolate(filter$dataname)
164	3x	if (!dataname %in% datanames) {
165	2x	sprintf(
166	2x	"- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)",
167	2x	shiny::isolate(filter$id),
168	2x	dQuote(dataname, q = FALSE),
169	2x	toString(dQuote(datanames, q = FALSE))
170		)
171		}
172		}
173		))
174
175
176	10x	if (length(out)) {
177	2x	paste(out, collapse = "\n")
178		} else {
179	8x	TRUE
180		}
181		}
182
183
184		#' Create filterable data for modules
185		#'
186		#' Converts input data to a `FilteredData` object(s) to allow filtering before passing data to individual modules.
187		#'
188		#' @param data (`teal_data`)
189		#' @param modules (`teal_modules`) object
190		#' @param filters (`teal_slices`) object
191		#' @param filtered_data_singleton A result of `teal_data_to_filtered_data` applied to `data`.
192		#' @return Returns list of same shape as `modules`, containing `FilteredData` at every leaf.
193		#' If module specific, each leaf contains different instance, otherwise every leaf contains `filtered_data_singleton`.
194		#' @keywords internal
195		modules_datasets <- function(data, modules, filters, filtered_data_singleton = teal_data_to_filtered_data(data)) {
196	15x	checkmate::assert_class(data, "teal_data")
197	15x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
198	15x	checkmate::assert_class(filters, "modules_teal_slices")
199	15x	checkmate::assert_r6(filtered_data_singleton, "FilteredData")
200
201	15x	if (!isTRUE(attr(filters, "module_specific"))) {
202		# subset global filters
203	3x	slices <- shiny::isolate({
204	3x	Filter(function(x) x$id %in% attr(filters, "mapping")$global_filters, filters)
205		})
206	3x	filtered_data_singleton$set_filter_state(slices)
207	3x	return(modules_structure(modules, filtered_data_singleton))
208		}
209
210	12x	if (inherits(modules, "teal_module")) {
211		# 1. get datanames
212	7x	datanames <-
213	7x	if (is.null(modules$datanames) \|\| identical(modules$datanames, "all")) {
214	4x	include_parent_datanames(
215	4x	teal_data_datanames(data),
216	4x	teal.data::join_keys(data)
217		)
218		} else {
219	3x	include_parent_datanames(
220	3x	modules$datanames,
221	3x	teal.data::join_keys(data)
222		)
223		}
224		# 2. subset filters (global + dedicated)
225	7x	slices <- shiny::isolate({
226	7x	Filter(x = filters, f = function(x) {
227	20x	x$dataname %in% datanames &&
228	20x	(x$id %in% attr(filters, "mapping")$global_filters \|\|
229	20x	x$id %in% unique(unlist(attr(filters, "mapping")[modules$label]))) # nolint: indentation_linter.
230		})
231		})
232		# 2a. subset include/exclude varnames
233	7x	slices$include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]
234	7x	slices$exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]
235
236		# 3. instantiate FilteredData
237	7x	filtered_data <- teal_data_to_filtered_data(data, datanames)
238		# 4. set state
239	7x	filtered_data$set_filter_state(slices)
240		# 5. return
241	7x	return(filtered_data)
242	5x	} else if (inherits(modules, "teal_modules")) {
243	5x	ans <- lapply(
244	5x	modules$children,
245	5x	modules_datasets,
246	5x	data = data,
247	5x	filters = filters,
248	5x	filtered_data_singleton = filtered_data_singleton
249		)
250	5x	names(ans) <- vapply(modules$children, `[[`, character(1), "label")
251
252	5x	return(ans)
253		}
254
255	!	stop("something is not right")
256		}
257
258		# Returns nested list of same shape as `modules` with `value` at every leaf.
259		modules_structure <- function(modules, value = TRUE) {
260	13x	if (inherits(modules, "teal_module")) {
261	8x	return(value)
262		} else {
263	5x	stats::setNames(
264	5x	lapply(modules$children, modules_structure, value),
265	5x	vapply(modules$children, `[[`, character(1), "label")
266		)
267		}
268		}
269
270		#' Wrapper on `teal.data::datanames`
271		#'
272		#' Special function used in internals of `teal` to return names of datasets even if `datanames`
273		#' has not been set.
274		#' @param data (`teal_data`)
275		#' @return `character`
276		#' @keywords internal
277		teal_data_datanames <- function(data) {
278	53x	checkmate::assert_class(data, "teal_data")
279	53x	if (length(teal.data::datanames(data))) {
280	47x	teal.data::datanames(data)
281		} else {
282	6x	ls(teal.code::get_env(data), all.names = TRUE)
283		}
284		}
285
286		#' Function for validating the title parameter of `teal::init`
287		#'
288		#' Checks if the input of the title from `teal::init` will create a valid title and favicon tag.
289		#' @param shiny_tag (`shiny.tag`) Object to validate for a valid title.
290		#' @keywords internal
291		validate_app_title_tag <- function(shiny_tag) {
292	7x	checkmate::assert_class(shiny_tag, "shiny.tag")
293	7x	checkmate::assert_true(shiny_tag$name == "head")
294	6x	child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name")
295	6x	checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags")
296	4x	rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel
297	4x	checkmate::assert_subset(
298	4x	rel_attr,
299	4x	c("icon", "shortcut icon"),
300	4x	.var.name = "Link tag's rel attribute",
301	4x	empty.ok = FALSE
302		)
303		}
304
305		#' Build app title with favicon
306		#'
307		#' A helper function to create the browser title along with a logo.
308		#'
309		#' @param title (`character`) The browser title for the `teal` app.
310		#' @param favicon (`character`) The path for the icon for the title.
311		#' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/`
312		#'
313		#' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app.
314		#' @export
315		build_app_title <- function(
316		title = "teal app",
317		favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
318	11x	checkmate::assert_string(title, null.ok = TRUE)
319	11x	checkmate::assert_string(favicon, null.ok = TRUE)
320	11x	tags$head(
321	11x	tags$title(title),
322	11x	tags$link(
323	11x	rel = "icon",
324	11x	href = favicon,
325	11x	sizes = "any"
326		)
327		)
328		}
329
330		#' Application ID
331		#'
332		#' Creates App ID used to match filter snapshots to application.
333		#'
334		#' Calculate app ID that will be used to stamp filter state snapshots.
335		#' App ID is a hash of the app's data and modules.
336		#' See "transferring snapshots" section in ?snapshot.
337		#'
338		#' @param data (`teal_data` or `teal_data_module`) as accepted by `init`
339		#' @param modules (`teal_modules`) object as accepted by `init`
340		#'
341		#' @return A single character string.
342		#'
343		#' @keywords internal
344		create_app_id <- function(data, modules) {
345	19x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
346	18x	checkmate::assert_class(modules, "teal_modules")
347
348	17x	data <- if (inherits(data, "teal_data")) {
349	15x	as.list(data@env)
350	17x	} else if (inherits(data, "teal_data_module")) {
351	2x	deparse1(body(data$server))
352		}
353	17x	modules <- lapply(modules, defunction)
354
355	17x	rlang::hash(list(data = data, modules = modules))
356		}
357
358		#' Go through list and extract bodies of encountered functions as string, recursively.
359		#' @keywords internal
360		#' @noRd
361		defunction <- function(x) {
362	186x	if (is.list(x)) {
363	40x	lapply(x, defunction)
364	146x	} else if (is.function(x)) {
365	44x	deparse1(body(x))
366		} else {
367	102x	x
368		}
369		}
370
371		#' Get unique labels
372		#'
373		#' Get unique labels for the modules to avoid namespace conflicts.
374		#'
375		#' @param labels (`character`) vector of labels
376		#'
377		#' @return (`character`) vector of unique labels
378		#'
379		#' @keywords internal
380		get_unique_labels <- function(labels) {
381	99x	make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
382		}

1		#' Manager bar module
2		#'
3		#' Bar of buttons that open modal dialogs.
4		#'
5		#' Creates a bar of buttons that open modal dialogs where manager modules reside.
6		#' Currently contains three modules:
7		#' - [`module_filter_manager`]
8		#' - [`module_snapshot_manager`]
9		#' - [`module_bookmark_manager`]
10		#'
11		#' The bar is placed in the `teal` app UI, next to the filter panel hamburger.
12		#'
13		#' @name module_wunder_bar
14		#' @aliases wunder_bar wunder_bar_module
15		#'
16		#' @inheritParams module_tabs_with_filters
17		#'
18		#' @return Nothing is returned.
19
20		#' @rdname module_wunder_bar
21		#' @keywords internal
22		wunder_bar_ui <- function(id) {
23	!	ns <- NS(id)
24	!	rev(
25	!	tagList(
26	!	title = "",
27	!	tags$button(
28	!	id = ns("show_filter_manager"),
29	!	class = "btn action-button wunder_bar_button",
30	!	title = "View filter mapping",
31	!	suppressMessages(icon("solid fa-grip"))
32		),
33	!	tags$button(
34	!	id = ns("show_snapshot_manager"),
35	!	class = "btn action-button wunder_bar_button",
36	!	title = "Manage filter state snapshots",
37	!	icon("camera")
38		),
39	!	bookmark_manager_ui(ns("bookmark_manager"))
40		)
41		)
42		}
43
44		#' @rdname module_wunder_bar
45		#' @keywords internal
46		wunder_bar_srv <- function(id, datasets, filter, modules) {
47	3x	moduleServer(id, function(input, output, session) {
48	3x	logger::log_trace("wunder_bar_srv initializing")
49
50	3x	setBookmarkExclude(c("show_filter_manager", "show_bookmark_manager", "show_bookmark_manager"))
51
52	3x	ns <- session$ns
53
54	3x	observeEvent(input$show_filter_manager, {
55	!	logger::log_trace("wunder_bar_srv@1 show_filter_manager button has been clicked.")
56	!	showModal(
57	!	modalDialog(
58	!	filter_manager_ui(ns("filter_manager")),
59	!	class = "filter_manager_modal",
60	!	size = "l",
61	!	footer = NULL,
62	!	easyClose = TRUE
63		)
64		)
65		})
66
67	3x	observeEvent(input$show_snapshot_manager, {
68	!	logger::log_trace("wunder_bar_srv@1 show_snapshot_manager button has been clicked.")
69	!	showModal(
70	!	modalDialog(
71	!	snapshot_manager_ui(ns("snapshot_manager")),
72	!	class = "snapshot_manager_modal",
73	!	size = "m",
74	!	footer = NULL,
75	!	easyClose = TRUE
76		)
77		)
78		})
79
80	3x	filter_manager_results <- filter_manager_srv(
81	3x	id = "filter_manager",
82	3x	datasets = datasets,
83	3x	filter = filter
84		)
85	3x	snapshot_history <- snapshot_manager_srv(
86	3x	id = "snapshot_manager",
87	3x	slices_global = filter_manager_results$slices_global,
88	3x	mapping_matrix = filter_manager_results$mapping_matrix,
89	3x	datasets = filter_manager_results$datasets_flat
90		)
91	3x	bookmark_manager_srv(id = "bookmark_manager", modules = modules)
92		})
93		}

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

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

1		#' Generates library calls from current session info
2		#'
3		#' Function to create multiple library calls out of current session info to ensure reproducible code works.
4		#'
5		#' @return Character vector of `library(<package>)` calls.
6		#' @keywords internal
7		get_rcode_libraries <- function() {
8	6x	vapply(
9	6x	utils::sessionInfo()$otherPkgs,
10	6x	function(x) {
11	48x	paste0("library(", x$Package, ")")
12		},
13	6x	character(1)
14		) %>%
15		# put it into reverse order to correctly simulate executed code
16	6x	rev() %>%
17	6x	paste0(sep = "\n") %>%
18	6x	paste0(collapse = "")
19		}
20
21		#' @noRd
22		#' @keywords internal
23		get_rcode_str_install <- function() {
24	10x	code_string <- getOption("teal.load_nest_code")
25	10x	if (is.character(code_string)) {
26	2x	code_string
27		} else {
28	8x	"# Add any code to install/load your NEST environment here\n"
29		}
30		}
31
32		#' Get datasets code
33		#'
34		#' Retrieve complete code to create, verify, and filter a dataset.
35		#'
36		#' @param datanames (`character`) names of datasets to extract code from
37		#' @param datasets (`FilteredData`) object
38		#' @param hashes named (`list`) of hashes per dataset
39		#'
40		#' @return Character string concatenated from the following elements:
41		#' - data pre-processing code (from `data` argument in `init`)
42		#' - hash check of loaded objects
43		#' - filter code (if any)
44		#'
45		#' @keywords internal
46		get_datasets_code <- function(datanames, datasets, hashes) {
47		# preprocessing code
48	4x	str_prepro <- attr(datasets, "preprocessing_code")
49	4x	if (length(str_prepro) == 0) {
50	!	str_prepro <- "message('Preprocessing is empty')"
51		} else {
52	4x	str_prepro <- paste(str_prepro, collapse = "\n")
53		}
54
55		# hash checks
56	4x	str_hash <- vapply(datanames, function(dataname) {
57	6x	sprintf(
58	6x	"stopifnot(%s == %s)",
59	6x	deparse1(bquote(rlang::hash(.(as.name(dataname))))),
60	6x	deparse1(hashes[[dataname]])
61		)
62	4x	}, character(1))
63	4x	str_hash <- paste(str_hash, collapse = "\n")
64
65		# filter expressions
66	4x	str_filter <- teal.slice::get_filter_expr(datasets, datanames)
67	4x	if (str_filter == "") {
68	2x	str_filter <- character(0)
69		}
70
71		# concatenate all code
72	4x	str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n")
73	4x	sprintf("%s\n", str_code)
74		}

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

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		#' An example `teal` module
2		#'
3		#' `r lifecycle::badge("experimental")`
4		#'
5		#' @inheritParams teal_modules
6		#' @return A `teal` module which can be included in the `modules` argument to [init()].
7		#' @examples
8		#' app <- init(
9		#' data = teal_data(IRIS = iris, MTCARS = mtcars),
10		#' modules = example_module()
11		#' )
12		#' if (interactive()) {
13		#' shinyApp(app$ui, app$server)
14		#' }
15		#' @export
16		example_module <- function(label = "example teal module", datanames = "all") {
17	53x	checkmate::assert_string(label)
18	53x	ans <- module(
19	53x	label,
20	53x	server = function(id, data) {
21	!	checkmate::assert_class(data(), "teal_data")
22	!	moduleServer(id, function(input, output, session) {
23	!	updateSelectInput(
24	!	inputId = "dataname",
25	!	choices = isolate(teal.data::datanames(data())),
26	!	selected = restoreInput(session$ns("dataname"), NULL)
27		)
28	!	output$text <- renderPrint({
29	!	req(input$dataname)
30	!	data()[[input$dataname]]
31		})
32	!	teal.widgets::verbatim_popup_srv(
33	!	id = "rcode",
34	!	verbatim_content = reactive(teal.code::get_code(data())),
35	!	title = "Example Code"
36		)
37		})
38		},
39	53x	ui = function(id) {
40	!	ns <- NS(id)
41	!	teal.widgets::standard_layout(
42	!	output = verbatimTextOutput(ns("text")),
43	!	encoding = tags$div(
44	!	selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
45	!	teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
46		)
47		)
48		},
49	53x	datanames = datanames
50		)
51	53x	attr(ans, "teal_bookmarkable") <- TRUE
52	53x	ans
53		}

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

1		#' Create `teal_module` and `teal_modules` objects
2		#'
3		#' @description
4		#' `r lifecycle::badge("stable")`
5		#'
6		#' Create a nested tab structure to embed modules in a `teal` application.
7		#'
8		#' @details
9		#' `module()` creates an instance of a `teal_module` that can be placed in a `teal` application.
10		#' `modules()` shapes the structure of a the application by organizing `teal_module` within the navigation panel.
11		#' It wraps `teal_module` and `teal_modules` objects in a `teal_modules` object,
12		#' which results in a nested structure corresponding to the nested tabs in the final application.
13		#'
14		#' Note that for `modules()` `label` comes after `...`, so it must be passed as a named argument,
15		#' otherwise it will be captured by `...`.
16		#'
17		#' The labels `"global_filters"` and `"Report previewer"` are reserved
18		#' because they are used by the `mapping` argument of [teal_slices()]
19		#' and the report previewer module [reporter_previewer_module()], respectively.
20		#'
21		#' @param label (`character(1)`) Label shown in the navigation item for the module or module group.
22		#' For `modules()` defaults to `"root"`. See `Details`.
23		#' @param server (`function`) `shiny` module with following arguments:
24		#' - `id` - `teal` will set proper `shiny` namespace for this module (see [shiny::moduleServer()]).
25		#' - `input`, `output`, `session` - (optional; not recommended) When provided, then [shiny::callModule()]
26		#' will be used to call a module. From `shiny` 1.5.0, the recommended way is to use
27		#' [shiny::moduleServer()] instead which doesn't require these arguments.
28		#' - `data` (optional) When provided, the module will be called with `teal_data` object (i.e. a list of
29		#' reactive (filtered) data specified in the `filters` argument) as the value of this argument.
30		#' - `datasets` (optional) When provided, the module will be called with `FilteredData` object as the
31		#' value of this argument. (See [`teal.slice::FilteredData`]).
32		#' - `reporter` (optional) When provided, the module will be called with `Reporter` object as the value
33		#' of this argument. (See [`teal.reporter::Reporter`]).
34		#' - `filter_panel_api` (optional) When provided, the module will be called with `FilterPanelAPI` object
35		#' as the value of this argument. (See [`teal.slice::FilterPanelAPI`]).
36		#' - `...` (optional) When provided, `server_args` elements will be passed to the module named argument
37		#' or to the `...`.
38		#' @param ui (`function`) `shiny` UI module function with following arguments:
39		#' - `id` - `teal` will set proper `shiny` namespace for this module.
40		#' - `...` (optional) When provided, `ui_args` elements will be passed to the module named argument
41		#' or to the `...`.
42		#' @param filters (`character`) Deprecated. Use `datanames` instead.
43		#' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The
44		#' filter panel will automatically update the shown filters to include only
45		#' filters in the listed datasets. `NULL` will hide the filter panel,
46		#' and the keyword `"all"` will show filters of all datasets. `datanames` also determines
47		#' a subset of datasets which are appended to the `data` argument in server function.
48		#' @param server_args (named `list`) with additional arguments passed on to the server function.
49		#' @param ui_args (named `list`) with additional arguments passed on to the UI function.
50		#' @param x (`teal_module` or `teal_modules`) Object to format/print.
51		#' @param indent (`integer(1)`) Indention level; each nested element is indented one level more.
52		#' @param ...
53		#' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab.
54		#' - For `format()` and `print()`: Arguments passed to other methods.
55		#'
56		#' @return
57		#' `module()` returns an object of class `teal_module`.
58		#'
59		#' `modules()` returns a `teal_modules` object which contains following fields:
60		#' - `label`: taken from the `label` argument.
61		#' - `children`: a list containing objects passed in `...`. List elements are named after
62		#' their `label` attribute converted to a valid `shiny` id.
63		#'
64		#' @name teal_modules
65		#' @aliases teal_module
66		#'
67		#' @examples
68		#' library(shiny)
69		#'
70		#' module_1 <- module(
71		#' label = "a module",
72		#' server = function(id, data) {
73		#' moduleServer(
74		#' id,
75		#' module = function(input, output, session) {
76		#' output$data <- renderDataTable(data()[["iris"]])
77		#' }
78		#' )
79		#' },
80		#' ui = function(id) {
81		#' ns <- NS(id)
82		#' tagList(dataTableOutput(ns("data")))
83		#' },
84		#' datanames = "all"
85		#' )
86		#'
87		#' module_2 <- module(
88		#' label = "another module",
89		#' server = function(id) {
90		#' moduleServer(
91		#' id,
92		#' module = function(input, output, session) {
93		#' output$text <- renderText("Another Module")
94		#' }
95		#' )
96		#' },
97		#' ui = function(id) {
98		#' ns <- NS(id)
99		#' tagList(textOutput(ns("text")))
100		#' },
101		#' datanames = NULL
102		#' )
103		#'
104		#' modules <- modules(
105		#' label = "modules",
106		#' modules(
107		#' label = "nested modules",
108		#' module_1
109		#' ),
110		#' module_2
111		#' )
112		#'
113		#' app <- init(
114		#' data = teal_data(iris = iris),
115		#' modules = modules
116		#' )
117		#'
118		#' if (interactive()) {
119		#' shinyApp(app$ui, app$server)
120		#' }
121
122		#' @rdname teal_modules
123		#' @export
124		#'
125		module <- function(label = "module",
126		server = function(id, ...) {
127	!	moduleServer(id, function(input, output, session) {})
128		},
129		ui = function(id, ...) {
130	!	tags$p(paste0("This module has no UI (id: ", id, " )"))
131		},
132		filters,
133		datanames = "all",
134		server_args = NULL,
135		ui_args = NULL) {
136		# argument checking (independent)
137		## `label`
138	147x	checkmate::assert_string(label)
139	144x	if (label == "global_filters") {
140	1x	stop(
141	1x	sprintf("module(label = \"%s\", ...\n ", label),
142	1x	"Label 'global_filters' is reserved in teal. Please change to something else.",
143	1x	call. = FALSE
144		)
145		}
146	143x	if (label == "Report previewer") {
147	!	stop(
148	!	sprintf("module(label = \"%s\", ...\n ", label),
149	!	"Label 'Report previewer' is reserved in teal. Please change to something else.",
150	!	call. = FALSE
151		)
152		}
153
154		## server
155	143x	checkmate::assert_function(server)
156	143x	server_formals <- names(formals(server))
157	143x	if (!(
158	143x	"id" %in% server_formals \|\|
159	143x	all(c("input", "output", "session") %in% server_formals)
160		)) {
161	2x	stop(
162	2x	"\nmodule() `server` argument requires a function with following arguments:",
163	2x	"\n - id - `teal` will set proper `shiny` namespace for this module.",
164	2x	"\n - input, output, session (not recommended) - then `shiny::callModule` will be used to call a module.",
165	2x	"\n\nFollowing arguments can be used optionaly:",
166	2x	"\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",
167	2x	"\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",
168	2x	"\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",
169	2x	"\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",
170	2x	"\n - `...` server_args elements will be passed to the module named argument or to the `...`"
171		)
172		}
173	141x	if ("datasets" %in% server_formals) {
174	2x	warning(
175	2x	sprintf("Called from module(label = \"%s\", ...)\n ", label),
176	2x	"`datasets` argument in the server is deprecated and will be removed in the next release. ",
177	2x	"Please use `data` instead.",
178	2x	call. = FALSE
179		)
180		}
181
182
183		## UI
184	141x	checkmate::assert_function(ui)
185	141x	ui_formals <- names(formals(ui))
186	141x	if (!"id" %in% ui_formals) {
187	1x	stop(
188	1x	"\nmodule() `ui` argument requires a function with following arguments:",
189	1x	"\n - id - `teal` will set proper `shiny` namespace for this module.",
190	1x	"\n\nFollowing arguments can be used optionally:",
191	1x	"\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"
192		)
193		}
194	140x	if (any(c("data", "datasets") %in% ui_formals)) {
195	2x	stop(
196	2x	sprintf("Called from module(label = \"%s\", ...)\n ", label),
197	2x	"UI with `data` or `datasets` argument is no longer accepted.\n ",
198	2x	"If some UI inputs depend on data, please move the logic to your server instead.\n ",
199	2x	"Possible solutions are renderUI() or updateXyzInput() functions."
200		)
201		}
202
203
204		## `filters`
205	138x	if (!missing(filters)) {
206	!	datanames <- filters
207	!	msg <-
208	!	"The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."
209	!	warning(msg)
210		}
211
212		## `datanames` (also including deprecated `filters`)
213		# please note a race condition between datanames set when filters is not missing and data arg in server function
214	138x	if (!is.element("data", server_formals) && !is.null(datanames)) {
215	50x	message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
216	50x	datanames <- NULL
217		}
218	138x	checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)
219
220		## `server_args`
221	137x	checkmate::assert_list(server_args, null.ok = TRUE, names = "named")
222	135x	srv_extra_args <- setdiff(names(server_args), server_formals)
223	135x	if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
224	1x	stop(
225	1x	"\nFollowing `server_args` elements have no equivalent in the formals of the server:\n",
226	1x	paste(paste(" -", srv_extra_args), collapse = "\n"),
227	1x	"\n\nUpdate the server arguments by including above or add `...`"
228		)
229		}
230
231		## `ui_args`
232	134x	checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")
233	132x	ui_extra_args <- setdiff(names(ui_args), ui_formals)
234	132x	if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
235	1x	stop(
236	1x	"\nFollowing `ui_args` elements have no equivalent in the formals of UI:\n",
237	1x	paste(paste(" -", ui_extra_args), collapse = "\n"),
238	1x	"\n\nUpdate the UI arguments by including above or add `...`"
239		)
240		}
241
242	131x	structure(
243	131x	list(
244	131x	label = label,
245	131x	server = server, ui = ui, datanames = unique(datanames),
246	131x	server_args = server_args, ui_args = ui_args
247		),
248	131x	class = "teal_module"
249		)
250		}
251
252		#' @rdname teal_modules
253		#' @export
254		#'
255		modules <- function(..., label = "root") {
256	102x	checkmate::assert_string(label)
257	100x	submodules <- list(...)
258	100x	if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
259	2x	stop(
260	2x	"The only character argument to modules() must be 'label' and it must be named, ",
261	2x	"change modules('lab', ...) to modules(label = 'lab', ...)"
262		)
263		}
264
265	98x	checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
266		# name them so we can more easily access the children
267		# beware however that the label of the submodules should not be changed as it must be kept synced
268	95x	labels <- vapply(submodules, function(submodule) submodule$label, character(1))
269	95x	names(submodules) <- get_unique_labels(labels)
270	95x	structure(
271	95x	list(
272	95x	label = label,
273	95x	children = submodules
274		),
275	95x	class = "teal_modules"
276		)
277		}
278
279		# printing methods ----
280
281		#' @rdname teal_modules
282		#' @export
283		format.teal_module <- function(x, indent = 0, ...) {
284	3x	paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, "\n", collapse = "")
285		}
286
287
288		#' @rdname teal_modules
289		#' @export
290		print.teal_module <- function(x, ...) {
291	!	cat(format(x, ...))
292	!	invisible(x)
293		}
294
295
296		#' @rdname teal_modules
297		#' @export
298		format.teal_modules <- function(x, indent = 0, ...) {
299	1x	paste(
300	1x	c(
301	1x	paste0(rep(" ", indent), "+ ", x$label, "\n"),
302	1x	unlist(lapply(x$children, format, indent = indent + 1, ...))
303		),
304	1x	collapse = ""
305		)
306		}
307
308
309		#' @rdname teal_modules
310		#' @export
311		print.teal_modules <- print.teal_module
312
313
314		# utilities ----
315		## subset or modify modules ----
316
317		#' Append a `teal_module` to `children` of a `teal_modules` object
318		#' @keywords internal
319		#' @param modules (`teal_modules`)
320		#' @param module (`teal_module`) object to be appended onto the children of `modules`
321		#' @return A `teal_modules` object with `module` appended.
322		append_module <- function(modules, module) {
323	8x	checkmate::assert_class(modules, "teal_modules")
324	6x	checkmate::assert_class(module, "teal_module")
325	4x	modules$children <- c(modules$children, list(module))
326	4x	labels <- vapply(modules$children, function(submodule) submodule$label, character(1))
327	4x	names(modules$children) <- get_unique_labels(labels)
328	4x	modules
329		}
330
331		#' Extract/Remove module(s) of specific class
332		#'
333		#' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`.
334		#'
335		#' @param modules (`teal_modules`)
336		#' @param class The class name of `teal_module` to be extracted or dropped.
337		#' @keywords internal
338		#' @return
339		#' - For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`.
340		#' - For `drop_module`, the opposite, which is all `teal_modules` of class other than `class`.
341		#' @rdname module_management
342		extract_module <- function(modules, class) {
343	20x	if (inherits(modules, class)) {
344	!	modules
345	20x	} else if (inherits(modules, "teal_module")) {
346	11x	NULL
347	9x	} else if (inherits(modules, "teal_modules")) {
348	9x	Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class))
349		}
350		}
351
352		#' @keywords internal
353		#' @return `teal_modules`
354		#' @rdname module_management
355		drop_module <- function(modules, class) {
356	!	if (inherits(modules, class)) {
357	!	NULL
358	!	} else if (inherits(modules, "teal_module")) {
359	!	modules
360	!	} else if (inherits(modules, "teal_modules")) {
361	!	do.call(
362	!	"modules",
363	!	c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label)
364		)
365		}
366		}
367
368		## read modules ----
369
370		#' Does the object make use of the `arg`
371		#'
372		#' @param modules (`teal_module` or `teal_modules`) object
373		#' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.
374		#' @return `logical` whether the object makes use of `arg`.
375		#' @rdname is_arg_used
376		#' @keywords internal
377		is_arg_used <- function(modules, arg) {
378	286x	checkmate::assert_string(arg)
379	283x	if (inherits(modules, "teal_modules")) {
380	29x	any(unlist(lapply(modules$children, is_arg_used, arg)))
381	254x	} else if (inherits(modules, "teal_module")) {
382	43x	is_arg_used(modules$server, arg) \|\| is_arg_used(modules$ui, arg)
383	211x	} else if (is.function(modules)) {
384	209x	isTRUE(arg %in% names(formals(modules)))
385		} else {
386	2x	stop("is_arg_used function not implemented for this object")
387		}
388		}
389
390
391		#' Get module depth
392		#'
393		#' Depth starts at 0, so a single `teal.module` has depth 0.
394		#' Nesting it increases overall depth by 1.
395		#'
396		#' @inheritParams init
397		#' @param depth optional integer determining current depth level
398		#'
399		#' @return Depth level for given module.
400		#' @keywords internal
401		modules_depth <- function(modules, depth = 0L) {
402	12x	checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
403	12x	checkmate::assert_int(depth, lower = 0)
404	11x	if (inherits(modules, "teal_modules")) {
405	4x	max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))
406		} else {
407	7x	depth
408		}
409		}
410
411		#' Retrieve labels from `teal_modules`
412		#'
413		#' @param modules (`teal_modules`)
414		#' @return A `list` containing the labels of the modules. If the modules are nested,
415		#' the function returns a nested `list` of labels.
416		#' @keywords internal
417		module_labels <- function(modules) {
418	!	if (inherits(modules, "teal_modules")) {
419	!	lapply(modules$children, module_labels)
420		} else {
421	!	modules$label
422		}
423		}
424
425		#' Retrieve `teal_bookmarkable` attribute from `teal_modules`
426		#'
427		#' @param modules (`teal_modules` or `teal_module`) object
428		#' @return named list of the same structure as `modules` with `TRUE` or `FALSE` values indicating
429		#' whether the module is bookmarkable.
430		#' @keywords internal
431		modules_bookmarkable <- function(modules) {
432	8x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
433	8x	if (inherits(modules, "teal_modules")) {
434	3x	setNames(
435	3x	lapply(modules$children, modules_bookmarkable),
436	3x	vapply(modules$children, `[[`, "label", FUN.VALUE = character(1))
437		)
438		} else {
439	5x	attr(modules, "teal_bookmarkable", exact = TRUE)
440		}
441		}

1		#' Create a UI of nested tabs of `teal_modules`
2		#'
3		#' @section `ui_nested_tabs`:
4		#' Each `teal_modules` is translated to a `tabsetPanel` and each
5		#' of its children is another tab-module called recursively. The UI of a
6		#' `teal_module` is obtained by calling its UI function.
7		#'
8		#' The `datasets` argument is required to resolve the `teal` arguments in an
9		#' isolated context (with respect to reactivity).
10		#'
11		#' @section `srv_nested_tabs`:
12		#' This module recursively calls all elements of `modules` and returns currently active one.
13		#' - `teal_module` returns self as a active module.
14		#' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.
15		#'
16		#' @name module_nested_tabs
17		#'
18		#' @inheritParams module_tabs_with_filters
19		#'
20		#' @param depth (`integer(1)`)
21		#' number which helps to determine depth of the modules nesting.
22		#' @param is_module_specific (`logical(1)`)
23		#' flag determining if the filter panel is global or module-specific.
24		#' When set to `TRUE`, a filter panel is called inside of each module tab.
25		#'
26		#' @return
27		#' Depending on the class of `modules`, `ui_nested_tabs` returns:
28		#' - `teal_module`: instantiated UI of the module.
29		#' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively
30		#' calling this function on it.
31		#'
32		#' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.
33		#'
34		#' @keywords internal
35		NULL
36
37		#' @rdname module_nested_tabs
38		ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
39	!	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
40	!	checkmate::assert_count(depth)
41	!	UseMethod("ui_nested_tabs", modules)
42		}
43
44		#' @rdname module_nested_tabs
45		#' @export
46		ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
47	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
48		}
49
50		#' @rdname module_nested_tabs
51		#' @export
52		ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
53	!	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
54	!	ns <- NS(id)
55	!	do.call(
56	!	tabsetPanel,
57	!	c(
58		# by giving an id, we can reactively respond to tab changes
59	!	list(
60	!	id = ns("active_tab"),
61	!	type = if (modules$label == "root") "pills" else "tabs"
62		),
63	!	lapply(
64	!	names(modules$children),
65	!	function(module_id) {
66	!	module_label <- modules$children[[module_id]]$label
67	!	tabPanel(
68	!	title = module_label,
69	!	value = module_id, # when clicked this tab value changes input$<tabset panel id>
70	!	ui_nested_tabs(
71	!	id = ns(module_id),
72	!	modules = modules$children[[module_id]],
73	!	datasets = datasets[[module_label]],
74	!	depth = depth + 1L,
75	!	is_module_specific = is_module_specific
76		)
77		)
78		}
79		)
80		)
81		)
82		}
83
84		#' @rdname module_nested_tabs
85		#' @export
86		ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
87	!	checkmate::assert_class(datasets, classes = "FilteredData")
88	!	ns <- NS(id)
89
90	!	args <- c(list(id = ns("module")), modules$ui_args)
91
92	!	teal_ui <- tags$div(
93	!	id = id,
94	!	class = "teal_module",
95	!	uiOutput(ns("data_reactive"), inline = TRUE),
96	!	tagList(
97	!	if (depth >= 2L) tags$div(style = "mt-6"),
98	!	do.call(modules$ui, args)
99		)
100		)
101
102	!	if (!is.null(modules$datanames) && is_module_specific) {
103	!	fluidRow(
104	!	column(width = 9, teal_ui, class = "teal_primary_col"),
105	!	column(
106	!	width = 3,
107	!	datasets$ui_filter_panel(ns("module_filter_panel")),
108	!	class = "teal_secondary_col"
109		)
110		)
111		} else {
112	!	teal_ui
113		}
114		}
115
116		#' @rdname module_nested_tabs
117		srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,
118		reporter = teal.reporter::Reporter$new()) {
119	50x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
120	50x	checkmate::assert_class(reporter, "Reporter")
121	49x	UseMethod("srv_nested_tabs", modules)
122		}
123
124		#' @rdname module_nested_tabs
125		#' @export
126		srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,
127		reporter = teal.reporter::Reporter$new()) {
128	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
129		}
130
131		#' @rdname module_nested_tabs
132		#' @export
133		srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,
134		reporter = teal.reporter::Reporter$new()) {
135	22x	checkmate::assert_list(datasets, types = c("list", "FilteredData"))
136
137	22x	moduleServer(id = id, module = function(input, output, session) {
138	22x	logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
139
140	22x	labels <- vapply(modules$children, `[[`, character(1), "label")
141	22x	modules_reactive <- sapply(
142	22x	names(modules$children),
143	22x	function(module_id) {
144	33x	srv_nested_tabs(
145	33x	id = module_id,
146	33x	datasets = datasets[[labels[module_id]]],
147	33x	modules = modules$children[[module_id]],
148	33x	is_module_specific = is_module_specific,
149	33x	reporter = reporter
150		)
151		},
152	22x	simplify = FALSE
153		)
154
155		# when not ready input$active_tab would return NULL - this would fail next reactive
156	22x	input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)
157	22x	get_active_module <- reactive({
158	12x	if (length(modules$children) == 1L) {
159		# single tab is active by default
160	1x	modules_reactive[[1]]()
161		} else {
162		# switch to active tab
163	11x	modules_reactive[[input_validated()]]()
164		}
165		})
166
167	22x	get_active_module
168		})
169		}
170
171		#' @rdname module_nested_tabs
172		#' @export
173		srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,
174		reporter = teal.reporter::Reporter$new()) {
175	27x	checkmate::assert_class(datasets, "FilteredData")
176	27x	logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
177
178	27x	moduleServer(id = id, module = function(input, output, session) {
179	27x	if (!is.null(modules$datanames) && is_module_specific) {
180	!	datasets$srv_filter_panel("module_filter_panel")
181		}
182
183		# Create two triggers to limit reactivity between filter-panel and modules.
184		# We want to recalculate only visible modules
185		# - trigger the data when the tab is selected
186		# - trigger module to be called when the tab is selected for the first time
187	27x	trigger_data <- reactiveVal(1L)
188	27x	trigger_module <- reactiveVal(NULL)
189	27x	output$data_reactive <- renderUI({
190	17x	lapply(datasets$datanames(), function(x) {
191	21x	datasets$get_data(x, filtered = TRUE)
192		})
193	17x	isolate(trigger_data(trigger_data() + 1))
194	17x	isolate(trigger_module(TRUE))
195
196	17x	NULL
197		})
198
199		# collect arguments to run teal_module
200	27x	args <- c(list(id = "module"), modules$server_args)
201	27x	if (is_arg_used(modules$server, "reporter")) {
202	!	args <- c(args, list(reporter = reporter))
203		}
204
205	27x	if (is_arg_used(modules$server, "datasets")) {
206	1x	args <- c(args, datasets = datasets)
207		}
208
209	27x	if (is_arg_used(modules$server, "data")) {
210	7x	data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets))
211	7x	args <- c(args, data = list(data))
212		}
213
214	27x	if (is_arg_used(modules$server, "filter_panel_api")) {
215	2x	filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)
216	2x	args <- c(args, filter_panel_api = filter_panel_api)
217		}
218
219		# This function calls a module server function.
220	27x	call_module <- function() {
221	17x	if (is_arg_used(modules$server, "id")) {
222	17x	do.call(modules$server, args)
223		} else {
224	!	do.call(callModule, c(args, list(module = modules$server)))
225		}
226		}
227
228		# Call modules.
229	27x	if (isTRUE(session$restoreContext$active)) {
230		# When restoring bookmark, all modules must be initialized on app start.
231		# Delayed module initiation (below) precludes restoring state b/c inputs do not exist when restoring occurs.
232	!	call_module()
233	27x	} else if (inherits(modules, "teal_module_previewer")) {
234		# Report previewer must be initiated on app start for report cards to be included in bookmarks.
235		# When previewer is delayed, cards are bookmarked only if previewer has been initiated (visited).
236	!	call_module()
237		} else {
238		# When app starts normally, modules are initialized only when corresponding tabs are clicked.
239		# Observing trigger_module() induces the module only when output$data_reactive is triggered (see above).
240	27x	observeEvent(
241	27x	ignoreNULL = TRUE,
242	27x	once = TRUE,
243	27x	eventExpr = trigger_module(),
244	27x	handlerExpr = call_module()
245		)
246		}
247
248	27x	reactive(modules)
249		})
250		}
251
252		#' Convert `FilteredData` to reactive list of datasets of the `teal_data` type.
253		#'
254		#' Converts `FilteredData` object to `teal_data` object containing datasets needed for a specific module.
255		#' Please note that if a module needs a dataset which has a parent, then the parent will also be returned.
256		#' A hash per `dataset` is calculated internally and returned in the code.
257		#'
258		#' @param module (`teal_module`) module where needed filters are taken from
259		#' @param datasets (`FilteredData`) object where needed data are taken from
260		#'
261		#' @return A `teal_data` object.
262		#'
263		#' @keywords internal
264		.datasets_to_data <- function(module, datasets) {
265	4x	checkmate::assert_class(module, "teal_module")
266	4x	checkmate::assert_class(datasets, "FilteredData")
267
268	4x	datanames <- if (is.null(module$datanames) \|\| identical(module$datanames, "all")) {
269	1x	datasets$datanames()
270		} else {
271	3x	include_parent_datanames(
272	3x	module$datanames,
273	3x	datasets$get_join_keys()
274		)
275		}
276
277		# list of reactive filtered data
278	4x	data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)
279
280	4x	hashes <- calculate_hashes(datanames, datasets)
281
282	4x	code <- c(
283	4x	get_rcode_str_install(),
284	4x	get_rcode_libraries(),
285	4x	get_datasets_code(datanames, datasets, hashes)
286		)
287
288
289	4x	data <- do.call(
290	4x	teal.data::teal_data,
291	4x	args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames]))
292		)
293
294	4x	data@verified <- attr(datasets, "verification_status")
295	4x	data
296		}
297
298		#' Get the hash of a dataset
299		#'
300		#' @param datanames (`character`) names of datasets
301		#' @param datasets (`FilteredData`) object holding the data
302		#'
303		#' @return A list of hashes per dataset.
304		#' @keywords internal
305		#'
306		calculate_hashes <- function(datanames, datasets) {
307	7x	sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)
308		}

1		#' Manage multiple `FilteredData` objects
2		#'
3		#' Oversee filter states across the entire application.
4		#'
5		#' This module observes changes in the filters of each `FilteredData` object
6		#' and keeps track of all filters used. A mapping of filters to modules
7		#' is kept in the `mapping_matrix` object (which is actually a `data.frame`)
8		#' that tracks which filters (rows) are active in which modules (columns).
9		#'
10		#' @param id (`character(1)`)
11		#' `shiny` module instance id.
12		#' @param datasets (named `list`)
13		#' A list, possibly nested, of `FilteredData` objects.
14		#' Each `FilteredData` will be served to one module in the `teal` application.
15		#' The structure of the list must reflect the nesting of modules in tabs
16		#' and the names of the list must match the labels of their respective modules.
17		#' @inheritParams init
18		#'
19		#' @return
20		#' A `list` containing:
21		#'
22		#' objects used by other manager modules
23		#' - `datasets_flat`: named list of `FilteredData` objects,
24		#' - `mapping_matrix`: `reactive` containing a `data.frame`,
25		#' - `slices_global`: `reactiveVal` containing a `teal_slices` object,
26		#'
27		#' objects used for testing
28		#' - modules_out: `list` of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.
29		#'
30		#' @name module_filter_manager
31		#' @aliases filter_manager filter_manager_module
32		#'
33
34		#' @rdname module_filter_manager
35		#' @keywords internal
36		#'
37		filter_manager_ui <- function(id) {
38	!	ns <- NS(id)
39	!	tags$div(
40	!	class = "filter_manager_content",
41	!	tableOutput(ns("slices_table"))
42		)
43		}
44
45		#' @rdname module_filter_manager
46		#' @keywords internal
47		#'
48		filter_manager_srv <- function(id, datasets, filter) {
49	5x	moduleServer(id, function(input, output, session) {
50	5x	logger::log_trace("filter_manager_srv initializing for: { paste(names(datasets), collapse = ', ')}.")
51
52	5x	is_module_specific <- isTRUE(attr(filter, "module_specific"))
53
54		# Create a global list of slices.
55		# Contains all available teal_slice objects available to all modules.
56		# Passed whole to instances of FilteredData used for individual modules.
57		# Down there a subset that pertains to the data sets used in that module is applied and displayed.
58	5x	slices_global <- reactiveVal(filter)
59
60	5x	datasets_flat <-
61	5x	if (!is_module_specific) {
62	4x	flatten_datasets(unlist(datasets)[[1]])
63		} else {
64	1x	flatten_datasets(datasets)
65		}
66
67		# Create mapping of filters to modules in matrix form (presented as data.frame).
68		# Modules get NAs for filters that cannot be set for them.
69	5x	mapping_matrix <- reactive({
70	3x	state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")
71	3x	mapping_smooth <- lapply(datasets_flat, function(x) {
72	3x	state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")
73	3x	state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")
74	3x	states_active <- state_ids_global %in% state_ids_local
75	3x	ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)
76		})
77
78	3x	as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)
79		})
80
81	5x	output$slices_table <- renderTable(
82	5x	expr = {
83		# Display logical values as UTF characters.
84	2x	mm <- mapping_matrix()
85	2x	mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))
86	2x	mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))
87
88		# Display placeholder if no filters defined.
89	2x	if (nrow(mm) == 0L) {
90	2x	mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)
91	2x	rownames(mm) <- ""
92		}
93
94		# Report Previewer will not be displayed.
95	2x	mm[names(mm) != "Report previewer"]
96		},
97	5x	align = paste(c("l", rep("c", sum(names(datasets_flat) != "Report previewer"))), collapse = ""),
98	5x	rownames = TRUE
99		)
100
101		# Create list of module calls.
102	5x	modules_out <- lapply(names(datasets_flat), function(module_name) {
103	7x	filter_manager_module_srv(
104	7x	id = module_name,
105	7x	module_fd = datasets_flat[[module_name]],
106	7x	slices_global = slices_global
107		)
108		})
109
110	5x	list(
111	5x	slices_global = slices_global,
112	5x	mapping_matrix = mapping_matrix,
113	5x	datasets_flat = datasets_flat,
114	5x	modules_out = modules_out # returned for testing purpose
115		)
116		})
117		}
118
119		#' Module specific filter manager
120		#'
121		#' Tracks filter states in a single module.
122		#'
123		#' This module tracks the state of a single `FilteredData` object and global `teal_slices`
124		#' and updates both objects as necessary. Filter states added in different modules
125		#' Filter states added any individual module are added to global `teal_slices`
126		#' and from there become available in other modules
127		#' by setting `private$available_teal_slices` in each `FilteredData`.
128		#'
129		#' @param id (`character(1)`)
130		#' `shiny` module id.
131		#' @param module_fd (`FilteredData`)
132		#' Object containing the data to be filtered in a single `teal` module.
133		#' @param slices_global (`reactiveVal`)
134		#' stores `teal_slices` with all available filters; allows the following actions:
135		#' - to disable/enable a specific filter in a module
136		#' - to restore saved filter settings
137		#' - to save current filter panel settings
138		#' @return A `reactive` expression containing a `teal_slices` with the slices active in this module.
139		#' @keywords internal
140		#'
141		filter_manager_module_srv <- function(id, module_fd, slices_global) {
142	7x	moduleServer(id, function(input, output, session) {
143		# Only operate on slices that refer to data sets present in this module.
144	7x	module_fd$set_available_teal_slices(reactive(slices_global()))
145
146		# Track filter state of this module.
147	7x	slices_module <- reactive(module_fd$get_filter_state())
148
149		# Reactive values for comparing states.
150	7x	previous_slices <- reactiveVal(isolate(slices_module()))
151	7x	slices_added <- reactiveVal(NULL)
152
153		# Observe changes in module filter state and trigger appropriate actions.
154	7x	observeEvent(slices_module(), ignoreNULL = FALSE, {
155	2x	logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
156	2x	added <- setdiff_teal_slices(slices_module(), slices_global())
157	!	if (length(added)) slices_added(added)
158	2x	previous_slices(slices_module())
159		})
160
161	7x	observeEvent(slices_added(), ignoreNULL = TRUE, {
162	!	logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
163		# In case the new state has the same id as an existing state, add a suffix to it.
164	!	global_ids <- vapply(slices_global(), `[[`, character(1L), "id")
165	!	lapply(
166	!	slices_added(),
167	!	function(slice) {
168	!	if (slice$id %in% global_ids) {
169	!	slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)
170		}
171		}
172		)
173	!	slices_global_new <- c(slices_global(), slices_added())
174	!	slices_global(slices_global_new)
175	!	slices_added(NULL)
176		})
177
178	7x	slices_module # returned for testing purpose
179		})
180		}
181
182
183
184		# utilities ----
185
186		#' Flatten potentially nested list of FilteredData objects while maintaining useful names.
187		#' Simply using `unlist` would result in concatenated names.
188		#' A single `FilteredData` will result in a list named "Global Filters"
189		#' because that name used in the mapping matrix display.
190		#' @param x `FilteredData` or a `list` thereof
191		#' @param name (`character(1)`) string used to name `x` in the resulting list
192		#' @return Unnested named list of `FilteredData` objects.
193		#' @keywords internal
194		#' @noRd
195		#'
196		flatten_datasets <- function(x, name = "Global Filters") {
197	9x	if (inherits(x, "FilteredData")) {
198	7x	setNames(list(x), name)
199		} else {
200	2x	unlist(lapply(names(x), function(name) flatten_datasets(x[[name]], name)))
201		}
202		}

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

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

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 supply or modify data in a `teal` application.
10		#' The module allows for running data pre-processing code (creation _and_ some modification) after the app starts.
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		#'
25		#' @return
26		#' `teal_data_module` returns an object of class `teal_data_module`.
27		#'
28		#' @examples
29		#' tdm <- teal_data_module(
30		#' ui = function(id) {
31		#' ns <- NS(id)
32		#' actionButton(ns("submit"), label = "Load data")
33		#' },
34		#' server = function(id) {
35		#' moduleServer(id, function(input, output, session) {
36		#' eventReactive(input$submit, {
37		#' data <- within(
38		#' teal_data(),
39		#' {
40		#' dataset1 <- iris
41		#' dataset2 <- mtcars
42		#' }
43		#' )
44		#' datanames(data) <- c("dataset1", "dataset2")
45		#'
46		#' data
47		#' })
48		#' })
49		#' }
50		#' )
51		#'
52		#' @name teal_data_module
53		#' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]
54		#'
55		#' @export
56		teal_data_module <- function(ui, server) {
57	36x	checkmate::assert_function(ui, args = "id", nargs = 1)
58	35x	checkmate::assert_function(server, args = "id", nargs = 1)
59	34x	structure(
60	34x	list(ui = ui, server = server),
61	34x	class = "teal_data_module"
62		)
63		}

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

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

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