teal coverage - 82.39%

Files
Source

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

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

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

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

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

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

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

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

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

        mm
      })
    })

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

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

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

    mapping_table # for testing purpose
  })
}

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

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

    module_fd_previous <- reactiveVal(NULL)

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

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

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

      module_fd()$set_filter_state(slices)

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

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

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

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

    slices_module # returned for testing purpose
  })
}

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

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

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

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

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

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

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

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

#' @rdname module_snapshot_manager
ui_snapshot_manager_panel <- function(id) {
  ns <- NS(id)
  .expand_button(
    id = ns("show_snapshot_manager"),
    label = "Snapshot Manager",
    icon = "camera-fill"
  )
}

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

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

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

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

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

    ns <- session$ns

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

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

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

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

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

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

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

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

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

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

    snapshot_history
  })
}

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

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

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

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

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

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

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


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

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

    invisible(NULL)
  })
}


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

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


# utilities ----

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    data_load_status <- reactive({
      if (inherits(data_handled(), "teal_data")) {
        shinyjs::enable(id = "close_teal_data_module_modal")
        "ok"
      } else if (inherits(data, "teal_data_module")) {
        shinyjs::disable(id = "close_teal_data_module_modal")
        "teal_data_module failed"
      } else {
        "external failed"
      }
    })

    if (inherits(data, "teal_data_module")) {
      setBookmarkExclude(c("teal_data_module_ui", "open_teal_data_module_ui"))
      .teal_navbar_insert_ui(
        ui = .expand_button(
          id = session$ns("open_teal_data_module_ui"),
          label = "Load Data",
          icon = "database-fill"
        )
      )
      observeEvent(
        input$open_teal_data_module_ui,
        ignoreInit = TRUE,
        ignoreNULL = FALSE, # should be shown on startup
        {
          showModal(
            div(
              class = "teal teal-data-module-popup",
              modalDialog(
                id = session$ns("teal_data_module_ui"),
                size = "xl",
                tags$div(
                  ui_init_data(session$ns("data")),
                  validate_ui
                ),
                easyClose = FALSE,
                footer = tags$div(id = session$ns("close_teal_data_module_modal"), modalButton("Dismiss"))
              )
            )
          )
          if (data_load_status() == "ok") {
            shinyjs::enable(id = "close_teal_data_module_modal")
          } else {
            shinyjs::disable(id = "close_teal_data_module_modal")
          }
        }
      )

      if (isTRUE(attr(data, "once"))) {
        # when once = TRUE we pull data once and then remove data button and a modal
        shiny::removeUI(selector = sprintf(".teal.expand-button:has(#%s)", session$ns("open_teal_data_module_ui")))
        observeEvent(data_signatured(), once = TRUE, {
          logger::log_debug("srv_teal@2 removing data tab.")
          shiny::removeModal()
        })
      }
    } else {
      # when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)
      insertUI(
        selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
        where = "beforeBegin",
        ui = tags$div(validate_ui)
      )
    }

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

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

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

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

  invisible(NULL)
}

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

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

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

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

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

  bs_theme
}

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

  unique(ordered_datanames)
}

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


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

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


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

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

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

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

  reserved_datanames <- check_reserved_datanames(datanames)

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

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

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


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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

#' Module to transform `reactive` `teal_data`
#'
#' Module calls [teal_transform_module()] in sequence so that `reactive teal_data` output
#' from one module is handed over to the following module's input.
#'
#' @inheritParams module_validate_error
#' @inheritParams teal_modules
#' @param class (character(1)) CSS class to be added in the `div` wrapper tag.
#' @param is_transform_failed (`reactiveValues`) contains `logical` flags named after each transformator.
#' Help to determine if any previous transformator failed, so that following transformators can be disabled
#' and display a generic failure message.
#' @return `reactive` `teal_data`
#'
#' @name module_transform_data
NULL

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    module_output
  })
}

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

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

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

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

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

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

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

    data_handled
  })
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    NULL
  })
}

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

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

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

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

  process
}

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

  list(out = out, res = res)
}

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  trigger_data
}

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

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

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

  message("Initializing reporter_previewer_module")

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

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

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

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

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

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

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

  opts
}

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


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

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

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

#' @rdname module_teal_module
srv_teal_module <- function(id,
                            data,
                            modules,
                            datasets = NULL,
                            slices_global,
                            reporter = teal.reporter::Reporter$new(),
                            data_load_status = reactive("ok")) {
  moduleServer(id, function(input, output, session) {
    .srv_teal_module(
      id = "nav",
      data = data,
      modules = modules,
      datasets = datasets,
      slices_global = slices_global,
      reporter = reporter,
      data_load_status = data_load_status,
      active_module_id = reactive(input$active_module_id)
    )
  })
}

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

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

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

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

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

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

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

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

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

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

  list(link = link, tab_pane = tab_pane)
}

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

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

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

    modules_output
  })
}

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

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

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

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

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

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

      summary_table <- srv_data_summary("data_summary", module_teal_data)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      NULL
    }
  )
}

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

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

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

  do.call(.smart_rbind, out)
}


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  out
}

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

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

setOldClass("teal_data_module")

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

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

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

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

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

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

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

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

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

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

  invisible()
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1		#' App state management.
2		#'
3		#' @description
4		#' `r lifecycle::badge("experimental")`
5		#'
6		#' Capture and restore the global (app) input state.
7		#'
8		#' @details
9		#' This module introduces bookmarks into `teal` apps: the `shiny` bookmarking mechanism becomes enabled
10		#' and server-side bookmarks can be created.
11		#'
12		#' The bookmark manager presents a button with the bookmark icon and is placed in the tab-bar.
13		#' When clicked, the button creates a bookmark and opens a modal which displays the bookmark URL.
14		#'
15		#' `teal` does not guarantee that all modules (`teal_module` objects) are bookmarkable.
16		#' Those that are, have a `teal_bookmarkable` attribute set to `TRUE`. If any modules are not bookmarkable,
17		#' the bookmark manager modal displays a warning and the bookmark button displays a flag.
18		#' In order to communicate that a external module is bookmarkable, the module developer
19		#' should set the `teal_bookmarkable` attribute to `TRUE`.
20		#'
21		#' @section Server logic:
22		#' A bookmark is a URL that contains the app address with a `/?_state_id_=<bookmark_dir>` suffix.
23		#' `<bookmark_dir>` is a directory created on the server, where the state of the application is saved.
24		#' Accessing the bookmark URL opens a new session of the app that starts in the previously saved state.
25		#'
26		#' @section Note:
27		#' To enable bookmarking use either:
28		#' - `shiny` app by using `shinyApp(..., enableBookmarking = "server")` (not supported in `shinytest2`)
29		#' - set `options(shiny.bookmarkStore = "server")` before running the app
30		#'
31		#'
32		#' @inheritParams module_teal
33		#'
34		#' @return Invisible `NULL`.
35		#'
36		#' @aliases bookmark bookmark_manager bookmark_manager_module
37		#'
38		#' @name module_bookmark_manager
39		#' @rdname module_bookmark_manager
40		#'
41		#' @keywords internal
42		#'
43		NULL
44
45		#' @rdname module_bookmark_manager
46		ui_bookmark_panel <- function(id, modules) {
47	3x	ns <- NS(id)
48
49	3x	bookmark_option <- get_bookmarking_option()
50	3x	is_unbookmarkable <- need_bookmarking(modules)
51	3x	shinyOptions(bookmarkStore = bookmark_option)
52
53	3x	if (!all(is_unbookmarkable) && identical(bookmark_option, "server")) {
54	!	.expand_button(
55	!	id = ns("do_bookmark"),
56	!	label = "Bookmark",
57	!	icon = "bookmark-fill"
58		)
59		}
60		}
61
62		#' @rdname module_bookmark_manager
63		srv_bookmark_panel <- function(id, modules) {
64	132x	checkmate::assert_character(id)
65	132x	checkmate::assert_class(modules, "teal_modules")
66	132x	moduleServer(id, function(input, output, session) {
67	132x	logger::log_debug("bookmark_manager_srv initializing")
68	132x	ns <- session$ns
69	132x	bookmark_option <- get_bookmarking_option()
70	132x	is_unbookmarkable <- need_bookmarking(modules)
71
72		# Set up bookmarking callbacks ----
73		# Register bookmark exclusions: do_bookmark button to avoid re-bookmarking
74	132x	setBookmarkExclude(c("do_bookmark"))
75		# This bookmark can only be used on the app session.
76	132x	app_session <- .subset2(session, "parent")
77	132x	app_session$onBookmarked(function(url) {
78	!	logger::log_debug("bookmark_manager_srv@onBookmarked: bookmark button clicked, registering bookmark")
79	!	modal_content <- if (bookmark_option != "server") {
80	!	msg <- sprintf(
81	!	"Bookmarking has been set to \"%s\".\n%s\n%s",
82	!	bookmark_option,
83	!	"Only server-side bookmarking is supported.",
84	!	"Please contact your app developer."
85		)
86	!	tags$div(
87	!	tags$p(msg, class = "text-warning")
88		)
89		} else {
90	!	tags$div(
91	!	tags$span(
92	!	tags$pre(url)
93		),
94	!	if (any(is_unbookmarkable)) {
95	!	bkmb_summary <- rapply2(
96	!	modules_bookmarkable(modules),
97	!	function(x) {
98	!	if (isTRUE(x)) {
99	!	"\u2705" # check mark
100	!	} else if (isFALSE(x)) {
101	!	"\u274C" # cross mark
102		} else {
103	!	"\u2753" # question mark
104		}
105		}
106		)
107	!	tags$div(
108	!	tags$p(
109	!	icon("fas fa-exclamation-triangle"),
110	!	"Some modules will not be restored when using this bookmark.",
111	!	tags$br(),
112	!	"Check the list below to see which modules are not bookmarkable.",
113	!	class = "text-warning"
114		),
115	!	tags$pre(yaml::as.yaml(bkmb_summary))
116		)
117		}
118		)
119		}
120
121
122	!	showModal(
123	!	div(
124	!	class = "teal bookmark-popup",
125	!	modalDialog(
126	!	id = ns("bookmark_modal"),
127	!	title = "Bookmarked teal app url",
128	!	modal_content,
129	!	easyClose = TRUE,
130	!	footer = NULL
131		)
132		)
133		)
134		})
135
136		# manually trigger bookmarking because of the problems reported on windows with bookmarkButton in teal
137	132x	observeEvent(input$do_bookmark, {
138	!	logger::log_debug("bookmark_manager_srv@1 do_bookmark module clicked.")
139	!	session$doBookmark()
140		})
141
142	132x	invisible(NULL)
143		})
144		}
145
146
147		#' @rdname module_bookmark_manager
148		get_bookmarking_option <- function() {
149	135x	bookmark_option <- getShinyOption("bookmarkStore")
150	135x	if (is.null(bookmark_option) && identical(getOption("shiny.bookmarkStore"), "server")) {
151	!	bookmark_option <- getOption("shiny.bookmarkStore")
152		}
153	135x	bookmark_option
154		}
155
156		#' @rdname module_bookmark_manager
157		need_bookmarking <- function(modules) {
158	135x	unlist(rapply2(
159	135x	modules_bookmarkable(modules),
160	135x	Negate(isTRUE)
161		))
162		}
163
164
165		# utilities ----
166
167		#' Restore value from bookmark.
168		#'
169		#' Get value from bookmark or return default.
170		#'
171		#' Bookmarks can store not only inputs but also arbitrary values.
172		#' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks,
173		#' and they are placed in the `values` environment in the `session$restoreContext` field.
174		#' Using `teal_data_module` makes it impossible to run the callbacks
175		#' because the app becomes ready before modules execute and callbacks are registered.
176		#' In those cases the stored values can still be recovered from the `session` object directly.
177		#'
178		#' Note that variable names in the `values` environment are prefixed with module name space names,
179		#' therefore, when using this function in modules, `value` must be run through the name space function.
180		#'
181		#' @param value (`character(1)`) name of value to restore
182		#' @param default fallback value
183		#'
184		#' @return
185		#' In an application restored from a server-side bookmark,
186		#' the variable specified by `value` from the `values` environment.
187		#' Otherwise `default`.
188		#'
189		#' @keywords internal
190		#'
191		restoreValue <- function(value, default) { # nolint: object_name.
192	303x	checkmate::assert_character(value)
193	303x	session_default <- shiny::getDefaultReactiveDomain()
194	303x	session_parent <- .subset2(session_default, "parent")
195	303x	session <- if (is.null(session_parent)) session_default else session_parent
196	303x	if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
197	2x	session$restoreContext$values[[value]]
198		} else {
199	301x	default
200		}
201		}
202
203		# Replacement for [base::rapply] which doesn't handle NULL values - skips the evaluation
204		# of the function and returns NULL for given element.
205		rapply2 <- function(x, f) {
206	296x	if (inherits(x, "list")) {
207	135x	lapply(x, rapply2, f = f)
208		} else {
209	161x	f(x)
210		}
211		}

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

1		#' `teal` main module
2		#'
3		#' @description
4		#' Module to create a `teal` app as a Shiny Module.
5		#'
6		#' @details
7		#' This module can be used instead of [init()] in custom Shiny applications. Unlike [init()], it doesn't
8		#' automatically include [`module_session_info`].
9		#'
10		#' Module is responsible for creating the main `shiny` app layout and initializing all the necessary
11		#' components. This module establishes reactive connection between the input `data` and every other
12		#' component in the app. Reactive change of the `data` passed as an argument, reloads the app and
13		#' possibly keeps all input settings the same so the user can continue where one left off.
14		#'
15		#' ## data flow in `teal` application
16		#'
17		#' This module supports multiple data inputs but eventually, they are all converted to `reactive`
18		#' returning `teal_data` in this module. On this `reactive teal_data` object several actions are
19		#' performed:
20		#' - data loading in [`module_init_data`]
21		#' - data filtering in [`module_filter_data`]
22		#' - data transformation in [`module_transform_data`]
23		#'
24		#' ## Fallback on failure
25		#'
26		#' `teal` is designed in such way that app will never crash if the error is introduced in any
27		#' custom `shiny` module provided by app developer (e.g. [teal_data_module()], [teal_transform_module()]).
28		#' If any module returns a failing object, the app will halt the evaluation and display a warning message.
29		#' App user should always have a chance to fix the improper input and continue without restarting the session.
30		#'
31		#' @rdname module_teal
32		#' @name module_teal
33		#'
34		#' @inheritParams init
35		#' @param id (`character(1)`) `shiny` module instance id.
36		#' @param data (`teal_data`, `teal_data_module`, or `reactive` returning `teal_data`)
37		#' The data which application will depend on.
38		#' @param modules (`teal_modules`)
39		#' `teal_modules` object. These are the specific output modules which
40		#' will be displayed in the `teal` application. See [modules()] and [module()] for
41		#' more details.
42		#'
43		#' @return `NULL` invisibly
44		NULL
45
46		#' @rdname module_teal
47		#' @export
48		ui_teal <- function(id, modules) {
49	3x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
50	3x	checkmate::assert_class(modules, "teal_modules")
51	3x	ns <- NS(id)
52
53	3x	mod <- extract_module(modules, class = "teal_module_previewer")
54	3x	reporter_opts <- if (length(mod)) .get_reporter_options(mod[[1]]$server_args)
55
56		# show busy icon when `shiny` session is busy computing stuff
57		# based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length.
58	3x	shiny_busy_message_panel <- conditionalPanel(
59	3x	condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
60	3x	tags$div(
61	3x	icon("arrows-rotate", class = "fa-spin", prefer_type = "solid"),
62	3x	"Computing ...",
63	3x	style = "position: fixed; bottom: 0; right: 0;
64	3x	width: 140px; margin: 15px; padding: 5px 0 5px 10px;
65	3x	text-align: left; font-weight: bold; font-size: 100%;
66	3x	color: #ffffff; background-color: #347ab7; z-index: 105;"
67		)
68		)
69
70	3x	navbar <- ui_teal_module(id = ns("teal_modules"), modules = modules)
71	3x	nav_elements <- list(
72	3x	withr::with_options(reporter_opts, { # for backwards compatibility of the report_previewer_module$server_args
73	3x	tags$div(
74	3x	id = ns("reporter_menu_container"),
75	3x	.teal_navbar_menu(
76	3x	label = "Report",
77	3x	icon = "file-text-fill",
78	3x	class = "reporter-menu",
79	3x	if ("preview" %in% getOption("teal.reporter.nav_buttons")) {
80	3x	teal.reporter::preview_report_button_ui(ns("preview_report"), label = "Preview Report")
81		},
82	3x	tags$hr(style = "margin: 0.5rem;"),
83	3x	if ("download" %in% getOption("teal.reporter.nav_buttons")) {
84	3x	teal.reporter::download_report_button_ui(ns("download_report"), label = "Download Report")
85		},
86	3x	if ("load" %in% getOption("teal.reporter.nav_buttons")) {
87	3x	teal.reporter::report_load_ui(ns("load_report"), label = "Load Report")
88		},
89	3x	tags$hr(style = "margin: 0.5rem;"),
90	3x	if ("reset" %in% getOption("teal.reporter.nav_buttons")) {
91	3x	teal.reporter::reset_report_button_ui(ns("reset_reports"), label = "Reset Report")
92		}
93		)
94		)
95		}),
96	3x	tags$span(style = "margin-left: auto;"),
97	3x	ui_bookmark_panel(ns("bookmark_manager"), modules),
98	3x	ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
99	3x	ui_filter_manager_panel(ns("filter_manager_panel"))
100		)
101	3x	navbar <- .teal_navbar_append(navbar, nav_elements)
102
103	3x	bslib::page_fluid(
104	3x	id = id,
105	3x	theme = get_teal_bs_theme(),
106	3x	include_teal_css_js(),
107	3x	shinyjs::useShinyjs(),
108	3x	shiny::includeScript(system.file("js/extendShinyJs.js", package = "teal")),
109	3x	shiny_busy_message_panel,
110	3x	tags$div(id = ns("tabpanel_wrapper"), class = "teal-body", navbar),
111	3x	tags$hr(style = "margin: 1rem 0 0.5rem 0;")
112		)
113		}
114
115		#' @rdname module_teal
116		#' @export
117		srv_teal <- function(id, data, modules, filter = teal_slices(), reporter = teal.reporter::Reporter$new()) {
118	134x	checkmate::assert_character(id, max.len = 1, any.missing = FALSE)
119	134x	checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
120	133x	checkmate::assert_class(modules, "teal_modules")
121	133x	checkmate::assert_class(filter, "teal_slices")
122
123	133x	moduleServer(id, function(input, output, session) {
124	133x	logger::log_debug("srv_teal initializing.")
125
126	133x	if (getOption("teal.show_js_log", default = FALSE)) {
127	!	shinyjs::showLog()
128		}
129
130	133x	session$onBookmark(function(state) {
131	2x	logger::log_debug("srv_teal@onBookmark: storing report cards")
132	2x	state$values$report_cards <- shiny::isolate(reporter$get_cards())
133		})
134		# set timezone in shiny app
135		# timezone is set in the early beginning so it will be available also
136		# for `DDL` and all shiny modules
137	133x	get_client_timezone(session$ns)
138	133x	observeEvent(
139	133x	eventExpr = input$timezone,
140	133x	once = TRUE,
141	133x	handlerExpr = {
142	!	session$userData$timezone <- input$timezone
143	!	logger::log_debug("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
144		}
145		)
146
147	133x	data_handled <- srv_init_data("data", data = data)
148
149	132x	validate_ui <- tags$div(
150	132x	id = session$ns("validate_messages"),
151	132x	class = "teal_validated",
152	132x	ui_check_class_teal_data(session$ns("class_teal_data")),
153	132x	ui_validate_error(session$ns("silent_error")),
154	132x	ui_check_module_datanames(session$ns("datanames_warning"))
155		)
156	132x	srv_check_class_teal_data("class_teal_data", data_handled)
157	132x	srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
158	132x	srv_check_module_datanames("datanames_warning", data_handled, modules)
159
160	132x	data_validated <- .trigger_on_success(data_handled)
161	132x	data_signatured <- reactive({
162	238x	req(inherits(data_validated(), "teal_data"))
163	116x	is_filter_ok <- check_filter_datanames(filter, names(data_validated()))
164	116x	if (!isTRUE(is_filter_ok)) {
165	2x	showNotification(
166	2x	"Some filters were not applied because of incompatibility with data. Contact app developer.",
167	2x	type = "warning",
168	2x	duration = 10
169		)
170	2x	warning(is_filter_ok)
171		}
172	116x	.add_signature_to_data(data_validated())
173		})
174
175	132x	data_load_status <- reactive({
176	125x	if (inherits(data_handled(), "teal_data")) {
177	116x	shinyjs::enable(id = "close_teal_data_module_modal")
178	116x	"ok"
179	9x	} else if (inherits(data, "teal_data_module")) {
180	9x	shinyjs::disable(id = "close_teal_data_module_modal")
181	9x	"teal_data_module failed"
182		} else {
183	!	"external failed"
184		}
185		})
186
187	132x	if (inherits(data, "teal_data_module")) {
188	14x	setBookmarkExclude(c("teal_data_module_ui", "open_teal_data_module_ui"))
189	14x	.teal_navbar_insert_ui(
190	14x	ui = .expand_button(
191	14x	id = session$ns("open_teal_data_module_ui"),
192	14x	label = "Load Data",
193	14x	icon = "database-fill"
194		)
195		)
196	14x	observeEvent(
197	14x	input$open_teal_data_module_ui,
198	14x	ignoreInit = TRUE,
199	14x	ignoreNULL = FALSE, # should be shown on startup
200		{
201	1x	showModal(
202	1x	div(
203	1x	class = "teal teal-data-module-popup",
204	1x	modalDialog(
205	1x	id = session$ns("teal_data_module_ui"),
206	1x	size = "xl",
207	1x	tags$div(
208	1x	ui_init_data(session$ns("data")),
209	1x	validate_ui
210		),
211	1x	easyClose = FALSE,
212	1x	footer = tags$div(id = session$ns("close_teal_data_module_modal"), modalButton("Dismiss"))
213		)
214		)
215		)
216	1x	if (data_load_status() == "ok") {
217	!	shinyjs::enable(id = "close_teal_data_module_modal")
218		} else {
219	1x	shinyjs::disable(id = "close_teal_data_module_modal")
220		}
221		}
222		)
223
224	14x	if (isTRUE(attr(data, "once"))) {
225		# when once = TRUE we pull data once and then remove data button and a modal
226	14x	shiny::removeUI(selector = sprintf(".teal.expand-button:has(#%s)", session$ns("open_teal_data_module_ui")))
227	14x	observeEvent(data_signatured(), once = TRUE, {
228	5x	logger::log_debug("srv_teal@2 removing data tab.")
229	5x	shiny::removeModal()
230		})
231		}
232		} else {
233		# when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)
234	118x	insertUI(
235	118x	selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
236	118x	where = "beforeBegin",
237	118x	ui = tags$div(validate_ui)
238		)
239		}
240
241		# Wait for UI to be rendered before showing/hiding reporter UI elements
242		# See: https://github.com/rstudio/shiny/issues/3348
243	132x	observeEvent(
244	132x	once = TRUE,
245	132x	ignoreInit = TRUE,
246	132x	reactiveValuesToList(session$input),
247		{
248	39x	if (!is.null(reporter)) {
249	39x	reporter$set_id(attr(filter, "app_id"))
250	39x	report_cards <- restoreValue(session$ns("report_cards"), NULL)
251	39x	if (length(report_cards)) {
252	1x	reporter$reset()
253	1x	reporter$append_cards(report_cards)
254		}
255	39x	teal.reporter::preview_report_button_srv("preview_report", reporter)
256	39x	teal.reporter::report_load_srv("load_report", reporter)
257	39x	teal.reporter::download_report_button_srv(id = "download_report", reporter = reporter)
258	39x	teal.reporter::reset_report_button_srv("reset_reports", reporter)
259		} else {
260	!	removeUI(selector = sprintf("#%s", session$ns("reporter_menu_container")))
261	!	removeUI(selector = ".report_add_wrapper")
262		}
263		}
264		)
265
266	132x	datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
267	121x	eventReactive(data_signatured(), {
268	107x	req(inherits(data_signatured(), "teal_data"))
269	107x	logger::log_debug("srv_teal@1 initializing FilteredData")
270	107x	teal_data_to_filtered_data(data_signatured())
271		})
272		}
273	132x	module_labels <- unlist(modules_slot(modules, "label"), use.names = FALSE)
274	132x	slices_global <- methods::new(".slicesGlobal", filter, module_labels)
275
276	132x	modules_output <- srv_teal_module(
277	132x	"teal_modules",
278	132x	data = data_signatured,
279	132x	modules = modules,
280	132x	datasets = datasets_rv,
281	132x	slices_global = slices_global,
282	132x	reporter = reporter,
283	132x	data_load_status = data_load_status
284		)
285
286	132x	mapping_table <- srv_filter_manager_panel("filter_manager_panel", slices_global = slices_global)
287	132x	snapshots <- srv_snapshot_manager_panel("snapshot_manager_panel", slices_global = slices_global)
288	132x	srv_bookmark_panel("bookmark_manager", modules)
289		})
290
291	132x	invisible(NULL)
292		}

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

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

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

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

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

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

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

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

1		#' Calls all `modules`
2		#'
3		#' Modules create navigation bar with drop-down menu and tab content. Each `teal_module` is called recursively
4		#' according to the structure of `modules` argument. This is a custom module which utilizes shiny/Bootstrap
5		#' `.nav` class. `modules` are called with an `id` derived from `teal_module`'s label and labels of its
6		#' ancestors (if any).
7		#'
8		#' ### Functions
9		#'
10		#' - `ui/srv_teal_module` - wrapper module which links drop-down buttons with modules panels.
11		#' Here `input$active_module_id` is instantiated.
12		#' - `.ui/srv_teal_module` - recursive S3 method which calls each module
13		#' - `.teal_navbar_append` - wrapper for [htmltools::tagAppendChild()] to add any element to navigation bar.
14		#' - `.teal_navbar_insert_ui` - wrapper for [shiny::insertUI()] to insert any element to navigation bar.
15		#' - `.teal_navbar_menu` - UI function to create a drop-down menu for navigation bar.
16		#'
17		#' ### Utilizing `.nav` class
18		#'
19		#' No extra `javascript` or server functionality were introduced to have navigation buttons toggle between
20		#' tab panels. This works thanks to `.nav` container which links `.nav-link` buttons `href = #<module id>`
21		#' attribute with `.tab-pane`'s `id = <module id>` (see ``.ui_teal_module.teal_module`).
22		#'
23		#' ### Initialization and isolation of the `teal_module`(s)
24		#'
25		#' Modules are initialized only when they are active. This speeds up app initialization and on
26		#' startup only the first module is activated and its outputs are calculated.
27		#' Only the active module is listening to reactive events. This way, modules are isolated and only
28		#' one can run at any given time. This makes the app more efficient by reducing unnecessary
29		#' computations on server side.
30		#'
31		#' @name module_teal_module
32		#'
33		#' @inheritParams module_teal
34		#'
35		#' @param data (`reactive` returning `teal_data`)
36		#'
37		#' @param slices_global (`reactiveVal` returning `modules_teal_slices`)
38		#' see [`module_filter_manager`]
39		#'
40		#' @param datasets (`reactive` returning `FilteredData` or `NULL`)
41		#' When `datasets` is passed from the parent module (`srv_teal`) then `dataset` is a singleton
42		#' which implies the filter-panel to be "global". When `NULL` then filter-panel is "module-specific".
43		#'
44		#' @param reporter (`Reporter`, singleton)
45		#' Stores reporter-cards appended in the server of `teal_module`.
46		#'
47		#' @param data_load_status (`reactive` returning `character(1)`)
48		#' Determines action dependent on a data loading status:
49		#' - `"ok"` when `teal_data` is returned from the data loading.
50		#' - `"teal_data_module failed"` when [teal_data_module()] didn't return `teal_data`. Disables tab buttons.
51		#' - `"external failed"` when a `reactive` passed to `srv_teal(data)` didn't return `teal_data`. Hides the whole tab
52		#' panel.
53		#'
54		#' @param active_module_id (`reactive` returning `character(1)`)
55		#' `id` of the currently active module. This helps to determine which module can listen to reactive events.
56		#'
57		#' @return
58		#' Output of currently active module.
59		#' - `srv_teal_module.teal_module` returns `reactiveVal` containing output of the called module.
60		#' - `srv_teal_module.teal_modules` returns output of modules in a list following the hierarchy of `modules`
61		#'
62		#' @keywords internal
63		NULL
64
65
66		#' @rdname module_teal_module
67		ui_teal_module <- function(id, modules) {
68	3x	ns <- NS(id)
69	3x	active_module_id <- restoreInput(
70	3x	ns("active_module_id"),
71	3x	unlist(modules_slot(modules, "path"), use.names = FALSE)[1]
72		)
73
74	3x	module_items <- .ui_teal_module(id = ns("nav"), modules = modules, active_module_id = active_module_id)
75
76	3x	tags$div(
77	3x	class = "teal-modules-wrapper",
78	3x	htmltools::htmlDependency(
79	3x	name = "module-navigation",
80	3x	version = utils::packageVersion("teal"),
81	3x	package = "teal",
82	3x	src = "module-navigation",
83	3x	stylesheet = "module-navigation.css"
84		),
85	3x	tags$ul(
86	3x	id = ns("active_module_id"),
87	3x	style = "align-items: center; gap: 1em; font-size: large;",
88	3x	class = "teal-navbar nav shiny-tab-input", # to mimic nav and mimic tabsetPanel
89	3x	`data-tabsetid` = "test",
90	3x	.teal_navbar_menu(
91	3x	!!!module_items$link,
92	3x	label = sprintf("Module (%d)", length(unlist(modules_slot(modules, "label")))),
93	3x	class = "teal-modules-tree",
94	3x	icon = "diagram-3-fill"
95		)
96		),
97	3x	tags$div(class = "tab-content", module_items$tab_pane)
98		)
99		}
100
101		#' @rdname module_teal_module
102		srv_teal_module <- function(id,
103		data,
104		modules,
105		datasets = NULL,
106		slices_global,
107		reporter = teal.reporter::Reporter$new(),
108		data_load_status = reactive("ok")) {
109	132x	moduleServer(id, function(input, output, session) {
110	132x	.srv_teal_module(
111	132x	id = "nav",
112	132x	data = data,
113	132x	modules = modules,
114	132x	datasets = datasets,
115	132x	slices_global = slices_global,
116	132x	reporter = reporter,
117	132x	data_load_status = data_load_status,
118	132x	active_module_id = reactive(input$active_module_id)
119		)
120		})
121		}
122
123		#' @rdname module_teal_module
124		.teal_navbar_append <- function(navbar, child) {
125	3x	tagAppendChild(tag = navbar, child = child, .cssSelector = ".teal-navbar")
126		}
127
128		#' @rdname module_teal_module
129		.teal_navbar_insert_ui <- function(ui, where = "afterBegin", session = getDefaultReactiveDomain()) {
130	14x	insertUI(
131	14x	selector = ".teal-navbar",
132	14x	where = where,
133	14x	ui = ui,
134	14x	session = session
135		)
136		}
137
138		#' @rdname module_teal_module
139		.teal_navbar_menu <- function(..., id = NULL, label = NULL, class = NULL, icon = NULL) {
140	6x	tags$div(
141	6x	class = "dropdown nav-item-custom",
142	6x	.dropdown_button(
143	6x	id = id,
144	6x	label = label,
145	6x	icon = icon
146		),
147	6x	tags$div(
148	6x	class = "dropdown-menu",
149	6x	tags$ul(class = class, !!!rlang::list2(...))
150		)
151		)
152		}
153
154		#' @rdname module_teal_module
155		.ui_teal_module <- function(id, modules, active_module_id) {
156	6x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module", "shiny.tag"))
157	6x	UseMethod(".ui_teal_module", modules)
158		}
159
160		#' @rdname module_teal_module
161		#' @export
162		.ui_teal_module.default <- function(id, modules, active_module_id) {
163	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
164		}
165
166		#' @rdname module_teal_module
167		#' @export
168		.ui_teal_module.teal_modules <- function(id, modules, active_module_id) {
169	3x	items <- mapply(
170	3x	FUN = .ui_teal_module,
171	3x	id = NS(id, .label_to_id(sapply(modules$children, `[[`, "label"))),
172	3x	modules = modules$children,
173	3x	active_module_id = active_module_id,
174	3x	SIMPLIFY = FALSE
175		)
176
177	3x	list(
178	3x	link = tagList(
179	3x	if (length(modules$label)) tags$li(tags$span(modules$label, class = "module-group-label")),
180	3x	tags$li(tags$ul(lapply(items, `[[`, "link")))
181		),
182	3x	tab_pane = tagList(lapply(items, `[[`, "tab_pane"))
183		)
184		}
185
186		#' @rdname module_teal_module
187		#' @export
188		.ui_teal_module.teal_module <- function(id, modules, active_module_id) {
189	3x	ns <- NS(id)
190	3x	args <- c(list(id = ns("module")), modules$ui_args)
191	3x	ui_teal <- tags$div(
192	3x	shinyjs::hidden(
193	3x	tags$div(
194	3x	id = ns("transform_failure_info"),
195	3x	class = "teal_validated",
196	3x	div(
197	3x	class = "teal-output-warning",
198	3x	"One of transformators failed. Please check its inputs."
199		)
200		)
201		),
202	3x	tags$div(
203	3x	id = ns("teal_module_ui"),
204	3x	tags$div(
205	3x	class = "teal_validated",
206	3x	ui_check_module_datanames(ns("validate_datanames"))
207		),
208	3x	do.call(what = modules$ui, args = args, quote = TRUE)
209		)
210		)
211	3x	container_id <- ns("wrapper")
212	3x	module_id <- modules$path
213
214	3x	link <- tags$li(
215	3x	tags$a(
216	3x	href = paste0("#", container_id), # links button with module content in `tab-content` with same id.
217	3x	`data-bs-toggle` = "tab", # signals shiny to treat this element as bootstrap tab buttons for toggle.
218	3x	`data-value` = module_id, # this data is set as the shiny input.
219	3x	class = c("nav-link", "module-button", "btn-default", if (identical(module_id, active_module_id)) "active"),
220		# `nav-link` is required to mimic bslib tab panel.
221	3x	modules$label
222		)
223		)
224
225	3x	tab_pane <- div(
226	3x	id = container_id,
227	3x	class = c("tab-pane", "teal_module", if (identical(module_id, active_module_id)) "active"),
228	3x	tagList(
229	3x	tags$div(
230	3x	style = "display: flex; justify-content: space-between; align-items: center; width: 100%;",
231	3x	.modules_breadcrumb(modules),
232	3x	tags$div(
233	3x	style = "display: flex; gap: 0.5em;",
234	3x	ui_add_reporter(ns("add_reporter_wrapper")),
235	3x	ui_source_code(ns("source_code_wrapper"))
236		)
237		),
238	3x	if (!is.null(modules$datanames)) {
239	3x	tagList(
240	3x	bslib::layout_sidebar(
241	3x	class = "teal-sidebar-layout",
242	3x	sidebar = bslib::sidebar(
243	3x	id = ns("teal_module_sidebar"),
244	3x	class = "teal-sidebar",
245	3x	position = getOption("teal.sidebar.position", "left"),
246	3x	width = getOption("teal.sidebar.width", 250),
247	3x	tags$div(
248	3x	tags$div(
249	3x	class = "teal-active-data-summary-panel",
250	3x	bslib::accordion(
251	3x	id = ns("data_summary_accordion"),
252	3x	bslib::accordion_panel(
253	3x	"Active Data Summary",
254	3x	tags$div(
255	3x	class = "teal-active-data-summary",
256	3x	ui_data_summary(ns("data_summary"))
257		)
258		)
259		)
260		),
261	3x	tags$br(),
262	3x	tags$div(
263	3x	class = "teal-filter-panel",
264	3x	ui_filter_data(ns("filter_panel"))
265		),
266	3x	if (length(modules$transformators) > 0 && !isTRUE(attr(modules$transformators, "custom_ui"))) {
267	!	tags$div(
268	!	tags$br(),
269	!	tags$div(
270	!	class = "teal-transform-panel",
271	!	bslib::accordion(
272	!	id = ns("data_transform_accordion"),
273	!	bslib::accordion_panel(
274	!	"Transform Data",
275	!	ui_transform_teal_data(
276	!	ns("data_transform"),
277	!	transformators = modules$transformators
278		)
279		)
280		)
281		)
282		)
283		}
284		)
285		),
286	3x	ui_teal
287		),
288	3x	div(
289	3x	id = ns("sidebar_toggle_buttons"),
290	3x	class = "sidebar-toggle-buttons",
291	3x	actionButton(
292	3x	class = "data-summary-toggle btn-outline-primary",
293	3x	ns("data_summary_toggle"),
294	3x	icon("fas fa-list")
295		),
296	3x	actionButton(
297	3x	class = "data-filters-toggle btn-outline-secondary",
298	3x	ns("data_filters_toggle"),
299	3x	icon("fas fa-filter")
300		),
301	3x	if (length(modules$transformators) > 0) {
302	!	actionButton(
303	!	class = "data-transforms-toggle btn-outline-primary",
304	!	ns("data_transforms_toggle"),
305	!	icon("fas fa-pen-to-square")
306		)
307		}
308		),
309	3x	tags$script(
310	3x	HTML(
311	3x	sprintf(
312		"
313	3x	$(document).ready(function() {
314	3x	$('#%s').insertAfter('#%s > .bslib-sidebar-layout > button.collapse-toggle');
315		});
316		",
317	3x	ns("sidebar_toggle_buttons"),
318	3x	ns("wrapper")
319		)
320		)
321		)
322		)
323		} else {
324	!	ui_teal
325		}
326		)
327		)
328
329	3x	list(link = link, tab_pane = tab_pane)
330		}
331
332		#' @rdname module_teal_module
333		.srv_teal_module <- function(id,
334		data,
335		modules,
336		datasets = NULL,
337		slices_global,
338		reporter = teal.reporter::Reporter$new(),
339		data_load_status = reactive("ok"),
340		active_module_id = reactive(TRUE)) {
341	290x	checkmate::assert_string(id)
342	290x	assert_reactive(data)
343	290x	checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
344	290x	assert_reactive(datasets, null.ok = TRUE)
345	290x	checkmate::assert_class(slices_global, ".slicesGlobal")
346	290x	checkmate::assert_class(reporter, "Reporter", null.ok = TRUE)
347	290x	assert_reactive(data_load_status)
348	290x	UseMethod(".srv_teal_module", modules)
349		}
350
351		#' @rdname module_teal_module
352		#' @export
353		.srv_teal_module.default <- function(id,
354		data,
355		modules,
356		datasets = NULL,
357		slices_global,
358		reporter = teal.reporter::Reporter$new(),
359		data_load_status = reactive("ok"),
360		active_module_id = reactive(TRUE)) {
361	!	stop("Modules class not supported: ", paste(class(modules), collapse = " "))
362		}
363
364		#' @rdname module_teal_module
365		#' @export
366		.srv_teal_module.teal_modules <- function(id,
367		data,
368		modules,
369		datasets = NULL,
370		slices_global,
371		reporter = teal.reporter::Reporter$new(),
372		data_load_status = reactive("ok"),
373		active_module_id = reactive(TRUE)) {
374	132x	moduleServer(id = id, module = function(input, output, session) {
375	132x	logger::log_debug("srv_teal_module.teal_modules initializing the module { deparse1(modules$label) }.")
376	132x	modules_output <- mapply(
377	132x	function(id, modules) {
378	158x	.srv_teal_module(
379	158x	id = id,
380	158x	modules = modules,
381	158x	data = data,
382	158x	datasets = datasets,
383	158x	slices_global = slices_global,
384	158x	reporter = reporter,
385	158x	data_load_status = data_load_status,
386	158x	active_module_id = active_module_id
387		)
388		},
389	132x	id = .label_to_id(sapply(modules$children, `[[`, "label")),
390	132x	modules = modules$children,
391	132x	SIMPLIFY = FALSE
392		)
393
394	132x	modules_output
395		})
396		}
397
398		#' @rdname module_teal_module
399		#' @export
400		.srv_teal_module.teal_module <- function(id,
401		data,
402		modules,
403		datasets = NULL,
404		slices_global,
405		reporter = teal.reporter::Reporter$new(),
406		data_load_status = reactive("ok"),
407		active_module_id = reactive(TRUE)) {
408	158x	logger::log_debug("srv_teal_module.teal_module initializing the module: { deparse1(modules$label) }.")
409	158x	moduleServer(id = id, module = function(input, output, session) {
410	158x	module_out <- reactiveVal()
411	158x	module_id <- modules$path
412	158x	is_active <- reactive({
413	172x	identical(data_load_status(), "ok") && identical(module_id, active_module_id())
414		})
415	158x	active_datanames <- reactive({
416	107x	.resolve_module_datanames(data = data(), modules = modules)
417		})
418	158x	if (is.null(datasets)) {
419	20x	datasets <- eventReactive(data(), {
420	16x	req(inherits(data(), "teal_data"))
421	16x	logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
422	16x	teal_data_to_filtered_data(data(), datanames = active_datanames())
423		})
424		}
425
426		# manage module filters on the module level
427		# important:
428		# filter_manager_module_srv needs to be called before filter_panel_srv
429		# Because available_teal_slices is used in FilteredData$srv_available_slices (via srv_filter_panel)
430		# and if it is not set, then it won't be available in the srv_filter_panel
431	158x	srv_module_filter_manager(modules$label, module_fd = datasets, slices_global = slices_global)
432
433	158x	.call_once_when(is_active(), {
434	104x	filtered_teal_data <- srv_filter_data(
435	104x	"filter_panel",
436	104x	datasets = datasets,
437	104x	active_datanames = active_datanames,
438	104x	data = data,
439	104x	is_active = is_active
440		)
441	104x	is_transform_failed <- reactiveValues()
442	104x	transformed_teal_data <- srv_transform_teal_data(
443	104x	"data_transform",
444	104x	data = filtered_teal_data,
445	104x	transformators = modules$transformators,
446	104x	modules = modules,
447	104x	is_transform_failed = is_transform_failed
448		)
449	104x	any_transform_failed <- reactive({
450	113x	any(unlist(reactiveValuesToList(is_transform_failed)))
451		})
452
453	104x	observeEvent(any_transform_failed(), {
454	113x	if (isTRUE(any_transform_failed())) {
455	6x	shinyjs::hide("teal_module_ui")
456	6x	shinyjs::show("transform_failure_info")
457		} else {
458	107x	shinyjs::show("teal_module_ui")
459	107x	shinyjs::hide("transform_failure_info")
460		}
461		})
462
463	104x	module_teal_data <- reactive({
464	123x	req(inherits(transformed_teal_data(), "teal_data"))
465	106x	all_teal_data <- transformed_teal_data()
466	106x	module_datanames <- .resolve_module_datanames(data = all_teal_data, modules = modules)
467	106x	all_teal_data[c(module_datanames, ".raw_data")]
468		})
469
470	104x	srv_check_module_datanames(
471	104x	"validate_datanames",
472	104x	data = module_teal_data,
473	104x	modules = modules
474		)
475
476	104x	summary_table <- srv_data_summary("data_summary", module_teal_data)
477
478	104x	observeEvent(input$data_summary_toggle, {
479	!	bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
480	!	bslib::accordion_panel_open(id = "data_summary_accordion", values = TRUE)
481	!	bslib::accordion_panel_close(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
482	!	bslib::accordion_panel_close(id = "data_transform_accordion", values = TRUE)
483		})
484
485	104x	observeEvent(input$data_filters_toggle, {
486	!	bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
487	!	bslib::accordion_panel_close(id = "data_summary_accordion", values = TRUE)
488	!	bslib::accordion_panel_open(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
489	!	bslib::accordion_panel_close(id = "data_transform_accordion", values = TRUE)
490		})
491
492	104x	observeEvent(input$data_transforms_toggle, {
493	!	bslib::toggle_sidebar(id = "teal_module_sidebar", open = TRUE)
494	!	bslib::accordion_panel_close(id = "data_summary_accordion", values = TRUE)
495	!	bslib::accordion_panel_close(id = "filter_panel-filters-main_filter_accordion", values = TRUE)
496	!	bslib::accordion_panel_open(id = "data_transform_accordion", values = TRUE)
497		})
498
499		# Call modules.
500	104x	obs_module <- .call_once_when(
501	104x	!is.null(module_teal_data()),
502	104x	ignoreNULL = TRUE,
503	104x	handlerExpr = {
504	98x	out <- .call_teal_module(modules, datasets, module_teal_data, reporter)
505	98x	srv_add_reporter("add_reporter_wrapper", module_out = out, reporter = reporter, module_label = modules$label)
506	98x	srv_source_code("source_code_wrapper", out)
507	98x	module_out(out)
508		}
509		)
510		})
511	158x	module_out
512		})
513		}
514
515		# This function calls a module server function.
516		.call_teal_module <- function(modules, datasets, data, reporter) {
517	98x	assert_reactive(data)
518
519		# collect arguments to run teal_module
520	98x	args <- c(list(id = "module"), modules$server_args)
521	98x	if (is_arg_used(modules$server, "reporter") && !is.null(reporter)) {
522	1x	args <- c(args, list(reporter = reporter))
523		}
524
525	98x	if (is_arg_used(modules$server, "datasets")) {
526	1x	args <- c(args, datasets = datasets())
527	1x	warning("datasets argument is not reactive and therefore it won't be updated when data is refreshed.")
528		}
529
530	98x	if (is_arg_used(modules$server, "data")) {
531	93x	args <- c(args, data = list(data))
532		}
533
534	98x	if (is_arg_used(modules$server, "filter_panel_api")) {
535	1x	args <- c(args, filter_panel_api = teal.slice::FilterPanelAPI$new(datasets()))
536		}
537
538	98x	if (is_arg_used(modules$server, "id")) {
539	97x	do.call(what = modules$server, args = args, quote = TRUE)
540		} else {
541	1x	do.call(what = callModule, args = c(args, list(module = modules$server)), quote = TRUE)
542		}
543		}
544
545		.resolve_module_datanames <- function(data, modules) {
546	213x	stopifnot("data must be teal_data object." = inherits(data, "teal_data"))
547	213x	if (is.null(modules$datanames) \|\| identical(modules$datanames, "all")) {
548	181x	names(data)
549		} else {
550	32x	intersect(
551	32x	names(data), # Keep topological order from teal.data::names()
552	32x	.include_parent_datanames(modules$datanames, teal.data::join_keys(data))
553		)
554		}
555		}
556
557		#' Calls expression when condition is met
558		#'
559		#' Function postpones `handlerExpr` to the moment when `eventExpr` (condition) returns `TRUE`,
560		#' otherwise nothing happens.
561		#' @param eventExpr A (quoted or unquoted) logical expression that represents the event;
562		#' this can be a simple reactive value like input$click, a call to a reactive expression
563		#' like dataset(), or even a complex expression inside curly braces.
564		#' @param ... additional arguments passed to `observeEvent` with the exception of `eventExpr` that is not allowed.
565		#' @inheritParams shiny::observeEvent
566		#'
567		#' @return An observer.
568		#'
569		#' @keywords internal
570		.call_once_when <- function(eventExpr, # nolint: object_name.
571		handlerExpr, # nolint: object_name.
572		event.env = parent.frame(), # nolint: object_name.
573		handler.env = parent.frame(), # nolint: object_name.
574		...) {
575	288x	event_quo <- rlang::new_quosure(substitute(eventExpr), env = event.env)
576	288x	handler_quo <- rlang::new_quosure(substitute(handlerExpr), env = handler.env)
577
578		# When `condExpr` is TRUE, then `handlerExpr` is evaluated once.
579	288x	activator <- reactive({
580	305x	if (isTRUE(rlang::eval_tidy(event_quo))) {
581	228x	TRUE
582		}
583		})
584
585	288x	observeEvent(
586	288x	eventExpr = activator(),
587	288x	once = TRUE,
588	288x	handlerExpr = rlang::eval_tidy(handler_quo),
589		...
590		)
591		}
592
593		.modules_breadcrumb <- function(module) {
594	3x	tags$div(
595	3x	style = "color: var(--bs-secondary); font-size: large; opacity: 0.6; margin: 0 0.5em 0.5em 0.5em;",
596	3x	paste("Home", module$path, sep = " / ")
597		)
598		}

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

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

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

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

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

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

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

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

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

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

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

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	3x	css_files <- list.files(
13	3x	system.file("css", package = "teal", mustWork = TRUE),
14	3x	pattern = pattern, full.names = TRUE
15		)
16
17	3x	singleton(
18	3x	tags$head(lapply(css_files, includeCSS))
19		)
20		}
21
22		#' Code to include `teal` `CSS` and `JavaScript` files
23		#'
24		#' This is useful when you want to use the same `JavaScript` and `CSS` files that are
25		#' used with the `teal` application.
26		#' This is also useful for running standalone modules in `teal` with the correct
27		#' styles.
28		#' Also initializes `shinyjs` so you can use it.
29		#'
30		#' Simply add `include_teal_css_js()` as one of the UI elements.
31		#' @return A `shiny.tag.list`.
32		#' @keywords internal
33		include_teal_css_js <- function() {
34	3x	tagList(
35	3x	shinyjs::useShinyjs(),
36	3x	include_css_files()
37		)
38		}