| 1 |
- #' Get Client Timezone+ #' Filter state snapshot management. |
||
| 3 |
- #' Local timezone in the browser may differ from the system timezone from the server.+ #' Capture and restore snapshots of the global (app) filter state. |
||
| 4 |
- #' This script can be run to register a shiny input which contains information about+ #' |
||
| 5 |
- #' the timezone in the browser.+ #' 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 |
- #' @param ns (`function`) namespace function passed from the `session` object in the+ #' as well as to save it to file in order to share it with an app developer or other users, |
||
| 8 |
- #' Shiny server. For Shiny modules this will allow for proper name spacing of the+ #' who in turn can upload it to their own session. |
||
| 9 |
- #' registered input.+ #' |
||
| 10 |
- #'+ #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner. |
||
| 11 |
- #' @return (`Shiny`) input variable accessible with `input$tz` which is a (`character`)+ #' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow. |
||
| 12 |
- #' string containing the timezone of the browser/client.+ #' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file |
||
| 13 |
- #' @keywords internal+ #' and applies the filter states therein, and clicking the arrow resets initial application state. |
||
| 14 |
- get_client_timezone <- function(ns) {
+ #' 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 | -18x | +
- script <- sprintf(+ #' |
|
| 16 | -18x | +
- "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",+ #' @section Server logic: |
|
| 17 | -18x | +
- ns("timezone")
+ #' 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 | -18x | +
- shinyjs::runjs(script) # function does not return anything+ #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation |
|
| 20 | -18x | +
- return(invisible(NULL))+ #' (attributes are maintained). |
|
| 21 |
- }+ #' |
||
| 22 |
-
+ #' Snapshots are stored in a `reactiveVal` as a named list. |
||
| 23 |
- #' Resolve the expected bootstrap theme+ #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit. |
||
| 24 |
- #' @keywords internal+ #' |
||
| 25 |
- get_teal_bs_theme <- function() {
+ #' For every snapshot except the initial one, a piece of UI is generated that contains |
||
| 26 | -16x | +
- bs_theme <- getOption("teal.bs_theme")
+ #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file. |
|
| 27 | -16x | +
- if (is.null(bs_theme)) {
+ #' The initial snapshot is restored by a separate "reset" button. |
|
| 28 | -13x | +
- NULL+ #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that. |
|
| 29 | -3x | +
- } else if (!inherits(bs_theme, "bs_theme")) {
+ #' |
|
| 30 | -2x | +
- warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
+ #' @section Snapshot mechanics: |
|
| 31 | -2x | +
- NULL+ #' When a snapshot is captured, the user is prompted to name it. |
|
| 32 |
- } else {
+ #' Names are displayed as is but since they are used to create button ids, |
||
| 33 | -1x | +
- bs_theme+ #' 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 |
- include_parent_datanames <- function(dataname, join_keys) {
+ #' The module can read the global state of the application from `slices_global` and `mapping_matrix`. |
||
| 38 | -3x | +
- parents <- character(0)+ #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module. |
|
| 39 | -3x | +
- for (i in dataname) {
+ #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot. |
|
| 40 | -6x | +
- while (length(i) > 0) {
+ #' The snapshot contains the `mapping` attribute of the initial application state |
|
| 41 | -6x | +
- parent_i <- teal.data::parent(join_keys, i)+ #' (or one that has been restored), which may not reflect the current one, |
|
| 42 | -6x | +
- parents <- c(parent_i, parents)+ #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that, |
|
| 43 | -6x | +
- i <- parent_i+ #' when passed to the `mapping` argument of [`teal::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 | -3x | +
- return(unique(c(parents, dataname)))+ #' Then state of all `FilteredData` objects (provided in `filtered_data_list`) 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 |
- #' Create a `FilteredData`+ #' and then saved to file with [`slices_store`]. |
||
| 54 |
- #' Create a `FilteredData` object from a `teal_data` object+ #' When a snapshot is uploaded, it will first be added to storage just like a newly created one, |
||
| 55 |
- #' @param x (`teal_data`) object+ #' and then used to restore app state much like a snapshot taken from storage. |
||
| 56 |
- #' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)`+ #' Upon clicking the upload icon the user will be prompted for a file to upload |
||
| 57 |
- #' @return (`FilteredData`) object+ #' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped) |
||
| 58 |
- #' @keywords internal+ #' and normal naming rules apply. Loading the file yields a `teal_slices` object, |
||
| 59 |
- teal_data_to_filtered_data <- function(x, datanames = teal.data::datanames(x)) {
+ #' which is disassembled for storage and used directly for restoring app state. |
||
| 60 | -12x | +
- checkmate::assert_class(x, "teal_data")+ #' |
|
| 61 | -12x | +
- checkmate::assert_character(datanames, min.len = 1L, any.missing = FALSE)+ #' @section Transferring snapshots: |
|
| 62 | -12x | +
- checkmate::assert_subset(datanames, teal.data::datanames(x))+ #' 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 | -12x | +
- ans <- teal.slice::init_filtered_data(+ #' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of |
|
| 65 | -12x | +
- x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE),+ #' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that |
|
| 66 | -12x | +
- join_keys = teal.data::join_keys(x)+ #' of the current app state and only if the match is the snapshot admitted to the session. |
|
| 67 |
- )+ #' |
||
| 68 |
- # Piggy-back entire pre-processing code so that filtering code can be appended later.+ #' @param id (`character(1)`) `shiny` module id |
||
| 69 | -12x | +
- attr(ans, "preprocessing_code") <- teal.code::get_code(x)+ #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object |
|
| 70 | -12x | +
- ans+ #' containing all `teal_slice`s existing in the app, both active and inactive |
|
| 71 |
- }+ #' @param mapping_matrix (`reactive`) that contains a `data.frame` representation |
||
| 72 |
-
+ #' of the mapping of filter state ids (rows) to modules labels (columns); |
||
| 73 |
- #' Template Function for `TealReportCard` Creation and Customization+ #' all columns are `logical` vectors |
||
| 74 |
- #'+ #' @param filtered_data_list non-nested (`named list`) that contains `FilteredData` objects |
||
| 75 |
- #' This function generates a report card with a title,+ #' |
||
| 76 |
- #' an optional description, and the option to append the filter state list.+ #' @return Nothing is returned. |
||
| 78 |
- #' @param title (`character(1)`) title of the card (unless overwritten by label)+ #' @name snapshot_manager_module |
||
| 79 |
- #' @param label (`character(1)`) label provided by the user when adding the card+ #' @aliases snapshot snapshot_manager |
||
| 80 |
- #' @param description (`character(1)`) optional additional description+ #' |
||
| 81 |
- #' @param with_filter (`logical(1)`) flag indicating to add filter state+ #' @author Aleksander Chlebowski |
||
| 82 |
- #' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation+ #' |
||
| 83 |
- #' of the filter state in the report+ #' @rdname snapshot_manager_module |
||
| 84 |
- #'+ #' @keywords internal |
||
| 85 |
- #' @return (`TealReportCard`) populated with a title, description and filter state+ #' |
||
| 86 |
- #'+ snapshot_manager_ui <- function(id) {
|
||
| 87 | -+ | ! |
- #' @export+ ns <- NS(id) |
| 88 | -+ | ! |
- report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
+ div( |
| 89 | -2x | +! |
- checkmate::assert_string(title)+ class = "snapshot_manager_content", |
| 90 | -2x | +! |
- checkmate::assert_string(label)+ div( |
| 91 | -2x | +! |
- checkmate::assert_string(description, null.ok = TRUE)+ class = "snapshot_table_row", |
| 92 | -2x | +! |
- checkmate::assert_flag(with_filter)+ span(tags$b("Snapshot manager")),
|
| 93 | -2x | +! |
- checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")+ actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
|
| 94 | -+ | ! |
-
+ actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"),
|
| 95 | -2x | +! |
- card <- teal::TealReportCard$new()+ actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
|
| 96 | -2x | +! |
- title <- if (label == "") title else label+ NULL |
| 97 | -2x | +
- card$set_name(title)+ ), |
|
| 98 | -2x | +! |
- card$append_text(title, "header2")+ uiOutput(ns("snapshot_list"))
|
| 99 | -1x | +
- if (!is.null(description)) card$append_text(description, "header3")+ ) |
|
| 100 | -1x | +
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ } |
|
| 101 | -2x | +
- card+ |
|
| 102 |
- }+ #' @rdname snapshot_manager_module |
||
| 103 |
- #' Resolve `datanames` for the modules+ #' @keywords internal |
||
| 105 |
- #' Modifies `module$datanames` to include names of the parent dataset (taken from `join_keys`).+ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
|
||
| 106 | -+ | 6x |
- #' When `datanames` is set to `"all"` it is replaced with all available datasets names.+ checkmate::assert_character(id) |
| 107 | -+ | 6x |
- #' @param modules (`teal_modules`) object+ checkmate::assert_true(is.reactive(slices_global)) |
| 108 | -+ | 6x |
- #' @param datanames (`character`) names of datasets available in the `data` object+ checkmate::assert_class(isolate(slices_global()), "teal_slices") |
| 109 | -+ | 6x |
- #' @param join_keys (`join_keys`) object+ checkmate::assert_true(is.reactive(mapping_matrix)) |
| 110 | -+ | 6x |
- #' @return `teal_modules` with resolved `datanames`+ checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE) |
| 111 | -+ | 6x |
- #' @keywords internal+ checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named") |
| 112 |
- resolve_modules_datanames <- function(modules, datanames, join_keys) {
+
|
||
| 113 | -! | +6x |
- if (inherits(modules, "teal_modules")) {
+ moduleServer(id, function(input, output, session) {
|
| 114 | -! | +6x |
- modules$children <- sapply(+ ns <- session$ns |
| 115 | -! | +
- modules$children,+ |
|
| 116 | -! | +
- resolve_modules_datanames,+ # Store global filter states ---- |
|
| 117 | -! | +6x |
- simplify = FALSE,+ filter <- isolate(slices_global()) |
| 118 | -! | +6x |
- datanames = datanames,+ snapshot_history <- reactiveVal({
|
| 119 | -! | +6x |
- join_keys = join_keys+ list( |
| 120 | -+ | 6x |
- )+ "Initial application state" = as.list(filter, recursive = TRUE) |
| 121 | -! | +
- modules+ ) |
|
| 122 |
- } else {
+ }) |
||
| 123 | -! | +
- modules$datanames <- if (identical(modules$datanames, "all")) {
+
|
|
| 124 | -! | +
- datanames+ # Snapshot current application state ---- |
|
| 125 | -! | +
- } else if (is.character(modules$datanames)) {
+ # Name snaphsot. |
|
| 126 | -! | +6x |
- extra_datanames <- setdiff(modules$datanames, datanames)+ observeEvent(input$snapshot_add, {
|
| 127 | ! |
- if (length(extra_datanames)) {
+ showModal( |
|
| 128 | ! |
- stop(+ modalDialog( |
|
| 129 | ! |
- sprintf(+ textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
|
|
| 130 | ! |
- "Module %s has datanames that are not available in a 'data':\n %s not in %s",+ footer = tagList( |
|
| 131 | ! |
- modules$label,+ actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
|
|
| 132 | ! |
- toString(extra_datanames),+ modalButton(label = "Cancel", icon = icon("thumbs-down"))
|
|
| 133 | -! | +
- toString(datanames)+ ), |
|
| 134 | -+ | ! |
- )+ size = "s" |
| 136 |
- }+ ) |
||
| 137 | -! | +
- datanames_adjusted <- intersect(modules$datanames, datanames)+ }) |
|
| 138 | -! | +
- include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)+ # Store snaphsot. |
|
| 139 | -+ | 6x |
- }+ observeEvent(input$snapshot_name_accept, {
|
| 140 | ! |
- modules+ snapshot_name <- trimws(input$snapshot_name) |
|
| 141 | -+ | ! |
- }+ if (identical(snapshot_name, "")) {
|
| 142 | -+ | ! |
- }+ showNotification( |
| 143 | -+ | ! |
-
+ "Please name the snapshot.", |
| 144 | -+ | ! |
- #' Check `datanames` in modules+ type = "message" |
| 145 |
- #'+ ) |
||
| 146 | -+ | ! |
- #' This function ensures specified `datanames` in modules match those in the data object,+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
| 147 | -+ | ! |
- #' returning error messages or `TRUE` for successful validation.+ } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
|
| 148 | -+ | ! |
- #'+ showNotification( |
| 149 | -+ | ! |
- #' @param modules (`teal_modules`) object+ "This name is in conflict with other snapshot names. Please choose a different one.", |
| 150 | -+ | ! |
- #' @param datanames (`character`) names of datasets available in the `data` object+ type = "message" |
| 151 |
- #'+ ) |
||
| 152 | -+ | ! |
- #' @return A `character(1)` containing error message or `TRUE` if validation passes.+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
| 153 |
- #' @keywords internal+ } else {
|
||
| 154 | -+ | ! |
- check_modules_datanames <- function(modules, datanames) {
+ snapshot <- as.list(slices_global(), recursive = TRUE) |
| 155 | -16x | +! |
- checkmate::assert_class(modules, "teal_modules")+ attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix()) |
| 156 | -16x | +! |
- checkmate::assert_character(datanames)+ snapshot_update <- c(snapshot_history(), list(snapshot)) |
| 157 | -+ | ! |
-
+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name |
| 158 | -16x | +! |
- recursive_check_datanames <- function(modules, datanames) {
+ snapshot_history(snapshot_update) |
| 159 | -+ | ! |
- # check teal_modules against datanames+ removeModal() |
| 160 | -34x | +
- if (inherits(modules, "teal_modules")) {
+ # Reopen filter manager modal by clicking button in the main application. |
|
| 161 | -16x | +! |
- sapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))+ shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE) |
| 162 |
- } else {
+ } |
||
| 163 | -18x | +
- extra_datanames <- setdiff(modules$datanames, c("all", datanames))
+ }) |
|
| 164 | -18x | +
- if (length(extra_datanames)) {
+
|
|
| 165 | -2x | +
- sprintf(+ # Upload a snapshot file ---- |
|
| 166 | -2x | +
- "- Module '%s' uses datanames not available in 'data': (%s) not in (%s)",+ # Select file. |
|
| 167 | -2x | +6x |
- modules$label,+ observeEvent(input$snapshot_load, {
|
| 168 | -2x | +! |
- toString(dQuote(extra_datanames, q = FALSE)),+ showModal( |
| 169 | -2x | +! |
- toString(dQuote(datanames, q = FALSE))+ modalDialog( |
| 170 | -+ | ! |
- )+ fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
|
| 171 | -+ | ! |
- }+ textInput( |
| 172 | -+ | ! |
- }+ ns("snapshot_name"),
|
| 173 | -+ | ! |
- }+ "Name the snapshot (optional)", |
| 174 | -16x | +! |
- check_datanames <- unlist(recursive_check_datanames(modules, datanames))+ width = "100%", |
| 175 | -16x | +! |
- if (length(check_datanames)) {
+ placeholder = "Meaningful, unique name" |
| 176 | -2x | +
- paste(check_datanames, collapse = "\n")+ ), |
|
| 177 | -+ | ! |
- } else {
+ footer = tagList( |
| 178 | -14x | +! |
- TRUE+ actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("thumbs-up")),
|
| 179 | -+ | ! |
- }+ modalButton(label = "Cancel", icon = icon("thumbs-down"))
|
| 180 |
- }+ ) |
||
| 181 |
-
+ ) |
||
| 182 |
- #' Check `datanames` in filters+ ) |
||
| 183 |
- #'+ }) |
||
| 184 |
- #' This function checks whether `datanames` in filters correspond to those in `data`,+ # Store new snapshot to list and restore filter states. |
||
| 185 | -+ | 6x |
- #' returning character vector with error messages or TRUE if all checks pass.+ observeEvent(input$snaphot_file_accept, {
|
| 186 | -+ | ! |
- #'+ snapshot_name <- trimws(input$snapshot_name) |
| 187 | -+ | ! |
- #' @param filters (`teal_slices`) object+ if (identical(snapshot_name, "")) {
|
| 188 | -+ | ! |
- #' @param datanames (`character`) names of datasets available in the `data` object+ snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name) |
| 189 |
- #'+ } |
||
| 190 | -+ | ! |
- #' @return A `character(1)` containing error message or TRUE if validation passes.+ if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
|
| 191 | -+ | ! |
- #' @keywords internal+ showNotification( |
| 192 | -+ | ! |
- check_filter_datanames <- function(filters, datanames) {
+ "This name is in conflict with other snapshot names. Please choose a different one.", |
| 193 | -14x | +! |
- checkmate::assert_class(filters, "teal_slices")+ type = "message" |
| 194 | -14x | +
- checkmate::assert_character(datanames)+ ) |
|
| 195 | -+ | ! |
-
+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
| 196 |
- # check teal_slices against datanames+ } else {
|
||
| 197 | -14x | +
- out <- unlist(sapply(+ # Restore snapshot and verify app compatibility. |
|
| 198 | -14x | +! |
- filters, function(filter) {
+ snapshot_state <- try(slices_restore(input$snapshot_file$datapath)) |
| 199 | -3x | +! |
- dataname <- shiny::isolate(filter$dataname)+ if (!inherits(snapshot_state, "modules_teal_slices")) {
|
| 200 | -3x | +! |
- if (!dataname %in% datanames) {
+ showNotification( |
| 201 | -2x | +! |
- sprintf(+ "File appears to be corrupt.", |
| 202 | -2x | +! |
- "- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)",+ type = "error" |
| 203 | -2x | +
- shiny::isolate(filter$id),+ ) |
|
| 204 | -2x | +! |
- dQuote(dataname, q = FALSE),+ } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) {
|
| 205 | -2x | +! |
- toString(dQuote(datanames, q = FALSE))+ showNotification( |
| 206 | -+ | ! |
- )+ "This snapshot file is not compatible with the app and cannot be loaded.", |
| 207 | -+ | ! |
- }+ type = "warning" |
| 208 |
- }+ ) |
||
| 209 |
- ))+ } else {
|
||
| 210 |
-
+ # Add to snapshot history. |
||
| 211 | -+ | ! |
-
+ snapshot <- as.list(snapshot_state, recursive = TRUE) |
| 212 | -14x | +! |
- if (length(out)) {
+ snapshot_update <- c(snapshot_history(), list(snapshot)) |
| 213 | -2x | +! |
- paste(out, collapse = "\n")+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name |
| 214 | -+ | ! |
- } else {
+ snapshot_history(snapshot_update) |
| 215 | -12x | +
- TRUE+ ### Begin simplified restore procedure. ### |
|
| 216 | -+ | ! |
- }+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
| 217 | -+ | ! |
- }+ mapply( |
| 1 | -+ | ||
| 218 | +! |
- #' Creates a `teal_modules` object.+ function(filtered_data, filter_ids) {
|
|
| 2 | -+ | ||
| 219 | +! |
- #'+ filtered_data$clear_filter_states(force = TRUE) |
|
| 3 | -+ | ||
| 220 | +! |
- #' @description `r lifecycle::badge("stable")`
+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state) |
|
| 4 | -+ | ||
| 221 | +! |
- #' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object+ filtered_data$set_filter_state(slices) |
|
| 5 | +222 |
- #' containing the passed objects.+ }, |
|
| 6 | -+ | ||
| 223 | +! |
- #'+ filtered_data = filtered_data_list, |
|
| 7 | -+ | ||
| 224 | +! |
- #' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules`+ filter_ids = mapping_unfolded |
|
| 8 | +225 |
- #' shapes the navigation panel of a `teal` application.+ ) |
|
| 9 | -+ | ||
| 226 | +! |
- #'+ slices_global(snapshot_state) |
|
| 10 | -+ | ||
| 227 | +! |
- #' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details+ removeModal() |
|
| 11 | +228 |
- #' @param label (`character(1)`) label of modules collection (default `"root"`).+ ### End simplified restore procedure. ### |
|
| 12 | +229 |
- #' If using the `label` argument then it must be explicitly named.+ } |
|
| 13 | +230 |
- #' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
+ } |
|
| 14 | +231 |
- #'+ }) |
|
| 15 | +232 |
- #' @export+ # Apply newly added snapshot. |
|
| 16 | +233 |
- #'+ |
|
| 17 | +234 |
- #' @return object of class \code{teal_modules}. Object contains following fields
+ # Restore initial state ---- |
|
| 18 | -+ | ||
| 235 | +6x |
- #' - `label`: taken from the `label` argument+ observeEvent(input$snapshot_reset, {
|
|
| 19 | -+ | ||
| 236 | +! |
- #' - `children`: a list containing objects passed in `...`. List elements are named after+ s <- "Initial application state" |
|
| 20 | +237 |
- #' their `label` attribute converted to a valid `shiny` id.+ ### Begin restore procedure. ### |
|
| 21 | -+ | ||
| 238 | +! |
- #' @examples+ snapshot <- snapshot_history()[[s]] |
|
| 22 | -+ | ||
| 239 | +! |
- #' library(shiny)+ snapshot_state <- as.teal_slices(snapshot) |
|
| 23 | -+ | ||
| 240 | +! |
- #'+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
|
| 24 | -+ | ||
| 241 | +! |
- #' app <- init(+ mapply( |
|
| 25 | -+ | ||
| 242 | +! |
- #' data = teal_data(iris = iris),+ function(filtered_data, filter_ids) {
|
|
| 26 | -+ | ||
| 243 | +! |
- #' modules = modules(+ filtered_data$clear_filter_states(force = TRUE) |
|
| 27 | -+ | ||
| 244 | +! |
- #' label = "Modules",+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state) |
|
| 28 | -+ | ||
| 245 | +! |
- #' modules(+ filtered_data$set_filter_state(slices) |
|
| 29 | +246 |
- #' label = "Module",+ }, |
|
| 30 | -+ | ||
| 247 | +! |
- #' module(+ filtered_data = filtered_data_list, |
|
| 31 | -+ | ||
| 248 | +! |
- #' label = "Inner module",+ filter_ids = mapping_unfolded |
|
| 32 | +249 |
- #' server = function(id, data) {
+ ) |
|
| 33 | -+ | ||
| 250 | +! |
- #' moduleServer(+ slices_global(snapshot_state) |
|
| 34 | -+ | ||
| 251 | +! |
- #' id,+ removeModal() |
|
| 35 | +252 |
- #' module = function(input, output, session) {
+ ### End restore procedure. ### |
|
| 36 | +253 |
- #' output$data <- renderDataTable(data[["iris"]]())+ }) |
|
| 37 | +254 |
- #' }+ |
|
| 38 | +255 |
- #' )+ # Build snapshot table ---- |
|
| 39 | +256 |
- #' },+ # Create UI elements and server logic for the snapshot table. |
|
| 40 | +257 |
- #' ui = function(id) {
+ # Observers must be tracked to avoid duplication and excess reactivity. |
|
| 41 | +258 |
- #' ns <- NS(id)+ # Remaining elements are tracked likewise for consistency and a slight speed margin. |
|
| 42 | -+ | ||
| 259 | +6x |
- #' tagList(dataTableOutput(ns("data")))
+ observers <- reactiveValues() |
|
| 43 | -+ | ||
| 260 | +6x |
- #' },+ handlers <- reactiveValues() |
|
| 44 | -+ | ||
| 261 | +6x |
- #' datanames = "all"+ divs <- reactiveValues() |
|
| 45 | +262 |
- #' )+ |
|
| 46 | -+ | ||
| 263 | +6x |
- #' ),+ observeEvent(snapshot_history(), {
|
|
| 47 | -+ | ||
| 264 | +2x |
- #' module(+ lapply(names(snapshot_history())[-1L], function(s) {
|
|
| 48 | -+ | ||
| 265 | +! |
- #' label = "Another module",+ id_pickme <- sprintf("pickme_%s", make.names(s))
|
|
| 49 | -+ | ||
| 266 | +! |
- #' server = function(id) {
+ id_saveme <- sprintf("saveme_%s", make.names(s))
|
|
| 50 | -+ | ||
| 267 | +! |
- #' moduleServer(+ id_rowme <- sprintf("rowme_%s", make.names(s))
|
|
| 51 | +268 |
- #' id,+ |
|
| 52 | +269 |
- #' module = function(input, output, session) {
+ # Observer for restoring snapshot. |
|
| 53 | -+ | ||
| 270 | +! |
- #' output$text <- renderText("Another module")
- |
- |
| 54 | -- |
- #' }- |
- |
| 55 | -- |
- #' )- |
- |
| 56 | -- |
- #' },- |
- |
| 57 | -- |
- #' ui = function(id) {
- |
- |
| 58 | -- |
- #' ns <- NS(id)- |
- |
| 59 | -- |
- #' tagList(textOutput(ns("text")))
- |
- |
| 60 | -- |
- #' },- |
- |
| 61 | -- |
- #' datanames = NULL- |
- |
| 62 | -- |
- #' )- |
- |
| 63 | -- |
- #' )- |
- |
| 64 | -- |
- #' )- |
- |
| 65 | -- |
- #' if (interactive()) {
- |
- |
| 66 | -- |
- #' shinyApp(app$ui, app$server)- |
- |
| 67 | -- |
- #' }- |
- |
| 68 | -- |
- modules <- function(..., label = "root") {
- |
- |
| 69 | -109x | -
- checkmate::assert_string(label)- |
- |
| 70 | -107x | -
- submodules <- list(...)- |
- |
| 71 | -107x | -
- if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
- |
- |
| 72 | -2x | -
- stop(- |
- |
| 73 | -2x | -
- "The only character argument to modules() must be 'label' and it must be named, ",- |
- |
| 74 | -2x | -
- "change modules('lab', ...) to modules(label = 'lab', ...)"
- |
- |
| 75 | -- |
- )- |
- |
| 76 | -- |
- }- |
- |
| 77 | -- | - - | -|
| 78 | -105x | -
- checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
- |
- |
| 79 | -- |
- # name them so we can more easily access the children- |
- |
| 80 | -- |
- # beware however that the label of the submodules should not be changed as it must be kept synced- |
- |
| 81 | -102x | -
- labels <- vapply(submodules, function(submodule) submodule$label, character(1))- |
- |
| 82 | -102x | -
- names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
- |
- |
| 83 | -102x | -
- structure(- |
- |
| 84 | -102x | -
- list(- |
- |
| 85 | -102x | -
- label = label,+ if (!is.element(id_pickme, names(observers))) {
|
|
| 86 | -102x | +||
| 271 | +! |
- children = submodules+ observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
|
|
| 87 | +272 |
- ),- |
- |
| 88 | -102x | -
- class = "teal_modules"+ ### Begin restore procedure. ### |
|
| 89 | -+ | ||
| 273 | +! |
- )+ snapshot <- snapshot_history()[[s]] |
|
| 90 | -+ | ||
| 274 | +! |
- }+ snapshot_state <- as.teal_slices(snapshot) |
|
| 91 | -+ | ||
| 275 | +! |
-
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
|
| 92 | -+ | ||
| 276 | +! |
- #' Append a `teal_module` to `children` of a `teal_modules` object+ mapply( |
|
| 93 | -+ | ||
| 277 | +! |
- #' @keywords internal+ function(filtered_data, filter_ids) {
|
|
| 94 | -+ | ||
| 278 | +! |
- #' @param modules `teal_modules`+ filtered_data$clear_filter_states(force = TRUE) |
|
| 95 | -+ | ||
| 279 | +! |
- #' @param module `teal_module` object to be appended onto the children of `modules`+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state) |
|
| 96 | -+ | ||
| 280 | +! |
- #' @return `teal_modules` object with `module` appended+ filtered_data$set_filter_state(slices) |
|
| 97 | +281 |
- append_module <- function(modules, module) {
- |
- |
| 98 | -7x | -
- checkmate::assert_class(modules, "teal_modules")- |
- |
| 99 | -5x | -
- checkmate::assert_class(module, "teal_module")- |
- |
| 100 | -3x | -
- modules$children <- c(modules$children, list(module))- |
- |
| 101 | -3x | -
- labels <- vapply(modules$children, function(submodule) submodule$label, character(1))- |
- |
| 102 | -3x | -
- names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
- |
- |
| 103 | -3x | -
- modules+ }, |
|
| 104 | -+ | ||
| 282 | +! |
- }+ filtered_data = filtered_data_list, |
|
| 105 | -+ | ||
| 283 | +! |
-
+ filter_ids = mapping_unfolded |
|
| 106 | +284 |
- #' Extract/Remove module(s) of specific class+ ) |
|
| 107 | -+ | ||
| 285 | +! |
- #'+ slices_global(snapshot_state) |
|
| 108 | -+ | ||
| 286 | +! |
- #' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`.+ removeModal() |
|
| 109 | +287 |
- #'+ ### End restore procedure. ### |
|
| 110 | +288 |
- #' @param modules `teal_modules`+ }) |
|
| 111 | +289 |
- #' @param class The class name of `teal_module` to be extracted or dropped.+ } |
|
| 112 | +290 |
- #' @keywords internal+ # Create handler for downloading snapshot. |
|
| 113 | -+ | ||
| 291 | +! |
- #' @return+ if (!is.element(id_saveme, names(handlers))) {
|
|
| 114 | -+ | ||
| 292 | +! |
- #' For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`.+ output[[id_saveme]] <- downloadHandler( |
|
| 115 | -+ | ||
| 293 | +! |
- #' For `drop_module`, the opposite, which is all `teal_modules` of class other than `class`.+ filename = function() {
|
|
| 116 | -+ | ||
| 294 | +! |
- #' @rdname module_management+ sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
|
|
| 117 | +295 |
- extract_module <- function(modules, class) {
- |
- |
| 118 | -30x | -
- if (inherits(modules, class)) {
+ }, |
|
| 119 | +296 | ! |
- modules- |
-
| 120 | -30x | -
- } else if (inherits(modules, "teal_module")) {
- |
- |
| 121 | -16x | -
- NULL- |
- |
| 122 | -14x | -
- } else if (inherits(modules, "teal_modules")) {
+ content = function(file) {
|
|
| 123 | -14x | +||
| 297 | +! |
- Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class))+ snapshot <- snapshot_history()[[s]] |
|
| 124 | -+ | ||
| 298 | +! |
- }+ snapshot_state <- as.teal_slices(snapshot) |
|
| 125 | -+ | ||
| 299 | +! |
- }+ slices_store(tss = snapshot_state, file = file) |
|
| 126 | +300 |
-
+ } |
|
| 127 | +301 |
- #' @keywords internal+ ) |
|
| 128 | -+ | ||
| 302 | +! |
- #' @return `teal_modules`+ handlers[[id_saveme]] <- id_saveme |
|
| 129 | +303 |
- #' @rdname module_management+ } |
|
| 130 | +304 |
- drop_module <- function(modules, class) {
- |
- |
| 131 | -30x | -
- if (inherits(modules, class)) {
+ # Create a row for the snapshot table. |
|
| 132 | +305 | ! |
- NULL+ if (!is.element(id_rowme, names(divs))) {
|
| 133 | -30x | +||
| 306 | +! |
- } else if (inherits(modules, "teal_module")) {
+ divs[[id_rowme]] <- div( |
|
| 134 | -16x | +||
| 307 | +! |
- modules+ class = "snapshot_table_row", |
|
| 135 | -14x | +||
| 308 | +! |
- } else if (inherits(modules, "teal_modules")) {
+ span(h5(s)), |
|
| 136 | -14x | +||
| 309 | +! |
- do.call(+ actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
|
|
| 137 | -14x | +||
| 310 | +! |
- "modules",+ downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
|
|
| 138 | -14x | +||
| 311 | +
- c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label)+ ) |
||
| 139 | +312 |
- )+ } |
|
| 140 | +313 |
- }+ }) |
|
| 141 | +314 |
- }+ }) |
|
| 142 | +315 | ||
| 143 | +316 |
- #' Does the object make use of the `arg`+ # Create table to display list of snapshots and their actions. |
|
| 144 | -+ | ||
| 317 | +6x |
- #'+ output$snapshot_list <- renderUI({
|
|
| 145 | -+ | ||
| 318 | +2x |
- #' @param modules (`teal_module` or `teal_modules`) object+ rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d) |
|
| 146 | -+ | ||
| 319 | +2x |
- #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.+ if (length(rows) == 0L) {
|
|
| 147 | -+ | ||
| 320 | +2x |
- #' @return `logical` whether the object makes use of `arg`+ div( |
|
| 148 | -+ | ||
| 321 | +2x |
- #' @rdname is_arg_used+ class = "snapshot_manager_placeholder",+ |
+ |
| 322 | +2x | +
+ "Snapshots will appear here." |
|
| 149 | +323 |
- #' @keywords internal+ ) |
|
| 150 | +324 |
- is_arg_used <- function(modules, arg) {
+ } else {
|
|
| 151 | -286x | +||
| 325 | +! |
- checkmate::assert_string(arg)+ rows |
|
| 152 | -283x | +||
| 326 | +
- if (inherits(modules, "teal_modules")) {
+ } |
||
| 153 | -29x | +||
| 327 | +
- any(unlist(lapply(modules$children, is_arg_used, arg)))+ }) |
||
| 154 | -254x | +||
| 328 | +
- } else if (inherits(modules, "teal_module")) {
+ }) |
||
| 155 | -43x | +||
| 329 | +
- is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg)+ } |
||
| 156 | -211x | +||
| 330 | +
- } else if (is.function(modules)) {
+
|
||
| 157 | -209x | +||
| 331 | +
- isTRUE(arg %in% names(formals(modules)))+ |
||
| 158 | +332 |
- } else {
+
|
|
| 159 | -2x | +||
| 333 | +
- stop("is_arg_used function not implemented for this object")
+
|
||
| 160 | +334 |
- }+ ### utility functions ---- |
|
| 161 | +335 |
- }+ |
|
| 162 | +336 |
-
+ #' Explicitly enumerate global filters. |
|
| 163 | +337 |
-
+ #' |
|
| 164 | +338 |
- #' Creates a `teal_module` object.+ #' Transform module mapping such that global filters are explicitly specified for every module. |
|
| 165 | +339 |
#' |
|
| 166 | +340 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param mapping (`named list`) as stored in mapping parameter of `teal_slices` |
|
| 167 | +341 |
- #' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module.+ #' @param module_names (`character`) vector containing names of all modules in the app |
|
| 168 | +342 |
- #'+ #' @return A `named_list` with one element per module, each element containing all filters applied to that module. |
|
| 169 | +343 |
- #' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except+ #' @keywords internal |
|
| 170 | +344 |
- #' `"global_filters"` - read more in `mapping` argument of [teal::teal_slices].+ #' |
|
| 171 | +345 |
- #' @param server (`function`) `shiny` module with following arguments:+ unfold_mapping <- function(mapping, module_names) {
|
|
| 172 | -+ | ||
| 346 | +! |
- #' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]).+ module_names <- structure(module_names, names = module_names) |
|
| 173 | -+ | ||
| 347 | +! |
- #' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module.+ lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]])) |
|
| 174 | +348 |
- #' - `data` (optional) module will receive a `teal_data` object, a list of reactive (filtered) data specified in+ } |
|
| 175 | +349 |
- #' the `filters` argument.+ |
|
| 176 | +350 |
- #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ #' Convert mapping matrix to filter mapping specification. |
|
| 177 | +351 |
- #' - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]).+ #' |
|
| 178 | +352 |
- # - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).+ #' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module, |
|
| 179 | +353 |
- #' - `...` (optional) `server_args` elements will be passed to the module named argument or to the `...`.+ #' to a list specification like the one used in the `mapping` attribute of `teal_slices`. |
|
| 180 | +354 |
- #' @param ui (`function`) Shiny `ui` module function with following arguments:+ #' Global filters are gathered in one list element. |
|
| 181 | +355 |
- #' - `id` - teal will set proper shiny namespace for this module.+ #' If a module has no active filters but the global ones, it will not be mentioned in the output. |
|
| 182 | +356 |
- #' - `...` (optional) `ui_args` elements will be passed to the module named argument or to the `...`.+ #' |
|
| 183 | +357 |
- #' @param filters (`character`) Deprecated. Use `datanames` instead.+ #' @param mapping_matrix (`data.frame`) of logical vectors where |
|
| 184 | +358 |
- #' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The+ #' columns represent modules and row represent `teal_slice`s |
|
| 185 | +359 |
- #' filter panel will automatically update the shown filters to include only+ #' @return `named list` like that in the `mapping` attribute of a `teal_slices` object. |
|
| 186 | +360 |
- #' filters in the listed datasets. `NULL` will hide the filter panel,+ #' @keywords internal |
|
| 187 | +361 |
- #' and the keyword `'all'` will show filters of all datasets. `datanames` also determines+ #' |
|
| 188 | +362 |
- #' a subset of datasets which are appended to the `data` argument in `server` function.+ matrix_to_mapping <- function(mapping_matrix) {
|
|
| 189 | -+ | ||
| 363 | +! |
- #' @param server_args (named `list`) with additional arguments passed on to the+ mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x)) |
|
| 190 | -+ | ||
| 364 | +! |
- #' `server` function.+ global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L)) |
|
| 191 | -+ | ||
| 365 | +! |
- #' @param ui_args (named `list`) with additional arguments passed on to the+ global_filters <- names(global[global]) |
|
| 192 | -+ | ||
| 366 | +! |
- #' `ui` function.+ local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ] |
|
| 193 | +367 |
- #'+ |
|
| 194 | -+ | ||
| 368 | +! |
- #' @return object of class `teal_module`.+ mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))+ |
+ |
| 369 | +! | +
+ Filter(function(x) length(x) != 0L, mapping) |
|
| 195 | +370 |
- #' @export+ } |
| 196 | +1 |
- #' @examples+ #' Filter settings for teal applications |
||
| 197 | +2 |
- #' library(shiny)+ #' |
||
| 198 | +3 |
- #'+ #' Specify initial filter states and filtering settings for a `teal` app. |
||
| 199 | +4 |
- #' app <- init(+ #' |
||
| 200 | +5 |
- #' data = teal_data(iris = iris),+ #' Produces a `teal_slices` object. |
||
| 201 | +6 |
- #' modules = list(+ #' The `teal_slice` components will specify filter states that will be active when the app starts. |
||
| 202 | +7 |
- #' module(+ #' Attributes (created with the named arguments) will configure the way the app applies filters. |
||
| 203 | +8 |
- #' label = "Module",+ #' See argument descriptions for details. |
||
| 204 | +9 |
- #' server = function(id, data) {
+ #' |
||
| 205 | +10 |
- #' moduleServer(+ #' @inheritParams teal.slice::teal_slices |
||
| 206 | +11 |
- #' id,+ #' |
||
| 207 | +12 |
- #' module = function(input, output, session) {
+ #' @param module_specific optional (`logical(1)`)\cr |
||
| 208 | +13 |
- #' output$data <- renderDataTable(data[["iris"]]())+ #' - `FALSE` (default) when one filter panel applied to all modules. |
||
| 209 | +14 |
- #' }+ #' All filters will be shared by all modules. |
||
| 210 | +15 |
- #' )+ #' - `TRUE` when filter panel module-specific. |
||
| 211 | +16 |
- #' },+ #' Modules can have different set of filters specified - see `mapping` argument. |
||
| 212 | +17 |
- #' ui = function(id) {
+ #' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
|
||
| 213 | +18 |
- #' ns <- NS(id)+ #' (`named list`)\cr |
||
| 214 | +19 |
- #' tagList(dataTableOutput(ns("data")))
+ #' Specifies which filters will be active in which modules on app start. |
||
| 215 | +20 |
- #' }+ #' Elements should contain character vector of `teal_slice` `id`s (see [teal.slice::teal_slice()]). |
||
| 216 | +21 |
- #' )+ #' Names of the list should correspond to `teal_module` `label` set in [module()] function. |
||
| 217 | +22 |
- #' )+ #' `id`s listed under `"global_filters` will be active in all modules. |
||
| 218 | +23 |
- #' )+ #' If missing, all filters will be applied to all modules. |
||
| 219 | +24 |
- #' if (interactive()) {
+ #' If empty list, all filters will be available to all modules but will start inactive. |
||
| 220 | +25 |
- #' shinyApp(app$ui, app$server)+ #' If `module_specific` is `FALSE`, only `global_filters` will be active on start. |
||
| 221 | +26 |
- #' }+ #' @param app_id (`character(1)`)\cr |
||
| 222 | +27 |
- module <- function(label = "module",+ #' For internal use only, do not set manually. |
||
| 223 | +28 |
- server = function(id, ...) {
+ #' Added by `init` so that a `teal_slices` can be matched to the app in which it was used. |
||
| 224 | -! | +|||
| 29 | +
- moduleServer(id, function(input, output, session) {}) # nolint
+ #' Used for verifying snapshots uploaded from file. See `snapshot`. |
|||
| 225 | +30 |
- },+ #' |
||
| 226 | +31 |
- ui = function(id, ...) {
+ #' @param x (`list`) of lists to convert to `teal_slices` |
||
| 227 | -! | +|||
| 32 | +
- tags$p(paste0("This module has no UI (id: ", id, " )"))
+ #' |
|||
| 228 | +33 |
- },+ #' @return |
||
| 229 | +34 |
- filters,+ #' A `teal_slices` object. |
||
| 230 | +35 |
- datanames = "all",+ #' |
||
| 231 | +36 |
- server_args = NULL,+ #' @seealso [`teal.slice::teal_slices`], [`teal.slice::teal_slice`], [`slices_store`] |
||
| 232 | +37 |
- ui_args = NULL) {
+ #' |
||
| 233 | -135x | +|||
| 38 | +
- checkmate::assert_string(label)+ #' @examples |
|||
| 234 | -132x | +|||
| 39 | +
- checkmate::assert_function(server)+ #' filter <- teal_slices( |
|||
| 235 | -132x | +|||
| 40 | +
- checkmate::assert_function(ui)+ #' teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"), |
|||
| 236 | -132x | +|||
| 41 | +
- checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"), |
|||
| 237 | -131x | +|||
| 42 | +
- checkmate::assert_list(server_args, null.ok = TRUE, names = "named")+ #' teal.slice::teal_slice( |
|||
| 238 | -129x | +|||
| 43 | +
- checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")+ #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5" |
|||
| 239 | +44 |
-
+ #' ), |
||
| 240 | -127x | +|||
| 45 | +
- if (!missing(filters)) {
+ #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"), |
|||
| 241 | -! | +|||
| 46 | +
- checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ #' mapping = list( |
|||
| 242 | -! | +|||
| 47 | +
- datanames <- filters+ #' module1 = c("species", "sepal_length"),
|
|||
| 243 | -! | +|||
| 48 | +
- msg <-+ #' module2 = c("mtcars_mpg"),
|
|||
| 244 | -! | +|||
| 49 | +
- "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."+ #' global_filters = "long_petals" |
|||
| 245 | -! | +|||
| 50 | +
- logger::log_warn(msg)+ #' ) |
|||
| 246 | -! | +|||
| 51 | +
- warning(msg)+ #' ) |
|||
| 247 | +52 |
- }+ #' |
||
| 248 | +53 |
-
+ #' app <- teal::init( |
||
| 249 | -127x | +|||
| 54 | +
- if (label == "global_filters") {
+ #' data = list(iris = iris, mtcars = mtcars), |
|||
| 250 | -1x | +|||
| 55 | +
- stop(+ #' modules = list( |
|||
| 251 | -1x | +|||
| 56 | +
- sprintf("module(label = \"%s\", ...\n ", label),
+ #' module("module1"),
|
|||
| 252 | -1x | +|||
| 57 | +
- "Label 'global_filters' is reserved in teal. Please change to something else.",+ #' module("module2")
|
|||
| 253 | -1x | +|||
| 58 | +
- call. = FALSE+ #' ), |
|||
| 254 | +59 |
- )+ #' filter = filter |
||
| 255 | +60 |
- }+ #' ) |
||
| 256 | -126x | +|||
| 61 | +
- if (label == "Report previewer") {
+ #' |
|||
| 257 | -! | +|||
| 62 | +
- stop(+ #' if (interactive()) {
|
|||
| 258 | -! | +|||
| 63 | +
- sprintf("module(label = \"%s\", ...\n ", label),
+ #' shinyApp(app$ui, app$server) |
|||
| 259 | -! | +|||
| 64 | +
- "Label 'Report previewer' is reserved in teal.",+ #' } |
|||
| 260 | -! | +|||
| 65 | +
- call. = FALSE+ #' |
|||
| 261 | +66 |
- )+ #' @export |
||
| 262 | +67 |
- }+ teal_slices <- function(..., |
||
| 263 | -126x | +|||
| 68 | +
- server_formals <- names(formals(server))+ exclude_varnames = NULL, |
|||
| 264 | -126x | +|||
| 69 | +
- if (!(+ include_varnames = NULL, |
|||
| 265 | -126x | +|||
| 70 | +
- "id" %in% server_formals ||+ count_type = NULL, |
|||
| 266 | -126x | +|||
| 71 | +
- all(c("input", "output", "session") %in% server_formals)
+ allow_add = TRUE, |
|||
| 267 | +72 |
- )) {
+ module_specific = FALSE, |
||
| 268 | -2x | +|||
| 73 | +
- stop(+ mapping, |
|||
| 269 | -2x | +|||
| 74 | +
- "\nmodule() `server` argument requires a function with following arguments:",+ app_id = NULL) {
|
|||
| 270 | -2x | +75 | +76x |
- "\n - id - teal will set proper shiny namespace for this module.",+ shiny::isolate({
|
| 271 | -2x | +76 | +76x |
- "\n - input, output, session (not recommended) - then shiny::callModule will be used to call a module.",+ checkmate::assert_flag(allow_add) |
| 272 | -2x | +77 | +76x |
- "\n\nFollowing arguments can be used optionaly:",+ checkmate::assert_flag(module_specific) |
| 273 | -2x | +78 | +37x |
- "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",+ if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
|
| 274 | -2x | +79 | +73x |
- "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ checkmate::assert_string(app_id, null.ok = TRUE) |
| 275 | -2x | +|||
| 80 | +
- "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",+ |
|||
| 276 | -2x | +81 | +73x |
- "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",+ slices <- list(...) |
| 277 | -2x | +82 | +73x |
- "\n - `...` server_args elements will be passed to the module named argument or to the `...`"+ all_slice_id <- vapply(slices, `[[`, character(1L), "id") |
| 278 | +83 |
- )+ |
||
| 279 | -+ | |||
| 84 | +73x |
- }+ if (missing(mapping)) {
+ |
+ ||
| 85 | +39x | +
+ mapping <- list(global_filters = all_slice_id) |
||
| 280 | +86 |
-
+ } |
||
| 281 | -124x | +87 | +73x |
- if (!is.element("data", server_formals) && !is.null(datanames)) {
+ if (!module_specific) {
|
| 282 | -46x | +88 | +69x |
- message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
+ mapping[setdiff(names(mapping), "global_filters")] <- NULL |
| 283 | -46x | +|||
| 89 | +
- datanames <- NULL+ } |
|||
| 284 | +90 |
- }+ |
||
| 285 | -124x | +91 | +73x |
- if ("datasets" %in% server_formals) {
+ failed_slice_id <- setdiff(unlist(mapping), all_slice_id) |
| 286 | -2x | +92 | +73x |
- warning(+ if (length(failed_slice_id)) {
|
| 287 | -2x | +93 | +1x |
- sprintf("Called from module(label = \"%s\", ...)\n ", label),
+ stop(sprintf( |
| 288 | -2x | +94 | +1x |
- "`datasets` argument in the `server` is deprecated and will be removed in the next release. ",+ "Filters in mapping don't match any available filter.\n %s not in %s", |
| 289 | -2x | +95 | +1x |
- "Please use `data` instead.",+ toString(failed_slice_id), |
| 290 | -2x | +96 | +1x |
- call. = FALSE+ toString(all_slice_id) |
| 291 | +97 |
- )+ )) |
||
| 292 | +98 |
- }+ } |
||
| 293 | +99 | |||
| 294 | -124x | +100 | +72x | +
+ tss <- teal.slice::teal_slices(+ |
+
| 101 | ++ |
+ ...,+ |
+ ||
| 102 | +72x | +
+ exclude_varnames = exclude_varnames,+ |
+ ||
| 103 | +72x | +
+ include_varnames = include_varnames,+ |
+ ||
| 104 | +72x | +
+ count_type = count_type,+ |
+ ||
| 105 | +72x | +
+ allow_add = allow_add+ |
+ ||
| 106 | +
- srv_extra_args <- setdiff(names(server_args), server_formals)+ ) |
|||
| 295 | -124x | +107 | +72x |
- if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
+ attr(tss, "mapping") <- mapping |
| 296 | -1x | +108 | +72x |
- stop(+ attr(tss, "module_specific") <- module_specific |
| 297 | -1x | +109 | +72x |
- "\nFollowing `server_args` elements have no equivalent in the formals of the `server`:\n",+ attr(tss, "app_id") <- app_id |
| 298 | -1x | +110 | +72x |
- paste(paste(" -", srv_extra_args), collapse = "\n"),
+ class(tss) <- c("modules_teal_slices", class(tss))
|
| 299 | -1x | +111 | +72x |
- "\n\nUpdate the `server` arguments by including above or add `...`"+ tss |
| 300 | +112 |
- )+ }) |
||
| 301 | +113 |
- }+ } |
||
| 302 | +114 | |||
| 303 | -123x | +|||
| 115 | +
- ui_formals <- names(formals(ui))+ |
|||
| 304 | -123x | +|||
| 116 | +
- if (!"id" %in% ui_formals) {
+ #' @rdname teal_slices |
|||
| 305 | -1x | +|||
| 117 | +
- stop(+ #' @export |
|||
| 306 | -1x | +|||
| 118 | +
- "\nmodule() `ui` argument requires a function with following arguments:",+ #' @keywords internal |
|||
| 307 | -1x | +|||
| 119 | +
- "\n - id - teal will set proper shiny namespace for this module.",+ #' |
|||
| 308 | -1x | +|||
| 120 | +
- "\n\nFollowing arguments can be used optionally:",+ as.teal_slices <- function(x) { # nolint
|
|||
| 309 | -1x | -
- "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"- |
- ||
| 310 | -+ | 121 | +15x |
- )+ checkmate::assert_list(x) |
| 311 | -+ | |||
| 122 | +15x |
- }+ lapply(x, checkmate::assert_list, names = "named", .var.name = "list element") |
||
| 312 | +123 | |||
| 313 | -122x | +124 | +15x |
- if (any(c("data", "datasets") %in% ui_formals)) {
+ attrs <- attributes(unclass(x)) |
| 314 | -2x | +125 | +15x |
- stop(+ ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x)) |
| 315 | -2x | +126 | +15x |
- sprintf("Called from module(label = \"%s\", ...)\n ", label),
+ do.call(teal_slices, c(ans, attrs)) |
| 316 | -2x | +|||
| 127 | +
- "`ui` with `data` or `datasets` argument is no longer accepted.\n ",+ } |
|||
| 317 | -2x | +|||
| 128 | +
- "If some `ui` inputs depend on data, please move the logic to your `server` instead.\n ",+ |
|||
| 318 | -2x | +|||
| 129 | +
- "Possible solutions are renderUI() or updateXyzInput() functions."+ |
|||
| 319 | +130 |
- )+ #' @rdname teal_slices |
||
| 320 | +131 |
- }+ #' @export |
||
| 321 | +132 |
-
+ #' @keywords internal |
||
| 322 | -120x | +|||
| 133 | +
- ui_extra_args <- setdiff(names(ui_args), ui_formals)+ #' |
|||
| 323 | -120x | +|||
| 134 | +
- if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
+ c.teal_slices <- function(...) {
|
|||
| 324 | -1x | +|||
| 135 | +! |
- stop(+ x <- list(...) |
||
| 325 | -1x | +|||
| 136 | +! |
- "\nFollowing `ui_args` elements have no equivalent in the formals of `ui`:\n",+ checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices") |
||
| 326 | -1x | +|||
| 137 | +
- paste(paste(" -", ui_extra_args), collapse = "\n"),
+
|
|||
| 327 | -1x | +|||
| 138 | +! |
- "\n\nUpdate the `ui` arguments by including above or add `...`"+ all_attributes <- lapply(x, attributes) |
||
| 328 | -+ | |||
| 139 | +! |
- )+ all_attributes <- coalesce_r(all_attributes) |
||
| 329 | -+ | |||
| 140 | +! |
- }+ all_attributes <- all_attributes[names(all_attributes) != "class"] |
||
| 330 | +141 | |||
| 331 | -119x | +|||
| 142 | +! |
- structure(+ do.call( |
||
| 332 | -119x | +|||
| 143 | +! |
- list(+ teal_slices, |
||
| 333 | -119x | +|||
| 144 | +! |
- label = label,+ c( |
||
| 334 | -119x | +|||
| 145 | +! |
- server = server, ui = ui, datanames = unique(datanames),+ unique(unlist(x, recursive = FALSE)), |
||
| 335 | -119x | +|||
| 146 | +! |
- server_args = server_args, ui_args = ui_args+ all_attributes |
||
| 336 | +147 |
- ),- |
- ||
| 337 | -119x | -
- class = "teal_module"+ ) |
||
| 338 | +148 |
) |
||
| 339 | +149 |
} |
||
| 340 | +150 | |||
| 341 | +151 | |||
| 342 | +152 |
- #' Get module depth+ #' Deep copy `teal_slices` |
||
| 343 | +153 |
#' |
||
| 344 | +154 |
- #' Depth starts at 0, so a single `teal.module` has depth 0.+ #' it's important to create a new copy of `teal_slices` when |
||
| 345 | +155 |
- #' Nesting it increases overall depth by 1.+ #' starting a new `shiny` session. Otherwise, object will be shared |
||
| 346 | +156 |
- #'+ #' by multiple users as it is created in global environment before |
||
| 347 | +157 |
- #' @inheritParams init+ #' `shiny` session starts. |
||
| 348 | +158 |
- #' @param depth optional, integer determining current depth level+ #' @param filter (`teal_slices`) |
||
| 349 | +159 |
- #'+ #' @return `teal_slices` |
||
| 350 | +160 |
- #' @return depth level for given module+ #' @keywords internal |
||
| 351 | +161 |
- #' @keywords internal+ deep_copy_filter <- function(filter) {
|
||
| 352 | -+ | |||
| 162 | +1x |
- #'+ checkmate::assert_class(filter, "teal_slices") |
||
| 353 | -+ | |||
| 163 | +1x |
- #' @examples+ shiny::isolate({
|
||
| 354 | -+ | |||
| 164 | +1x |
- #' mods <- modules(+ filter_copy <- lapply(filter, function(slice) {
|
||
| 355 | -+ | |||
| 165 | +2x |
- #' label = "d1",+ teal.slice::as.teal_slice(as.list(slice)) |
||
| 356 | +166 |
- #' modules(+ }) |
||
| 357 | -+ | |||
| 167 | +1x |
- #' label = "d2",+ attributes(filter_copy) <- attributes(filter) |
||
| 358 | -+ | |||
| 168 | +1x |
- #' modules(+ filter_copy |
||
| 359 | +169 |
- #' label = "d3",+ }) |
||
| 360 | +170 |
- #' module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3")+ } |
| 361 | +1 |
- #' ),+ #' Landing Popup Module |
|
| 362 | +2 |
- #' module(label = "bbb")+ #' |
|
| 363 | +3 |
- #' ),+ #' @description Creates a landing welcome popup for `teal` applications. |
|
| 364 | +4 |
- #' module(label = "ccc")+ #' |
|
| 365 | +5 |
- #' )+ #' This module is used to display a popup dialog when the application starts. |
|
| 366 | +6 |
- #' stopifnot(teal:::modules_depth(mods) == 3L)+ #' The dialog blocks the access to the application and must be closed with a button before the application is viewed. |
|
| 367 | +7 |
#' |
|
| 368 | +8 |
- #' mods <- modules(+ #' @param label `character(1)` the label of the module. |
|
| 369 | +9 |
- #' label = "a",+ #' @param title `character(1)` the text to be displayed as a title of the popup. |
|
| 370 | +10 |
- #' modules(+ #' @param content The content of the popup. Passed to `...` of `shiny::modalDialog`. Can be a `character` |
|
| 371 | +11 |
- #' label = "b1", module(label = "c")+ #' or a list of `shiny.tag`s. See examples. |
|
| 372 | +12 |
- #' ),+ #' @param buttons `shiny.tag` or a list of tags (`tagList`). Typically a `modalButton` or `actionButton`. See examples. |
|
| 373 | +13 |
- #' module(label = "b2")+ #' |
|
| 374 | +14 |
- #' )+ #' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications. |
|
| 375 | +15 |
- #' stopifnot(teal:::modules_depth(mods) == 2L)+ #' |
|
| 376 | +16 |
- modules_depth <- function(modules, depth = 0L) {
- |
- |
| 377 | -12x | -
- checkmate::assert(+ #' @examples |
|
| 378 | -12x | +||
| 17 | +
- checkmate::check_class(modules, "teal_module"),+ #' app1 <- teal::init( |
||
| 379 | -12x | +||
| 18 | +
- checkmate::check_class(modules, "teal_modules")+ #' data = teal_data(iris = iris), |
||
| 380 | +19 |
- )+ #' modules = teal::modules( |
|
| 381 | -12x | +||
| 20 | +
- checkmate::assert_int(depth, lower = 0)+ #' teal::landing_popup_module( |
||
| 382 | -11x | +||
| 21 | +
- if (inherits(modules, "teal_modules")) {
+ #' content = "A place for the welcome message or a disclaimer statement.", |
||
| 383 | -4x | +||
| 22 | +
- max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))+ #' buttons = modalButton("Proceed")
|
||
| 384 | +23 |
- } else {
+ #' ), |
|
| 385 | -7x | +||
| 24 | +
- depth+ #' example_module() |
||
| 386 | +25 |
- }+ #' ) |
|
| 387 | +26 |
- }+ #' ) |
|
| 388 | +27 |
-
+ #' if (interactive()) {
|
|
| 389 | +28 |
-
+ #' shinyApp(app1$ui, app1$server) |
|
| 390 | +29 |
- module_labels <- function(modules) {
+ #' } |
|
| 391 | -! | +||
| 30 | +
- if (inherits(modules, "teal_modules")) {
+ #' |
||
| 392 | -! | +||
| 31 | +
- lapply(modules$children, module_labels)+ #' app2 <- teal::init( |
||
| 393 | +32 |
- } else {
+ #' data = teal_data(iris = iris), |
|
| 394 | -! | +||
| 33 | +
- modules$label+ #' modules = teal::modules( |
||
| 395 | +34 |
- }+ #' teal::landing_popup_module( |
|
| 396 | +35 |
- }+ #' title = "Welcome", |
|
| 397 | +36 |
-
+ #' content = tags$b( |
|
| 398 | +37 |
- #' Converts `teal_modules` to a string+ #' "A place for the welcome message or a disclaimer statement.", |
|
| 399 | +38 |
- #'+ #' style = "color: red;" |
|
| 400 | +39 |
- #' @param x (`teal_modules`) to print+ #' ), |
|
| 401 | +40 |
- #' @param indent (`integer`) indent level;+ #' buttons = tagList( |
|
| 402 | +41 |
- #' each `submodule` is indented one level more+ #' modalButton("Proceed"),
|
|
| 403 | +42 |
- #' @param ... (optional) additional parameters to pass to recursive calls of `toString`+ #' actionButton("read", "Read more",
|
|
| 404 | +43 |
- #' @return (`character`)+ #' onclick = "window.open('http://google.com', '_blank')"
|
|
| 405 | +44 |
- #' @export+ #' ), |
|
| 406 | +45 |
- #' @rdname modules+ #' actionButton("close", "Reject", onclick = "window.close()")
|
|
| 407 | +46 |
- toString.teal_modules <- function(x, indent = 0, ...) { # nolint
+ #' ) |
|
| 408 | +47 |
- # argument must be `x` to be consistent with base method+ #' ), |
|
| 409 | -! | +||
| 48 | +
- paste(c(+ #' example_module() |
||
| 410 | -! | +||
| 49 | +
- paste0(rep(" ", indent), "+ ", x$label),
+ #' ) |
||
| 411 | -! | +||
| 50 | +
- unlist(lapply(x$children, toString, indent = indent + 1, ...))+ #' ) |
||
| 412 | -! | +||
| 51 | +
- ), collapse = "\n")+ #' |
||
| 413 | +52 |
- }+ #' if (interactive()) {
|
|
| 414 | +53 |
-
+ #' shinyApp(app2$ui, app2$server) |
|
| 415 | +54 |
- #' Converts `teal_module` to a string+ #' } |
|
| 416 | +55 |
#' |
|
| 417 | +56 |
- #' @inheritParams toString.teal_modules+ #' @export |
|
| 418 | +57 |
- #' @param x `teal_module`+ landing_popup_module <- function(label = "Landing Popup", |
|
| 419 | +58 |
- #' @param ... ignored+ title = NULL, |
|
| 420 | +59 |
- #' @export+ content = NULL, |
|
| 421 | +60 |
- #' @rdname module+ buttons = modalButton("Accept")) {
|
|
| 422 | -+ | ||
| 61 | +! |
- toString.teal_module <- function(x, indent = 0, ...) { # nolint
+ checkmate::assert_string(label) |
|
| 423 | +62 | ! |
- paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
+ checkmate::assert_string(title, null.ok = TRUE)+ |
+
| 63 | +! | +
+ checkmate::assert_multi_class(+ |
+ |
| 64 | +! | +
+ content,+ |
+ |
| 65 | +! | +
+ classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
|
|
| 424 | +66 |
- }+ )+ |
+ |
| 67 | +! | +
+ checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
|
|
| 425 | +68 | ||
| 426 | -+ | ||
| 69 | +! |
- #' Prints `teal_modules`+ logger::log_info("Initializing landing_popup_module")
|
|
| 427 | +70 |
- #' @param x `teal_modules`+ + |
+ |
| 71 | +! | +
+ module <- module(+ |
+ |
| 72 | +! | +
+ label = label,+ |
+ |
| 73 | +! | +
+ server = function(id) {
|
|
| 428 | -+ | ||
| 74 | +! |
- #' @param ... parameters passed to `toString`+ moduleServer(id, function(input, output, session) {
|
|
| 429 | -+ | ||
| 75 | +! |
- #' @export+ showModal( |
|
| 430 | -+ | ||
| 76 | +! |
- #' @rdname modules+ modalDialog( |
|
| 431 | -+ | ||
| 77 | +! |
- print.teal_modules <- function(x, ...) {
+ id = "landingpopup", |
|
| 432 | +78 | ! |
- s <- toString(x, ...)+ title = title, |
| 433 | +79 | ! |
- cat(s)+ content, |
| 434 | +80 | ! |
- return(invisible(s))+ footer = buttons |
| 435 | +81 |
- }+ ) |
|
| 436 | +82 |
-
+ ) |
|
| 437 | +83 |
- #' Prints `teal_module`+ }) |
|
| 438 | +84 |
- #' @param x `teal_module`+ } |
|
| 439 | +85 |
- #' @param ... parameters passed to `toString`+ ) |
|
| 440 | -+ | ||
| 86 | +! |
- #' @export+ class(module) <- c("teal_module_landing", class(module))
|
|
| 441 | -+ | ||
| 87 | +! |
- #' @rdname module+ module |
|
| 442 | +88 |
- print.teal_module <- print.teal_modules+ } |
| 1 |
- .onLoad <- function(libname, pkgname) { # nolint
+ # This module is the main teal module that puts everything together. |
||
| 2 |
- # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R+ |
||
| 3 | -! | +
- teal_default_options <- list(teal.show_js_log = FALSE)+ #' teal main app module |
|
| 4 |
-
+ #' |
||
| 5 | -! | +
- op <- options()+ #' This is the main teal app that puts everything together. |
|
| 6 | -! | +
- toset <- !(names(teal_default_options) %in% names(op))+ #' |
|
| 7 | -! | +
- if (any(toset)) options(teal_default_options[toset])+ #' It displays the splash UI which is used to fetch the data, possibly |
|
| 8 |
-
+ #' prompting for a password input to fetch the data. Once the data is ready, |
||
| 9 | -! | +
- options("shiny.sanitize.errors" = FALSE)
+ #' the splash screen is replaced by the actual teal UI that is tabsetted and |
|
| 10 |
-
+ #' has a filter panel with `datanames` that are relevant for the current tab. |
||
| 11 |
- # Set up the teal logger instance+ #' Nested tabs are possible, but we limit it to two nesting levels for reasons |
||
| 12 | -! | +
- teal.logger::register_logger("teal")
+ #' of clarity of the UI. |
|
| 13 |
-
+ #' |
||
| 14 | -! | +
- invisible()+ #' The splash screen functionality can also be used |
|
| 15 |
- }+ #' for non-delayed data which takes time to load into memory, avoiding |
||
| 16 |
-
+ #' Shiny session timeouts. |
||
| 17 |
- .onAttach <- function(libname, pkgname) { # nolint
+ #' |
||
| 18 | -2x | +
- packageStartupMessage(+ #' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the |
|
| 19 | -2x | +
- "\nYou are using teal version ",+ #' `datasets` object that is shared across modules. |
|
| 20 |
- # `system.file` uses the `shim` of `system.file` by `teal`+ #' Once it is ready and non-`NULL`, the splash screen is replaced by the |
||
| 21 |
- # we avoid `desc` dependency here to get the version+ #' main teal UI that depends on the data. |
||
| 22 | -2x | +
- read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
+ #' The currently active tab is tracked and the right filter panel |
|
| 23 |
- )+ #' updates the displayed datasets to filter for according to the active `datanames` |
||
| 24 |
- }+ #' of the tab. |
||
| 25 |
-
+ #' |
||
| 26 |
- # This one is here because setdiff_teal_slice should not be exported from teal.slice.+ #' It is written as a Shiny module so it can be added into other apps as well. |
||
| 27 |
- setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
+ #' |
||
| 28 |
- # This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice.+ #' @name module_teal |
||
| 29 |
- coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
+ #' |
||
| 30 |
- # all *Block objects are private in teal.reporter+ #' @inheritParams ui_teal_with_splash |
||
| 31 |
- RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint
+ #' |
||
| 32 |
-
+ #' @param splash_ui (`shiny.tag`)\cr UI to display initially, |
||
| 33 |
- # Use non-exported function(s) from teal.code+ #' can be a splash screen or a Shiny module UI. For the latter, see |
||
| 34 |
- # This one is here because lang2calls should not be exported from teal.code+ #' [init()] about how to call the corresponding server function. |
||
| 35 |
- lang2calls <- getFromNamespace("lang2calls", "teal.code")
+ #' |
| 1 | +36 |
- #' Create a UI of nested tabs of `teal_modules`+ #' @param teal_data_rv (`reactive`)\cr |
||
| 2 | +37 | ++ |
+ #' returns the `teal_data`, only evaluated once, `NULL` value is ignored+ |
+ |
| 38 |
#' |
|||
| 3 | +39 |
- #' @section `ui_nested_tabs`:+ #' @return |
||
| 4 | +40 |
- #' Each `teal_modules` is translated to a `tabsetPanel` and each+ #' `ui_teal` returns `HTML` for Shiny module UI. |
||
| 5 | +41 |
- #' of its children is another tab-module called recursively. The UI of a+ #' `srv_teal` returns `reactive` which returns the currently active module. |
||
| 6 | +42 |
- #' `teal_module` is obtained by calling the `ui` function on it.+ #' |
||
| 7 | +43 | ++ |
+ #' @keywords internal+ |
+ |
| 44 |
#' |
|||
| 8 | +45 |
- #' The `datasets` argument is required to resolve the teal arguments in an+ #' @examples |
||
| 9 | +46 |
- #' isolated context (with respect to reactivity)+ #' mods <- teal:::example_modules() |
||
| 10 | +47 |
- #'+ #' teal_data_rv <- reactive(teal:::example_cdisc_data()) |
||
| 11 | +48 |
- #' @section `srv_nested_tabs`:+ #' app <- shinyApp( |
||
| 12 | +49 |
- #' This module calls recursively all elements of the `modules` returns one which+ #' ui = function() {
|
||
| 13 | +50 |
- #' is currently active.+ #' teal:::ui_teal("dummy")
|
||
| 14 | +51 |
- #' - `teal_module` returns self as a active module.+ #' }, |
||
| 15 | +52 |
- #' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.+ #' server = function(input, output, session) {
|
||
| 16 | +53 |
- #'+ #' active_module <- teal:::srv_teal(id = "dummy", modules = mods, teal_data_rv = teal_data_rv) |
||
| 17 | +54 |
- #' @name module_nested_tabs+ #' } |
||
| 18 | +55 |
- #'+ #' ) |
||
| 19 | +56 |
- #' @inheritParams module_tabs_with_filters+ #' if (interactive()) {
|
||
| 20 | +57 |
- #'+ #' shinyApp(app$ui, app$server) |
||
| 21 | +58 |
- #' @param depth (`integer(1)`)\cr+ #' } |
||
| 22 | +59 |
- #' number which helps to determine depth of the modules nesting.+ NULL |
||
| 23 | +60 |
- #' @param is_module_specific (`logical(1)`)\cr+ |
||
| 24 | +61 |
- #' flag determining if the filter panel is global or module-specific.+ #' @rdname module_teal |
||
| 25 | +62 |
- #' When set to `TRUE`, a filter panel is called inside of each module tab.+ ui_teal <- function(id, |
||
| 26 | +63 |
- #' @return depending on class of `modules`, `ui_nested_tabs` returns:+ splash_ui = tags$h2("Starting the Teal App"),
|
||
| 27 | +64 |
- #' - `teal_module`: instantiated UI of the module+ title = NULL, |
||
| 28 | +65 |
- #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively+ header = tags$p(""),
|
||
| 29 | +66 |
- #' calling this function on it.\cr+ footer = tags$p("")) {
|
||
| 30 | -+ | |||
| 67 | +12x |
- #' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.+ if (checkmate::test_string(header)) {
|
||
| 31 | -+ | |||
| 68 | +! |
- #'+ header <- tags$h1(header) |
||
| 32 | +69 |
- #' @examples+ } |
||
| 33 | -+ | |||
| 70 | +12x |
- #' mods <- teal:::example_modules()+ if (checkmate::test_string(footer)) {
|
||
| 34 | -+ | |||
| 71 | +! |
- #' datasets <- teal:::example_datasets()+ footer <- tags$p(footer) |
||
| 35 | +72 |
- #' app <- shinyApp(+ } |
||
| 36 | -+ | |||
| 73 | +12x |
- #' ui = function() {
+ checkmate::assert( |
||
| 37 | -+ | |||
| 74 | +12x |
- #' tagList(+ checkmate::check_class(splash_ui, "shiny.tag"), |
||
| 38 | -+ | |||
| 75 | +12x |
- #' teal:::include_teal_css_js(),+ checkmate::check_class(splash_ui, "shiny.tag.list"), |
||
| 39 | -+ | |||
| 76 | +12x |
- #' textOutput("info"),
+ checkmate::check_class(splash_ui, "html") |
||
| 40 | +77 |
- #' fluidPage( # needed for nice tabs+ ) |
||
| 41 | -+ | |||
| 78 | +12x |
- #' teal:::ui_nested_tabs("dummy", modules = mods, datasets = datasets)
+ checkmate::assert( |
||
| 42 | -+ | |||
| 79 | +12x |
- #' )+ checkmate::check_class(header, "shiny.tag"), |
||
| 43 | -+ | |||
| 80 | +12x |
- #' )+ checkmate::check_class(header, "shiny.tag.list"), |
||
| 44 | -+ | |||
| 81 | +12x |
- #' },+ checkmate::check_class(header, "html") |
||
| 45 | +82 |
- #' server = function(input, output, session) {
+ ) |
||
| 46 | -+ | |||
| 83 | +12x |
- #' active_module <- teal:::srv_nested_tabs(+ checkmate::assert( |
||
| 47 | -+ | |||
| 84 | +12x |
- #' "dummy",+ checkmate::check_class(footer, "shiny.tag"), |
||
| 48 | -+ | |||
| 85 | +12x |
- #' datasets = datasets,+ checkmate::check_class(footer, "shiny.tag.list"), |
||
| 49 | -+ | |||
| 86 | +12x |
- #' modules = mods+ checkmate::check_class(footer, "html") |
||
| 50 | +87 |
- #' )+ ) |
||
| 51 | +88 |
- #' output$info <- renderText({
+
|
||
| 52 | -+ | |||
| 89 | +12x |
- #' paste0("The currently active tab name is ", active_module()$label)
+ ns <- NS(id) |
||
| 53 | +90 |
- #' })+ # Once the data is loaded, we will remove this element and add the real teal UI instead |
||
| 54 | -+ | |||
| 91 | +12x |
- #' }+ splash_ui <- div( |
||
| 55 | +92 |
- #' )+ # id so we can remove the splash screen once ready, which is the first child of this container |
||
| 56 | -+ | |||
| 93 | +12x |
- #' if (interactive()) {
+ id = ns("main_ui_container"),
|
||
| 57 | +94 |
- #' shinyApp(app$ui, app$server)+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not |
||
| 58 | +95 |
- #' }+ # just the first item of the tagList) |
||
| 59 | -+ | |||
| 96 | +12x |
- #' @keywords internal+ div(splash_ui) |
||
| 60 | +97 |
- NULL+ ) |
||
| 61 | +98 | |||
| 62 | +99 |
- #' @rdname module_nested_tabs+ # show busy icon when shiny session is busy computing stuff |
||
| 63 | +100 |
- ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 #nolint |
||
| 64 | -! | +|||
| 101 | +12x |
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ shiny_busy_message_panel <- conditionalPanel( |
||
| 65 | -! | +|||
| 102 | +12x |
- checkmate::assert_count(depth)+ condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
|
||
| 66 | -! | +|||
| 103 | +12x |
- UseMethod("ui_nested_tabs", modules)
+ div( |
||
| 67 | -+ | |||
| 104 | +12x |
- }+ icon("arrows-rotate", "spin fa-spin"),
|
||
| 68 | -+ | |||
| 105 | +12x |
-
+ "Computing ...", |
||
| 69 | +106 |
- #' @rdname module_nested_tabs+ # CSS defined in `custom.css` |
||
| 70 | -+ | |||
| 107 | +12x |
- #' @export+ class = "shinybusymessage" |
||
| 71 | +108 |
- ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
- |
- ||
| 72 | -! | -
- stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ ) |
||
| 73 | +109 |
- }+ ) |
||
| 74 | +110 | |||
| 75 | -+ | |||
| 111 | +12x |
- #' @rdname module_nested_tabs+ res <- fluidPage( |
||
| 76 | -+ | |||
| 112 | +12x |
- #' @export+ title = title, |
||
| 77 | -+ | |||
| 113 | +12x |
- ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ theme = get_teal_bs_theme(), |
||
| 78 | -! | +|||
| 114 | +12x |
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ include_teal_css_js(), |
||
| 79 | -! | +|||
| 115 | +12x |
- ns <- NS(id)+ tags$header(header), |
||
| 80 | -! | +|||
| 116 | +12x |
- do.call(+ tags$hr(class = "my-2"), |
||
| 81 | -! | +|||
| 117 | +12x |
- tabsetPanel,+ shiny_busy_message_panel, |
||
| 82 | -! | +|||
| 118 | +12x |
- c(+ splash_ui, |
||
| 83 | -+ | |||
| 119 | +12x |
- # by giving an id, we can reactively respond to tab changes+ tags$hr(), |
||
| 84 | -! | +|||
| 120 | +12x |
- list(+ tags$footer( |
||
| 85 | -! | +|||
| 121 | +12x |
- id = ns("active_tab"),
+ div( |
||
| 86 | -! | +|||
| 122 | +12x |
- type = if (modules$label == "root") "pills" else "tabs"+ footer, |
||
| 87 | -+ | |||
| 123 | +12x |
- ),+ teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
|
||
| 88 | -! | +|||
| 124 | +12x |
- lapply(+ textOutput(ns("identifier"))
|
||
| 89 | -! | +|||
| 125 | +
- names(modules$children),+ ) |
|||
| 90 | -! | +|||
| 126 | +
- function(module_id) {
+ ) |
|||
| 91 | -! | +|||
| 127 | +
- module_label <- modules$children[[module_id]]$label+ ) |
|||
| 92 | -! | +|||
| 128 | +12x |
- tabPanel(+ return(res) |
||
| 93 | -! | +|||
| 129 | +
- title = module_label,+ } |
|||
| 94 | -! | +|||
| 130 | +
- value = module_id, # when clicked this tab value changes input$<tabset panel id>+ |
|||
| 95 | -! | +|||
| 131 | +
- ui_nested_tabs(+ |
|||
| 96 | -! | +|||
| 132 | +
- id = ns(module_id),+ #' @rdname module_teal |
|||
| 97 | -! | +|||
| 133 | +
- modules = modules$children[[module_id]],+ srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
|
|||
| 98 | -! | +|||
| 134 | +19x |
- datasets = datasets[[module_label]],+ stopifnot(is.reactive(teal_data_rv)) |
||
| 99 | -! | +|||
| 135 | +18x |
- depth = depth + 1L,+ moduleServer(id, function(input, output, session) {
|
||
| 100 | -! | +|||
| 136 | +18x |
- is_module_specific = is_module_specific+ logger::log_trace("srv_teal initializing the module.")
|
||
| 101 | +137 |
- )+ |
||
| 102 | -+ | |||
| 138 | +18x |
- )+ output$identifier <- renderText( |
||
| 103 | -+ | |||
| 139 | +18x |
- }+ paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
|
||
| 104 | +140 |
- )+ ) |
||
| 105 | +141 |
- )+ |
||
| 106 | -+ | |||
| 142 | +18x |
- )+ teal.widgets::verbatim_popup_srv( |
||
| 107 | -+ | |||
| 143 | +18x |
- }+ "sessionInfo", |
||
| 108 | -+ | |||
| 144 | +18x |
-
+ verbatim_content = utils::capture.output(utils::sessionInfo()), |
||
| 109 | -+ | |||
| 145 | +18x |
- #' @rdname module_nested_tabs+ title = "SessionInfo" |
||
| 110 | +146 |
- #' @export+ ) |
||
| 111 | +147 |
- ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+
|
||
| 112 | -! | +|||
| 148 | +
- checkmate::assert_class(datasets, classes = "FilteredData")+ # `JavaScript` code |
|||
| 113 | -! | +|||
| 149 | +18x |
- ns <- NS(id)+ run_js_files(files = "init.js") # `JavaScript` code to make the clipboard accessible |
||
| 114 | +150 |
-
+ # set timezone in shiny app |
||
| 115 | -! | +|||
| 151 | +
- args <- c(list(id = ns("module")), modules$ui_args)
+ # timezone is set in the early beginning so it will be available also |
|||
| 116 | +152 |
-
+ # for `DDL` and all shiny modules |
||
| 117 | -! | +|||
| 153 | +18x |
- teal_ui <- tags$div(+ get_client_timezone(session$ns) |
||
| 118 | -! | +|||
| 154 | +18x |
- id = id,+ observeEvent( |
||
| 119 | -! | +|||
| 155 | +18x |
- class = "teal_module",+ eventExpr = input$timezone, |
||
| 120 | -! | +|||
| 156 | +18x |
- uiOutput(ns("data_reactive"), inline = TRUE),
+ once = TRUE, |
||
| 121 | -! | +|||
| 157 | +18x |
- tagList(+ handlerExpr = {
|
||
| 122 | +158 | ! |
- if (depth >= 2L) div(style = "mt-6"),+ session$userData$timezone <- input$timezone |
|
| 123 | +159 | ! |
- do.call(modules$ui, args)+ logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
|
|
| 124 | +160 |
- )+ } |
||
| 125 | +161 |
- )+ ) |
||
| 126 | +162 | |||
| 127 | -! | +|||
| 163 | +18x |
- if (!is.null(modules$datanames) && is_module_specific) {
+ reporter <- teal.reporter::Reporter$new() |
||
| 128 | -! | +|||
| 164 | +18x |
- fluidRow(+ if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
|
||
| 129 | +165 | ! |
- column(width = 9, teal_ui, class = "teal_primary_col"),+ modules <- append_module(modules, reporter_previewer_module()) |
|
| 130 | -! | +|||
| 166 | +
- column(+ }+ |
+ |||
| 167 | ++ | + + | +||
| 168 | +18x | +
+ env <- environment() |
||
| 131 | -! | +|||
| 169 | +18x |
- width = 3,+ datasets_reactive <- eventReactive(teal_data_rv(), {
|
||
| 132 | -! | +|||
| 170 | +4x |
- datasets$ui_filter_panel(ns("module_filter_panel")),
+ env$progress <- shiny::Progress$new(session) |
||
| 133 | -! | +|||
| 171 | +4x |
- class = "teal_secondary_col"+ env$progress$set(0.25, message = "Setting data") |
||
| 134 | +172 |
- )+ |
||
| 135 | +173 |
- )+ # create a list of data following structure of the nested modules list structure. |
||
| 136 | +174 |
- } else {
+ # Because it's easier to unpack modules and datasets when they follow the same nested structure. |
||
| 137 | -! | +|||
| 175 | +4x |
- teal_ui+ datasets_singleton <- teal_data_to_filtered_data(teal_data_rv()) |
||
| 138 | +176 |
- }+ |
||
| 139 | +177 |
- }+ # Singleton starts with only global filters active.+ |
+ ||
| 178 | +4x | +
+ filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)+ |
+ ||
| 179 | +4x | +
+ datasets_singleton$set_filter_state(filter_global) |
||
| 140 | +180 | |||
| 141 | -+ | |||
| 181 | +4x |
- #' @rdname module_nested_tabs+ module_datasets <- function(modules) {
|
||
| 142 | -+ | |||
| 182 | +18x |
- srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,+ if (inherits(modules, "teal_modules")) {
|
||
| 143 | -+ | |||
| 183 | +7x |
- reporter = teal.reporter::Reporter$new()) {
+ datasets <- lapply(modules$children, module_datasets) |
||
| 144 | -50x | +184 | +7x |
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ labels <- vapply(modules$children, `[[`, character(1), "label") |
| 145 | -50x | +185 | +7x |
- checkmate::assert_class(reporter, "Reporter")+ names(datasets) <- labels |
| 146 | -49x | +186 | +7x |
- UseMethod("srv_nested_tabs", modules)
+ datasets |
| 147 | -+ | |||
| 187 | +11x |
- }+ } else if (isTRUE(attr(filter, "module_specific"))) {
|
||
| 148 | +188 |
-
+ # we should create FilteredData even if modules$datanames is null |
||
| 149 | +189 |
- #' @rdname module_nested_tabs+ # null controls a display of filter panel but data should be still passed |
||
| 150 | -+ | |||
| 190 | +3x |
- #' @export+ datanames <- if (is.null(modules$datanames) || modules$datanames == "all") {
+ |
+ ||
| 191 | +3x | +
+ include_parent_datanames(+ |
+ ||
| 192 | +3x | +
+ teal.data::datanames(teal_data_rv()),+ |
+ ||
| 193 | +3x | +
+ teal_data_rv()@join_keys |
||
| 151 | +194 |
- srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,+ ) |
||
| 152 | +195 |
- reporter = teal.reporter::Reporter$new()) {
+ } else {
|
||
| 153 | +196 | ! |
- stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ modules$datanames |
|
| 154 | +197 |
- }+ } |
||
| 155 | +198 |
-
+ # todo: subset teal_data to datanames |
||
| 156 | -+ | |||
| 199 | +3x |
- #' @rdname module_nested_tabs+ datasets_module <- teal_data_to_filtered_data(teal_data_rv(), datanames = datanames) |
||
| 157 | +200 |
- #' @export+ |
||
| 158 | +201 |
- srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,+ # set initial filters |
||
| 159 | +202 |
- reporter = teal.reporter::Reporter$new()) {
+ # - filtering filters for this module |
||
| 160 | -22x | +203 | +3x |
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ slices <- Filter(x = filter, f = function(x) {
|
| 161 | -+ | |||
| 204 | +! |
-
+ x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) && |
||
| 162 | -22x | +|||
| 205 | +! |
- moduleServer(id = id, module = function(input, output, session) {
+ x$dataname %in% datanames+ |
+ ||
| 206 | ++ |
+ }) |
||
| 163 | -22x | +207 | +3x |
- logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
+ include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames] |
| 164 | -+ | |||
| 208 | +3x |
-
+ exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames] |
||
| 165 | -22x | +209 | +3x |
- labels <- vapply(modules$children, `[[`, character(1), "label")+ slices$include_varnames <- include_varnames |
| 166 | -22x | +210 | +3x |
- modules_reactive <- sapply(+ slices$exclude_varnames <- exclude_varnames |
| 167 | -22x | +211 | +3x |
- names(modules$children),+ datasets_module$set_filter_state(slices) |
| 168 | -22x | +212 | +3x |
- function(module_id) {
+ datasets_module |
| 169 | -33x | +|||
| 213 | +
- srv_nested_tabs(+ } else {
|
|||
| 170 | -33x | +214 | +8x |
- id = module_id,+ datasets_singleton |
| 171 | -33x | +|||
| 215 | +
- datasets = datasets[[labels[module_id]]],+ } |
|||
| 172 | -33x | +|||
| 216 | +
- modules = modules$children[[module_id]],+ } |
|||
| 173 | -33x | +217 | +4x |
- is_module_specific = is_module_specific,+ module_datasets(modules) |
| 174 | -33x | +|||
| 218 | +
- reporter = reporter+ }) |
|||
| 175 | +219 |
- )+ |
||
| 176 | +220 |
- },+ # Replace splash / welcome screen once data is loaded ---- |
||
| 177 | -22x | +|||
| 221 | +
- simplify = FALSE+ # ignoreNULL to not trigger at the beginning when data is NULL |
|||
| 178 | +222 |
- )+ # just handle it once because data obtained through delayed loading should |
||
| 179 | +223 |
-
+ # usually not change afterwards |
||
| 180 | +224 |
- # when not ready input$active_tab would return NULL - this would fail next reactive+ # if restored from bookmarked state, `filter` is ignored |
||
| 181 | -22x | +|||
| 225 | +
- input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)+ |
|||
| 182 | -22x | +226 | +18x |
- get_active_module <- reactive({
+ observeEvent(datasets_reactive(), once = TRUE, {
|
| 183 | -12x | +|||
| 227 | +! |
- if (length(modules$children) == 1L) {
+ logger::log_trace("srv_teal@5 setting main ui after data was pulled")
|
||
| 184 | -+ | |||
| 228 | +! |
- # single tab is active by default+ on.exit(env$progress$close()) |
||
| 185 | -1x | +|||
| 229 | +! |
- modules_reactive[[1]]()+ env$progress$set(0.5, message = "Setting up main UI")+ |
+ ||
| 230 | +! | +
+ datasets <- datasets_reactive() |
||
| 186 | +231 |
- } else {
+
|
||
| 187 | +232 |
- # switch to active tab+ # main_ui_container contains splash screen first and we remove it and replace it by the real UI |
||
| 188 | -11x | +|||
| 233 | +! |
- modules_reactive[[input_validated()]]()+ removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container")))
|
||
| 189 | -+ | |||
| 234 | +! |
- }+ insertUI(+ |
+ ||
| 235 | +! | +
+ selector = paste0("#", session$ns("main_ui_container")),
+ |
+ ||
| 236 | +! | +
+ where = "beforeEnd", |
||
| 190 | +237 |
- })+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not |
||
| 191 | +238 |
-
+ # just the first item of the tagList) |
||
| 192 | -22x | +|||
| 239 | +! |
- get_active_module+ ui = div(ui_tabs_with_filters(+ |
+ ||
| 240 | +! | +
+ session$ns("main_ui"),
+ |
+ ||
| 241 | +! | +
+ modules = modules,+ |
+ ||
| 242 | +! | +
+ datasets = datasets,+ |
+ ||
| 243 | +! | +
+ filter = filter |
||
| 193 | +244 |
- })+ )), |
||
| 194 | +245 |
- }+ # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not |
||
| 195 | +246 |
-
+ # have any effect as they are ignored when not present+ |
+ ||
| 247 | +! | +
+ immediate = TRUE |
||
| 196 | +248 |
- #' @rdname module_nested_tabs+ ) |
||
| 197 | +249 |
- #' @export+ |
||
| 198 | +250 |
- srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,+ # must make sure that this is only executed once as modules assume their observers are only |
||
| 199 | +251 |
- reporter = teal.reporter::Reporter$new()) {
+ # registered once (calling server functions twice would trigger observers twice each time) |
||
| 200 | -27x | +|||
| 252 | +! |
- checkmate::assert_class(datasets, "FilteredData")+ active_module <- srv_tabs_with_filters( |
||
| 201 | -27x | +|||
| 253 | +! |
- logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
+ id = "main_ui", |
||
| 202 | -+ | |||
| 254 | +! |
-
+ datasets = datasets, |
||
| 203 | -27x | +|||
| 255 | +! |
- moduleServer(id = id, module = function(input, output, session) {
+ modules = modules, |
||
| 204 | -27x | +|||
| 256 | +! |
- if (!is.null(modules$datanames) && is_module_specific) {
+ reporter = reporter, |
||
| 205 | +257 | ! |
- datasets$srv_filter_panel("module_filter_panel")
+ filter = filter |
|
| 206 | +258 |
- }+ ) |
||
| 207 | -+ | |||
| 259 | +! |
-
+ return(active_module) |
||
| 208 | +260 |
- # Create two triggers to limit reactivity between filter-panel and modules.+ }) |
||
| 209 | +261 |
- # We want to recalculate only visible modules+ }) |
||
| 210 | +262 |
- # - trigger the data when the tab is selected+ } |
| 211 | +1 |
- # - trigger module to be called when the tab is selected for the first time- |
- |
| 212 | -27x | -
- trigger_data <- reactiveVal(1L)- |
- |
| 213 | -27x | -
- trigger_module <- reactiveVal(NULL)+ # This file contains Shiny modules useful for debugging and developing teal. |
|
| 214 | -27x | +||
| 2 | +
- output$data_reactive <- renderUI({
+ # We do not export the functions in this file. They are for |
||
| 215 | -17x | +||
| 3 | +
- lapply(datasets$datanames(), function(x) {
+ # developers only and can be accessed via `:::`. |
||
| 216 | -21x | +||
| 4 | +
- datasets$get_data(x, filtered = TRUE)+ |
||
| 217 | +5 |
- })+ #' Dummy module to show the filter calls generated by the right encoding panel |
|
| 218 | -17x | +||
| 6 | +
- isolate(trigger_data(trigger_data() + 1))+ #' |
||
| 219 | -17x | +||
| 7 | +
- isolate(trigger_module(TRUE))+ #' |
||
| 220 | +8 |
-
+ #' Please do not remove, this is useful for debugging teal without |
|
| 221 | -17x | +||
| 9 | +
- NULL+ #' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
|
||
| 222 | +10 |
- })+ #' and avoids session restarts! |
|
| 223 | +11 |
-
+ #' |
|
| 224 | +12 |
- # collect arguments to run teal_module+ #' @param label `character` label of module |
|
| 225 | -27x | +||
| 13 | +
- args <- c(list(id = "module"), modules$server_args)+ #' @keywords internal |
||
| 226 | -27x | +||
| 14 | +
- if (is_arg_used(modules$server, "reporter")) {
+ #' |
||
| 227 | -! | +||
| 15 | +
- args <- c(args, list(reporter = reporter))+ #' @examples |
||
| 228 | +16 |
- }+ #' app <- init( |
|
| 229 | +17 |
-
+ #' data = teal_data(iris = iris, mtcars = mtcars), |
|
| 230 | -27x | +||
| 18 | +
- if (is_arg_used(modules$server, "datasets")) {
+ #' modules = teal:::filter_calls_module(), |
||
| 231 | -1x | +||
| 19 | +
- args <- c(args, datasets = datasets)+ #' header = "Simple teal app" |
||
| 232 | +20 |
- }+ #' ) |
|
| 233 | +21 |
-
+ #' if (interactive()) {
|
|
| 234 | -27x | +||
| 22 | +
- if (is_arg_used(modules$server, "data")) {
+ #' shinyApp(app$ui, app$server) |
||
| 235 | -7x | +||
| 23 | +
- data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets))+ #' } |
||
| 236 | -7x | +||
| 24 | +
- args <- c(args, data = list(data))+ filter_calls_module <- function(label = "Filter Calls Module") { # nolint
|
||
| 237 | -+ | ||
| 25 | +! |
- }+ checkmate::assert_string(label) |
|
| 238 | +26 | ||
| 239 | -27x | +||
| 27 | +! |
- if (is_arg_used(modules$server, "filter_panel_api")) {
+ module( |
|
| 240 | -2x | +||
| 28 | +! |
- filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)+ label = label, |
|
| 241 | -2x | +||
| 29 | +! |
- args <- c(args, filter_panel_api = filter_panel_api)+ server = function(input, output, session, data) {
|
|
| 242 | -+ | ||
| 30 | +! |
- }+ checkmate::assert_class(data, "reactive") |
|
| 243 | -+ | ||
| 31 | +! |
-
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 244 | +32 |
- # observe the trigger_module above to induce the module once the renderUI is triggered+ |
|
| 245 | -27x | +||
| 33 | +! |
- observeEvent(+ output$filter_calls <- renderText({
|
|
| 246 | -27x | +||
| 34 | +! |
- ignoreNULL = TRUE,+ teal.data::get_code(data()) |
|
| 247 | -27x | +||
| 35 | +
- once = TRUE,+ }) |
||
| 248 | -27x | +||
| 36 | +
- eventExpr = trigger_module(),+ }, |
||
| 249 | -27x | +||
| 37 | +! |
- handlerExpr = {
+ ui = function(id, ...) {
|
|
| 250 | -17x | +||
| 38 | +! |
- module_output <- if (is_arg_used(modules$server, "id")) {
+ ns <- NS(id) |
|
| 251 | -17x | +||
| 39 | +! |
- do.call(modules$server, args)+ div( |
|
| 252 | -+ | ||
| 40 | +! |
- } else {
+ h2("The following filter calls are generated:"),
|
|
| 253 | +41 | ! |
- do.call(callModule, c(args, list(module = modules$server)))+ verbatimTextOutput(ns("filter_calls"))
|
| 254 | +42 |
- }+ ) |
|
| 255 | +43 |
- }+ }, |
|
| 256 | -+ | ||
| 44 | +! |
- )+ datanames = "all" |
|
| 257 | +45 |
-
+ ) |
|
| 258 | -27x | +||
| 46 | +
- reactive(modules)+ } |
| 259 | +1 |
- })+ #' Creates a `teal_modules` object. |
|
| 260 | +2 |
- }+ #' |
|
| 261 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
|
| 262 | +4 |
- #' Convert `FilteredData` to reactive list of datasets of the `teal_data` type.+ #' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object |
|
| 263 | +5 |
- #'+ #' containing the passed objects. |
|
| 264 | +6 |
- #' Converts `FilteredData` object to `teal_data` object containing datasets needed for a specific module.+ #' |
|
| 265 | +7 |
- #' Please note that if module needs dataset which has a parent, then parent will be also returned.+ #' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules` |
|
| 266 | +8 |
- #' A hash per `dataset` is calculated internally and returned in the code.+ #' shapes the navigation panel of a `teal` application. |
|
| 267 | +9 |
#' |
|
| 268 | +10 |
- #' @param module (`teal_module`) module where needed filters are taken from+ #' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details |
|
| 269 | +11 |
- #' @param datasets (`FilteredData`) object where needed data are taken from+ #' @param label (`character(1)`) label of modules collection (default `"root"`). |
|
| 270 | +12 |
- #' @return A `teal_data` object.+ #' If using the `label` argument then it must be explicitly named. |
|
| 271 | +13 |
- #'+ #' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
|
|
| 272 | +14 |
- #' @keywords internal+ #' |
|
| 273 | +15 |
- .datasets_to_data <- function(module, datasets) {
- |
- |
| 274 | -4x | -
- checkmate::assert_class(module, "teal_module")- |
- |
| 275 | -4x | -
- checkmate::assert_class(datasets, "FilteredData")+ #' @export |
|
| 276 | +16 | - - | -|
| 277 | -4x | -
- datanames <- if (is.null(module$datanames) || identical(module$datanames, "all")) {
- |
- |
| 278 | -1x | -
- datasets$datanames()+ #' |
|
| 279 | +17 |
- } else {
- |
- |
| 280 | -3x | -
- unique(module$datanames) # todo: include parents! unique shouldn't be needed here!+ #' @return object of class \code{teal_modules}. Object contains following fields
|
|
| 281 | +18 |
- }+ #' - `label`: taken from the `label` argument |
|
| 282 | +19 |
-
+ #' - `children`: a list containing objects passed in `...`. List elements are named after |
|
| 283 | +20 |
- # list of reactive filtered data- |
- |
| 284 | -4x | -
- data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)+ #' their `label` attribute converted to a valid `shiny` id. |
|
| 285 | +21 |
-
+ #' @examples |
|
| 286 | -4x | +||
| 22 | +
- hashes <- calculate_hashes(datanames, datasets)+ #' library(shiny) |
||
| 287 | +23 |
-
+ #' |
|
| 288 | -4x | +||
| 24 | +
- code <- c(+ #' app <- init( |
||
| 289 | -4x | +||
| 25 | +
- get_rcode_str_install(),+ #' data = teal_data(iris = iris), |
||
| 290 | -4x | +||
| 26 | +
- get_rcode_libraries(),+ #' modules = modules( |
||
| 291 | -4x | +||
| 27 | +
- get_datasets_code(datanames, datasets, hashes)+ #' label = "Modules", |
||
| 292 | +28 |
- )+ #' modules( |
|
| 293 | +29 |
-
+ #' label = "Module", |
|
| 294 | -4x | +||
| 30 | +
- do.call(+ #' module( |
||
| 295 | -4x | +||
| 31 | +
- teal.data::teal_data,+ #' label = "Inner module", |
||
| 296 | -4x | +||
| 32 | +
- args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames]))+ #' server = function(id, data) {
|
||
| 297 | +33 |
- )+ #' moduleServer( |
|
| 298 | +34 |
- }+ #' id, |
|
| 299 | +35 |
-
+ #' module = function(input, output, session) {
|
|
| 300 | +36 |
- #' Get the hash of a dataset+ #' output$data <- renderDataTable(data[["iris"]]()) |
|
| 301 | +37 |
- #'+ #' } |
|
| 302 | +38 |
- #' @param datanames (`character`) names of datasets+ #' ) |
|
| 303 | +39 |
- #' @param datasets (`FilteredData`) object holding the data+ #' }, |
|
| 304 | +40 |
- #'+ #' ui = function(id) {
|
|
| 305 | +41 |
- #' @return A list of hashes per dataset+ #' ns <- NS(id) |
|
| 306 | +42 |
- #' @keywords internal+ #' tagList(dataTableOutput(ns("data")))
|
|
| 307 | +43 |
- #'+ #' }, |
|
| 308 | +44 |
- calculate_hashes <- function(datanames, datasets) {
+ #' datanames = "all" |
|
| 309 | -7x | +||
| 45 | +
- sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)+ #' ) |
||
| 310 | +46 |
- }+ #' ), |
| 1 | +47 |
- # This module is the main teal module that puts everything together.+ #' module( |
||
| 2 | +48 |
-
+ #' label = "Another module", |
||
| 3 | +49 |
- #' teal main app module+ #' server = function(id) {
|
||
| 4 | +50 |
- #'+ #' moduleServer( |
||
| 5 | +51 |
- #' This is the main teal app that puts everything together.+ #' id, |
||
| 6 | +52 |
- #'+ #' module = function(input, output, session) {
|
||
| 7 | +53 |
- #' It displays the splash UI which is used to fetch the data, possibly+ #' output$text <- renderText("Another module")
|
||
| 8 | +54 |
- #' prompting for a password input to fetch the data. Once the data is ready,+ #' } |
||
| 9 | +55 |
- #' the splash screen is replaced by the actual teal UI that is tabsetted and+ #' ) |
||
| 10 | +56 |
- #' has a filter panel with `datanames` that are relevant for the current tab.+ #' }, |
||
| 11 | +57 |
- #' Nested tabs are possible, but we limit it to two nesting levels for reasons+ #' ui = function(id) {
|
||
| 12 | +58 |
- #' of clarity of the UI.+ #' ns <- NS(id) |
||
| 13 | +59 |
- #'+ #' tagList(textOutput(ns("text")))
|
||
| 14 | +60 |
- #' The splash screen functionality can also be used+ #' }, |
||
| 15 | +61 |
- #' for non-delayed data which takes time to load into memory, avoiding+ #' datanames = NULL |
||
| 16 | +62 |
- #' Shiny session timeouts.+ #' ) |
||
| 17 | +63 |
- #'+ #' ) |
||
| 18 | +64 |
- #' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the+ #' ) |
||
| 19 | +65 |
- #' `datasets` object that is shared across modules.+ #' if (interactive()) {
|
||
| 20 | +66 |
- #' Once it is ready and non-`NULL`, the splash screen is replaced by the+ #' shinyApp(app$ui, app$server) |
||
| 21 | +67 |
- #' main teal UI that depends on the data.+ #' } |
||
| 22 | +68 |
- #' The currently active tab is tracked and the right filter panel+ modules <- function(..., label = "root") {
|
||
| 23 | -+ | |||
| 69 | +109x | +
+ checkmate::assert_string(label)+ |
+ ||
| 70 | +107x | +
+ submodules <- list(...)+ |
+ ||
| 71 | +107x | +
+ if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
+ |
+ ||
| 72 | +2x | +
+ stop(+ |
+ ||
| 73 | +2x |
- #' updates the displayed datasets to filter for according to the active `datanames`+ "The only character argument to modules() must be 'label' and it must be named, ", |
||
| 24 | -+ | |||
| 74 | +2x |
- #' of the tab.+ "change modules('lab', ...) to modules(label = 'lab', ...)"
|
||
| 25 | +75 |
- #'+ ) |
||
| 26 | +76 |
- #' It is written as a Shiny module so it can be added into other apps as well.+ } |
||
| 27 | +77 |
- #'+ |
||
| 28 | -+ | |||
| 78 | +105x |
- #' @name module_teal+ checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
|
||
| 29 | +79 |
- #'+ # name them so we can more easily access the children |
||
| 30 | +80 |
- #' @inheritParams ui_teal_with_splash+ # beware however that the label of the submodules should not be changed as it must be kept synced |
||
| 31 | -+ | |||
| 81 | +102x |
- #'+ labels <- vapply(submodules, function(submodule) submodule$label, character(1)) |
||
| 32 | -+ | |||
| 82 | +102x |
- #' @param splash_ui (`shiny.tag`)\cr UI to display initially,+ names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
|
||
| 33 | -+ | |||
| 83 | +102x |
- #' can be a splash screen or a Shiny module UI. For the latter, see+ structure( |
||
| 34 | -+ | |||
| 84 | +102x |
- #' [init()] about how to call the corresponding server function.+ list( |
||
| 35 | -+ | |||
| 85 | +102x |
- #'+ label = label, |
||
| 36 | -+ | |||
| 86 | +102x |
- #' @param teal_data_rv (`reactive`)\cr+ children = submodules |
||
| 37 | +87 |
- #' returns the `teal_data`, only evaluated once, `NULL` value is ignored+ ), |
||
| 38 | -+ | |||
| 88 | +102x |
- #'+ class = "teal_modules" |
||
| 39 | +89 |
- #' @return+ ) |
||
| 40 | +90 |
- #' `ui_teal` returns `HTML` for Shiny module UI.+ } |
||
| 41 | +91 |
- #' `srv_teal` returns `reactive` which returns the currently active module.+ |
||
| 42 | +92 |
- #'+ #' Append a `teal_module` to `children` of a `teal_modules` object |
||
| 43 | +93 |
#' @keywords internal |
||
| 44 | +94 |
- #'+ #' @param modules `teal_modules` |
||
| 45 | +95 |
- #' @examples+ #' @param module `teal_module` object to be appended onto the children of `modules` |
||
| 46 | +96 |
- #' mods <- teal:::example_modules()+ #' @return `teal_modules` object with `module` appended |
||
| 47 | +97 |
- #' teal_data_rv <- reactive(teal:::example_cdisc_data())+ append_module <- function(modules, module) {
|
||
| 48 | -+ | |||
| 98 | +7x |
- #' app <- shinyApp(+ checkmate::assert_class(modules, "teal_modules") |
||
| 49 | -+ | |||
| 99 | +5x |
- #' ui = function() {
+ checkmate::assert_class(module, "teal_module") |
||
| 50 | -+ | |||
| 100 | +3x |
- #' teal:::ui_teal("dummy")
+ modules$children <- c(modules$children, list(module)) |
||
| 51 | -+ | |||
| 101 | +3x |
- #' },+ labels <- vapply(modules$children, function(submodule) submodule$label, character(1)) |
||
| 52 | -+ | |||
| 102 | +3x |
- #' server = function(input, output, session) {
+ names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
+ |
+ ||
| 103 | +3x | +
+ modules |
||
| 53 | +104 |
- #' active_module <- teal:::srv_teal(id = "dummy", modules = mods, teal_data_rv = teal_data_rv)+ } |
||
| 54 | +105 |
- #' }+ |
||
| 55 | +106 |
- #' )+ #' Extract/Remove module(s) of specific class |
||
| 56 | +107 |
- #' if (interactive()) {
+ #' |
||
| 57 | +108 |
- #' shinyApp(app$ui, app$server)+ #' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`. |
||
| 58 | +109 |
- #' }+ #' |
||
| 59 | +110 |
- NULL+ #' @param modules `teal_modules` |
||
| 60 | +111 |
-
+ #' @param class The class name of `teal_module` to be extracted or dropped. |
||
| 61 | +112 |
- #' @rdname module_teal+ #' @keywords internal |
||
| 62 | +113 |
- ui_teal <- function(id,+ #' @return |
||
| 63 | +114 |
- splash_ui = tags$h2("Starting the Teal App"),
+ #' For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`. |
||
| 64 | +115 |
- title = NULL,+ #' For `drop_module`, the opposite, which is all `teal_modules` of class other than `class`. |
||
| 65 | +116 |
- header = tags$p(""),
+ #' @rdname module_management |
||
| 66 | +117 |
- footer = tags$p("")) {
+ extract_module <- function(modules, class) {
|
||
| 67 | -12x | +118 | +30x |
- if (checkmate::test_string(header)) {
+ if (inherits(modules, class)) {
|
| 68 | +119 | ! |
- header <- tags$h1(header)+ modules |
|
| 69 | -+ | |||
| 120 | +30x | +
+ } else if (inherits(modules, "teal_module")) {
+ |
+ ||
| 121 | +16x |
- }+ NULL |
||
| 70 | -12x | +122 | +14x |
- if (checkmate::test_string(footer)) {
+ } else if (inherits(modules, "teal_modules")) {
|
| 71 | -! | +|||
| 123 | +14x |
- footer <- tags$p(footer)+ Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class)) |
||
| 72 | +124 |
} |
||
| 73 | -12x | +|||
| 125 | +
- checkmate::assert(+ } |
|||
| 74 | -12x | +|||
| 126 | +
- checkmate::check_class(splash_ui, "shiny.tag"),+ |
|||
| 75 | -12x | +|||
| 127 | +
- checkmate::check_class(splash_ui, "shiny.tag.list"),+ #' @keywords internal |
|||
| 76 | -12x | +|||
| 128 | +
- checkmate::check_class(splash_ui, "html")+ #' @return `teal_modules` |
|||
| 77 | +129 |
- )+ #' @rdname module_management |
||
| 78 | -12x | +|||
| 130 | +
- checkmate::assert(+ drop_module <- function(modules, class) {
|
|||
| 79 | -12x | +131 | +30x |
- checkmate::check_class(header, "shiny.tag"),+ if (inherits(modules, class)) {
|
| 80 | -12x | +|||
| 132 | +! |
- checkmate::check_class(header, "shiny.tag.list"),+ NULL |
||
| 81 | -12x | +133 | +30x |
- checkmate::check_class(header, "html")+ } else if (inherits(modules, "teal_module")) {
|
| 82 | -+ | |||
| 134 | +16x |
- )+ modules |
||
| 83 | -12x | +135 | +14x |
- checkmate::assert(+ } else if (inherits(modules, "teal_modules")) {
|
| 84 | -12x | +136 | +14x |
- checkmate::check_class(footer, "shiny.tag"),+ do.call( |
| 85 | -12x | +137 | +14x |
- checkmate::check_class(footer, "shiny.tag.list"),+ "modules", |
| 86 | -12x | +138 | +14x |
- checkmate::check_class(footer, "html")+ c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label) |
| 87 | +139 |
- )+ ) |
||
| 88 | +140 |
-
+ } |
||
| 89 | -12x | +|||
| 141 | +
- ns <- NS(id)+ } |
|||
| 90 | +142 |
- # Once the data is loaded, we will remove this element and add the real teal UI instead+ |
||
| 91 | -12x | +|||
| 143 | +
- splash_ui <- div(+ #' Does the object make use of the `arg` |
|||
| 92 | +144 |
- # id so we can remove the splash screen once ready, which is the first child of this container+ #' |
||
| 93 | -12x | +|||
| 145 | +
- id = ns("main_ui_container"),
+ #' @param modules (`teal_module` or `teal_modules`) object |
|||
| 94 | +146 |
- # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules. |
||
| 95 | +147 |
- # just the first item of the tagList)+ #' @return `logical` whether the object makes use of `arg` |
||
| 96 | -12x | +|||
| 148 | +
- div(splash_ui)+ #' @rdname is_arg_used |
|||
| 97 | +149 |
- )+ #' @keywords internal |
||
| 98 | +150 |
-
+ is_arg_used <- function(modules, arg) {
|
||
| 99 | -+ | |||
| 151 | +286x |
- # show busy icon when shiny session is busy computing stuff+ checkmate::assert_string(arg) |
||
| 100 | -+ | |||
| 152 | +283x |
- # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 #nolint+ if (inherits(modules, "teal_modules")) {
|
||
| 101 | -12x | +153 | +29x |
- shiny_busy_message_panel <- conditionalPanel(+ any(unlist(lapply(modules$children, is_arg_used, arg))) |
| 102 | -12x | +154 | +254x |
- condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
+ } else if (inherits(modules, "teal_module")) {
|
| 103 | -12x | +155 | +43x |
- div(+ is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg) |
| 104 | -12x | +156 | +211x |
- icon("arrows-rotate", "spin fa-spin"),
+ } else if (is.function(modules)) {
|
| 105 | -12x | +157 | +209x |
- "Computing ...",+ isTRUE(arg %in% names(formals(modules))) |
| 106 | +158 | ++ |
+ } else {
+ |
+ |
| 159 | +2x | +
+ stop("is_arg_used function not implemented for this object")
+ |
+ ||
| 160 | ++ |
+ }+ |
+ ||
| 161 | ++ |
+ }+ |
+ ||
| 162 |
- # CSS defined in `custom.css`+ |
|||
| 107 | -12x | +|||
| 163 | +
- class = "shinybusymessage"+ |
|||
| 108 | +164 |
- )+ #' Creates a `teal_module` object. |
||
| 109 | +165 |
- )+ #' |
||
| 110 | +166 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 111 | -12x | +|||
| 167 | +
- res <- fluidPage(+ #' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module. |
|||
| 112 | -12x | +|||
| 168 | +
- title = title,+ #' |
|||
| 113 | -12x | +|||
| 169 | +
- theme = get_teal_bs_theme(),+ #' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except |
|||
| 114 | -12x | +|||
| 170 | +
- include_teal_css_js(),+ #' `"global_filters"` - read more in `mapping` argument of [teal::teal_slices]. |
|||
| 115 | -12x | +|||
| 171 | +
- tags$header(header),+ #' @param server (`function`) `shiny` module with following arguments: |
|||
| 116 | -12x | +|||
| 172 | +
- tags$hr(class = "my-2"),+ #' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]). |
|||
| 117 | -12x | +|||
| 173 | +
- shiny_busy_message_panel,+ #' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module. |
|||
| 118 | -12x | +|||
| 174 | +
- splash_ui,+ #' - `data` (optional) module will receive a `teal_data` object, a list of reactive (filtered) data specified in |
|||
| 119 | -12x | +|||
| 175 | +
- tags$hr(),+ #' the `filters` argument. |
|||
| 120 | -12x | +|||
| 176 | +
- tags$footer(+ #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`). |
|||
| 121 | -12x | +|||
| 177 | +
- div(+ #' - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]). |
|||
| 122 | -12x | +|||
| 178 | +
- footer,+ # - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]). |
|||
| 123 | -12x | +|||
| 179 | +
- teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
+ #' - `...` (optional) `server_args` elements will be passed to the module named argument or to the `...`. |
|||
| 124 | -12x | +|||
| 180 | +
- textOutput(ns("identifier"))
+ #' @param ui (`function`) Shiny `ui` module function with following arguments: |
|||
| 125 | +181 |
- )+ #' - `id` - teal will set proper shiny namespace for this module. |
||
| 126 | +182 |
- )+ #' - `...` (optional) `ui_args` elements will be passed to the module named argument or to the `...`. |
||
| 127 | +183 |
- )+ #' @param filters (`character`) Deprecated. Use `datanames` instead. |
||
| 128 | -12x | +|||
| 184 | +
- return(res)+ #' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The |
|||
| 129 | +185 |
- }+ #' filter panel will automatically update the shown filters to include only |
||
| 130 | +186 |
-
+ #' filters in the listed datasets. `NULL` will hide the filter panel, |
||
| 131 | +187 |
-
+ #' and the keyword `'all'` will show filters of all datasets. `datanames` also determines |
||
| 132 | +188 |
- #' @rdname module_teal+ #' a subset of datasets which are appended to the `data` argument in `server` function. |
||
| 133 | +189 |
- srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
+ #' @param server_args (named `list`) with additional arguments passed on to the |
||
| 134 | -19x | +|||
| 190 | +
- stopifnot(is.reactive(teal_data_rv))+ #' `server` function. |
|||
| 135 | -18x | +|||
| 191 | +
- moduleServer(id, function(input, output, session) {
+ #' @param ui_args (named `list`) with additional arguments passed on to the |
|||
| 136 | -18x | +|||
| 192 | +
- logger::log_trace("srv_teal initializing the module.")
+ #' `ui` function. |
|||
| 137 | +193 |
-
+ #' |
||
| 138 | -18x | +|||
| 194 | +
- output$identifier <- renderText(+ #' @return object of class `teal_module`. |
|||
| 139 | -18x | +|||
| 195 | +
- paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
+ #' @export |
|||
| 140 | +196 |
- )+ #' @examples |
||
| 141 | +197 |
-
+ #' library(shiny) |
||
| 142 | -18x | +|||
| 198 | +
- teal.widgets::verbatim_popup_srv(+ #' |
|||
| 143 | -18x | +|||
| 199 | +
- "sessionInfo",+ #' app <- init( |
|||
| 144 | -18x | +|||
| 200 | +
- verbatim_content = utils::capture.output(utils::sessionInfo()),+ #' data = teal_data(iris = iris), |
|||
| 145 | -18x | +|||
| 201 | +
- title = "SessionInfo"+ #' modules = list( |
|||
| 146 | +202 |
- )+ #' module( |
||
| 147 | +203 |
-
+ #' label = "Module", |
||
| 148 | +204 |
- # `JavaScript` code+ #' server = function(id, data) {
|
||
| 149 | -18x | +|||
| 205 | +
- run_js_files(files = "init.js") # `JavaScript` code to make the clipboard accessible+ #' moduleServer( |
|||
| 150 | +206 |
- # set timezone in shiny app+ #' id, |
||
| 151 | +207 |
- # timezone is set in the early beginning so it will be available also+ #' module = function(input, output, session) {
|
||
| 152 | +208 |
- # for `DDL` and all shiny modules+ #' output$data <- renderDataTable(data[["iris"]]()) |
||
| 153 | -18x | +|||
| 209 | +
- get_client_timezone(session$ns)+ #' } |
|||
| 154 | -18x | +|||
| 210 | +
- observeEvent(+ #' ) |
|||
| 155 | -18x | +|||
| 211 | +
- eventExpr = input$timezone,+ #' }, |
|||
| 156 | -18x | +|||
| 212 | +
- once = TRUE,+ #' ui = function(id) {
|
|||
| 157 | -18x | +|||
| 213 | +
- handlerExpr = {
+ #' ns <- NS(id) |
|||
| 158 | -! | +|||
| 214 | +
- session$userData$timezone <- input$timezone+ #' tagList(dataTableOutput(ns("data")))
|
|||
| 159 | -! | +|||
| 215 | +
- logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
+ #' } |
|||
| 160 | +216 |
- }+ #' ) |
||
| 161 | +217 |
- )+ #' ) |
||
| 162 | +218 |
-
+ #' ) |
||
| 163 | -18x | +|||
| 219 | +
- reporter <- teal.reporter::Reporter$new()+ #' if (interactive()) {
|
|||
| 164 | -18x | +|||
| 220 | +
- if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
+ #' shinyApp(app$ui, app$server) |
|||
| 165 | -! | +|||
| 221 | +
- modules <- append_module(modules, reporter_previewer_module())+ #' } |
|||
| 166 | +222 |
- }+ module <- function(label = "module", |
||
| 167 | +223 |
-
+ server = function(id, ...) {
|
||
| 168 | -18x | +|||
| 224 | +! |
- env <- environment()+ moduleServer(id, function(input, output, session) {}) # nolint
|
||
| 169 | -18x | +|||
| 225 | +
- datasets_reactive <- eventReactive(teal_data_rv(), {
+ }, |
|||
| 170 | -4x | +|||
| 226 | +
- env$progress <- shiny::Progress$new(session)+ ui = function(id, ...) {
|
|||
| 171 | -4x | +|||
| 227 | +! |
- env$progress$set(0.25, message = "Setting data")+ tags$p(paste0("This module has no UI (id: ", id, " )"))
|
||
| 172 | +228 |
-
+ }, |
||
| 173 | +229 |
- # create a list of data following structure of the nested modules list structure.+ filters, |
||
| 174 | +230 |
- # Because it's easier to unpack modules and datasets when they follow the same nested structure.- |
- ||
| 175 | -4x | -
- datasets_singleton <- teal_data_to_filtered_data(teal_data_rv())+ datanames = "all", |
||
| 176 | +231 |
-
+ server_args = NULL, |
||
| 177 | +232 |
- # Singleton starts with only global filters active.- |
- ||
| 178 | -4x | -
- filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)+ ui_args = NULL) {
|
||
| 179 | -4x | -
- datasets_singleton$set_filter_state(filter_global)- |
- ||
| 180 | -+ | 233 | +135x |
-
+ checkmate::assert_string(label) |
| 181 | -4x | +234 | +132x |
- module_datasets <- function(modules) {
+ checkmate::assert_function(server) |
| 182 | -18x | +235 | +132x |
- if (inherits(modules, "teal_modules")) {
+ checkmate::assert_function(ui) |
| 183 | -7x | +236 | +132x |
- datasets <- lapply(modules$children, module_datasets)+ checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
| 184 | -7x | +237 | +131x |
- labels <- vapply(modules$children, `[[`, character(1), "label")+ checkmate::assert_list(server_args, null.ok = TRUE, names = "named") |
| 185 | -7x | +238 | +129x |
- names(datasets) <- labels+ checkmate::assert_list(ui_args, null.ok = TRUE, names = "named") |
| 186 | -7x | +|||
| 239 | +
- datasets+ |
|||
| 187 | -11x | +240 | +127x |
- } else if (isTRUE(attr(filter, "module_specific"))) {
+ if (!missing(filters)) {
|
| 188 | -+ | |||
| 241 | +! |
- # we should create FilteredData even if modules$datanames is null+ checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
||
| 189 | -+ | |||
| 242 | +! |
- # null controls a display of filter panel but data should be still passed+ datanames <- filters |
||
| 190 | -3x | +|||
| 243 | +! |
- datanames <- if (is.null(modules$datanames) || modules$datanames == "all") {
+ msg <- |
||
| 191 | -3x | +|||
| 244 | +! |
- include_parent_datanames(+ "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead." |
||
| 192 | -3x | +|||
| 245 | +! |
- teal.data::datanames(teal_data_rv()),+ logger::log_warn(msg) |
||
| 193 | -3x | +|||
| 246 | +! |
- teal_data_rv()@join_keys+ warning(msg) |
||
| 194 | +247 |
- )+ } |
||
| 195 | +248 |
- } else {
+
|
||
| 196 | -! | +|||
| 249 | +127x |
- modules$datanames+ if (label == "global_filters") {
|
||
| 197 | -+ | |||
| 250 | +1x |
- }+ stop( |
||
| 198 | -+ | |||
| 251 | +1x |
- # todo: subset teal_data to datanames+ sprintf("module(label = \"%s\", ...\n ", label),
|
||
| 199 | -3x | +252 | +1x |
- datasets_module <- teal_data_to_filtered_data(teal_data_rv(), datanames = datanames)+ "Label 'global_filters' is reserved in teal. Please change to something else.", |
| 200 | -+ | |||
| 253 | +1x |
-
+ call. = FALSE |
||
| 201 | +254 |
- # set initial filters+ ) |
||
| 202 | +255 |
- # - filtering filters for this module+ } |
||
| 203 | -3x | +256 | +126x |
- slices <- Filter(x = filter, f = function(x) {
+ if (label == "Report previewer") {
|
| 204 | +257 | ! |
- x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&+ stop( |
|
| 205 | +258 | ! |
- x$dataname %in% datanames+ sprintf("module(label = \"%s\", ...\n ", label),
|
|
| 206 | -+ | |||
| 259 | +! |
- })+ "Label 'Report previewer' is reserved in teal.", |
||
| 207 | -3x | +|||
| 260 | +! |
- include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]+ call. = FALSE |
||
| 208 | -3x | +|||
| 261 | +
- exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]+ )+ |
+ |||
| 262 | ++ |
+ } |
||
| 209 | -3x | +263 | +126x |
- slices$include_varnames <- include_varnames+ server_formals <- names(formals(server)) |
| 210 | -3x | +264 | +126x |
- slices$exclude_varnames <- exclude_varnames+ if (!( |
| 211 | -3x | +265 | +126x |
- datasets_module$set_filter_state(slices)+ "id" %in% server_formals || |
| 212 | -3x | +266 | +126x |
- datasets_module+ all(c("input", "output", "session") %in% server_formals)
|
| 213 | +267 |
- } else {
+ )) {
|
||
| 214 | -8x | +268 | +2x |
- datasets_singleton+ stop( |
| 215 | -+ | |||
| 269 | +2x |
- }+ "\nmodule() `server` argument requires a function with following arguments:", |
||
| 216 | -+ | |||
| 270 | +2x |
- }+ "\n - id - teal will set proper shiny namespace for this module.", |
||
| 217 | -4x | +271 | +2x |
- module_datasets(modules)+ "\n - input, output, session (not recommended) - then shiny::callModule will be used to call a module.", |
| 218 | -+ | |||
| 272 | +2x |
- })+ "\n\nFollowing arguments can be used optionaly:", |
||
| 219 | -+ | |||
| 273 | +2x |
-
+ "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument", |
||
| 220 | -+ | |||
| 274 | +2x |
- # Replace splash / welcome screen once data is loaded ----+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`", |
||
| 221 | -+ | |||
| 275 | +2x |
- # ignoreNULL to not trigger at the beginning when data is NULL+ "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`", |
||
| 222 | -+ | |||
| 276 | +2x |
- # just handle it once because data obtained through delayed loading should+ "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",+ |
+ ||
| 277 | +2x | +
+ "\n - `...` server_args elements will be passed to the module named argument or to the `...`" |
||
| 223 | +278 |
- # usually not change afterwards+ ) |
||
| 224 | +279 |
- # if restored from bookmarked state, `filter` is ignored+ } |
||
| 225 | +280 | |||
| 226 | -18x | +281 | +124x |
- observeEvent(datasets_reactive(), once = TRUE, {
+ if (!is.element("data", server_formals) && !is.null(datanames)) {
|
| 227 | -! | +|||
| 282 | +46x |
- logger::log_trace("srv_teal@5 setting main ui after data was pulled")
+ message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
|
||
| 228 | -! | +|||
| 283 | +46x |
- on.exit(env$progress$close())+ datanames <- NULL |
||
| 229 | -! | +|||
| 284 | +
- env$progress$set(0.5, message = "Setting up main UI")+ } |
|||
| 230 | -! | +|||
| 285 | +124x |
- datasets <- datasets_reactive()+ if ("datasets" %in% server_formals) {
|
||
| 231 | -+ | |||
| 286 | +2x |
-
+ warning( |
||
| 232 | -+ | |||
| 287 | +2x |
- # main_ui_container contains splash screen first and we remove it and replace it by the real UI+ sprintf("Called from module(label = \"%s\", ...)\n ", label),
|
||
| 233 | -! | +|||
| 288 | +2x |
- removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container")))
+ "`datasets` argument in the `server` is deprecated and will be removed in the next release. ", |
||
| 234 | -! | +|||
| 289 | +2x |
- insertUI(+ "Please use `data` instead.", |
||
| 235 | -! | +|||
| 290 | +2x |
- selector = paste0("#", session$ns("main_ui_container")),
+ call. = FALSE |
||
| 236 | -! | +|||
| 291 | +
- where = "beforeEnd",+ ) |
|||
| 237 | +292 |
- # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ } |
||
| 238 | +293 |
- # just the first item of the tagList)+ |
||
| 239 | -! | +|||
| 294 | +124x |
- ui = div(ui_tabs_with_filters(+ srv_extra_args <- setdiff(names(server_args), server_formals) |
||
| 240 | -! | +|||
| 295 | +124x |
- session$ns("main_ui"),
+ if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
|
||
| 241 | -! | +|||
| 296 | +1x |
- modules = modules,+ stop( |
||
| 242 | -! | +|||
| 297 | +1x |
- datasets = datasets,+ "\nFollowing `server_args` elements have no equivalent in the formals of the `server`:\n", |
||
| 243 | -! | +|||
| 298 | +1x |
- filter = filter+ paste(paste(" -", srv_extra_args), collapse = "\n"),
|
||
| 244 | -+ | |||
| 299 | +1x |
- )),+ "\n\nUpdate the `server` arguments by including above or add `...`" |
||
| 245 | +300 |
- # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not+ ) |
||
| 246 | +301 |
- # have any effect as they are ignored when not present- |
- ||
| 247 | -! | -
- immediate = TRUE+ } |
||
| 248 | +302 |
- )+ |
||
| 249 | -+ | |||
| 303 | +123x |
-
+ ui_formals <- names(formals(ui)) |
||
| 250 | -+ | |||
| 304 | +123x |
- # must make sure that this is only executed once as modules assume their observers are only+ if (!"id" %in% ui_formals) {
|
||
| 251 | -+ | |||
| 305 | +1x |
- # registered once (calling server functions twice would trigger observers twice each time)+ stop( |
||
| 252 | -! | +|||
| 306 | +1x |
- active_module <- srv_tabs_with_filters(+ "\nmodule() `ui` argument requires a function with following arguments:", |
||
| 253 | -! | +|||
| 307 | +1x |
- id = "main_ui",+ "\n - id - teal will set proper shiny namespace for this module.", |
||
| 254 | -! | +|||
| 308 | +1x |
- datasets = datasets,+ "\n\nFollowing arguments can be used optionally:", |
||
| 255 | -! | +|||
| 309 | +1x |
- modules = modules,+ "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`" |
||
| 256 | -! | +|||
| 310 | +
- reporter = reporter,+ ) |
|||
| 257 | -! | +|||
| 311 | +
- filter = filter+ } |
|||
| 258 | +312 |
- )+ |
||
| 259 | -! | +|||
| 313 | +122x |
- return(active_module)+ if (any(c("data", "datasets") %in% ui_formals)) {
|
||
| 260 | -+ | |||
| 314 | +2x |
- })+ stop( |
||
| 261 | -+ | |||
| 315 | +2x |
- })+ sprintf("Called from module(label = \"%s\", ...)\n ", label),
|
||
| 262 | -+ | |||
| 316 | +2x |
- }+ "`ui` with `data` or `datasets` argument is no longer accepted.\n ", |
| 1 | -+ | ||
| 317 | +2x |
- # This is the main function from teal to be used by the end-users. Although it delegates+ "If some `ui` inputs depend on data, please move the logic to your `server` instead.\n ", |
|
| 2 | -+ | ||
| 318 | +2x |
- # directly to `module_teal_with_splash.R`, we keep it in a separate file because its doc is quite large+ "Possible solutions are renderUI() or updateXyzInput() functions." |
|
| 3 | +319 |
- # and it is very end-user oriented. It may also perform more argument checking with more informative+ ) |
|
| 4 | +320 |
- # error messages.+ } |
|
| 5 | +321 | ||
| 6 | -+ | ||
| 322 | +120x |
-
+ ui_extra_args <- setdiff(names(ui_args), ui_formals) |
|
| 7 | -+ | ||
| 323 | +120x |
- #' Create the Server and UI Function For the Shiny App+ if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
|
|
| 8 | -+ | ||
| 324 | +1x |
- #'+ stop( |
|
| 9 | -+ | ||
| 325 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ "\nFollowing `ui_args` elements have no equivalent in the formals of `ui`:\n", |
|
| 10 | -+ | ||
| 326 | +1x |
- #' End-users: This is the most important function for you to start a+ paste(paste(" -", ui_extra_args), collapse = "\n"),
|
|
| 11 | -+ | ||
| 327 | +1x |
- #' teal app that is composed out of teal modules.+ "\n\nUpdate the `ui` arguments by including above or add `...`" |
|
| 12 | +328 |
- #'+ ) |
|
| 13 | +329 |
- #' @param data (`teal_data`, `teal_data_module`, `named list`)\cr+ } |
|
| 14 | +330 |
- #' `teal_data` object as returned by [teal.data::teal_data()] or+ |
|
| 15 | -+ | ||
| 331 | +119x |
- #' `teal_data_modules` or simply a list of a named list of objects+ structure( |
|
| 16 | -+ | ||
| 332 | +119x |
- #' (`data.frame` or `MultiAssayExperiment`).+ list( |
|
| 17 | -+ | ||
| 333 | +119x |
- #' @param modules (`list`, `teal_modules` or `teal_module`)\cr+ label = label, |
|
| 18 | -+ | ||
| 334 | +119x |
- #' nested list of `teal_modules` or `teal_module` objects or a single+ server = server, ui = ui, datanames = unique(datanames), |
|
| 19 | -+ | ||
| 335 | +119x |
- #' `teal_modules` or `teal_module` object. These are the specific output modules which+ server_args = server_args, ui_args = ui_args |
|
| 20 | +336 |
- #' will be displayed in the teal application. See [modules()] and [module()] for+ ),+ |
+ |
| 337 | +119x | +
+ class = "teal_module" |
|
| 21 | +338 |
- #' more details.+ ) |
|
| 22 | +339 |
- #' @param title (`NULL` or `character`)\cr+ } |
|
| 23 | +340 |
- #' The browser window title (defaults to the host URL of the page).+ |
|
| 24 | +341 |
- #' @param filter (`teal_slices`)\cr+ |
|
| 25 | +342 |
- #' Specification of initial filter. Filters can be specified using [teal::teal_slices()].+ #' Get module depth |
|
| 26 | +343 |
- #' Old way of specifying filters through a list is deprecated and will be removed in the+ #' |
|
| 27 | +344 |
- #' next release. Please fix your applications to use [teal::teal_slices()].+ #' Depth starts at 0, so a single `teal.module` has depth 0. |
|
| 28 | +345 |
- #' @param header (`shiny.tag` or `character`) \cr+ #' Nesting it increases overall depth by 1. |
|
| 29 | +346 |
- #' the header of the app. Note shiny code placed here (and in the footer+ #' |
|
| 30 | +347 |
- #' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function+ #' @inheritParams init |
|
| 31 | +348 |
- #' (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here.+ #' @param depth optional, integer determining current depth level |
|
| 32 | +349 |
- #' @param footer (`shiny.tag` or `character`)\cr+ #' |
|
| 33 | +350 |
- #' the footer of the app+ #' @return depth level for given module |
|
| 34 | +351 |
- #' @param id (`character`)\cr+ #' @keywords internal |
|
| 35 | +352 |
- #' module id to embed it, if provided,+ #' |
|
| 36 | +353 |
- #' the server function must be called with [shiny::moduleServer()];+ #' @examples |
|
| 37 | +354 |
- #' See the vignette for an example. However, [ui_teal_with_splash()]+ #' mods <- modules( |
|
| 38 | +355 |
- #' is then preferred to this function.+ #' label = "d1", |
|
| 39 | +356 |
- #'+ #' modules( |
|
| 40 | +357 |
- #' @return named list with `server` and `ui` function+ #' label = "d2", |
|
| 41 | +358 |
- #'+ #' modules( |
|
| 42 | +359 |
- #' @export+ #' label = "d3", |
|
| 43 | +360 |
- #'+ #' module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3") |
|
| 44 | +361 |
- #' @include modules.R+ #' ), |
|
| 45 | +362 |
- #'+ #' module(label = "bbb") |
|
| 46 | +363 |
- #' @examples+ #' ), |
|
| 47 | +364 |
- #' app <- init(+ #' module(label = "ccc") |
|
| 48 | +365 |
- #' data = teal_data(+ #' ) |
|
| 49 | +366 |
- #' new_iris = transform(iris, id = seq_len(nrow(iris))),+ #' stopifnot(teal:::modules_depth(mods) == 3L) |
|
| 50 | +367 |
- #' new_mtcars = transform(mtcars, id = seq_len(nrow(mtcars))),+ #' |
|
| 51 | +368 |
- #' code = "+ #' mods <- modules( |
|
| 52 | +369 |
- #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ #' label = "a", |
|
| 53 | +370 |
- #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ #' modules( |
|
| 54 | +371 |
- #' "+ #' label = "b1", module(label = "c") |
|
| 55 | +372 |
#' ), |
|
| 56 | +373 |
- #' modules = modules(+ #' module(label = "b2") |
|
| 57 | +374 |
- #' module(+ #' ) |
|
| 58 | +375 |
- #' label = "data source",+ #' stopifnot(teal:::modules_depth(mods) == 2L) |
|
| 59 | +376 |
- #' server = function(input, output, session, data) {},
+ modules_depth <- function(modules, depth = 0L) {
|
|
| 60 | -+ | ||
| 377 | +12x |
- #' ui = function(id, ...) div(p("information about data source")),
+ checkmate::assert( |
|
| 61 | -+ | ||
| 378 | +12x |
- #' datanames = "all"+ checkmate::check_class(modules, "teal_module"), |
|
| 62 | -+ | ||
| 379 | +12x |
- #' ),+ checkmate::check_class(modules, "teal_modules") |
|
| 63 | +380 |
- #' example_module(label = "example teal module"),+ ) |
|
| 64 | -+ | ||
| 381 | +12x |
- #' module(+ checkmate::assert_int(depth, lower = 0) |
|
| 65 | -+ | ||
| 382 | +11x |
- #' "Iris Sepal.Length histogram",+ if (inherits(modules, "teal_modules")) {
|
|
| 66 | -+ | ||
| 383 | +4x |
- #' server = function(input, output, session, data) {
+ max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L)) |
|
| 67 | +384 |
- #' output$hist <- renderPlot(+ } else {
|
|
| 68 | -+ | ||
| 385 | +7x |
- #' hist(data()[["new_iris"]]$Sepal.Length)+ depth |
|
| 69 | +386 |
- #' )+ } |
|
| 70 | +387 |
- #' },+ } |
|
| 71 | +388 |
- #' ui = function(id, ...) {
+
|
|
| 72 | +389 |
- #' ns <- NS(id)+ |
|
| 73 | +390 |
- #' plotOutput(ns("hist"))
+ module_labels <- function(modules) {
|
|
| 74 | -+ | ||
| 391 | +! |
- #' },+ if (inherits(modules, "teal_modules")) {
|
|
| 75 | -+ | ||
| 392 | +! |
- #' datanames = "new_iris"+ lapply(modules$children, module_labels) |
|
| 76 | +393 |
- #' )+ } else {
|
|
| 77 | -+ | ||
| 394 | +! |
- #' ),+ modules$label |
|
| 78 | +395 |
- #' title = "App title",+ } |
|
| 79 | +396 |
- #' filter = teal_slices(+ } |
|
| 80 | +397 |
- #' teal_slice(dataname = "new_iris", varname = "Species"),+ |
|
| 81 | +398 |
- #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),+ #' Converts `teal_modules` to a string |
|
| 82 | +399 |
- #' teal_slice(dataname = "new_mtcars", varname = "cyl"),+ #' |
|
| 83 | +400 |
- #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
+ #' @param x (`teal_modules`) to print |
|
| 84 | +401 |
- #' mapping = list(+ #' @param indent (`integer`) indent level; |
|
| 85 | +402 |
- #' `example teal module` = "new_iris Species",+ #' each `submodule` is indented one level more |
|
| 86 | +403 |
- #' `Iris Sepal.Length histogram` = "new_iris Species",+ #' @param ... (optional) additional parameters to pass to recursive calls of `toString` |
|
| 87 | +404 |
- #' global_filters = "new_mtcars cyl"+ #' @return (`character`) |
|
| 88 | +405 |
- #' )+ #' @export |
|
| 89 | +406 |
- #' ),+ #' @rdname modules |
|
| 90 | +407 |
- #' header = tags$h1("Sample App"),
+ toString.teal_modules <- function(x, indent = 0, ...) { # nolint
|
|
| 91 | +408 |
- #' footer = tags$p("Copyright 2017 - 2023")
+ # argument must be `x` to be consistent with base method |
|
| 92 | -+ | ||
| 409 | +! |
- #' )+ paste(c( |
|
| 93 | -+ | ||
| 410 | +! |
- #' if (interactive()) {
+ paste0(rep(" ", indent), "+ ", x$label),
+ |
+ |
| 411 | +! | +
+ unlist(lapply(x$children, toString, indent = indent + 1, ...))+ |
+ |
| 412 | +! | +
+ ), collapse = "\n") |
|
| 94 | +413 |
- #' shinyApp(app$ui, app$server)+ } |
|
| 95 | +414 |
- #' }+ |
|
| 96 | +415 |
- #'+ #' Converts `teal_module` to a string |
|
| 97 | +416 |
- init <- function(data,+ #' |
|
| 98 | +417 |
- modules,+ #' @inheritParams toString.teal_modules |
|
| 99 | +418 |
- title = NULL,+ #' @param x `teal_module` |
|
| 100 | +419 |
- filter = teal_slices(),+ #' @param ... ignored |
|
| 101 | +420 |
- header = tags$p(),+ #' @export |
|
| 102 | +421 |
- footer = tags$p(),+ #' @rdname module |
|
| 103 | +422 |
- id = character(0)) {
+ toString.teal_module <- function(x, indent = 0, ...) { # nolint
|
|
| 104 | -15x | +||
| 423 | +! |
- logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
+ paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
|
|
| 105 | -15x | +||
| 424 | +
- if (is.list(data) && !inherits(data, "teal_data_module")) {
+ } |
||
| 106 | -10x | +||
| 425 | +
- checkmate::assert_list(data, names = "named")+ |
||
| 107 | -10x | +||
| 426 | +
- data <- do.call(teal.data::teal_data, data)+ #' Prints `teal_modules` |
||
| 108 | +427 |
- }+ #' @param x `teal_modules` |
|
| 109 | -15x | +||
| 428 | +
- if (inherits(data, "TealData")) {
+ #' @param ... parameters passed to `toString` |
||
| 110 | -! | +||
| 429 | +
- lifecycle::deprecate_stop(+ #' @export |
||
| 111 | -! | +||
| 430 | +
- when = "0.99.0",+ #' @rdname modules |
||
| 112 | -! | +||
| 431 | +
- what = "init(data)",+ print.teal_modules <- function(x, ...) {
|
||
| 113 | +432 | ! |
- paste(+ s <- toString(x, ...) |
| 114 | +433 | ! |
- "TealData is no longer supported. Use teal_data() instead.",+ cat(s) |
| 115 | +434 | ! |
- "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/988."+ return(invisible(s)) |
| 116 | +435 |
- )+ } |
|
| 117 | +436 |
- )+ |
|
| 118 | +437 |
- }+ #' Prints `teal_module` |
|
| 119 | +438 | - - | -|
| 120 | -15x | -
- checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
- |
- |
| 121 | -15x | -
- checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
- |
- |
| 122 | -15x | -
- checkmate::assert_string(title, null.ok = TRUE)- |
- |
| 123 | -15x | -
- checkmate::assert(- |
- |
| 124 | -15x | -
- checkmate::check_class(filter, "teal_slices"),- |
- |
| 125 | -15x | -
- checkmate::check_list(filter, names = "named")+ #' @param x `teal_module` |
|
| 126 | +439 |
- )- |
- |
| 127 | -14x | -
- checkmate::assert_multi_class(header, c("shiny.tag", "character"))
- |
- |
| 128 | -14x | -
- checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
- |
- |
| 129 | -14x | -
- checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ #' @param ... parameters passed to `toString` |
|
| 130 | +440 | - - | -|
| 131 | -14x | -
- teal.logger::log_system_info()+ #' @export |
|
| 132 | +441 | - - | -|
| 133 | -14x | -
- if (inherits(modules, "teal_module")) {
- |
- |
| 134 | -1x | -
- modules <- list(modules)+ #' @rdname module |
|
| 135 | +442 |
- }- |
- |
| 136 | -14x | -
- if (inherits(modules, "list")) {
- |
- |
| 137 | -4x | -
- modules <- do.call(teal::modules, modules)+ print.teal_module <- print.teal_modules |
| 138 | +1 |
- }+ # This is the main function from teal to be used by the end-users. Although it delegates |
|
| 139 | +2 | - - | -|
| 140 | -14x | -
- landing <- extract_module(modules, "teal_module_landing")+ # directly to `module_teal_with_splash.R`, we keep it in a separate file because its doc is quite large |
|
| 141 | -! | +||
| 3 | +
- if (length(landing) > 1L) stop("Only one `landing_popup_module` can be used.")
+ # and it is very end-user oriented. It may also perform more argument checking with more informative |
||
| 142 | -14x | +||
| 4 | +
- modules <- drop_module(modules, "teal_module_landing")+ # error messages. |
||
| 143 | +5 | ||
| 144 | +6 |
- # Calculate app id that will be used to stamp filter state snapshots.+ |
|
| 145 | +7 |
- # App id is a hash of the app's data and modules.+ #' Create the Server and UI Function For the Shiny App |
|
| 146 | +8 |
- # See "transferring snapshots" section in ?snapshot.- |
- |
| 147 | -14x | -
- hashables <- mget(c("data", "modules"))
- |
- |
| 148 | -14x | -
- hashables$data <- if (inherits(hashables$data, "teal_data")) {
+ #' |
|
| 149 | -13x | +||
| 9 | +
- as.list(hashables$data@env)+ #' @description `r lifecycle::badge("stable")`
|
||
| 150 | -14x | +||
| 10 | +
- } else if (inherits(data, "teal_data_module")) {
+ #' End-users: This is the most important function for you to start a |
||
| 151 | -1x | +||
| 11 | +
- body(data$server)+ #' teal app that is composed out of teal modules. |
||
| 152 | +12 |
- }+ #' |
|
| 153 | +13 |
-
+ #' @param data (`teal_data`, `teal_data_module`, `named list`)\cr |
|
| 154 | -14x | +||
| 14 | +
- attr(filter, "app_id") <- rlang::hash(hashables)+ #' `teal_data` object as returned by [teal.data::teal_data()] or |
||
| 155 | +15 |
-
+ #' `teal_data_modules` or simply a list of a named list of objects |
|
| 156 | +16 |
- # convert teal.slice::teal_slices to teal::teal_slices+ #' (`data.frame` or `MultiAssayExperiment`). |
|
| 157 | -14x | +||
| 17 | +
- filter <- as.teal_slices(as.list(filter))+ #' @param modules (`list`, `teal_modules` or `teal_module`)\cr |
||
| 158 | +18 |
-
+ #' nested list of `teal_modules` or `teal_module` objects or a single |
|
| 159 | -14x | +||
| 19 | +
- if (isTRUE(attr(filter, "module_specific"))) {
+ #' `teal_modules` or `teal_module` object. These are the specific output modules which |
||
| 160 | -! | +||
| 20 | +
- module_names <- unlist(c(module_labels(modules), "global_filters"))+ #' will be displayed in the teal application. See [modules()] and [module()] for |
||
| 161 | -! | +||
| 21 | +
- failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)+ #' more details. |
||
| 162 | -! | +||
| 22 | +
- if (length(failed_mod_names)) {
+ #' @param title (`NULL` or `character`)\cr |
||
| 163 | -! | +||
| 23 | +
- stop(+ #' The browser window title (defaults to the host URL of the page). |
||
| 164 | -! | +||
| 24 | +
- sprintf(+ #' @param filter (`teal_slices`)\cr |
||
| 165 | -! | +||
| 25 | +
- "Some module names in the mapping arguments don't match module labels.\n %s not in %s",+ #' Specification of initial filter. Filters can be specified using [teal::teal_slices()]. |
||
| 166 | -! | +||
| 26 | +
- toString(failed_mod_names),+ #' Old way of specifying filters through a list is deprecated and will be removed in the |
||
| 167 | -! | +||
| 27 | +
- toString(unique(module_names))+ #' next release. Please fix your applications to use [teal::teal_slices()]. |
||
| 168 | +28 |
- )+ #' @param header (`shiny.tag` or `character`) \cr |
|
| 169 | +29 |
- )+ #' the header of the app. Note shiny code placed here (and in the footer |
|
| 170 | +30 |
- }+ #' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function |
|
| 171 | +31 |
-
+ #' (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here. |
|
| 172 | -! | +||
| 32 | +
- if (anyDuplicated(module_names)) {
+ #' @param footer (`shiny.tag` or `character`)\cr |
||
| 173 | +33 |
- # In teal we are able to set nested modules with duplicated label.+ #' the footer of the app |
|
| 174 | +34 |
- # Because mapping argument bases on the relationship between module-label and filter-id,+ #' @param id (`character`)\cr |
|
| 175 | +35 |
- # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)+ #' module id to embed it, if provided, |
|
| 176 | -! | +||
| 36 | +
- stop(+ #' the server function must be called with [shiny::moduleServer()]; |
||
| 177 | -! | +||
| 37 | +
- sprintf(+ #' See the vignette for an example. However, [ui_teal_with_splash()] |
||
| 178 | -! | +||
| 38 | +
- "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",+ #' is then preferred to this function. |
- ||
| 179 | -! | +||
| 39 | +
- toString(module_names[duplicated(module_names)])+ #' |
||
| 180 | +40 |
- )+ #' @return named list with `server` and `ui` function |
|
| 181 | +41 |
- )+ #' |
|
| 182 | +42 |
- }+ #' @export |
|
| 183 | +43 |
- }+ #' |
|
| 184 | +44 |
-
+ #' @include modules.R |
|
| 185 | -14x | +||
| 45 | +
- if (inherits(data, "teal_data")) {
+ #' |
||
| 186 | -13x | +||
| 46 | +
- if (length(teal.data::datanames(data)) == 0) {
+ #' @examples |
||
| 187 | -1x | +||
| 47 | +
- stop("`data` object has no datanames. Specify `datanames(data)` and try again.")
+ #' app <- init( |
||
| 188 | +48 |
- }+ #' data = teal_data( |
|
| 189 | +49 |
-
+ #' new_iris = transform(iris, id = seq_len(nrow(iris))), |
|
| 190 | +50 |
- # in case of teal_data_module this check is postponed to the srv_teal_with_splash+ #' new_mtcars = transform(mtcars, id = seq_len(nrow(mtcars))), |
|
| 191 | -12x | +||
| 51 | +
- is_modules_ok <- check_modules_datanames(modules, teal.data::datanames(data))+ #' code = " |
||
| 192 | -12x | +||
| 52 | +
- if (!isTRUE(is_modules_ok)) {
+ #' new_iris <- transform(iris, id = seq_len(nrow(iris))) |
||
| 193 | -1x | +||
| 53 | +
- logger::log_error(is_modules_ok)+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars))) |
||
| 194 | -1x | +||
| 54 | +
- checkmate::assert(is_modules_ok, .var.name = "modules")+ #' " |
||
| 195 | +55 |
- }+ #' ), |
|
| 196 | +56 |
-
+ #' modules = modules( |
|
| 197 | +57 |
-
+ #' module( |
|
| 198 | -11x | +||
| 58 | +
- is_filter_ok <- check_filter_datanames(filter, teal.data::datanames(data))+ #' label = "data source", |
||
| 199 | -11x | +||
| 59 | +
- if (!isTRUE(is_filter_ok)) {
+ #' server = function(input, output, session, data) {},
|
||
| 200 | -1x | +||
| 60 | +
- logger::log_warn(is_filter_ok)+ #' ui = function(id, ...) div(p("information about data source")),
|
||
| 201 | +61 |
- # we allow app to continue if applied filters are outside+ #' datanames = "all" |
|
| 202 | +62 |
- # of possible data range+ #' ), |
|
| 203 | +63 |
- }+ #' example_module(label = "example teal module"), |
|
| 204 | +64 |
- }+ #' module( |
|
| 205 | +65 |
-
+ #' "Iris Sepal.Length histogram", |
|
| 206 | +66 |
- # Note regarding case `id = character(0)`:+ #' server = function(input, output, session, data) {
|
|
| 207 | +67 |
- # rather than using `callModule` and creating a submodule of this module, we directly modify+ #' output$hist <- renderPlot( |
|
| 208 | +68 |
- # the `ui` and `server` with `id = character(0)` and calling the server function directly+ #' hist(data()[["new_iris"]]$Sepal.Length) |
|
| 209 | +69 |
- # rather than through `callModule`+ #' ) |
|
| 210 | -12x | +||
| 70 | +
- res <- list(+ #' }, |
||
| 211 | -12x | +||
| 71 | +
- ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),+ #' ui = function(id, ...) {
|
||
| 212 | -12x | +||
| 72 | +
- server = function(input, output, session) {
+ #' ns <- NS(id) |
||
| 213 | -! | +||
| 73 | +
- if (length(landing) == 1L) {
+ #' plotOutput(ns("hist"))
|
||
| 214 | -! | +||
| 74 | +
- landing_module <- landing[[1L]]+ #' }, |
||
| 215 | -! | +||
| 75 | +
- do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args))+ #' datanames = "new_iris" |
||
| 216 | +76 |
- }+ #' ) |
|
| 217 | -! | +||
| 77 | +
- filter <- deep_copy_filter(filter)+ #' ), |
||
| 218 | -! | +||
| 78 | +
- srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)+ #' title = "App title", |
||
| 219 | +79 |
- }+ #' filter = teal_slices( |
|
| 220 | +80 |
- )+ #' teal_slice(dataname = "new_iris", varname = "Species"), |
|
| 221 | -12x | +||
| 81 | +
- logger::log_trace("init teal app has been initialized.")
+ #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"), |
||
| 222 | -12x | +||
| 82 | +
- return(res)+ #' teal_slice(dataname = "new_mtcars", varname = "cyl"), |
||
| 223 | +83 |
- }+ #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
|
| 1 | +84 |
- #' Filter state snapshot management.+ #' mapping = list( |
||
| 2 | +85 |
- #'+ #' `example teal module` = "new_iris Species", |
||
| 3 | +86 |
- #' Capture and restore snapshots of the global (app) filter state.+ #' `Iris Sepal.Length histogram` = "new_iris Species", |
||
| 4 | +87 |
- #'+ #' global_filters = "new_mtcars cyl" |
||
| 5 | +88 |
- #' This module introduces snapshots: stored descriptions of the filter state of the entire application.+ #' ) |
||
| 6 | +89 |
- #' Snapshots allow the user to save the current filter state of the application for later use in the session,+ #' ), |
||
| 7 | +90 |
- #' as well as to save it to file in order to share it with an app developer or other users,+ #' header = tags$h1("Sample App"),
|
||
| 8 | +91 |
- #' who in turn can upload it to their own session.+ #' footer = tags$p("Copyright 2017 - 2023")
|
||
| 9 | +92 |
- #'+ #' ) |
||
| 10 | +93 |
- #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner.+ #' if (interactive()) {
|
||
| 11 | +94 |
- #' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow.+ #' shinyApp(app$ui, app$server) |
||
| 12 | +95 |
- #' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file+ #' } |
||
| 13 | +96 |
- #' and applies the filter states therein, and clicking the arrow resets initial application state.+ #' |
||
| 14 | +97 |
- #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.+ init <- function(data, |
||
| 15 | +98 |
- #'+ modules, |
||
| 16 | +99 |
- #' @section Server logic:+ title = NULL, |
||
| 17 | +100 |
- #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance+ filter = teal_slices(), |
||
| 18 | +101 |
- #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`+ header = tags$p(), |
||
| 19 | +102 |
- #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation+ footer = tags$p(), |
||
| 20 | +103 |
- #' (attributes are maintained).+ id = character(0)) {
+ |
+ ||
| 104 | +15x | +
+ logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
+ |
+ ||
| 105 | +15x | +
+ if (is.list(data) && !inherits(data, "teal_data_module")) {
+ |
+ ||
| 106 | +10x | +
+ checkmate::assert_list(data, names = "named")+ |
+ ||
| 107 | +10x | +
+ data <- do.call(teal.data::teal_data, data) |
||
| 21 | +108 |
- #'+ }+ |
+ ||
| 109 | +15x | +
+ if (inherits(data, "TealData")) {
+ |
+ ||
| 110 | +! | +
+ lifecycle::deprecate_stop(+ |
+ ||
| 111 | +! | +
+ when = "0.99.0",+ |
+ ||
| 112 | +! | +
+ what = "init(data)",+ |
+ ||
| 113 | +! | +
+ paste(+ |
+ ||
| 114 | +! | +
+ "TealData is no longer supported. Use teal_data() instead.",+ |
+ ||
| 115 | +! | +
+ "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/988." |
||
| 22 | +116 |
- #' Snapshots are stored in a `reactiveVal` as a named list.+ ) |
||
| 23 | +117 |
- #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.+ ) |
||
| 24 | +118 |
- #'+ } |
||
| 25 | +119 |
- #' For every snapshot except the initial one, a piece of UI is generated that contains+ + |
+ ||
| 120 | +15x | +
+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
+ |
+ ||
| 121 | +15x | +
+ checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
+ |
+ ||
| 122 | +15x | +
+ checkmate::assert_string(title, null.ok = TRUE)+ |
+ ||
| 123 | +15x | +
+ checkmate::assert(+ |
+ ||
| 124 | +15x | +
+ checkmate::check_class(filter, "teal_slices"),+ |
+ ||
| 125 | +15x | +
+ checkmate::check_list(filter, names = "named") |
||
| 26 | +126 |
- #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.+ )+ |
+ ||
| 127 | +14x | +
+ checkmate::assert_multi_class(header, c("shiny.tag", "character"))
+ |
+ ||
| 128 | +14x | +
+ checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
+ |
+ ||
| 129 | +14x | +
+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
||
| 27 | +130 |
- #' The initial snapshot is restored by a separate "reset" button.+ |
||
| 28 | -+ | |||
| 131 | +14x |
- #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.+ teal.logger::log_system_info() |
||
| 29 | +132 |
- #'+ |
||
| 30 | -+ | |||
| 133 | +14x |
- #' @section Snapshot mechanics:+ if (inherits(modules, "teal_module")) {
|
||
| 31 | -+ | |||
| 134 | +1x |
- #' When a snapshot is captured, the user is prompted to name it.+ modules <- list(modules) |
||
| 32 | +135 |
- #' Names are displayed as is but since they are used to create button ids,+ } |
||
| 33 | -+ | |||
| 136 | +14x |
- #' under the hood they are converted to syntactically valid strings.+ if (inherits(modules, "list")) {
|
||
| 34 | -+ | |||
| 137 | +4x |
- #' New snapshot names are validated so that their valid versions are unique.+ modules <- do.call(teal::modules, modules) |
||
| 35 | +138 |
- #' Leading and trailing white space is trimmed.+ } |
||
| 36 | +139 |
- #'+ |
||
| 37 | -+ | |||
| 140 | +14x |
- #' The module can read the global state of the application from `slices_global` and `mapping_matrix`.+ landing <- extract_module(modules, "teal_module_landing") |
||
| 38 | -+ | |||
| 141 | +! |
- #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.+ if (length(landing) > 1L) stop("Only one `landing_popup_module` can be used.")
|
||
| 39 | -+ | |||
| 142 | +14x |
- #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.+ modules <- drop_module(modules, "teal_module_landing") |
||
| 40 | +143 |
- #' The snapshot contains the `mapping` attribute of the initial application state+ |
||
| 41 | +144 |
- #' (or one that has been restored), which may not reflect the current one,+ # Calculate app id that will be used to stamp filter state snapshots. |
||
| 42 | +145 |
- #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,+ # App id is a hash of the app's data and modules. |
||
| 43 | +146 |
- #' when passed to the `mapping` argument of [`teal::teal_slices`], would result in the current mapping.+ # See "transferring snapshots" section in ?snapshot. |
||
| 44 | -+ | |||
| 147 | +14x |
- #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.+ hashables <- mget(c("data", "modules"))
|
||
| 45 | -+ | |||
| 148 | +14x |
- #'+ hashables$data <- if (inherits(hashables$data, "teal_data")) {
|
||
| 46 | -+ | |||
| 149 | +13x |
- #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.+ as.list(hashables$data@env) |
||
| 47 | -+ | |||
| 150 | +14x |
- #' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared+ } else if (inherits(data, "teal_data_module")) {
|
||
| 48 | -+ | |||
| 151 | +1x |
- #' and set anew according to the `mapping` attribute of the snapshot.+ body(data$server) |
||
| 49 | +152 |
- #' The snapshot is then set as the current content of `slices_global`.+ } |
||
| 50 | +153 |
- #'+ |
||
| 51 | -+ | |||
| 154 | +14x |
- #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,+ attr(filter, "app_id") <- rlang::hash(hashables) |
||
| 52 | +155 |
- #' and then saved to file with [`slices_store`].+ |
||
| 53 | +156 |
- #'+ # convert teal.slice::teal_slices to teal::teal_slices |
||
| 54 | -+ | |||
| 157 | +14x |
- #' When a snapshot is uploaded, it will first be added to storage just like a newly created one,+ filter <- as.teal_slices(as.list(filter)) |
||
| 55 | +158 |
- #' and then used to restore app state much like a snapshot taken from storage.+ |
||
| 56 | -+ | |||
| 159 | +14x |
- #' Upon clicking the upload icon the user will be prompted for a file to upload+ if (isTRUE(attr(filter, "module_specific"))) {
|
||
| 57 | -+ | |||
| 160 | +! |
- #' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped)+ module_names <- unlist(c(module_labels(modules), "global_filters")) |
||
| 58 | -+ | |||
| 161 | +! |
- #' and normal naming rules apply. Loading the file yields a `teal_slices` object,+ failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names) |
||
| 59 | -+ | |||
| 162 | +! |
- #' which is disassembled for storage and used directly for restoring app state.+ if (length(failed_mod_names)) {
|
||
| 60 | -+ | |||
| 163 | +! |
- #'+ stop( |
||
| 61 | -+ | |||
| 164 | +! |
- #' @section Transferring snapshots:+ sprintf( |
||
| 62 | -+ | |||
| 165 | +! |
- #' Snapshots uploaded from disk should only be used in the same application they come from,+ "Some module names in the mapping arguments don't match module labels.\n %s not in %s", |
||
| 63 | -+ | |||
| 166 | +! |
- #' _i.e._ an application that uses the same data and the same modules.+ toString(failed_mod_names), |
||
| 64 | -+ | |||
| 167 | +! |
- #' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of+ toString(unique(module_names)) |
||
| 65 | +168 |
- #' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that+ ) |
||
| 66 | +169 |
- #' of the current app state and only if the match is the snapshot admitted to the session.+ ) |
||
| 67 | +170 |
- #'+ } |
||
| 68 | +171 |
- #' @param id (`character(1)`) `shiny` module id+ |
||
| 69 | -+ | |||
| 172 | +! |
- #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object+ if (anyDuplicated(module_names)) {
|
||
| 70 | +173 |
- #' containing all `teal_slice`s existing in the app, both active and inactive+ # In teal we are able to set nested modules with duplicated label. |
||
| 71 | +174 |
- #' @param mapping_matrix (`reactive`) that contains a `data.frame` representation+ # Because mapping argument bases on the relationship between module-label and filter-id, |
||
| 72 | +175 |
- #' of the mapping of filter state ids (rows) to modules labels (columns);+ # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label) |
||
| 73 | -+ | |||
| 176 | +! |
- #' all columns are `logical` vectors+ stop( |
||
| 74 | -+ | |||
| 177 | +! |
- #' @param filtered_data_list non-nested (`named list`) that contains `FilteredData` objects+ sprintf( |
||
| 75 | -+ | |||
| 178 | +! |
- #'+ "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ", |
||
| 76 | -+ | |||
| 179 | +! |
- #' @return Nothing is returned.+ toString(module_names[duplicated(module_names)]) |
||
| 77 | +180 |
- #'+ ) |
||
| 78 | +181 |
- #' @name snapshot_manager_module+ ) |
||
| 79 | +182 |
- #' @aliases snapshot snapshot_manager+ } |
||
| 80 | +183 |
- #'+ } |
||
| 81 | +184 |
- #' @author Aleksander Chlebowski+ |
||
| 82 | -+ | |||
| 185 | +14x |
- #'+ if (inherits(data, "teal_data")) {
|
||
| 83 | -+ | |||
| 186 | +13x |
- #' @rdname snapshot_manager_module+ if (length(teal.data::datanames(data)) == 0) {
+ |
+ ||
| 187 | +1x | +
+ stop("`data` object has no datanames. Specify `datanames(data)` and try again.")
|
||
| 84 | +188 |
- #' @keywords internal+ } |
||
| 85 | +189 |
- #'+ |
||
| 86 | +190 |
- snapshot_manager_ui <- function(id) {
+ # in case of teal_data_module this check is postponed to the srv_teal_with_splash |
||
| 87 | -! | +|||
| 191 | +12x |
- ns <- NS(id)+ is_modules_ok <- check_modules_datanames(modules, teal.data::datanames(data)) |
||
| 88 | -! | +|||
| 192 | +12x |
- div(+ if (!isTRUE(is_modules_ok)) {
|
||
| 89 | -! | +|||
| 193 | +1x |
- class = "snapshot_manager_content",+ logger::log_error(is_modules_ok) |
||
| 90 | -! | +|||
| 194 | +1x |
- div(+ checkmate::assert(is_modules_ok, .var.name = "modules") |
||
| 91 | -! | +|||
| 195 | +
- class = "snapshot_table_row",+ } |
|||
| 92 | -! | +|||
| 196 | +
- span(tags$b("Snapshot manager")),
+
|
|||
| 93 | -! | +|||
| 197 | +
- actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
+
|
|||
| 94 | -! | +|||
| 198 | +11x |
- actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"),
+ is_filter_ok <- check_filter_datanames(filter, teal.data::datanames(data)) |
||
| 95 | -! | +|||
| 199 | +11x |
- actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
+ if (!isTRUE(is_filter_ok)) {
|
||
| 96 | -! | +|||
| 200 | +1x |
- NULL+ logger::log_warn(is_filter_ok) |
||
| 97 | +201 |
- ),+ # we allow app to continue if applied filters are outside |
||
| 98 | -! | +|||
| 202 | +
- uiOutput(ns("snapshot_list"))
+ # of possible data range |
|||
| 99 | +203 |
- )+ } |
||
| 100 | +204 |
- }+ } |
||
| 101 | +205 | |||
| 102 | +206 |
- #' @rdname snapshot_manager_module+ # Note regarding case `id = character(0)`: |
||
| 103 | +207 |
- #' @keywords internal+ # rather than using `callModule` and creating a submodule of this module, we directly modify |
||
| 104 | +208 |
- #'+ # the `ui` and `server` with `id = character(0)` and calling the server function directly |
||
| 105 | +209 |
- snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
+ # rather than through `callModule` |
||
| 106 | -6x | +210 | +12x |
- checkmate::assert_character(id)+ res <- list( |
| 107 | -6x | +211 | +12x |
- checkmate::assert_true(is.reactive(slices_global))+ ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer), |
| 108 | -6x | +212 | +12x |
- checkmate::assert_class(isolate(slices_global()), "teal_slices")+ server = function(input, output, session) {
|
| 109 | -6x | +|||
| 213 | +! |
- checkmate::assert_true(is.reactive(mapping_matrix))+ if (length(landing) == 1L) {
|
||
| 110 | -6x | +|||
| 214 | +! |
- checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)+ landing_module <- landing[[1L]] |
||
| 111 | -6x | +|||
| 215 | +! |
- checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named")+ do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args)) |
||
| 112 | +216 |
-
+ } |
||
| 113 | -6x | +|||
| 217 | +! |
- moduleServer(id, function(input, output, session) {
+ filter <- deep_copy_filter(filter) |
||
| 114 | -6x | +|||
| 218 | +! |
- ns <- session$ns+ srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter) |
||
| 115 | +219 |
-
+ } |
||
| 116 | +220 |
- # Store global filter states ----- |
- ||
| 117 | -6x | -
- filter <- isolate(slices_global())- |
- ||
| 118 | -6x | -
- snapshot_history <- reactiveVal({
+ ) |
||
| 119 | -6x | +221 | +12x |
- list(+ logger::log_trace("init teal app has been initialized.")
|
| 120 | -6x | +222 | +12x |
- "Initial application state" = as.list(filter, recursive = TRUE)+ return(res) |
| 121 | +223 |
- )+ } |
| 122 | +1 |
- })+ #' Filter manager modal |
||
| 123 | +2 |
-
+ #' |
||
| 124 | +3 |
- # Snapshot current application state ----+ #' Opens modal containing the filter manager UI. |
||
| 125 | +4 |
- # Name snaphsot.+ #' |
||
| 126 | -6x | +|||
| 5 | +
- observeEvent(input$snapshot_add, {
+ #' @name module_filter_manager_modal |
|||
| 127 | -! | +|||
| 6 | +
- showModal(+ #' @inheritParams filter_manager_srv |
|||
| 128 | -! | +|||
| 7 | +
- modalDialog(+ #' @examples |
|||
| 129 | -! | +|||
| 8 | +
- textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
+ #' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris))) |
|||
| 130 | -! | +|||
| 9 | +
- footer = tagList(+ #' fd2 <- teal.slice::init_filtered_data( |
|||
| 131 | -! | +|||
| 10 | +
- actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
+ #' list(iris = list(dataset = iris), mtcars = list(dataset = mtcars)) |
|||
| 132 | -! | +|||
| 11 | +
- modalButton(label = "Cancel", icon = icon("thumbs-down"))
+ #' ) |
|||
| 133 | +12 |
- ),+ #' fd3 <- teal.slice::init_filtered_data( |
||
| 134 | -! | +|||
| 13 | +
- size = "s"+ #' list(iris = list(dataset = iris), women = list(dataset = women)) |
|||
| 135 | +14 |
- )+ #' ) |
||
| 136 | +15 |
- )+ #' filter <- teal_slices( |
||
| 137 | +16 |
- })+ #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length"), |
||
| 138 | +17 |
- # Store snaphsot.+ #' teal.slice::teal_slice(dataname = "iris", varname = "Species"), |
||
| 139 | -6x | +|||
| 18 | +
- observeEvent(input$snapshot_name_accept, {
+ #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg"), |
|||
| 140 | -! | +|||
| 19 | +
- snapshot_name <- trimws(input$snapshot_name)+ #' teal.slice::teal_slice(dataname = "women", varname = "height"), |
|||
| 141 | -! | +|||
| 20 | +
- if (identical(snapshot_name, "")) {
+ #' mapping = list( |
|||
| 142 | -! | +|||
| 21 | +
- showNotification(+ #' module2 = c("mtcars mpg"),
|
|||
| 143 | -! | +|||
| 22 | +
- "Please name the snapshot.",+ #' module3 = c("women height"),
|
|||
| 144 | -! | +|||
| 23 | +
- type = "message"+ #' global_filters = "iris Species" |
|||
| 145 | +24 |
- )+ #' ) |
||
| 146 | -! | +|||
| 25 | +
- updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ #' ) |
|||
| 147 | -! | +|||
| 26 | +
- } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ #' |
|||
| 148 | -! | +|||
| 27 | +
- showNotification(+ #' app <- shinyApp( |
|||
| 149 | -! | +|||
| 28 | +
- "This name is in conflict with other snapshot names. Please choose a different one.",+ #' ui = fluidPage( |
|||
| 150 | -! | +|||
| 29 | +
- type = "message"+ #' teal:::filter_manager_modal_ui("manager")
|
|||
| 151 | +30 |
- )+ #' ), |
||
| 152 | -! | +|||
| 31 | +
- updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ #' server = function(input, output, session) {
|
|||
| 153 | +32 |
- } else {
+ #' teal:::filter_manager_modal_srv( |
||
| 154 | -! | +|||
| 33 | +
- snapshot <- as.list(slices_global(), recursive = TRUE)+ #' "manager", |
|||
| 155 | -! | +|||
| 34 | +
- attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())+ #' filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3), |
|||
| 156 | -! | +|||
| 35 | +
- snapshot_update <- c(snapshot_history(), list(snapshot))+ #' filter = filter |
|||
| 157 | -! | +|||
| 36 | +
- names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ #' ) |
|||
| 158 | -! | +|||
| 37 | +
- snapshot_history(snapshot_update)+ #' } |
|||
| 159 | -! | +|||
| 38 | +
- removeModal()+ #' ) |
|||
| 160 | +39 |
- # Reopen filter manager modal by clicking button in the main application.+ #' if (interactive()) {
|
||
| 161 | -! | +|||
| 40 | +
- shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE)+ #' shinyApp(app$ui, app$server) |
|||
| 162 | +41 |
- }+ #' } |
||
| 163 | +42 |
- })+ #' |
||
| 164 | +43 |
-
+ #' @keywords internal |
||
| 165 | +44 |
- # Upload a snapshot file ----+ #' |
||
| 166 | +45 |
- # Select file.+ NULL |
||
| 167 | -6x | +|||
| 46 | +
- observeEvent(input$snapshot_load, {
+
|
|||
| 168 | -! | +|||
| 47 | +
- showModal(+ #' @rdname module_filter_manager_modal |
|||
| 169 | -! | +|||
| 48 | +
- modalDialog(+ filter_manager_modal_ui <- function(id) {
|
|||
| 170 | +49 | ! |
- fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
+ ns <- NS(id) |
|
| 171 | +50 | ! |
- textInput(+ tags$button( |
|
| 172 | +51 | ! |
- ns("snapshot_name"),
+ id = ns("show"),
|
|
| 173 | +52 | ! |
- "Name the snapshot (optional)",+ class = "btn action-button filter_manager_button", |
|
| 174 | +53 | ! |
- width = "100%",+ title = "Show filters manager modal", |
|
| 175 | +54 | ! |
- placeholder = "Meaningful, unique name"+ icon("gear")
|
|
| 176 | +55 |
- ),+ ) |
||
| 177 | -! | +|||
| 56 | +
- footer = tagList(+ } |
|||
| 178 | -! | +|||
| 57 | +
- actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("thumbs-up")),
+
|
|||
| 179 | -! | +|||
| 58 | +
- modalButton(label = "Cancel", icon = icon("thumbs-down"))
+ #' @rdname module_filter_manager_modal |
|||
| 180 | +59 |
- )+ filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
|
||
| 181 | -+ | |||
| 60 | +3x |
- )+ moduleServer(id, function(input, output, session) {
|
||
| 182 | -+ | |||
| 61 | +3x |
- )+ observeEvent(input$show, {
|
||
| 183 | -+ | |||
| 62 | +! |
- })+ logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
|
||
| 184 | -+ | |||
| 63 | +! |
- # Store new snapshot to list and restore filter states.+ showModal( |
||
| 185 | -6x | +|||
| 64 | +! |
- observeEvent(input$snaphot_file_accept, {
+ modalDialog( |
||
| 186 | +65 | ! |
- snapshot_name <- trimws(input$snapshot_name)+ filter_manager_ui(session$ns("filter_manager")),
|
|
| 187 | +66 | ! |
- if (identical(snapshot_name, "")) {
+ size = "l", |
|
| 188 | +67 | +! | +
+ footer = NULL,+ |
+ |
| 68 | ! |
- snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)+ easyClose = TRUE+ |
+ ||
| 69 | ++ |
+ ) |
||
| 189 | +70 |
- }+ ) |
||
| 190 | -! | +|||
| 71 | +
- if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ }) |
|||
| 191 | -! | +|||
| 72 | +
- showNotification(+ |
|||
| 192 | -! | +|||
| 73 | +3x |
- "This name is in conflict with other snapshot names. Please choose a different one.",+ filter_manager_srv("filter_manager", filtered_data_list, filter)
|
||
| 193 | -! | +|||
| 74 | +
- type = "message"+ }) |
|||
| 194 | +75 |
- )+ } |
||
| 195 | -! | +|||
| 76 | +
- updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ |
|||
| 196 | +77 |
- } else {
+ #' @rdname module_filter_manager |
||
| 197 | +78 |
- # Restore snapshot and verify app compatibility.+ filter_manager_ui <- function(id) {
|
||
| 198 | +79 | ! |
- snapshot_state <- try(slices_restore(input$snapshot_file$datapath))+ ns <- NS(id) |
|
| 199 | +80 | ! |
- if (!inherits(snapshot_state, "modules_teal_slices")) {
+ div( |
|
| 200 | +81 | ! |
- showNotification(+ class = "filter_manager_content", |
|
| 201 | +82 | ! |
- "File appears to be corrupt.",+ tableOutput(ns("slices_table")),
|
|
| 202 | +83 | ! |
- type = "error"+ snapshot_manager_ui(ns("snapshot_manager"))
|
|
| 203 | +84 |
- )+ ) |
||
| 204 | -! | +|||
| 85 | +
- } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) {
+ } |
|||
| 205 | -! | +|||
| 86 | +
- showNotification(+ |
|||
| 206 | -! | +|||
| 87 | +
- "This snapshot file is not compatible with the app and cannot be loaded.",+ #' Manage multiple `FilteredData` objects |
|||
| 207 | -! | +|||
| 88 | +
- type = "warning"+ #' |
|||
| 208 | +89 |
- )+ #' Oversee filter states in the whole application. |
||
| 209 | +90 |
- } else {
+ #' |
||
| 210 | +91 |
- # Add to snapshot history.+ #' @rdname module_filter_manager |
||
| 211 | -! | +|||
| 92 | +
- snapshot <- as.list(snapshot_state, recursive = TRUE)+ #' @details |
|||
| 212 | -! | +|||
| 93 | +
- snapshot_update <- c(snapshot_history(), list(snapshot))+ #' This module observes the changes of the filters in each `FilteredData` object |
|||
| 213 | -! | +|||
| 94 | +
- names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ #' and keeps track of all filters used. A mapping of filters to modules |
|||
| 214 | -! | +|||
| 95 | +
- snapshot_history(snapshot_update)+ #' is kept in the `mapping_matrix` object (which is actually a `data.frame`) |
|||
| 215 | +96 |
- ### Begin simplified restore procedure. ###+ #' that tracks which filters (rows) are active in which modules (columns). |
||
| 216 | -! | +|||
| 97 | +
- mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ #' |
|||
| 217 | -! | +|||
| 98 | +
- mapply(+ #' @param id (`character(1)`)\cr |
|||
| 218 | -! | +|||
| 99 | +
- function(filtered_data, filter_ids) {
+ #' `shiny` module id. |
|||
| 219 | -! | +|||
| 100 | +
- filtered_data$clear_filter_states(force = TRUE)+ #' @param filtered_data_list (`named list`)\cr |
|||
| 220 | -! | +|||
| 101 | +
- slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ #' A list, possibly nested, of `FilteredData` objects. |
|||
| 221 | -! | +|||
| 102 | +
- filtered_data$set_filter_state(slices)+ #' Each `FilteredData` will be served to one module in the `teal` application. |
|||
| 222 | +103 |
- },+ #' The structure of the list must reflect the nesting of modules in tabs |
||
| 223 | -! | +|||
| 104 | +
- filtered_data = filtered_data_list,+ #' and names of the list must be the same as labels of their respective modules. |
|||
| 224 | -! | +|||
| 105 | +
- filter_ids = mapping_unfolded+ #' @inheritParams init |
|||
| 225 | +106 | ++ |
+ #' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.+ |
+ |
| 107 | ++ |
+ #' @keywords internal+ |
+ ||
| 108 | ++ |
+ #'+ |
+ ||
| 109 |
- )+ filter_manager_srv <- function(id, filtered_data_list, filter) {
|
|||
| 226 | -! | +|||
| 110 | +5x |
- slices_global(snapshot_state)+ moduleServer(id, function(input, output, session) {
|
||
| 227 | -! | +|||
| 111 | +5x |
- removeModal()+ logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
|
||
| 228 | +112 |
- ### End simplified restore procedure. ###+ |
||
| 229 | -+ | |||
| 113 | +5x |
- }+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
||
| 230 | +114 |
- }+ |
||
| 231 | +115 |
- })+ # Create global list of slices. |
||
| 232 | +116 |
- # Apply newly added snapshot.+ # Contains all available teal_slice objects available to all modules. |
||
| 233 | +117 |
-
+ # Passed whole to instances of FilteredData used for individual modules. |
||
| 234 | +118 |
- # Restore initial state ----+ # Down there a subset that pertains to the data sets used in that module is applied and displayed. |
||
| 235 | -6x | -
- observeEvent(input$snapshot_reset, {
- |
- ||
| 236 | -! | +119 | +5x |
- s <- "Initial application state"+ slices_global <- reactiveVal(filter) |
| 237 | +120 |
- ### Begin restore procedure. ###- |
- ||
| 238 | -! | -
- snapshot <- snapshot_history()[[s]]+ |
||
| 239 | -! | +|||
| 121 | +5x |
- snapshot_state <- as.teal_slices(snapshot)+ filtered_data_list <- |
||
| 240 | -! | +|||
| 122 | +5x |
- mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ if (!is_module_specific) {
|
||
| 241 | -! | +|||
| 123 | +
- mapply(+ # Retrieve the first FilteredData from potentially nested list. |
|||
| 242 | -! | +|||
| 124 | +
- function(filtered_data, filter_ids) {
+ # List of length one is named "global_filters" because that name is forbidden for a module label. |
|||
| 243 | -! | +|||
| 125 | +4x |
- filtered_data$clear_filter_states(force = TRUE)+ list(global_filters = unlist(filtered_data_list)[[1]]) |
||
| 244 | -! | +|||
| 126 | +
- slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ } else {
|
|||
| 245 | -! | +|||
| 127 | +
- filtered_data$set_filter_state(slices)+ # Flatten potentially nested list of FilteredData objects while maintaining useful names. |
|||
| 246 | +128 |
- },+ # Simply using `unlist` would result in concatenated names. |
||
| 247 | -! | +|||
| 129 | +1x |
- filtered_data = filtered_data_list,+ flatten_nested <- function(x, name = NULL) {
|
||
| 248 | -! | +|||
| 130 | +5x |
- filter_ids = mapping_unfolded+ if (inherits(x, "FilteredData")) {
|
||
| 249 | -+ | |||
| 131 | +3x |
- )+ setNames(list(x), name) |
||
| 250 | -! | +|||
| 132 | +
- slices_global(snapshot_state)+ } else {
|
|||
| 251 | -! | +|||
| 133 | +2x |
- removeModal()+ unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name))) |
||
| 252 | +134 |
- ### End restore procedure. ###+ } |
||
| 253 | +135 |
- })+ } |
||
| 254 | -+ | |||
| 136 | +1x |
-
+ flatten_nested(filtered_data_list) |
||
| 255 | +137 |
- # Build snapshot table ----+ } |
||
| 256 | +138 |
- # Create UI elements and server logic for the snapshot table.+ |
||
| 257 | +139 |
- # Observers must be tracked to avoid duplication and excess reactivity.+ # Create mapping fo filters to modules in matrix form (presented as data.frame). |
||
| 258 | +140 |
- # Remaining elements are tracked likewise for consistency and a slight speed margin.+ # Modules get NAs for filters that cannot be set for them. |
||
| 259 | -6x | +141 | +5x |
- observers <- reactiveValues()+ mapping_matrix <- reactive({
|
| 260 | -6x | +142 | +5x |
- handlers <- reactiveValues()+ state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id") |
| 261 | -6x | -
- divs <- reactiveValues()- |
- ||
| 262 | -+ | 143 | +5x |
-
+ mapping_smooth <- lapply(filtered_data_list, function(x) {
|
| 263 | -6x | +144 | +7x |
- observeEvent(snapshot_history(), {
+ state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id") |
| 264 | -2x | -
- lapply(names(snapshot_history())[-1L], function(s) {
- |
- ||
| 265 | -! | -
- id_pickme <- sprintf("pickme_%s", make.names(s))
- |
- ||
| 266 | -! | +145 | +7x |
- id_saveme <- sprintf("saveme_%s", make.names(s))
+ state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id") |
| 267 | -! | +|||
| 146 | +7x |
- id_rowme <- sprintf("rowme_%s", make.names(s))
+ states_active <- state_ids_global %in% state_ids_local |
||
| 268 | -+ | |||
| 147 | +7x |
-
+ ifelse(state_ids_global %in% state_ids_allowed, states_active, NA) |
||
| 269 | +148 |
- # Observer for restoring snapshot.+ }) |
||
| 270 | -! | +|||
| 149 | +
- if (!is.element(id_pickme, names(observers))) {
+
|
|||
| 271 | -! | +|||
| 150 | +5x |
- observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
+ as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE) |
||
| 272 | +151 |
- ### Begin restore procedure. ###+ }) |
||
| 273 | -! | +|||
| 152 | +
- snapshot <- snapshot_history()[[s]]+ |
|||
| 274 | -! | +|||
| 153 | +5x |
- snapshot_state <- as.teal_slices(snapshot)+ output$slices_table <- renderTable( |
||
| 275 | -! | +|||
| 154 | +5x |
- mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ expr = {
|
||
| 276 | -! | +|||
| 155 | +
- mapply(+ # Display logical values as UTF characters. |
|||
| 277 | -! | +|||
| 156 | +2x |
- function(filtered_data, filter_ids) {
+ mm <- mapping_matrix() |
||
| 278 | -! | +|||
| 157 | +2x |
- filtered_data$clear_filter_states(force = TRUE)+ mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060)) |
||
| 279 | -! | +|||
| 158 | +2x |
- slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x)) |
||
| 280 | -! | +|||
| 159 | +2x |
- filtered_data$set_filter_state(slices)+ if (!is_module_specific) colnames(mm) <- "Global Filters" |
||
| 281 | +160 |
- },+ |
||
| 282 | -! | +|||
| 161 | +
- filtered_data = filtered_data_list,+ # Display placeholder if no filters defined. |
|||
| 283 | -! | +|||
| 162 | +2x |
- filter_ids = mapping_unfolded+ if (nrow(mm) == 0L) {
|
||
| 284 | -+ | |||
| 163 | +2x |
- )+ mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE) |
||
| 285 | -! | +|||
| 164 | +2x |
- slices_global(snapshot_state)+ rownames(mm) <- "" |
||
| 286 | -! | +|||
| 165 | +
- removeModal()+ } |
|||
| 287 | +166 |
- ### End restore procedure. ###+ |
||
| 288 | +167 |
- })+ # Report Previewer will not be displayed. |
||
| 289 | -+ | |||
| 168 | +2x |
- }+ mm[names(mm) != "Report previewer"] |
||
| 290 | +169 |
- # Create handler for downloading snapshot.+ }, |
||
| 291 | -! | +|||
| 170 | +5x |
- if (!is.element(id_saveme, names(handlers))) {
+ align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
|
||
| 292 | -! | +|||
| 171 | +5x |
- output[[id_saveme]] <- downloadHandler(+ rownames = TRUE |
||
| 293 | -! | +|||
| 172 | +
- filename = function() {
+ ) |
|||
| 294 | -! | +|||
| 173 | +
- sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
+
|
|||
| 295 | +174 |
- },+ # Create list of module calls. |
||
| 296 | -! | +|||
| 175 | +5x |
- content = function(file) {
+ modules_out <- lapply(names(filtered_data_list), function(module_name) {
|
||
| 297 | -! | +|||
| 176 | +7x |
- snapshot <- snapshot_history()[[s]]+ filter_manager_module_srv( |
||
| 298 | -! | +|||
| 177 | +7x |
- snapshot_state <- as.teal_slices(snapshot)+ id = module_name, |
||
| 299 | -! | +|||
| 178 | +7x |
- slices_store(tss = snapshot_state, file = file)+ module_fd = filtered_data_list[[module_name]], |
||
| 300 | -+ | |||
| 179 | +7x |
- }+ slices_global = slices_global |
||
| 301 | +180 |
- )+ ) |
||
| 302 | -! | +|||
| 181 | +
- handlers[[id_saveme]] <- id_saveme+ }) |
|||
| 303 | +182 |
- }+ |
||
| 304 | +183 |
- # Create a row for the snapshot table.+ # Call snapshot manager. |
||
| 305 | -! | +|||
| 184 | +5x |
- if (!is.element(id_rowme, names(divs))) {
+ snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
|
||
| 306 | -! | +|||
| 185 | +
- divs[[id_rowme]] <- div(+ |
|||
| 307 | -! | +|||
| 186 | +5x |
- class = "snapshot_table_row",+ modules_out # returned for testing purpose |
||
| 308 | -! | +|||
| 187 | +
- span(h5(s)),+ }) |
|||
| 309 | -! | +|||
| 188 | +
- actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
+ } |
|||
| 310 | -! | +|||
| 189 | +
- downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
+
|
|||
| 311 | +190 |
- )+ #' Module specific filter manager |
||
| 312 | +191 |
- }+ #' |
||
| 313 | +192 |
- })+ #' Track filter states in single module. |
||
| 314 | +193 |
- })+ #' |
||
| 315 | +194 |
-
+ #' This module tracks the state of a single `FilteredData` object and global `teal_slices` |
||
| 316 | +195 |
- # Create table to display list of snapshots and their actions.+ #' and updates both objects as necessary. Filter states added in different modules |
||
| 317 | -6x | +|||
| 196 | +
- output$snapshot_list <- renderUI({
+ #' Filter states added any individual module are added to global `teal_slices` |
|||
| 318 | -2x | +|||
| 197 | +
- rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d)+ #' and from there become available in other modules |
|||
| 319 | -2x | +|||
| 198 | +
- if (length(rows) == 0L) {
+ #' by setting `private$available_teal_slices` in each `FilteredData`. |
|||
| 320 | -2x | +|||
| 199 | +
- div(+ #' |
|||
| 321 | -2x | +|||
| 200 | +
- class = "snapshot_manager_placeholder",+ #' @param id (`character(1)`)\cr |
|||
| 322 | -2x | +|||
| 201 | +
- "Snapshots will appear here."+ #' `shiny` module id. |
|||
| 323 | +202 |
- )+ #' @param module_fd (`FilteredData`)\cr |
||
| 324 | +203 |
- } else {
+ #' object to filter data in the teal-module |
||
| 325 | -! | +|||
| 204 | +
- rows+ #' @param slices_global (`reactiveVal`)\cr |
|||
| 326 | +205 |
- }+ #' stores `teal_slices` with all available filters; allows the following actions: |
||
| 327 | +206 |
- })+ #' - to disable/enable a specific filter in a module |
||
| 328 | +207 |
- })+ #' - to restore saved filter settings |
||
| 329 | +208 |
- }+ #' - to save current filter panel settings |
||
| 330 | +209 |
-
+ #' @return A `reactive` expression containing the slices active in this module. |
||
| 331 | +210 |
-
+ #' @keywords internal |
||
| 332 | +211 |
-
+ #' |
||
| 333 | +212 |
-
+ filter_manager_module_srv <- function(id, module_fd, slices_global) {
+ |
+ ||
| 213 | +7x | +
+ moduleServer(id, function(input, output, session) {
|
||
| 334 | +214 |
- ### utility functions ----+ # Only operate on slices that refer to data sets present in this module.+ |
+ ||
| 215 | +7x | +
+ module_fd$set_available_teal_slices(reactive(slices_global())) |
||
| 335 | +216 | |||
| 336 | +217 |
- #' Explicitly enumerate global filters.+ # Track filter state of this module. |
||
| 337 | -+ | |||
| 218 | +7x |
- #'+ slices_module <- reactive(module_fd$get_filter_state()) |
||
| 338 | +219 |
- #' Transform module mapping such that global filters are explicitly specified for every module.+ |
||
| 339 | +220 |
- #'+ # Reactive values for comparing states. |
||
| 340 | -+ | |||
| 221 | +7x |
- #' @param mapping (`named list`) as stored in mapping parameter of `teal_slices`+ previous_slices <- reactiveVal(isolate(slices_module())) |
||
| 341 | -+ | |||
| 222 | +7x |
- #' @param module_names (`character`) vector containing names of all modules in the app+ slices_added <- reactiveVal(NULL) |
||
| 342 | +223 |
- #' @return A `named_list` with one element per module, each element containing all filters applied to that module.+ |
||
| 343 | +224 |
- #' @keywords internal+ # Observe changes in module filter state and trigger appropriate actions. |
||
| 344 | -+ | |||
| 225 | +7x |
- #'+ observeEvent(slices_module(), ignoreNULL = FALSE, {
|
||
| 345 | -+ | |||
| 226 | +2x |
- unfold_mapping <- function(mapping, module_names) {
+ logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
|
||
| 346 | -! | +|||
| 227 | +2x |
- module_names <- structure(module_names, names = module_names)+ added <- setdiff_teal_slices(slices_module(), slices_global()) |
||
| 347 | +228 | ! |
- lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))+ if (length(added)) slices_added(added) |
|
| 348 | -+ | |||
| 229 | +2x |
- }+ previous_slices(slices_module()) |
||
| 349 | +230 |
-
+ }) |
||
| 350 | +231 |
- #' Convert mapping matrix to filter mapping specification.+ |
||
| 351 | -+ | |||
| 232 | +7x |
- #'+ observeEvent(slices_added(), ignoreNULL = TRUE, {
|
||
| 352 | -+ | |||
| 233 | +! |
- #' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,+ logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
|
||
| 353 | +234 |
- #' to a list specification like the one used in the `mapping` attribute of `teal_slices`.+ # In case the new state has the same id as an existing state, add a suffix to it. |
||
| 354 | -+ | |||
| 235 | +! |
- #' Global filters are gathered in one list element.+ global_ids <- vapply(slices_global(), `[[`, character(1L), "id") |
||
| 355 | -+ | |||
| 236 | +! |
- #' If a module has no active filters but the global ones, it will not be mentioned in the output.+ lapply( |
||
| 356 | -+ | |||
| 237 | +! |
- #'+ slices_added(), |
||
| 357 | -+ | |||
| 238 | +! |
- #' @param mapping_matrix (`data.frame`) of logical vectors where+ function(slice) {
|
||
| 358 | -+ | |||
| 239 | +! |
- #' columns represent modules and row represent `teal_slice`s+ if (slice$id %in% global_ids) {
|
||
| 359 | -+ | |||
| 240 | +! |
- #' @return `named list` like that in the `mapping` attribute of a `teal_slices` object.+ slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1) |
||
| 360 | +241 |
- #' @keywords internal+ } |
||
| 361 | +242 |
- #'+ } |
||
| 362 | +243 |
- matrix_to_mapping <- function(mapping_matrix) {
+ ) |
||
| 363 | +244 | ! |
- mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x))+ slices_global_new <- c(slices_global(), slices_added()) |
|
| 364 | +245 | ! |
- global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))+ slices_global(slices_global_new) |
|
| 365 | +246 | ! |
- global_filters <- names(global[global])+ slices_added(NULL) |
|
| 366 | -! | +|||
| 247 | +
- local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]+ }) |
|||
| 367 | +248 | |||
| 368 | -! | +|||
| 249 | +7x |
- mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))+ slices_module # returned for testing purpose |
||
| 369 | -! | +|||
| 250 | +
- Filter(function(x) length(x) != 0L, mapping)+ }) |
|||
| 370 | +251 |
}@@ -13166,14 +13123,14 @@ teal coverage - 63.32% |
| 1 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ #' Create a UI of nested tabs of `teal_modules` |
||
| 3 |
- #' `system.file` should not be used to access files in other packages, it does+ #' @section `ui_nested_tabs`: |
||
| 4 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' Each `teal_modules` is translated to a `tabsetPanel` and each |
||
| 5 |
- #' as needed. Thus, we do not export this method+ #' of its children is another tab-module called recursively. The UI of a |
||
| 6 |
- #'+ #' `teal_module` is obtained by calling the `ui` function on it. |
||
| 7 |
- #' @param pattern (`character`) pattern of files to be included+ #' |
||
| 8 |
- #'+ #' The `datasets` argument is required to resolve the teal arguments in an |
||
| 9 |
- #' @return HTML code that includes `CSS` files+ #' isolated context (with respect to reactivity) |
||
| 10 |
- #' @keywords internal+ #' |
||
| 11 |
- include_css_files <- function(pattern = "*") {
+ #' @section `srv_nested_tabs`: |
||
| 12 | -12x | +
- css_files <- list.files(+ #' This module calls recursively all elements of the `modules` returns one which |
|
| 13 | -12x | +
- system.file("css", package = "teal", mustWork = TRUE),
+ #' is currently active. |
|
| 14 | -12x | +
- pattern = pattern, full.names = TRUE+ #' - `teal_module` returns self as a active module. |
|
| 15 |
- )+ #' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`. |
||
| 16 | -12x | +
- return(+ #' |
|
| 17 | -12x | +
- shiny::singleton(+ #' @name module_nested_tabs |
|
| 18 | -12x | +
- shiny::tags$head(lapply(css_files, shiny::includeCSS))+ #' |
|
| 19 |
- )+ #' @inheritParams module_tabs_with_filters |
||
| 20 |
- )+ #' |
||
| 21 |
- }+ #' @param depth (`integer(1)`)\cr |
||
| 22 |
-
+ #' number which helps to determine depth of the modules nesting. |
||
| 23 |
- #' Include `JS` files from `/inst/js/` package directory to application header+ #' @param is_module_specific (`logical(1)`)\cr |
||
| 24 |
- #'+ #' flag determining if the filter panel is global or module-specific. |
||
| 25 |
- #' `system.file` should not be used to access files in other packages, it does+ #' When set to `TRUE`, a filter panel is called inside of each module tab. |
||
| 26 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' @return depending on class of `modules`, `ui_nested_tabs` returns: |
||
| 27 |
- #' as needed. Thus, we do not export this method+ #' - `teal_module`: instantiated UI of the module |
||
| 28 |
- #'+ #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively |
||
| 29 |
- #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ #' calling this function on it.\cr |
||
| 30 |
- #' @param except (`character`) vector of basename filenames to be excluded+ #' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab. |
||
| 32 |
- #' @return HTML code that includes `JS` files+ #' @examples |
||
| 33 |
- #' @keywords internal+ #' mods <- teal:::example_modules() |
||
| 34 |
- include_js_files <- function(pattern = NULL, except = NULL) {
+ #' datasets <- teal:::example_datasets() |
||
| 35 | -12x | +
- checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)+ #' app <- shinyApp( |
|
| 36 | -12x | +
- js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
+ #' ui = function() {
|
|
| 37 | -12x | +
- js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL+ #' tagList( |
|
| 38 |
-
+ #' teal:::include_teal_css_js(), |
||
| 39 | -12x | +
- return(singleton(lapply(js_files, includeScript)))+ #' textOutput("info"),
|
|
| 40 |
- }+ #' fluidPage( # needed for nice tabs |
||
| 41 |
-
+ #' teal:::ui_nested_tabs("dummy", modules = mods, datasets = datasets)
|
||
| 42 |
- #' Run `JS` file from `/inst/js/` package directory+ #' ) |
||
| 43 |
- #'+ #' ) |
||
| 44 |
- #' This is triggered from the server to execute on the client+ #' }, |
||
| 45 |
- #' rather than triggered directly on the client.+ #' server = function(input, output, session) {
|
||
| 46 |
- #' Unlike `include_js_files` which includes `JavaScript` functions,+ #' active_module <- teal:::srv_nested_tabs( |
||
| 47 |
- #' the `run_js` actually executes `JavaScript` functions.+ #' "dummy", |
||
| 48 |
- #'+ #' datasets = datasets, |
||
| 49 |
- #' `system.file` should not be used to access files in other packages, it does+ #' modules = mods |
||
| 50 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' ) |
||
| 51 |
- #' as needed. Thus, we do not export this method+ #' output$info <- renderText({
|
||
| 52 |
- #'+ #' paste0("The currently active tab name is ", active_module()$label)
|
||
| 53 |
- #' @param files (`character`) vector of filenames+ #' }) |
||
| 54 |
- #' @keywords internal+ #' } |
||
| 55 |
- run_js_files <- function(files) {
+ #' ) |
||
| 56 | -18x | +
- checkmate::assert_character(files, min.len = 1, any.missing = FALSE)+ #' if (interactive()) {
|
|
| 57 | -18x | +
- lapply(files, function(file) {
+ #' shinyApp(app$ui, app$server) |
|
| 58 | -18x | +
- shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
+ #' } |
|
| 59 |
- })+ #' @keywords internal |
||
| 60 | -18x | +
- return(invisible(NULL))+ NULL |
|
| 61 |
- }+ |
||
| 62 |
-
+ #' @rdname module_nested_tabs |
||
| 63 |
- #' Code to include teal `CSS` and `JavaScript` files+ ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 64 | -+ | ! |
- #'+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
| 65 | -+ | ! |
- #' This is useful when you want to use the same `JavaScript` and `CSS` files that are+ checkmate::assert_count(depth) |
| 66 | -+ | ! |
- #' used with the teal application.+ UseMethod("ui_nested_tabs", modules)
|
| 67 |
- #' This is also useful for running standalone modules in teal with the correct+ } |
||
| 68 |
- #' styles.+ |
||
| 69 |
- #' Also initializes `shinyjs` so you can use it.+ #' @rdname module_nested_tabs |
||
| 70 |
- #'+ #' @export |
||
| 71 |
- #' @return HTML code to include+ ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 72 | -+ | ! |
- #' @examples+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
|
| 73 |
- #' shiny_ui <- tagList(+ } |
||
| 74 |
- #' teal:::include_teal_css_js(),+ |
||
| 75 |
- #' p("Hello")
+ #' @rdname module_nested_tabs |
||
| 76 |
- #' )+ #' @export |
||
| 77 |
- #' @keywords internal+ ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 78 | -+ | ! |
- include_teal_css_js <- function() {
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
| 79 | -12x | +! |
- tagList(+ ns <- NS(id) |
| 80 | -12x | +! |
- shinyjs::useShinyjs(),+ do.call( |
| 81 | -12x | +! |
- include_css_files(),+ tabsetPanel, |
| 82 | -+ | ! |
- # init.js is executed from the server+ c( |
| 83 | -12x | +
- include_js_files(except = "init.js"),+ # by giving an id, we can reactively respond to tab changes |
|
| 84 | -12x | +! |
- shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
+ list( |
| 85 | -+ | ! |
- )+ id = ns("active_tab"),
|
| 86 | -+ | ! |
- }+ type = if (modules$label == "root") "pills" else "tabs" |
| 1 | +87 |
- #' Filter settings for teal applications+ ), |
||
| 2 | -+ | |||
| 88 | +! |
- #'+ lapply( |
||
| 3 | -+ | |||
| 89 | +! |
- #' Specify initial filter states and filtering settings for a `teal` app.+ names(modules$children), |
||
| 4 | -+ | |||
| 90 | +! |
- #'+ function(module_id) {
|
||
| 5 | -+ | |||
| 91 | +! |
- #' Produces a `teal_slices` object.+ module_label <- modules$children[[module_id]]$label |
||
| 6 | -+ | |||
| 92 | +! |
- #' The `teal_slice` components will specify filter states that will be active when the app starts.+ tabPanel( |
||
| 7 | -+ | |||
| 93 | +! |
- #' Attributes (created with the named arguments) will configure the way the app applies filters.+ title = module_label,+ |
+ ||
| 94 | +! | +
+ value = module_id, # when clicked this tab value changes input$<tabset panel id>+ |
+ ||
| 95 | +! | +
+ ui_nested_tabs(+ |
+ ||
| 96 | +! | +
+ id = ns(module_id),+ |
+ ||
| 97 | +! | +
+ modules = modules$children[[module_id]], |
||
| 8 | -+ | |||
| 98 | +! |
- #' See argument descriptions for details.+ datasets = datasets[[module_label]], |
||
| 9 | -+ | |||
| 99 | +! |
- #'+ depth = depth + 1L, |
||
| 10 | -+ | |||
| 100 | +! |
- #' @inheritParams teal.slice::teal_slices+ is_module_specific = is_module_specific |
||
| 11 | +101 |
- #'+ ) |
||
| 12 | +102 |
- #' @param module_specific optional (`logical(1)`)\cr+ ) |
||
| 13 | +103 |
- #' - `FALSE` (default) when one filter panel applied to all modules.+ } |
||
| 14 | +104 |
- #' All filters will be shared by all modules.+ ) |
||
| 15 | +105 |
- #' - `TRUE` when filter panel module-specific.+ ) |
||
| 16 | +106 |
- #' Modules can have different set of filters specified - see `mapping` argument.+ ) |
||
| 17 | +107 |
- #' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
+ } |
||
| 18 | +108 |
- #' (`named list`)\cr+ |
||
| 19 | +109 |
- #' Specifies which filters will be active in which modules on app start.+ #' @rdname module_nested_tabs |
||
| 20 | +110 |
- #' Elements should contain character vector of `teal_slice` `id`s (see [teal.slice::teal_slice()]).+ #' @export |
||
| 21 | +111 |
- #' Names of the list should correspond to `teal_module` `label` set in [module()] function.+ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 22 | -+ | |||
| 112 | +! |
- #' `id`s listed under `"global_filters` will be active in all modules.+ checkmate::assert_class(datasets, classes = "FilteredData") |
||
| 23 | -+ | |||
| 113 | +! |
- #' If missing, all filters will be applied to all modules.+ ns <- NS(id) |
||
| 24 | +114 |
- #' If empty list, all filters will be available to all modules but will start inactive.+ |
||
| 25 | -+ | |||
| 115 | +! |
- #' If `module_specific` is `FALSE`, only `global_filters` will be active on start.+ args <- c(list(id = ns("module")), modules$ui_args)
|
||
| 26 | +116 |
- #' @param app_id (`character(1)`)\cr+ |
||
| 27 | -+ | |||
| 117 | +! |
- #' For internal use only, do not set manually.+ teal_ui <- tags$div( |
||
| 28 | -+ | |||
| 118 | +! |
- #' Added by `init` so that a `teal_slices` can be matched to the app in which it was used.+ id = id, |
||
| 29 | -+ | |||
| 119 | +! |
- #' Used for verifying snapshots uploaded from file. See `snapshot`.+ class = "teal_module", |
||
| 30 | -+ | |||
| 120 | +! |
- #'+ uiOutput(ns("data_reactive"), inline = TRUE),
|
||
| 31 | -+ | |||
| 121 | +! |
- #' @param x (`list`) of lists to convert to `teal_slices`+ tagList( |
||
| 32 | -+ | |||
| 122 | +! |
- #'+ if (depth >= 2L) div(style = "mt-6"), |
||
| 33 | -+ | |||
| 123 | +! |
- #' @return+ do.call(modules$ui, args) |
||
| 34 | +124 |
- #' A `teal_slices` object.+ ) |
||
| 35 | +125 |
- #'+ ) |
||
| 36 | +126 |
- #' @seealso [`teal.slice::teal_slices`], [`teal.slice::teal_slice`], [`slices_store`]+ |
||
| 37 | -+ | |||
| 127 | +! |
- #'+ if (!is.null(modules$datanames) && is_module_specific) {
|
||
| 38 | -+ | |||
| 128 | +! |
- #' @examples+ fluidRow( |
||
| 39 | -+ | |||
| 129 | +! |
- #' filter <- teal_slices(+ column(width = 9, teal_ui, class = "teal_primary_col"), |
||
| 40 | -+ | |||
| 130 | +! |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"),+ column( |
||
| 41 | -+ | |||
| 131 | +! |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),+ width = 3, |
||
| 42 | -+ | |||
| 132 | +! |
- #' teal.slice::teal_slice(+ datasets$ui_filter_panel(ns("module_filter_panel")),
|
||
| 43 | -+ | |||
| 133 | +! |
- #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"+ class = "teal_secondary_col" |
||
| 44 | +134 |
- #' ),+ ) |
||
| 45 | +135 |
- #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),+ ) |
||
| 46 | +136 |
- #' mapping = list(+ } else {
|
||
| 47 | -+ | |||
| 137 | +! |
- #' module1 = c("species", "sepal_length"),
+ teal_ui |
||
| 48 | +138 |
- #' module2 = c("mtcars_mpg"),
+ } |
||
| 49 | +139 |
- #' global_filters = "long_petals"+ } |
||
| 50 | +140 |
- #' )+ |
||
| 51 | +141 |
- #' )+ #' @rdname module_nested_tabs |
||
| 52 | +142 |
- #'+ srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE, |
||
| 53 | +143 |
- #' app <- teal::init(+ reporter = teal.reporter::Reporter$new()) {
|
||
| 54 | -+ | |||
| 144 | +50x |
- #' data = list(iris = iris, mtcars = mtcars),+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
||
| 55 | -+ | |||
| 145 | +50x |
- #' modules = list(+ checkmate::assert_class(reporter, "Reporter") |
||
| 56 | -+ | |||
| 146 | +49x |
- #' module("module1"),
+ UseMethod("srv_nested_tabs", modules)
|
||
| 57 | +147 |
- #' module("module2")
+ } |
||
| 58 | +148 |
- #' ),+ |
||
| 59 | +149 |
- #' filter = filter+ #' @rdname module_nested_tabs |
||
| 60 | +150 |
- #' )+ #' @export |
||
| 61 | +151 |
- #'+ srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE, |
||
| 62 | +152 |
- #' if (interactive()) {
+ reporter = teal.reporter::Reporter$new()) {
|
||
| 63 | -+ | |||
| 153 | +! |
- #' shinyApp(app$ui, app$server)+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
|
||
| 64 | +154 |
- #' }+ } |
||
| 65 | +155 |
- #'+ |
||
| 66 | +156 |
- #' @export+ #' @rdname module_nested_tabs |
||
| 67 | +157 |
- teal_slices <- function(...,+ #' @export |
||
| 68 | +158 |
- exclude_varnames = NULL,+ srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE, |
||
| 69 | +159 |
- include_varnames = NULL,+ reporter = teal.reporter::Reporter$new()) {
|
||
| 70 | -+ | |||
| 160 | +22x |
- count_type = NULL,+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
||
| 71 | +161 |
- allow_add = TRUE,+ |
||
| 72 | -+ | |||
| 162 | +22x |
- module_specific = FALSE,+ moduleServer(id = id, module = function(input, output, session) {
|
||
| 73 | -+ | |||
| 163 | +22x |
- mapping,+ logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
|
||
| 74 | +164 |
- app_id = NULL) {
+
|
||
| 75 | -76x | +165 | +22x |
- shiny::isolate({
+ labels <- vapply(modules$children, `[[`, character(1), "label") |
| 76 | -76x | +166 | +22x |
- checkmate::assert_flag(allow_add)+ modules_reactive <- sapply( |
| 77 | -76x | +167 | +22x |
- checkmate::assert_flag(module_specific)+ names(modules$children), |
| 78 | -37x | +168 | +22x |
- if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
+ function(module_id) {
|
| 79 | -73x | +169 | +33x |
- checkmate::assert_string(app_id, null.ok = TRUE)+ srv_nested_tabs( |
| 80 | -+ | |||
| 170 | +33x |
-
+ id = module_id, |
||
| 81 | -73x | +171 | +33x |
- slices <- list(...)+ datasets = datasets[[labels[module_id]]], |
| 82 | -73x | +172 | +33x |
- all_slice_id <- vapply(slices, `[[`, character(1L), "id")+ modules = modules$children[[module_id]], |
| 83 | -+ | |||
| 173 | +33x |
-
+ is_module_specific = is_module_specific, |
||
| 84 | -73x | +174 | +33x |
- if (missing(mapping)) {
+ reporter = reporter |
| 85 | -39x | +|||
| 175 | +
- mapping <- list(global_filters = all_slice_id)+ ) |
|||
| 86 | +176 |
- }+ }, |
||
| 87 | -73x | +177 | +22x |
- if (!module_specific) {
+ simplify = FALSE |
| 88 | -69x | +|||
| 178 | +
- mapping[setdiff(names(mapping), "global_filters")] <- NULL+ ) |
|||
| 89 | +179 |
- }+ |
||
| 90 | +180 |
-
+ # when not ready input$active_tab would return NULL - this would fail next reactive |
||
| 91 | -73x | +181 | +22x |
- failed_slice_id <- setdiff(unlist(mapping), all_slice_id)+ input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE) |
| 92 | -73x | +182 | +22x |
- if (length(failed_slice_id)) {
+ get_active_module <- reactive({
|
| 93 | -1x | +183 | +12x |
- stop(sprintf(+ if (length(modules$children) == 1L) {
+ |
+
| 184 | ++ |
+ # single tab is active by default |
||
| 94 | +185 | 1x |
- "Filters in mapping don't match any available filter.\n %s not in %s",+ modules_reactive[[1]]()+ |
+ |
| 186 | ++ |
+ } else {
|
||
| 95 | -1x | +|||
| 187 | +
- toString(failed_slice_id),+ # switch to active tab |
|||
| 96 | -1x | +188 | +11x |
- toString(all_slice_id)+ modules_reactive[[input_validated()]]() |
| 97 | +189 |
- ))+ } |
||
| 98 | +190 |
- }+ }) |
||
| 99 | +191 | |||
| 100 | -72x | +192 | +22x |
- tss <- teal.slice::teal_slices(+ get_active_module |
| 101 | +193 |
- ...,+ }) |
||
| 102 | -72x | +|||
| 194 | +
- exclude_varnames = exclude_varnames,+ } |
|||
| 103 | -72x | +|||
| 195 | +
- include_varnames = include_varnames,+ |
|||
| 104 | -72x | +|||
| 196 | +
- count_type = count_type,+ #' @rdname module_nested_tabs |
|||
| 105 | -72x | +|||
| 197 | +
- allow_add = allow_add+ #' @export |
|||
| 106 | +198 |
- )+ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE, |
||
| 107 | -72x | +|||
| 199 | +
- attr(tss, "mapping") <- mapping+ reporter = teal.reporter::Reporter$new()) {
|
|||
| 108 | -72x | +200 | +27x |
- attr(tss, "module_specific") <- module_specific+ checkmate::assert_class(datasets, "FilteredData") |
| 109 | -72x | +201 | +27x |
- attr(tss, "app_id") <- app_id+ logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
+ |
+
| 202 | ++ | + | ||
| 110 | -72x | +203 | +27x |
- class(tss) <- c("modules_teal_slices", class(tss))
+ moduleServer(id = id, module = function(input, output, session) {
|
| 111 | -72x | +204 | +27x |
- tss+ if (!is.null(modules$datanames) && is_module_specific) {
|
| 112 | -+ | |||
| 205 | +! |
- })+ datasets$srv_filter_panel("module_filter_panel")
|
||
| 113 | +206 |
- }+ } |
||
| 114 | +207 | |||
| 115 | +208 |
-
+ # Create two triggers to limit reactivity between filter-panel and modules. |
||
| 116 | +209 |
- #' @rdname teal_slices+ # We want to recalculate only visible modules |
||
| 117 | +210 |
- #' @export+ # - trigger the data when the tab is selected |
||
| 118 | +211 |
- #' @keywords internal+ # - trigger module to be called when the tab is selected for the first time |
||
| 119 | -+ | |||
| 212 | +27x |
- #'+ trigger_data <- reactiveVal(1L) |
||
| 120 | -+ | |||
| 213 | +27x |
- as.teal_slices <- function(x) { # nolint
+ trigger_module <- reactiveVal(NULL) |
||
| 121 | -15x | +214 | +27x |
- checkmate::assert_list(x)+ output$data_reactive <- renderUI({
|
| 122 | -15x | +215 | +17x |
- lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")+ lapply(datasets$datanames(), function(x) {
+ |
+
| 216 | +21x | +
+ datasets$get_data(x, filtered = TRUE) |
||
| 123 | +217 |
-
+ }) |
||
| 124 | -15x | +218 | +17x |
- attrs <- attributes(unclass(x))+ isolate(trigger_data(trigger_data() + 1)) |
| 125 | -15x | +219 | +17x |
- ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))+ isolate(trigger_module(TRUE))+ |
+
| 220 | ++ | + | ||
| 126 | -15x | +221 | +17x |
- do.call(teal_slices, c(ans, attrs))+ NULL |
| 127 | +222 |
- }+ }) |
||
| 128 | +223 | |||
| 129 | +224 |
-
+ # collect arguments to run teal_module |
||
| 130 | -+ | |||
| 225 | +27x |
- #' @rdname teal_slices+ args <- c(list(id = "module"), modules$server_args) |
||
| 131 | -+ | |||
| 226 | +27x |
- #' @export+ if (is_arg_used(modules$server, "reporter")) {
|
||
| 132 | -+ | |||
| 227 | +! |
- #' @keywords internal+ args <- c(args, list(reporter = reporter)) |
||
| 133 | +228 |
- #'+ } |
||
| 134 | +229 |
- c.teal_slices <- function(...) {
+
|
||
| 135 | -! | +|||
| 230 | +27x | +
+ if (is_arg_used(modules$server, "datasets")) {
+ |
+ ||
| 231 | +1x |
- x <- list(...)+ args <- c(args, datasets = datasets) |
||
| 136 | -! | +|||
| 232 | +
- checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ } |
|||
| 137 | +233 | |||
| 138 | -! | +|||
| 234 | +27x |
- all_attributes <- lapply(x, attributes)+ if (is_arg_used(modules$server, "data")) {
|
||
| 139 | -! | +|||
| 235 | +7x |
- all_attributes <- coalesce_r(all_attributes)+ data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets)) |
||
| 140 | -! | +|||
| 236 | +7x |
- all_attributes <- all_attributes[names(all_attributes) != "class"]+ args <- c(args, data = list(data)) |
||
| 141 | +237 | - - | -||
| 142 | -! | -
- do.call(+ } |
||
| 143 | -! | +|||
| 238 | +
- teal_slices,+ |
|||
| 144 | -! | +|||
| 239 | +27x |
- c(+ if (is_arg_used(modules$server, "filter_panel_api")) {
|
||
| 145 | -! | +|||
| 240 | +2x |
- unique(unlist(x, recursive = FALSE)),+ filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets) |
||
| 146 | -! | +|||
| 241 | +2x |
- all_attributes+ args <- c(args, filter_panel_api = filter_panel_api) |
||
| 147 | +242 |
- )+ } |
||
| 148 | +243 |
- )+ |
||
| 149 | +244 |
- }+ # observe the trigger_module above to induce the module once the renderUI is triggered |
||
| 150 | -+ | |||
| 245 | +27x |
-
+ observeEvent( |
||
| 151 | -+ | |||
| 246 | +27x |
-
+ ignoreNULL = TRUE, |
||
| 152 | -+ | |||
| 247 | +27x |
- #' Deep copy `teal_slices`+ once = TRUE, |
||
| 153 | -+ | |||
| 248 | +27x |
- #'+ eventExpr = trigger_module(), |
||
| 154 | -+ | |||
| 249 | +27x |
- #' it's important to create a new copy of `teal_slices` when+ handlerExpr = {
|
||
| 155 | -+ | |||
| 250 | +17x |
- #' starting a new `shiny` session. Otherwise, object will be shared+ module_output <- if (is_arg_used(modules$server, "id")) {
|
||
| 156 | -+ | |||
| 251 | +17x |
- #' by multiple users as it is created in global environment before+ do.call(modules$server, args) |
||
| 157 | +252 |
- #' `shiny` session starts.+ } else {
|
||
| 158 | -+ | |||
| 253 | +! |
- #' @param filter (`teal_slices`)+ do.call(callModule, c(args, list(module = modules$server))) |
||
| 159 | +254 |
- #' @return `teal_slices`+ } |
||
| 160 | +255 |
- #' @keywords internal+ } |
||
| 161 | +256 |
- deep_copy_filter <- function(filter) {
- |
- ||
| 162 | -1x | -
- checkmate::assert_class(filter, "teal_slices")+ ) |
||
| 163 | -1x | +|||
| 257 | +
- shiny::isolate({
+
|
|||
| 164 | -1x | +258 | +27x |
- filter_copy <- lapply(filter, function(slice) {
+ reactive(modules) |
| 165 | -2x | +|||
| 259 | +
- teal.slice::as.teal_slice(as.list(slice))+ }) |
|||
| 166 | +260 |
- })+ } |
||
| 167 | -1x | +|||
| 261 | +
- attributes(filter_copy) <- attributes(filter)+ |
|||
| 168 | -1x | +|||
| 262 | +
- filter_copy+ #' Convert `FilteredData` to reactive list of datasets of the `teal_data` type. |
|||
| 169 | +263 |
- })+ #' |
||
| 170 | +264 |
- }+ #' Converts `FilteredData` object to `teal_data` object containing datasets needed for a specific module. |
| 1 | +265 |
- #' Create a `teal` module for previewing a report+ #' Please note that if module needs dataset which has a parent, then parent will be also returned. |
||
| 2 | +266 |
- #'+ #' A hash per `dataset` is calculated internally and returned in the code. |
||
| 3 | +267 |
- #' @description `r lifecycle::badge("experimental")`
+ #' |
||
| 4 | +268 |
- #' This function wraps [teal.reporter::reporter_previewer_ui()] and+ #' @param module (`teal_module`) module where needed filters are taken from |
||
| 5 | +269 |
- #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be+ #' @param datasets (`FilteredData`) object where needed data are taken from |
||
| 6 | +270 |
- #' used in `teal` applications.+ #' @return A `teal_data` object. |
||
| 7 | +271 |
#' |
||
| 8 | +272 |
- #' If you are creating a `teal` application using [teal::init()] then this+ #' @keywords internal |
||
| 9 | +273 |
- #' module will be added to your application automatically if any of your `teal modules`+ .datasets_to_data <- function(module, datasets) {
|
||
| 10 | -+ | |||
| 274 | +4x |
- #' support report generation.+ checkmate::assert_class(module, "teal_module") |
||
| 11 | -+ | |||
| 275 | +4x |
- #'+ checkmate::assert_class(datasets, "FilteredData") |
||
| 12 | +276 |
- #' @inheritParams module+ |
||
| 13 | -+ | |||
| 277 | +4x |
- #' @param server_args (`named list`)\cr+ datanames <- if (is.null(module$datanames) || identical(module$datanames, "all")) {
|
||
| 14 | -+ | |||
| 278 | +1x |
- #' Arguments passed to [teal.reporter::reporter_previewer_srv()].+ datasets$datanames() |
||
| 15 | +279 |
- #' @return `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer+ } else {
+ |
+ ||
| 280 | +3x | +
+ unique(module$datanames) # todo: include parents! unique shouldn't be needed here! |
||
| 16 | +281 |
- #' functionality.+ } |
||
| 17 | +282 |
- #' @export+ |
||
| 18 | +283 |
- reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
+ # list of reactive filtered data |
||
| 19 | +284 | 4x |
- checkmate::assert_string(label)+ data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE) |
|
| 20 | -2x | +|||
| 285 | +
- checkmate::assert_list(server_args, names = "named")+ |
|||
| 21 | -2x | +286 | +4x |
- checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))+ hashes <- calculate_hashes(datanames, datasets) |
| 22 | +287 | |||
| 23 | -2x | +288 | +4x |
- logger::log_info("Initializing reporter_previewer_module")
+ code <- c( |
| 24 | -+ | |||
| 289 | +4x |
-
+ get_rcode_str_install(), |
||
| 25 | -2x | +290 | +4x |
- srv <- function(id, reporter, ...) {
+ get_rcode_libraries(), |
| 26 | -! | +|||
| 291 | +4x |
- teal.reporter::reporter_previewer_srv(id, reporter, ...)+ get_datasets_code(datanames, datasets, hashes) |
||
| 27 | +292 |
- }+ ) |
||
| 28 | +293 | |||
| 29 | -2x | +294 | +4x |
- ui <- function(id, ...) {
+ do.call( |
| 30 | -! | +|||
| 295 | +4x |
- teal.reporter::reporter_previewer_ui(id, ...)+ teal.data::teal_data,+ |
+ ||
| 296 | +4x | +
+ args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames])) |
||
| 31 | +297 |
- }+ ) |
||
| 32 | +298 | ++ |
+ }+ |
+ |
| 299 | ||||
| 33 | -2x | +|||
| 300 | +
- module <- module(+ #' Get the hash of a dataset |
|||
| 34 | -2x | +|||
| 301 | +
- label = "temporary label",+ #' |
|||
| 35 | -2x | +|||
| 302 | +
- server = srv, ui = ui,+ #' @param datanames (`character`) names of datasets |
|||
| 36 | -2x | +|||
| 303 | +
- server_args = server_args, ui_args = list(), datanames = NULL+ #' @param datasets (`FilteredData`) object holding the data |
|||
| 37 | +304 |
- )+ #' |
||
| 38 | +305 |
- # Module is created with a placeholder label and the label is changed later.+ #' @return A list of hashes per dataset |
||
| 39 | +306 |
- # This is to prevent another module being labeled "Report previewer".+ #' @keywords internal |
||
| 40 | -2x | +|||
| 307 | +
- class(module) <- c("teal_module_previewer", class(module))
+ #' |
|||
| 41 | -2x | +|||
| 308 | +
- module$label <- label+ calculate_hashes <- function(datanames, datasets) {
|
|||
| 42 | -2x | +309 | +7x |
- module+ sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE) |
| 43 | +310 |
}@@ -15277,11988 +15299,11813 @@ teal coverage - 63.32% |
| 1 |
- #' Add right filter panel into each of the top-level `teal_modules` UIs.+ #' @title `TealReportCard` |
|||
| 2 |
- #'+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 3 |
- #' The [ui_nested_tabs] function returns a nested tabbed UI corresponding+ #' A child of [`ReportCard`] that is used for teal specific applications. |
|||
| 4 |
- #' to the nested modules.+ #' In addition to the parent methods, it supports rendering teal specific elements such as |
|||
| 5 |
- #' This function adds the right filter panel to each main tab.+ #' the source code, the encodings panel content and the filter panel content as part of the |
|||
| 6 |
- #'+ #' meta data. |
|||
| 7 |
- #' The right filter panel's filter choices affect the `datasets` object. Therefore,+ #' @export |
|||
| 8 |
- #' all modules using the same `datasets` share the same filters.+ #' |
|||
| 9 |
- #'+ TealReportCard <- R6::R6Class( # nolint: object_name_linter. |
|||
| 10 |
- #' This works with nested modules of depth greater than 2, though the filter+ classname = "TealReportCard", |
|||
| 11 |
- #' panel is inserted at the right of the modules at depth 1 and not at the leaves.+ inherit = teal.reporter::ReportCard, |
|||
| 12 |
- #'+ public = list( |
|||
| 13 |
- #' @name module_tabs_with_filters+ #' @description Appends the source code to the `content` meta data of this `TealReportCard`. |
|||
| 14 |
- #'+ #' |
|||
| 15 |
- #' @inheritParams module_teal+ #' @param src (`character(1)`) code as text. |
|||
| 16 |
- #'+ #' @param ... any `rmarkdown` R chunk parameter and its value. |
|||
| 17 |
- #' @param datasets (`named list` of `FilteredData`)\cr+ #' But `eval` parameter is always set to `FALSE`. |
|||
| 18 |
- #' object to store filter state and filtered datasets, shared across modules. For more+ #' @return invisibly self |
|||
| 19 |
- #' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure+ #' @examples |
|||
| 20 |
- #' of the `modules` argument and list names must correspond to the labels in `modules`.+ #' card <- TealReportCard$new()$append_src( |
|||
| 21 |
- #' When filter is not module-specific then list contains the same object in all elements.+ #' "plot(iris)" |
|||
| 22 |
- #' @param reporter (`Reporter`) object from `teal.reporter`+ #' ) |
|||
| 23 |
- #'+ #' card$get_content()[[1]]$get_content() |
|||
| 24 |
- #' @return A `tagList` of The main menu, place holders for filters and+ append_src = function(src, ...) {
|
|||
| 25 | -+ | 4x |
- #' place holders for the teal modules+ checkmate::assert_character(src, min.len = 0, max.len = 1) |
|
| 26 | -+ | 4x |
- #'+ params <- list(...) |
|
| 27 | -+ | 4x |
- #'+ params$eval <- FALSE |
|
| 28 | -+ | 4x |
- #' @keywords internal+ rblock <- RcodeBlock$new(src) |
|
| 29 | -+ | 4x |
- #'+ rblock$set_params(params) |
|
| 30 | -+ | 4x |
- #' @examples+ self$append_content(rblock) |
|
| 31 | -+ | 4x |
- #'+ self$append_metadata("SRC", src)
|
|
| 32 | -+ | 4x |
- #' mods <- teal:::example_modules()+ invisible(self) |
|
| 33 |
- #' datasets <- teal:::example_datasets()+ }, |
|||
| 34 |
- #'+ #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`. |
|||
| 35 |
- #' app <- shinyApp(+ #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses |
|||
| 36 |
- #' ui = function() {
+ #' the default `yaml::as.yaml` to format the list. |
|||
| 37 |
- #' tagList(+ #' If the filter state list is empty, nothing is appended to the `content`. |
|||
| 38 |
- #' teal:::include_teal_css_js(),+ #' |
|||
| 39 |
- #' textOutput("info"),
+ #' @param fs (`teal_slices`) object returned from [teal_slices()] function. |
|||
| 40 |
- #' fluidPage( # needed for nice tabs+ #' @return invisibly self |
|||
| 41 |
- #' ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
+ append_fs = function(fs) {
|
|||
| 42 | -+ | 5x |
- #' )+ checkmate::assert_class(fs, "teal_slices") |
|
| 43 | -+ | 4x |
- #' )+ self$append_text("Filter State", "header3")
|
|
| 44 | -+ | 4x |
- #' },+ self$append_content(TealSlicesBlock$new(fs)) |
|
| 45 | -+ | 4x |
- #' server = function(input, output, session) {
+ invisible(self) |
|
| 46 |
- #' output$info <- renderText({
+ }, |
|||
| 47 |
- #' paste0("The currently active tab name is ", active_module()$label)
+ #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`. |
|||
| 48 |
- #' })+ #' |
|||
| 49 |
- #' active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods)+ #' @param encodings (`list`) list of encodings selections of the teal app. |
|||
| 50 |
- #' }+ #' @return invisibly self |
|||
| 51 |
- #' )+ #' @examples |
|||
| 52 |
- #' if (interactive()) {
+ #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X")) |
|||
| 53 |
- #' shinyApp(app$ui, app$server)+ #' card$get_content()[[1]]$get_content() |
|||
| 54 |
- #' }+ #' |
|||
| 55 |
- #'+ append_encodings = function(encodings) {
|
|||
| 56 | -+ | 4x |
- NULL+ checkmate::assert_list(encodings) |
|
| 57 | -+ | 4x |
-
+ self$append_text("Selected Options", "header3")
|
|
| 58 | -+ | 4x |
- #' @rdname module_tabs_with_filters+ if (requireNamespace("yaml", quietly = TRUE)) {
|
|
| 59 | -+ | 4x |
- ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
+ self$append_text(yaml::as.yaml(encodings, handlers = list( |
|
| 60 | -! | +4x |
- checkmate::assert_class(modules, "teal_modules")+ POSIXct = function(x) format(x, "%Y-%m-%d"), |
|
| 61 | -! | +4x |
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ POSIXlt = function(x) format(x, "%Y-%m-%d"), |
|
| 62 | -! | +4x |
- checkmate::assert_class(filter, "teal_slices")+ Date = function(x) format(x, "%Y-%m-%d") |
|
| 63 | -+ | 4x |
-
+ )), "verbatim") |
|
| 64 | -! | +
- ns <- NS(id)+ } else {
|
||
| 65 | ! |
- is_module_specific <- isTRUE(attr(filter, "module_specific"))+ stop("yaml package is required to format the encodings list")
|
||
| 66 |
-
+ } |
|||
| 67 | -! | +4x |
- teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
+ self$append_metadata("Encodings", encodings)
|
|
| 68 | -! | +4x |
- filter_panel_btns <- tags$li(+ invisible(self) |
|
| 69 | -! | +
- class = "flex-grow",+ } |
||
| 70 | -! | +
- tags$button(+ ), |
||
| 71 | -! | +
- class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger+ private = list() |
||
| 72 | -! | +
- href = "javascript:void(0)",+ ) |
||
| 73 | -! | +
- onclick = "toggleFilterPanel();", # see sidebar.js+ |
||
| 74 | -! | +
- title = "Toggle filter panels",+ #' @title `RcodeBlock` |
||
| 75 | -! | +
- icon("fas fa-bars")
+ #' @keywords internal |
||
| 76 |
- ),+ TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter. |
|||
| 77 | -! | +
- filter_manager_modal_ui(ns("filter_manager"))
+ classname = "TealSlicesBlock", |
||
| 78 |
- )+ inherit = teal.reporter:::TextBlock, |
|||
| 79 | -! | +
- teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)+ public = list( |
||
| 80 |
-
+ #' @description Returns a `TealSlicesBlock` object. |
|||
| 81 | -! | +
- if (!is_module_specific) {
+ #' |
||
| 82 |
- # need to rearrange html so that filter panel is within tabset+ #' @details Returns a `TealSlicesBlock` object with no content and no parameters. |
|||
| 83 | -! | +
- tabset_bar <- teal_ui$children[[1]]+ #' |
||
| 84 | -! | +
- teal_modules <- teal_ui$children[[2]]+ #' @param content (`teal_slices`) object returned from [teal_slices()] function. |
||
| 85 | -! | +
- filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
+ #' @param style (`character(1)`) string specifying style to apply. |
||
| 86 | -! | +
- list(+ #' |
||
| 87 | -! | +
- tabset_bar,+ #' @return `TealSlicesBlock` |
||
| 88 | -! | +
- tags$hr(class = "my-2"),+ #' @examples |
||
| 89 | -! | +
- fluidRow(+ #' block <- teal:::TealSlicesBlock$new() |
||
| 90 | -! | +
- column(width = 9, teal_modules, class = "teal_primary_col"),+ #' |
||
| 91 | -! | +
- column(width = 3, filter_ui, class = "teal_secondary_col")+ initialize = function(content = teal_slices(), style = "verbatim") {
|
||
| 92 | -+ | 10x |
- )+ self$set_content(content) |
|
| 93 | -+ | 9x |
- )+ self$set_style(style) |
|
| 94 | -+ | 9x |
- } else {
+ invisible(self) |
|
| 95 | -! | +
- teal_ui+ }, |
||
| 96 |
- }+ |
|||
| 97 |
- }+ #' @description Sets content of this `TealSlicesBlock`. |
|||
| 98 |
-
+ #' Sets content as `YAML` text which represents a list generated from `teal_slices`. |
|||
| 99 |
- #' @rdname module_tabs_with_filters+ #' The list displays limited number of fields from `teal_slice` objects, but this list is |
|||
| 100 |
- srv_tabs_with_filters <- function(id,+ #' sufficient to conclude which filters were applied. |
|||
| 101 |
- datasets,+ #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min" |
|||
| 102 |
- modules,+ #' |
|||
| 103 |
- reporter = teal.reporter::Reporter$new(),+ #' |
|||
| 104 |
- filter = teal_slices()) {
+ #' @param content (`teal_slices`) object returned from [teal_slices()] function. |
|||
| 105 | -5x | +
- checkmate::assert_class(modules, "teal_modules")+ #' @return invisibly self |
||
| 106 | -5x | +
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ set_content = function(content) {
|
||
| 107 | -5x | +11x |
- checkmate::assert_class(reporter, "Reporter")+ checkmate::assert_class(content, "teal_slices") |
|
| 108 | -3x | +10x |
- checkmate::assert_class(filter, "teal_slices")+ if (length(content) != 0) {
|
|
| 109 | -+ | 7x |
-
+ states_list <- lapply(content, function(x) {
|
|
| 110 | -3x | +7x |
- moduleServer(id, function(input, output, session) {
+ x_list <- shiny::isolate(as.list(x)) |
|
| 111 | -3x | +7x |
- logger::log_trace("srv_tabs_with_filters initializing the module.")
+ if ( |
|
| 112 | -+ | 7x |
-
+ inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
|
|
| 113 | -3x | +7x |
- is_module_specific <- isTRUE(attr(filter, "module_specific"))+ length(x_list$choices) == 2 && |
|
| 114 | -3x | +7x |
- manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
+ length(x_list$selected) == 2 |
|
| 115 |
-
+ ) {
|
|||
| 116 | -3x | +! |
- active_module <- srv_nested_tabs(+ x_list$range <- paste(x_list$selected, collapse = " - ") |
|
| 117 | -3x | -
- id = "root",- |
- ||
| 118 | -3x | -
- datasets = datasets,- |
- ||
| 119 | -3x | -
- modules = modules,- |
- ||
| 120 | -3x | -
- reporter = reporter,- |
- ||
| 121 | -3x | -
- is_module_specific = is_module_specific- |
- ||
| 122 | -+ | ! |
- )+ x_list["selected"] <- NULL |
|
| 123 | +118 | - - | -||
| 124 | -3x | -
- if (!is_module_specific) {
- |
- ||
| 125 | -3x | -
- active_datanames <- reactive({
+ } |
||
| 126 | -6x | +119 | +7x |
- if (identical(active_module()$datanames, "all")) {
+ if (!is.null(x_list$arg)) {
|
| 127 | +120 | ! |
- singleton$datanames()- |
- |
| 128 | -- |
- } else {
- |
- ||
| 129 | -5x | -
- active_module()$datanames+ x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples" |
||
| 130 | +121 |
- }+ } |
||
| 131 | +122 |
- })+ |
||
| 132 | -3x | +123 | +7x |
- singleton <- unlist(datasets)[[1]]+ x_list <- x_list[ |
| 133 | -3x | +124 | +7x |
- singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
+ c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
|
| 134 | +125 |
-
+ ] |
||
| 135 | -3x | +126 | +7x |
- observeEvent(+ names(x_list) <- c( |
| 136 | -3x | +127 | +7x |
- eventExpr = active_datanames(),+ "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression", |
| 137 | -3x | +128 | +7x |
- handlerExpr = {
+ "Selected Values", "Selected range", "Include NA values", "Include Inf values" |
| 138 | -4x | +|||
| 129 | +
- script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
+ ) |
|||
| 139 | +130 |
- # hide the filter panel and disable the burger button+ |
||
| 140 | -! | +|||
| 131 | +7x |
- "handleNoActiveDatasets();"+ Filter(Negate(is.null), x_list) |
||
| 141 | +132 |
- } else {
+ }) |
||
| 142 | +133 |
- # show the filter panel and enable the burger button+ |
||
| 143 | -4x | -
- "handleActiveDatasetsPresent();"- |
- ||
| 144 | -+ | 134 | +7x |
- }+ if (requireNamespace("yaml", quietly = TRUE)) {
|
| 145 | -4x | +135 | +7x |
- shinyjs::runjs(script)+ super$set_content(yaml::as.yaml(states_list)) |
| 146 | +136 |
- },- |
- ||
| 147 | -3x | -
- ignoreNULL = FALSE+ } else {
|
||
| 148 | -+ | |||
| 137 | +! |
- )+ stop("yaml package is required to format the filter state list")
|
||
| 149 | +138 |
- }+ } |
||
| 150 | +139 | - - | -||
| 151 | -3x | -
- showNotification("Data loaded - App fully started up")
+ } |
||
| 152 | -3x | +140 | +10x |
- logger::log_trace("srv_tabs_with_filters initialized the module")
+ private$teal_slices <- content |
| 153 | -3x | -
- return(active_module)- |
- ||
| 154 | -- |
- })- |
- ||
| 155 | -+ | 141 | +10x |
- }+ invisible(self) |
| 1 | +142 |
- # This file adds a splash screen for delayed data loading on top of teal+ }, |
|
| 2 | +143 |
-
+ #' @description Create the `RcodeBlock` from a list. |
|
| 3 | +144 |
- #' UI to show a splash screen in the beginning, then delegate to [srv_teal()]+ #' @param x `named list` with two fields `c("text", "params")`.
|
|
| 4 | +145 |
- #'+ #' Use the `get_available_params` method to get all possible parameters. |
|
| 5 | +146 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return invisibly self |
|
| 6 | +147 |
- #' The splash screen could be used to query for a password to fetch the data.+ from_list = function(x) {
|
|
| 7 | -+ | ||
| 148 | +1x |
- #' [init()] is a very thin wrapper around this module useful for end-users which+ checkmate::assert_list(x) |
|
| 8 | -+ | ||
| 149 | +1x |
- #' assumes that it is a top-level module and cannot be embedded.+ checkmate::assert_names(names(x), must.include = c("teal_slices"))
|
|
| 9 | -+ | ||
| 150 | +1x |
- #' This function instead adheres to the Shiny module conventions.+ self$set_content(x$teal_slices) |
|
| 10 | -+ | ||
| 151 | +1x |
- #'+ invisible(self) |
|
| 11 | +152 |
- #' If data is obtained through delayed loading, its splash screen is used. Otherwise,+ }, |
|
| 12 | +153 |
- #' a default splash screen is shown.+ #' @description Convert the `RcodeBlock` to a list. |
|
| 13 | +154 |
- #'+ #' @return `named list` with a text and `params`. |
|
| 14 | +155 |
- #' Please also refer to the doc of [init()].+ |
|
| 15 | +156 |
- #'+ to_list = function() {
|
|
| 16 | -+ | ||
| 157 | +2x |
- #' @param id (`character(1)`)\cr+ list(teal_slices = private$teal_slices) |
|
| 17 | +158 |
- #' module id+ } |
|
| 18 | +159 |
- #' @inheritParams init+ ), |
|
| 19 | +160 |
- #' @export+ private = list( |
|
| 20 | +161 |
- ui_teal_with_splash <- function(id,+ style = "verbatim", |
|
| 21 | +162 |
- data,+ teal_slices = NULL # teal_slices |
|
| 22 | +163 |
- title,+ ) |
|
| 23 | +164 |
- header = tags$p("Add Title Here"),
+ ) |
| 24 | +1 |
- footer = tags$p("Add Footer Here")) {
+ #' Create a `tdata` Object |
||
| 25 | -12x | +|||
| 2 | +
- checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
+ #' |
|||
| 26 | -12x | +|||
| 3 | +
- ns <- NS(id)+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 27 | +4 |
-
+ #' Create a new object called `tdata` which contains `data`, a `reactive` list of data.frames |
||
| 28 | +5 |
- # Startup splash screen for delayed loading+ #' (or `MultiAssayExperiment`), with attributes: |
||
| 29 | +6 |
- # We use delayed loading in all cases, even when the data does not need to be fetched.+ #' \itemize{
|
||
| 30 | +7 |
- # This has the benefit that when filtering the data takes a lot of time initially, the+ #' \item{`code` (`reactive`) containing code used to generate the data}
|
||
| 31 | +8 |
- # Shiny app does not time out.+ #' \item{join_keys (`join_keys`) containing the relationships between the data}
|
||
| 32 | -12x | +|||
| 9 | +
- splash_ui <- if (inherits(data, "teal_data_module")) {
+ #' \item{metadata (`named list`) containing any metadata associated with the data frames}
|
|||
| 33 | -1x | +|||
| 10 | +
- data$ui(ns("teal_data_module"))
+ #' } |
|||
| 34 | -12x | +|||
| 11 | +
- } else if (inherits(data, "teal_data")) {
+ #' @name tdata |
|||
| 35 | -11x | +|||
| 12 | +
- div()+ #' @param data A `named list` of `data.frames` (or `MultiAssayExperiment`) |
|||
| 36 | +13 |
- }+ #' which optionally can be `reactive`. |
||
| 37 | -12x | +|||
| 14 | +
- ui_teal(+ #' Inside this object all of these items will be made `reactive`. |
|||
| 38 | -12x | +|||
| 15 | +
- id = ns("teal"),
+ #' @param code A `character` (or `reactive` which evaluates to a `character`) containing |
|||
| 39 | -12x | +|||
| 16 | +
- splash_ui = div(splash_ui, uiOutput(ns("error"))),
+ #' the code used to generate the data. This should be `reactive` if the code is changing |
|||
| 40 | -12x | +|||
| 17 | +
- title = title,+ #' during a reactive context (e.g. if filtering changes the code). Inside this |
|||
| 41 | -12x | +|||
| 18 | +
- header = header,+ #' object `code` will be made reactive |
|||
| 42 | -12x | +|||
| 19 | +
- footer = footer+ #' @param join_keys A `teal.data::join_keys` object containing relationships between the |
|||
| 43 | +20 |
- )+ #' datasets. |
||
| 44 | +21 |
- }+ #' @param metadata A `named list` each element contains a list of metadata about the named data.frame |
||
| 45 | +22 |
-
+ #' Each element of these list should be atomic and length one. |
||
| 46 | +23 |
- #' Server function that loads the data through reactive loading and then delegates+ #' @return A `tdata` object |
||
| 47 | +24 |
- #' to [srv_teal()].+ #' |
||
| 48 | +25 |
- #'+ #' @seealso `as_tdata` |
||
| 49 | +26 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 50 | +27 |
- #' Please also refer to the doc of [init()].+ #' @examples |
||
| 51 | +28 |
#' |
||
| 52 | +29 |
- #' @inheritParams init+ #' data <- new_tdata( |
||
| 53 | +30 |
- #' @param modules `teal_modules` object containing the output modules which+ #' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)), |
||
| 54 | +31 |
- #' will be displayed in the teal application. See [modules()] and [module()] for+ #' code = "iris <- iris |
||
| 55 | +32 |
- #' more details.+ #' mtcars <- mtcars |
||
| 56 | +33 |
- #' @inheritParams shiny::moduleServer+ #' dd <- data.frame(x = 1:10)", |
||
| 57 | +34 |
- #' @return `reactive` containing `teal_data` object when data is loaded.+ #' metadata = list(dd = list(author = "NEST"), iris = list(version = 1)) |
||
| 58 | +35 |
- #' If data is not loaded yet, `reactive` returns `NULL`.+ #' ) |
||
| 59 | +36 |
- #' @export+ #' |
||
| 60 | +37 |
- srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
+ #' # Extract a data.frame |
||
| 61 | -15x | +|||
| 38 | +
- checkmate::check_multi_class(data, c("teal_data", "teal_data_module"))
+ #' isolate(data[["iris"]]()) |
|||
| 62 | +39 |
-
+ #' |
||
| 63 | -15x | +|||
| 40 | +
- moduleServer(id, function(input, output, session) {
+ #' # Get code |
|||
| 64 | -15x | +|||
| 41 | +
- logger::log_trace("srv_teal_with_splash initializing module with data.")
+ #' isolate(get_code_tdata(data)) |
|||
| 65 | +42 |
-
+ #' |
||
| 66 | -15x | +|||
| 43 | +
- if (getOption("teal.show_js_log", default = FALSE)) {
+ #' # Get metadata |
|||
| 67 | -! | +|||
| 44 | +
- shinyjs::showLog()+ #' get_metadata(data, "iris") |
|||
| 68 | +45 |
- }+ #' |
||
| 69 | +46 |
-
+ #' @export |
||
| 70 | +47 |
- # teal_data_rv contains teal_data object+ new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
|
||
| 71 | -+ | |||
| 48 | +35x |
- # either passed to teal::init or returned from teal_data_module+ lifecycle::deprecate_soft( |
||
| 72 | -15x | +49 | +35x |
- teal_data_rv <- if (inherits(data, "teal_data_module")) {
+ when = "0.99.0", |
| 73 | -10x | +50 | +35x |
- data <- data$server(id = "teal_data_module")+ what = "tdata()", |
| 74 | -10x | +51 | +35x |
- if (!is.reactive(data)) {
+ details = paste( |
| 75 | -1x | +52 | +35x |
- stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
+ "tdata is deprecated and will be removed in the next release. Use `teal_data` instead.\n",+ |
+
| 53 | +35x | +
+ "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987." |
||
| 76 | +54 |
- }+ )+ |
+ ||
| 55 | ++ |
+ ) |
||
| 77 | -9x | +56 | +35x |
- data+ checkmate::assert_list( |
| 78 | -15x | +57 | +35x |
- } else if (inherits(data, "teal_data")) {
+ data, |
| 79 | -5x | +58 | +35x |
- reactiveVal(data)+ any.missing = FALSE, names = "unique", |
| 80 | -+ | |||
| 59 | +35x |
- }+ types = c("data.frame", "reactive", "MultiAssayExperiment")
|
||
| 81 | +60 |
-
+ ) |
||
| 82 | -14x | +61 | +31x |
- teal_data_rv_validate <- reactive({
+ checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)+ |
+
| 62 | +30x | +
+ checkmate::assert_multi_class(code, c("character", "reactive"))
|
||
| 83 | +63 |
- # custom module can return error+ |
||
| 84 | -11x | +64 | +29x |
- data <- tryCatch(teal_data_rv(), error = function(e) e)+ checkmate::assert_list(metadata, names = "unique", null.ok = TRUE) |
| 85 | -+ | |||
| 65 | +27x |
-
+ checkmate::assert_subset(names(metadata), names(data)) |
||
| 86 | +66 |
- # there is an empty reactive cycle on init!+ |
||
| 87 | -11x | +67 | +26x |
- if (inherits(data, "shiny.silent.error") && identical(data$message, "")) {
+ if (is.reactive(code)) {
|
| 88 | -! | +|||
| 68 | +9x |
- return(NULL)+ isolate(checkmate::assert_class(code(), "character", .var.name = "code")) |
||
| 89 | +69 |
- }+ } |
||
| 90 | +70 | |||
| 91 | +71 |
- # to handle qenv.error+ # create reactive data.frames |
||
| 92 | -11x | +72 | +25x |
- if (inherits(data, "qenv.error")) {
+ for (x in names(data)) {
|
| 93 | -2x | +73 | +48x |
- validate(+ if (!is.reactive(data[[x]])) {
|
| 94 | -2x | +74 | +31x |
- need(+ data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x])) |
| 95 | -2x | +|||
| 75 | +
- FALSE,+ } else {
|
|||
| 96 | -2x | +76 | +17x |
- paste(+ isolate( |
| 97 | -2x | +77 | +17x |
- "Error when executing `teal_data_module`:\n ",+ checkmate::assert_multi_class( |
| 98 | -2x | +78 | +17x |
- paste(data$message, collapse = "\n"),+ data[[x]](), c("data.frame", "MultiAssayExperiment"),
|
| 99 | -2x | +79 | +17x |
- "\n Check your inputs or contact app developer if error persists."+ .var.name = "data" |
| 100 | +80 |
- )+ ) |
||
| 101 | +81 |
- )+ ) |
||
| 102 | +82 |
- )+ } |
||
| 103 | +83 |
- }+ } |
||
| 104 | +84 | |||
| 105 | -- |
- # to handle module non-qenv errors- |
- ||
| 106 | -9x | -
- if (inherits(data, "error")) {
- |
- ||
| 107 | -1x | -
- validate(- |
- ||
| 108 | -1x | -
- need(- |
- ||
| 109 | -1x | -
- FALSE,- |
- ||
| 110 | -1x | +85 | +
- paste(+ # set attributes |
|
| 111 | -1x | +86 | +24x |
- "Error when executing `teal_data_module`:\n ",+ attr(data, "code") <- if (is.reactive(code)) code else reactive(code) |
| 112 | -1x | +87 | +24x |
- paste(data$message, collpase = "\n"),+ attr(data, "join_keys") <- join_keys |
| 113 | -1x | +88 | +24x |
- "\n Check your inputs or contact app developer if error persists."+ attr(data, "metadata") <- metadata |
| 114 | +89 |
- )+ |
||
| 115 | +90 |
- )+ # set class |
||
| 116 | -+ | |||
| 91 | +24x |
- )+ class(data) <- c("tdata", class(data))
|
||
| 117 | -+ | |||
| 92 | +24x |
- }+ data |
||
| 118 | +93 |
-
+ } |
||
| 119 | -8x | +|||
| 94 | +
- validate(+ |
|||
| 120 | -8x | +|||
| 95 | +
- need(+ #' Function to convert a `tdata` object to an `environment` |
|||
| 121 | -8x | +|||
| 96 | +
- inherits(data, "teal_data"),+ #' Any `reactives` inside `tdata` are first evaluated |
|||
| 122 | -8x | +|||
| 97 | +
- paste(+ #' @param data a `tdata` object |
|||
| 123 | -8x | +|||
| 98 | +
- "Error: `teal_data_module` did not return `teal_data` object",+ #' @return an `environment` |
|||
| 124 | -8x | +|||
| 99 | +
- "\n Check your inputs or contact app developer if error persists"+ #' @examples |
|||
| 125 | +100 |
- )+ #' |
||
| 126 | +101 |
- )+ #' data <- new_tdata( |
||
| 127 | +102 |
- )+ #' data = list(iris = iris, mtcars = reactive(mtcars)), |
||
| 128 | +103 |
-
+ #' code = "iris <- iris |
||
| 129 | -5x | +|||
| 104 | +
- validate(need(teal.data::datanames(data), "Data has no datanames. Contact app developer."))+ #' mtcars = mtcars" |
|||
| 130 | +105 |
-
+ #' ) |
||
| 131 | +106 |
-
+ #' |
||
| 132 | -4x | +|||
| 107 | +
- is_modules_ok <- check_modules_datanames(modules, teal.data::datanames(data))+ #' my_env <- isolate(tdata2env(data)) |
|||
| 133 | -4x | +|||
| 108 | +
- validate(need(isTRUE(is_modules_ok), is_modules_ok))+ #' |
|||
| 134 | +109 |
-
+ #' @export |
||
| 135 | -3x | +|||
| 110 | +
- is_filter_ok <- check_filter_datanames(filter, teal.data::datanames(data))+ tdata2env <- function(data) { # nolint
|
|||
| 136 | -3x | +111 | +2x |
- if (!isTRUE(is_filter_ok)) {
+ checkmate::assert_class(data, "tdata") |
| 137 | +112 | 1x |
- showNotification(+ list2env(lapply(data, function(x) if (is.reactive(x)) x() else x)) |
|
| 138 | -1x | +|||
| 113 | +
- "Some filters were not applied because of incompatibility with data. Contact app developer.",+ } |
|||
| 139 | -1x | +|||
| 114 | +
- type = "warning",+ |
|||
| 140 | -1x | +|||
| 115 | +
- duration = 10+ |
|||
| 141 | +116 |
- )+ #' Wrapper for `get_code.tdata` |
||
| 142 | -1x | +|||
| 117 | +
- logger::log_warn(is_filter_ok)+ #' This wrapper is to be used by downstream packages to extract the code of a `tdata` object |
|||
| 143 | +118 |
- }+ #' |
||
| 144 | +119 |
-
+ #' @param data (`tdata`) object |
||
| 145 | -3x | +|||
| 120 | +
- teal_data_rv()+ #' |
|||
| 146 | +121 |
- })+ #' @return (`character`) code used in the `tdata` object. |
||
| 147 | +122 |
-
+ #' @export |
||
| 148 | -14x | +|||
| 123 | +
- output$error <- renderUI({
+ get_code_tdata <- function(data) {
|
|||
| 149 | -! | +|||
| 124 | +7x |
- teal_data_rv_validate()+ checkmate::assert_class(data, "tdata") |
||
| 150 | -! | +|||
| 125 | +5x |
- NULL+ attr(data, "code")() |
||
| 151 | +126 |
- })+ } |
||
| 152 | +127 | |||
| 153 | +128 |
-
+ #' Extract `join_keys` from `tdata` |
||
| 154 | -14x | +|||
| 129 | +
- res <- srv_teal(id = "teal", modules = modules, teal_data_rv = teal_data_rv_validate, filter = filter)+ #' @param data A `tdata` object |
|||
| 155 | -14x | +|||
| 130 | +
- logger::log_trace("srv_teal_with_splash initialized module with data.")
+ #' @param ... Additional arguments (not used) |
|||
| 156 | -14x | +|||
| 131 | +
- return(res)+ #' @export |
|||
| 157 | +132 |
- })+ join_keys.tdata <- function(data, ...) {
+ |
+ ||
| 133 | +2x | +
+ attr(data, "join_keys") |
||
| 158 | +134 |
} |
| 1 | +135 |
- #' @title `TealReportCard`+ |
||
| 2 | +136 |
- #' @description `r lifecycle::badge("experimental")`
+
|
||
| 3 | +137 |
- #' A child of [`ReportCard`] that is used for teal specific applications.+ #' Function to get metadata from a `tdata` object |
||
| 4 | +138 |
- #' In addition to the parent methods, it supports rendering teal specific elements such as+ #' @param data `tdata` - object to extract the data from |
||
| 5 | +139 |
- #' the source code, the encodings panel content and the filter panel content as part of the+ #' @param dataname `character(1)` the dataset name whose metadata is requested |
||
| 6 | +140 |
- #' meta data.+ #' @return Either list of metadata or NULL if no metadata |
||
| 7 | +141 |
#' @export |
||
| 8 | +142 |
- #'+ get_metadata <- function(data, dataname) {
|
||
| 9 | -+ | |||
| 143 | +4x |
- TealReportCard <- R6::R6Class( # nolint: object_name_linter.+ checkmate::assert_string(dataname) |
||
| 10 | -+ | |||
| 144 | +4x |
- classname = "TealReportCard",+ UseMethod("get_metadata", data)
|
||
| 11 | +145 |
- inherit = teal.reporter::ReportCard,+ } |
||
| 12 | +146 |
- public = list(+ |
||
| 13 | +147 |
- #' @description Appends the source code to the `content` meta data of this `TealReportCard`.+ #' @rdname get_metadata |
||
| 14 | +148 |
- #'+ #' @export |
||
| 15 | +149 |
- #' @param src (`character(1)`) code as text.+ get_metadata.tdata <- function(data, dataname) {
|
||
| 16 | -+ | |||
| 150 | +4x |
- #' @param ... any `rmarkdown` R chunk parameter and its value.+ metadata <- attr(data, "metadata") |
||
| 17 | -+ | |||
| 151 | +4x |
- #' But `eval` parameter is always set to `FALSE`.+ if (is.null(metadata)) {
|
||
| 18 | -+ | |||
| 152 | +1x |
- #' @return invisibly self+ return(NULL) |
||
| 19 | +153 |
- #' @examples+ } |
||
| 20 | -+ | |||
| 154 | +3x |
- #' card <- TealReportCard$new()$append_src(+ metadata[[dataname]] |
||
| 21 | +155 |
- #' "plot(iris)"+ } |
||
| 22 | +156 |
- #' )+ |
||
| 23 | +157 |
- #' card$get_content()[[1]]$get_content()+ #' @rdname get_metadata |
||
| 24 | +158 |
- append_src = function(src, ...) {
- |
- ||
| 25 | -4x | -
- checkmate::assert_character(src, min.len = 0, max.len = 1)+ #' @export |
||
| 26 | -4x | +|||
| 159 | +
- params <- list(...)+ get_metadata.default <- function(data, dataname) {
|
|||
| 27 | -4x | +|||
| 160 | +! |
- params$eval <- FALSE+ stop("get_metadata function not implemented for this object")
|
||
| 28 | -4x | +|||
| 161 | +
- rblock <- RcodeBlock$new(src)+ } |
|||
| 29 | -4x | +|||
| 162 | +
- rblock$set_params(params)+ |
|||
| 30 | -4x | +|||
| 163 | +
- self$append_content(rblock)+ |
|||
| 31 | -4x | +|||
| 164 | +
- self$append_metadata("SRC", src)
+ #' Downgrade `teal_data` objects in modules for compatibility. |
|||
| 32 | -4x | +|||
| 165 | +
- invisible(self)+ #' |
|||
| 33 | +166 |
- },+ #' Convert `teal_data` to `tdata` in `teal` modules. |
||
| 34 | +167 |
- #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.+ #' |
||
| 35 | +168 |
- #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses+ #' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object |
||
| 36 | +169 |
- #' the default `yaml::as.yaml` to format the list.+ #' to be passed to the `data` argument but instead they receive a `teal_data` object, |
||
| 37 | +170 |
- #' If the filter state list is empty, nothing is appended to the `content`.+ #' which is additionally wrapped in a reactive expression in the server functions. |
||
| 38 | +171 |
- #'+ #' In order to easily adapt such modules without a proper refactor, |
||
| 39 | +172 |
- #' @param fs (`teal_slices`) object returned from [teal_slices()] function.+ #' use this function to downgrade the `data` argument. |
||
| 40 | +173 |
- #' @return invisibly self+ #' |
||
| 41 | +174 |
- append_fs = function(fs) {
+ #' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression |
||
| 42 | -5x | +|||
| 175 | +
- checkmate::assert_class(fs, "teal_slices")+ #' |
|||
| 43 | -4x | +|||
| 176 | +
- self$append_text("Filter State", "header3")
+ #' @return Object of class `tdata`. |
|||
| 44 | -4x | +|||
| 177 | +
- self$append_content(TealSlicesBlock$new(fs))+ #' |
|||
| 45 | -4x | +|||
| 178 | +
- invisible(self)+ #' @examples |
|||
| 46 | +179 |
- },+ #' td <- teal_data() |
||
| 47 | +180 |
- #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.+ #' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars) |
||
| 48 | +181 |
- #'+ #' td |
||
| 49 | +182 |
- #' @param encodings (`list`) list of encodings selections of the teal app.+ #' as_tdata(td) |
||
| 50 | +183 |
- #' @return invisibly self+ #' as_tdata(reactive(td)) |
||
| 51 | +184 |
- #' @examples+ #' |
||
| 52 | +185 |
- #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))+ #' @export |
||
| 53 | +186 |
- #' card$get_content()[[1]]$get_content()+ #' @rdname tdata_deprecation |
||
| 54 | +187 |
- #'+ #' |
||
| 55 | +188 |
- append_encodings = function(encodings) {
+ as_tdata <- function(x) {
|
||
| 56 | -4x | +189 | +8x |
- checkmate::assert_list(encodings)+ if (inherits(x, "tdata")) {
|
| 57 | -4x | +190 | +2x |
- self$append_text("Selected Options", "header3")
+ return(x) |
| 58 | -4x | +|||
| 191 | +
- if (requireNamespace("yaml", quietly = TRUE)) {
+ } |
|||
| 59 | -4x | +192 | +6x |
- self$append_text(yaml::as.yaml(encodings, handlers = list(+ if (is.reactive(x)) {
|
| 60 | -4x | +193 | +1x |
- POSIXct = function(x) format(x, "%Y-%m-%d"),+ checkmate::assert_class(isolate(x()), "teal_data") |
| 61 | -4x | +194 | +1x |
- POSIXlt = function(x) format(x, "%Y-%m-%d"),+ datanames <- isolate(teal.data::datanames(x())) |
| 62 | -4x | +195 | +1x |
- Date = function(x) format(x, "%Y-%m-%d")+ datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE) |
| 63 | -4x | -
- )), "verbatim")- |
- ||
| 64 | -- |
- } else {
- |
- ||
| 65 | -! | +196 | +1x |
- stop("yaml package is required to format the encodings list")
+ code <- reactive(teal.code::get_code(x())) |
| 66 | -+ | |||
| 197 | +1x |
- }+ join_keys <- isolate(teal.data::join_keys(x())) |
||
| 67 | -4x | +198 | +5x |
- self$append_metadata("Encodings", encodings)
+ } else if (inherits(x, "teal_data")) {
|
| 68 | -4x | +199 | +5x |
- invisible(self)+ datanames <- teal.data::datanames(x) |
| 69 | -+ | |||
| 200 | +5x |
- }+ datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE) |
||
| 70 | -+ | |||
| 201 | +5x |
- ),+ code <- reactive(teal.code::get_code(x)) |
||
| 71 | -+ | |||
| 202 | +5x |
- private = list()+ join_keys <- isolate(teal.data::join_keys(x)) |
||
| 72 | +203 |
- )+ } |
||
| 73 | +204 | |||
| 74 | -+ | |||
| 205 | +6x |
- #' @title `RcodeBlock`+ new_tdata(data = datasets, code = code, join_keys = join_keys) |
||
| 75 | +206 |
- #' @keywords internal+ } |
| 76 | +1 |
- TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter.+ # This file adds a splash screen for delayed data loading on top of teal |
||
| 77 | +2 |
- classname = "TealSlicesBlock",+ |
||
| 78 | +3 |
- inherit = teal.reporter:::TextBlock,+ #' UI to show a splash screen in the beginning, then delegate to [srv_teal()] |
||
| 79 | +4 |
- public = list(+ #' |
||
| 80 | +5 |
- #' @description Returns a `TealSlicesBlock` object.+ #' @description `r lifecycle::badge("stable")`
|
||
| 81 | +6 |
- #'+ #' The splash screen could be used to query for a password to fetch the data. |
||
| 82 | +7 |
- #' @details Returns a `TealSlicesBlock` object with no content and no parameters.+ #' [init()] is a very thin wrapper around this module useful for end-users which |
||
| 83 | +8 |
- #'+ #' assumes that it is a top-level module and cannot be embedded. |
||
| 84 | +9 |
- #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ #' This function instead adheres to the Shiny module conventions. |
||
| 85 | +10 |
- #' @param style (`character(1)`) string specifying style to apply.+ #' |
||
| 86 | +11 |
- #'+ #' If data is obtained through delayed loading, its splash screen is used. Otherwise, |
||
| 87 | +12 |
- #' @return `TealSlicesBlock`+ #' a default splash screen is shown. |
||
| 88 | +13 |
- #' @examples+ #' |
||
| 89 | +14 |
- #' block <- teal:::TealSlicesBlock$new()+ #' Please also refer to the doc of [init()]. |
||
| 90 | +15 |
- #'+ #' |
||
| 91 | +16 |
- initialize = function(content = teal_slices(), style = "verbatim") {
+ #' @param id (`character(1)`)\cr |
||
| 92 | -10x | +|||
| 17 | +
- self$set_content(content)+ #' module id |
|||
| 93 | -9x | +|||
| 18 | +
- self$set_style(style)+ #' @inheritParams init |
|||
| 94 | -9x | +|||
| 19 | +
- invisible(self)+ #' @export |
|||
| 95 | +20 |
- },+ ui_teal_with_splash <- function(id, |
||
| 96 | +21 |
-
+ data, |
||
| 97 | +22 |
- #' @description Sets content of this `TealSlicesBlock`.+ title, |
||
| 98 | +23 |
- #' Sets content as `YAML` text which represents a list generated from `teal_slices`.+ header = tags$p("Add Title Here"),
|
||
| 99 | +24 |
- #' The list displays limited number of fields from `teal_slice` objects, but this list is+ footer = tags$p("Add Footer Here")) {
|
||
| 100 | -+ | |||
| 25 | +12x |
- #' sufficient to conclude which filters were applied.+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
|
||
| 101 | -+ | |||
| 26 | +12x |
- #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"+ ns <- NS(id) |
||
| 102 | +27 |
- #'+ |
||
| 103 | +28 |
- #'+ # Startup splash screen for delayed loading |
||
| 104 | +29 |
- #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ # We use delayed loading in all cases, even when the data does not need to be fetched. |
||
| 105 | +30 |
- #' @return invisibly self+ # This has the benefit that when filtering the data takes a lot of time initially, the |
||
| 106 | +31 |
- set_content = function(content) {
+ # Shiny app does not time out. |
||
| 107 | -11x | +32 | +12x |
- checkmate::assert_class(content, "teal_slices")+ splash_ui <- if (inherits(data, "teal_data_module")) {
|
| 108 | -10x | +33 | +1x |
- if (length(content) != 0) {
+ data$ui(ns("teal_data_module"))
|
| 109 | -7x | +34 | +12x |
- states_list <- lapply(content, function(x) {
+ } else if (inherits(data, "teal_data")) {
|
| 110 | -7x | +35 | +11x |
- x_list <- shiny::isolate(as.list(x))+ div() |
| 111 | -7x | +|||
| 36 | +
- if (+ } |
|||
| 112 | -7x | +37 | +12x |
- inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
+ ui_teal( |
| 113 | -7x | +38 | +12x |
- length(x_list$choices) == 2 &&+ id = ns("teal"),
|
| 114 | -7x | +39 | +12x |
- length(x_list$selected) == 2+ splash_ui = div(splash_ui, uiOutput(ns("error"))),
|
| 115 | -+ | |||
| 40 | +12x |
- ) {
+ title = title, |
||
| 116 | -! | +|||
| 41 | +12x |
- x_list$range <- paste(x_list$selected, collapse = " - ")+ header = header, |
||
| 117 | -! | +|||
| 42 | +12x |
- x_list["selected"] <- NULL+ footer = footer |
||
| 118 | +43 |
- }- |
- ||
| 119 | -7x | -
- if (!is.null(x_list$arg)) {
- |
- ||
| 120 | -! | -
- x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"+ ) |
||
| 121 | +44 |
- }+ } |
||
| 122 | +45 | |||
| 123 | -7x | -
- x_list <- x_list[- |
- ||
| 124 | -7x | +|||
| 46 | +
- c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
+ #' Server function that loads the data through reactive loading and then delegates |
|||
| 125 | +47 |
- ]+ #' to [srv_teal()]. |
||
| 126 | -7x | +|||
| 48 | +
- names(x_list) <- c(+ #' |
|||
| 127 | -7x | +|||
| 49 | +
- "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",+ #' @description `r lifecycle::badge("stable")`
|
|||
| 128 | -7x | +|||
| 50 | +
- "Selected Values", "Selected range", "Include NA values", "Include Inf values"+ #' Please also refer to the doc of [init()]. |
|||
| 129 | +51 |
- )+ #' |
||
| 130 | +52 |
-
+ #' @inheritParams init |
||
| 131 | -7x | +|||
| 53 | +
- Filter(Negate(is.null), x_list)+ #' @param modules `teal_modules` object containing the output modules which |
|||
| 132 | +54 |
- })+ #' will be displayed in the teal application. See [modules()] and [module()] for |
||
| 133 | +55 |
-
+ #' more details. |
||
| 134 | -7x | +|||
| 56 | +
- if (requireNamespace("yaml", quietly = TRUE)) {
+ #' @inheritParams shiny::moduleServer |
|||
| 135 | -7x | +|||
| 57 | +
- super$set_content(yaml::as.yaml(states_list))+ #' @return `reactive` containing `teal_data` object when data is loaded. |
|||
| 136 | +58 |
- } else {
+ #' If data is not loaded yet, `reactive` returns `NULL`. |
||
| 137 | -! | +|||
| 59 | +
- stop("yaml package is required to format the filter state list")
+ #' @export |
|||
| 138 | +60 |
- }+ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
+ |
+ ||
| 61 | +15x | +
+ checkmate::check_multi_class(data, c("teal_data", "teal_data_module"))
|
||
| 139 | +62 |
- }+ |
||
| 140 | -10x | +63 | +15x |
- private$teal_slices <- content+ moduleServer(id, function(input, output, session) {
|
| 141 | -10x | +64 | +15x |
- invisible(self)+ logger::log_trace("srv_teal_with_splash initializing module with data.")
|
| 142 | +65 |
- },+ |
||
| 143 | -+ | |||
| 66 | +15x |
- #' @description Create the `RcodeBlock` from a list.+ if (getOption("teal.show_js_log", default = FALSE)) {
+ |
+ ||
| 67 | +! | +
+ shinyjs::showLog() |
||
| 144 | +68 |
- #' @param x `named list` with two fields `c("text", "params")`.
+ } |
||
| 145 | +69 |
- #' Use the `get_available_params` method to get all possible parameters.+ |
||
| 146 | +70 |
- #' @return invisibly self+ # teal_data_rv contains teal_data object |
||
| 147 | +71 |
- from_list = function(x) {
+ # either passed to teal::init or returned from teal_data_module |
||
| 148 | -1x | +72 | +15x |
- checkmate::assert_list(x)+ teal_data_rv <- if (inherits(data, "teal_data_module")) {
|
| 149 | -1x | +73 | +10x |
- checkmate::assert_names(names(x), must.include = c("teal_slices"))
+ data <- data$server(id = "teal_data_module") |
| 150 | -1x | +74 | +10x |
- self$set_content(x$teal_slices)+ if (!is.reactive(data)) {
|
| 151 | +75 | 1x |
- invisible(self)+ stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
|
|
| 152 | +76 |
- },+ } |
||
| 153 | -+ | |||
| 77 | +9x |
- #' @description Convert the `RcodeBlock` to a list.+ data |
||
| 154 | -+ | |||
| 78 | +15x |
- #' @return `named list` with a text and `params`.+ } else if (inherits(data, "teal_data")) {
|
||
| 155 | -+ | |||
| 79 | +5x |
-
+ reactiveVal(data) |
||
| 156 | +80 |
- to_list = function() {
- |
- ||
| 157 | -2x | -
- list(teal_slices = private$teal_slices)+ } |
||
| 158 | +81 |
- }+ |
||
| 159 | -+ | |||
| 82 | +14x |
- ),+ teal_data_rv_validate <- reactive({
|
||
| 160 | +83 |
- private = list(+ # custom module can return error |
||
| 161 | -+ | |||
| 84 | +11x |
- style = "verbatim",+ data <- tryCatch(teal_data_rv(), error = function(e) e) |
||
| 162 | +85 |
- teal_slices = NULL # teal_slices+ |
||
| 163 | +86 |
- )+ # there is an empty reactive cycle on init! |
||
| 164 | -+ | |||
| 87 | +11x |
- )+ if (inherits(data, "shiny.silent.error") && identical(data$message, "")) {
|
| 1 | -+ | |||
| 88 | +! |
- #' Create a `tdata` Object+ return(NULL) |
||
| 2 | +89 |
- #'+ } |
||
| 3 | +90 |
- #' @description `r lifecycle::badge("deprecated")`
+
|
||
| 4 | +91 |
- #' Create a new object called `tdata` which contains `data`, a `reactive` list of data.frames+ # to handle qenv.error |
||
| 5 | -+ | |||
| 92 | +11x |
- #' (or `MultiAssayExperiment`), with attributes:+ if (inherits(data, "qenv.error")) {
|
||
| 6 | -+ | |||
| 93 | +2x |
- #' \itemize{
+ validate( |
||
| 7 | -+ | |||
| 94 | +2x |
- #' \item{`code` (`reactive`) containing code used to generate the data}
+ need( |
||
| 8 | -+ | |||
| 95 | +2x |
- #' \item{join_keys (`join_keys`) containing the relationships between the data}
+ FALSE, |
||
| 9 | -+ | |||
| 96 | +2x |
- #' \item{metadata (`named list`) containing any metadata associated with the data frames}
+ paste( |
||
| 10 | -+ | |||
| 97 | +2x |
- #' }+ "Error when executing `teal_data_module`:\n ", |
||
| 11 | -+ | |||
| 98 | +2x |
- #' @name tdata+ paste(data$message, collapse = "\n"), |
||
| 12 | -+ | |||
| 99 | +2x |
- #' @param data A `named list` of `data.frames` (or `MultiAssayExperiment`)+ "\n Check your inputs or contact app developer if error persists." |
||
| 13 | +100 |
- #' which optionally can be `reactive`.+ ) |
||
| 14 | +101 |
- #' Inside this object all of these items will be made `reactive`.+ ) |
||
| 15 | +102 |
- #' @param code A `character` (or `reactive` which evaluates to a `character`) containing+ ) |
||
| 16 | +103 |
- #' the code used to generate the data. This should be `reactive` if the code is changing+ } |
||
| 17 | +104 |
- #' during a reactive context (e.g. if filtering changes the code). Inside this+ |
||
| 18 | +105 |
- #' object `code` will be made reactive+ # to handle module non-qenv errors |
||
| 19 | -+ | |||
| 106 | +9x |
- #' @param join_keys A `teal.data::join_keys` object containing relationships between the+ if (inherits(data, "error")) {
|
||
| 20 | -+ | |||
| 107 | +1x |
- #' datasets.+ validate( |
||
| 21 | -+ | |||
| 108 | +1x |
- #' @param metadata A `named list` each element contains a list of metadata about the named data.frame+ need( |
||
| 22 | -+ | |||
| 109 | +1x |
- #' Each element of these list should be atomic and length one.+ FALSE, |
||
| 23 | -+ | |||
| 110 | +1x |
- #' @return A `tdata` object+ paste( |
||
| 24 | -+ | |||
| 111 | +1x |
- #'+ "Error when executing `teal_data_module`:\n ", |
||
| 25 | -+ | |||
| 112 | +1x |
- #' @seealso `as_tdata`+ paste(data$message, collpase = "\n"), |
||
| 26 | -+ | |||
| 113 | +1x |
- #'+ "\n Check your inputs or contact app developer if error persists." |
||
| 27 | +114 |
- #' @examples+ ) |
||
| 28 | +115 |
- #'+ ) |
||
| 29 | +116 |
- #' data <- new_tdata(+ ) |
||
| 30 | +117 |
- #' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),+ } |
||
| 31 | +118 |
- #' code = "iris <- iris+ |
||
| 32 | -+ | |||
| 119 | +8x |
- #' mtcars <- mtcars+ validate( |
||
| 33 | -+ | |||
| 120 | +8x |
- #' dd <- data.frame(x = 1:10)",+ need( |
||
| 34 | -+ | |||
| 121 | +8x |
- #' metadata = list(dd = list(author = "NEST"), iris = list(version = 1))+ inherits(data, "teal_data"), |
||
| 35 | -+ | |||
| 122 | +8x |
- #' )+ paste( |
||
| 36 | -+ | |||
| 123 | +8x |
- #'+ "Error: `teal_data_module` did not return `teal_data` object", |
||
| 37 | -+ | |||
| 124 | +8x |
- #' # Extract a data.frame+ "\n Check your inputs or contact app developer if error persists" |
||
| 38 | +125 |
- #' isolate(data[["iris"]]())+ ) |
||
| 39 | +126 |
- #'+ ) |
||
| 40 | +127 |
- #' # Get code+ ) |
||
| 41 | +128 |
- #' isolate(get_code_tdata(data))+ |
||
| 42 | -+ | |||
| 129 | +5x |
- #'+ validate(need(teal.data::datanames(data), "Data has no datanames. Contact app developer.")) |
||
| 43 | +130 |
- #' # Get metadata+ |
||
| 44 | +131 |
- #' get_metadata(data, "iris")+ |
||
| 45 | -+ | |||
| 132 | +4x |
- #'+ is_modules_ok <- check_modules_datanames(modules, teal.data::datanames(data)) |
||
| 46 | -+ | |||
| 133 | +4x |
- #' @export+ validate(need(isTRUE(is_modules_ok), is_modules_ok)) |
||
| 47 | +134 |
- new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
+
|
||
| 48 | -35x | +135 | +3x |
- lifecycle::deprecate_soft(+ is_filter_ok <- check_filter_datanames(filter, teal.data::datanames(data)) |
| 49 | -35x | +136 | +3x |
- when = "0.99.0",+ if (!isTRUE(is_filter_ok)) {
|
| 50 | -35x | +137 | +1x |
- what = "tdata()",+ showNotification( |
| 51 | -35x | +138 | +1x |
- details = paste(+ "Some filters were not applied because of incompatibility with data. Contact app developer.", |
| 52 | -35x | +139 | +1x |
- "tdata is deprecated and will be removed in the next release. Use `teal_data` instead.\n",+ type = "warning", |
| 53 | -35x | +140 | +1x |
- "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."+ duration = 10 |
| 54 | +141 |
- )+ ) |
||
| 55 | -+ | |||
| 142 | +1x |
- )+ logger::log_warn(is_filter_ok) |
||
| 56 | -35x | +|||
| 143 | +
- checkmate::assert_list(+ } |
|||
| 57 | -35x | +|||
| 144 | +
- data,+ |
|||
| 58 | -35x | +145 | +3x |
- any.missing = FALSE, names = "unique",+ teal_data_rv() |
| 59 | -35x | +|||
| 146 | +
- types = c("data.frame", "reactive", "MultiAssayExperiment")
+ }) |
|||
| 60 | +147 |
- )+ |
||
| 61 | -31x | +148 | +14x |
- checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)+ output$error <- renderUI({
|
| 62 | -30x | +|||
| 149 | +! |
- checkmate::assert_multi_class(code, c("character", "reactive"))
+ teal_data_rv_validate() |
||
| 63 | -+ | |||
| 150 | +! |
-
+ NULL |
||
| 64 | -29x | +|||
| 151 | +
- checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)+ }) |
|||
| 65 | -27x | +|||
| 152 | +
- checkmate::assert_subset(names(metadata), names(data))+ |
|||
| 66 | +153 | |||
| 67 | -26x | +154 | +14x |
- if (is.reactive(code)) {
+ res <- srv_teal(id = "teal", modules = modules, teal_data_rv = teal_data_rv_validate, filter = filter) |
| 68 | -9x | +155 | +14x |
- isolate(checkmate::assert_class(code(), "character", .var.name = "code"))+ logger::log_trace("srv_teal_with_splash initialized module with data.")
|
| 69 | -+ | |||
| 156 | +14x |
- }+ return(res) |
||
| 70 | +157 |
-
+ }) |
||
| 71 | +158 |
- # create reactive data.frames+ } |
||
| 72 | -25x | +
| 1 | +
- for (x in names(data)) {
+ #' Get Client Timezone |
|||
| 73 | -48x | +|||
| 2 | +
- if (!is.reactive(data[[x]])) {
+ #' |
|||
| 74 | -31x | +|||
| 3 | +
- data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))+ #' Local timezone in the browser may differ from the system timezone from the server. |
|||
| 75 | +4 |
- } else {
+ #' This script can be run to register a shiny input which contains information about |
||
| 76 | -17x | +|||
| 5 | +
- isolate(+ #' the timezone in the browser. |
|||
| 77 | -17x | +|||
| 6 | +
- checkmate::assert_multi_class(+ #' |
|||
| 78 | -17x | +|||
| 7 | +
- data[[x]](), c("data.frame", "MultiAssayExperiment"),
+ #' @param ns (`function`) namespace function passed from the `session` object in the |
|||
| 79 | -17x | +|||
| 8 | +
- .var.name = "data"+ #' Shiny server. For Shiny modules this will allow for proper name spacing of the |
|||
| 80 | +9 |
- )+ #' registered input. |
||
| 81 | +10 |
- )+ #' |
||
| 82 | +11 |
- }+ #' @return (`Shiny`) input variable accessible with `input$tz` which is a (`character`) |
||
| 83 | +12 |
- }+ #' string containing the timezone of the browser/client. |
||
| 84 | +13 |
-
+ #' @keywords internal |
||
| 85 | +14 |
- # set attributes+ get_client_timezone <- function(ns) {
|
||
| 86 | -24x | +15 | +18x |
- attr(data, "code") <- if (is.reactive(code)) code else reactive(code)+ script <- sprintf( |
| 87 | -24x | +16 | +18x |
- attr(data, "join_keys") <- join_keys+ "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)", |
| 88 | -24x | -
- attr(data, "metadata") <- metadata- |
- ||
| 89 | -+ | 17 | +18x |
-
+ ns("timezone")
|
| 90 | +18 |
- # set class+ ) |
||
| 91 | -24x | +19 | +18x |
- class(data) <- c("tdata", class(data))
+ shinyjs::runjs(script) # function does not return anything |
| 92 | -24x | +20 | +18x |
- data+ return(invisible(NULL)) |
| 93 | +21 |
} |
||
| 94 | +22 | |||
| 95 | +23 |
- #' Function to convert a `tdata` object to an `environment`+ #' Resolve the expected bootstrap theme |
||
| 96 | +24 |
- #' Any `reactives` inside `tdata` are first evaluated+ #' @keywords internal |
||
| 97 | +25 |
- #' @param data a `tdata` object+ get_teal_bs_theme <- function() {
|
||
| 98 | -+ | |||
| 26 | +16x |
- #' @return an `environment`+ bs_theme <- getOption("teal.bs_theme")
|
||
| 99 | -+ | |||
| 27 | +16x |
- #' @examples+ if (is.null(bs_theme)) {
|
||
| 100 | -+ | |||
| 28 | +13x |
- #'+ NULL |
||
| 101 | -+ | |||
| 29 | +3x |
- #' data <- new_tdata(+ } else if (!inherits(bs_theme, "bs_theme")) {
|
||
| 102 | -+ | |||
| 30 | +2x |
- #' data = list(iris = iris, mtcars = reactive(mtcars)),+ warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
|
||
| 103 | -+ | |||
| 31 | +2x |
- #' code = "iris <- iris+ NULL |
||
| 104 | +32 |
- #' mtcars = mtcars"+ } else {
|
||
| 105 | -+ | |||
| 33 | +1x |
- #' )+ bs_theme |
||
| 106 | +34 |
- #'+ } |
||
| 107 | +35 |
- #' my_env <- isolate(tdata2env(data))+ } |
||
| 108 | +36 |
- #'+ |
||
| 109 | +37 |
- #' @export+ include_parent_datanames <- function(dataname, join_keys) {
|
||
| 110 | -+ | |||
| 38 | +3x |
- tdata2env <- function(data) { # nolint
+ parents <- character(0) |
||
| 111 | -2x | +39 | +3x |
- checkmate::assert_class(data, "tdata")+ for (i in dataname) {
|
| 112 | -1x | +40 | +6x |
- list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))+ while (length(i) > 0) {
|
| 113 | -+ | |||
| 41 | +6x |
- }+ parent_i <- teal.data::parent(join_keys, i) |
||
| 114 | -+ | |||
| 42 | +6x |
-
+ parents <- c(parent_i, parents) |
||
| 115 | -+ | |||
| 43 | +6x |
-
+ i <- parent_i |
||
| 116 | +44 |
- #' Wrapper for `get_code.tdata`+ } |
||
| 117 | +45 |
- #' This wrapper is to be used by downstream packages to extract the code of a `tdata` object+ } |
||
| 118 | +46 |
- #'+ |
||
| 119 | -+ | |||
| 47 | +3x |
- #' @param data (`tdata`) object+ return(unique(c(parents, dataname))) |
||
| 120 | +48 |
- #'+ } |
||
| 121 | +49 |
- #' @return (`character`) code used in the `tdata` object.+ |
||
| 122 | +50 |
- #' @export+ |
||
| 123 | +51 |
- get_code_tdata <- function(data) {
- |
- ||
| 124 | -7x | -
- checkmate::assert_class(data, "tdata")+ |
||
| 125 | -5x | +|||
| 52 | +
- attr(data, "code")()+ #' Create a `FilteredData` |
|||
| 126 | +53 |
- }+ #' |
||
| 127 | +54 |
-
+ #' Create a `FilteredData` object from a `teal_data` object |
||
| 128 | +55 |
- #' Extract `join_keys` from `tdata`+ #' @param x (`teal_data`) object |
||
| 129 | +56 |
- #' @param data A `tdata` object+ #' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)` |
||
| 130 | +57 |
- #' @param ... Additional arguments (not used)+ #' @return (`FilteredData`) object |
||
| 131 | +58 |
- #' @export+ #' @keywords internal |
||
| 132 | +59 |
- join_keys.tdata <- function(data, ...) {
+ teal_data_to_filtered_data <- function(x, datanames = teal.data::datanames(x)) {
|
||
| 133 | -2x | -
- attr(data, "join_keys")- |
- ||
| 134 | -+ | 60 | +12x |
- }+ checkmate::assert_class(x, "teal_data") |
| 135 | -+ | |||
| 61 | +12x |
-
+ checkmate::assert_character(datanames, min.len = 1L, any.missing = FALSE) |
||
| 136 | -+ | |||
| 62 | +12x |
-
+ checkmate::assert_subset(datanames, teal.data::datanames(x)) |
||
| 137 | +63 |
- #' Function to get metadata from a `tdata` object+ |
||
| 138 | -+ | |||
| 64 | +12x |
- #' @param data `tdata` - object to extract the data from+ ans <- teal.slice::init_filtered_data( |
||
| 139 | -+ | |||
| 65 | +12x |
- #' @param dataname `character(1)` the dataset name whose metadata is requested+ x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE), |
||
| 140 | -+ | |||
| 66 | +12x |
- #' @return Either list of metadata or NULL if no metadata+ join_keys = teal.data::join_keys(x) |
||
| 141 | +67 |
- #' @export+ ) |
||
| 142 | +68 |
- get_metadata <- function(data, dataname) {
+ # Piggy-back entire pre-processing code so that filtering code can be appended later. |
||
| 143 | -4x | +69 | +12x |
- checkmate::assert_string(dataname)+ attr(ans, "preprocessing_code") <- teal.code::get_code(x) |
| 144 | -4x | +70 | +12x |
- UseMethod("get_metadata", data)
+ ans |
| 145 | +71 |
} |
||
| 146 | +72 | |||
| 147 | +73 |
- #' @rdname get_metadata+ #' Template Function for `TealReportCard` Creation and Customization |
||
| 148 | +74 |
- #' @export+ #' |
||
| 149 | +75 |
- get_metadata.tdata <- function(data, dataname) {
- |
- ||
| 150 | -4x | -
- metadata <- attr(data, "metadata")+ #' This function generates a report card with a title, |
||
| 151 | -4x | +|||
| 76 | +
- if (is.null(metadata)) {
+ #' an optional description, and the option to append the filter state list. |
|||
| 152 | -1x | +|||
| 77 | +
- return(NULL)+ #' |
|||
| 153 | +78 |
- }+ #' @param title (`character(1)`) title of the card (unless overwritten by label) |
||
| 154 | -3x | +|||
| 79 | +
- metadata[[dataname]]+ #' @param label (`character(1)`) label provided by the user when adding the card |
|||
| 155 | +80 |
- }+ #' @param description (`character(1)`) optional additional description |
||
| 156 | +81 |
-
+ #' @param with_filter (`logical(1)`) flag indicating to add filter state |
||
| 157 | +82 |
- #' @rdname get_metadata+ #' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation |
||
| 158 | +83 |
- #' @export+ #' of the filter state in the report |
||
| 159 | +84 |
- get_metadata.default <- function(data, dataname) {
+ #' |
||
| 160 | -! | +|||
| 85 | +
- stop("get_metadata function not implemented for this object")
+ #' @return (`TealReportCard`) populated with a title, description and filter state |
|||
| 161 | +86 |
- }+ #' |
||
| 162 | +87 |
-
+ #' @export |
||
| 163 | +88 |
-
+ report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
|
||
| 164 | -+ | |||
| 89 | +2x |
- #' Downgrade `teal_data` objects in modules for compatibility.+ checkmate::assert_string(title) |
||
| 165 | -+ | |||
| 90 | +2x |
- #'+ checkmate::assert_string(label) |
||
| 166 | -+ | |||
| 91 | +2x |
- #' Convert `teal_data` to `tdata` in `teal` modules.+ checkmate::assert_string(description, null.ok = TRUE) |
||
| 167 | -+ | |||
| 92 | +2x |
- #'+ checkmate::assert_flag(with_filter) |
||
| 168 | -+ | |||
| 93 | +2x |
- #' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object+ checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI") |
||
| 169 | +94 |
- #' to be passed to the `data` argument but instead they receive a `teal_data` object,+ |
||
| 170 | -+ | |||
| 95 | +2x |
- #' which is additionally wrapped in a reactive expression in the server functions.+ card <- teal::TealReportCard$new() |
||
| 171 | -+ | |||
| 96 | +2x |
- #' In order to easily adapt such modules without a proper refactor,+ title <- if (label == "") title else label |
||
| 172 | -+ | |||
| 97 | +2x |
- #' use this function to downgrade the `data` argument.+ card$set_name(title) |
||
| 173 | -+ | |||
| 98 | +2x |
- #'+ card$append_text(title, "header2") |
||
| 174 | -+ | |||
| 99 | +1x |
- #' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression+ if (!is.null(description)) card$append_text(description, "header3") |
||
| 175 | -+ | |||
| 100 | +1x |
- #'+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
||
| 176 | -+ | |||
| 101 | +2x |
- #' @return Object of class `tdata`.+ card |
||
| 177 | +102 |
- #'+ } |
||
| 178 | +103 |
- #' @examples+ #' Resolve `datanames` for the modules |
||
| 179 | +104 |
- #' td <- teal_data()+ #' |
||
| 180 | +105 |
- #' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars)+ #' Modifies `module$datanames` to include names of the parent dataset (taken from `join_keys`). |
||
| 181 | +106 |
- #' td+ #' When `datanames` is set to `"all"` it is replaced with all available datasets names. |
||
| 182 | +107 |
- #' as_tdata(td)+ #' @param modules (`teal_modules`) object |
||
| 183 | +108 |
- #' as_tdata(reactive(td))+ #' @param datanames (`character`) names of datasets available in the `data` object |
||
| 184 | +109 |
- #'+ #' @param join_keys (`join_keys`) object |
||
| 185 | +110 |
- #' @export+ #' @return `teal_modules` with resolved `datanames` |
||
| 186 | +111 |
- #' @rdname tdata_deprecation+ #' @keywords internal |
||
| 187 | +112 |
- #'+ resolve_modules_datanames <- function(modules, datanames, join_keys) {
|
||
| 188 | -+ | |||
| 113 | +! |
- as_tdata <- function(x) {
+ if (inherits(modules, "teal_modules")) {
|
||
| 189 | -8x | +|||
| 114 | +! |
- if (inherits(x, "tdata")) {
+ modules$children <- sapply( |
||
| 190 | -2x | +|||
| 115 | +! |
- return(x)+ modules$children, |
||
| 191 | -+ | |||
| 116 | +! |
- }+ resolve_modules_datanames, |
||
| 192 | -6x | +|||
| 117 | +! |
- if (is.reactive(x)) {
+ simplify = FALSE, |
||
| 193 | -1x | +|||
| 118 | +! |
- checkmate::assert_class(isolate(x()), "teal_data")+ datanames = datanames, |
||
| 194 | -1x | +|||
| 119 | +! |
- datanames <- isolate(teal.data::datanames(x()))+ join_keys = join_keys |
||
| 195 | -1x | +|||
| 120 | +
- datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)+ ) |
|||
| 196 | -1x | +|||
| 121 | +! |
- code <- reactive(teal.code::get_code(x()))+ modules |
||
| 197 | -1x | +|||
| 122 | +
- join_keys <- isolate(teal.data::join_keys(x()))+ } else {
|
|||
| 198 | -5x | +|||
| 123 | +! |
- } else if (inherits(x, "teal_data")) {
+ modules$datanames <- if (identical(modules$datanames, "all")) {
|
||
| 199 | -5x | +|||
| 124 | +! |
- datanames <- teal.data::datanames(x)+ datanames |
||
| 200 | -5x | +|||
| 125 | +! |
- datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)+ } else if (is.character(modules$datanames)) {
|
||
| 201 | -5x | +|||
| 126 | +! |
- code <- reactive(teal.code::get_code(x))+ extra_datanames <- setdiff(modules$datanames, datanames) |
||
| 202 | -5x | +|||
| 127 | +! |
- join_keys <- isolate(teal.data::join_keys(x))+ if (length(extra_datanames)) {
|
||
| 203 | -+ | |||
| 128 | +! |
- }+ stop( |
||
| 204 | -+ | |||
| 129 | +! |
-
+ sprintf( |
||
| 205 | -6x | +|||
| 130 | +! |
- new_tdata(data = datasets, code = code, join_keys = join_keys)+ "Module %s has datanames that are not available in a 'data':\n %s not in %s", |
||
| 206 | -+ | |||
| 131 | +! |
- }+ modules$label, |
| 1 | -+ | |||
| 132 | +! |
- #' Filter manager modal+ toString(extra_datanames), |
||
| 2 | -+ | |||
| 133 | +! |
- #'+ toString(datanames) |
||
| 3 | +134 |
- #' Opens modal containing the filter manager UI.+ ) |
||
| 4 | +135 |
- #'+ ) |
||
| 5 | +136 |
- #' @name module_filter_manager_modal+ } |
||
| 6 | -+ | |||
| 137 | +! |
- #' @inheritParams filter_manager_srv+ datanames_adjusted <- intersect(modules$datanames, datanames) |
||
| 7 | -+ | |||
| 138 | +! |
- #' @examples+ include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys) |
||
| 8 | +139 |
- #' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris)))+ }+ |
+ ||
| 140 | +! | +
+ modules |
||
| 9 | +141 |
- #' fd2 <- teal.slice::init_filtered_data(+ } |
||
| 10 | +142 |
- #' list(iris = list(dataset = iris), mtcars = list(dataset = mtcars))+ } |
||
| 11 | +143 |
- #' )+ |
||
| 12 | +144 |
- #' fd3 <- teal.slice::init_filtered_data(+ #' Check `datanames` in modules |
||
| 13 | +145 |
- #' list(iris = list(dataset = iris), women = list(dataset = women))+ #' |
||
| 14 | +146 |
- #' )+ #' This function ensures specified `datanames` in modules match those in the data object, |
||
| 15 | +147 |
- #' filter <- teal_slices(+ #' returning error messages or `TRUE` for successful validation. |
||
| 16 | +148 |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length"),+ #' |
||
| 17 | +149 |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Species"),+ #' @param modules (`teal_modules`) object |
||
| 18 | +150 |
- #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg"),+ #' @param datanames (`character`) names of datasets available in the `data` object |
||
| 19 | +151 |
- #' teal.slice::teal_slice(dataname = "women", varname = "height"),+ #' |
||
| 20 | +152 |
- #' mapping = list(+ #' @return A `character(1)` containing error message or `TRUE` if validation passes. |
||
| 21 | +153 |
- #' module2 = c("mtcars mpg"),
+ #' @keywords internal |
||
| 22 | +154 |
- #' module3 = c("women height"),
+ check_modules_datanames <- function(modules, datanames) {
|
||
| 23 | -+ | |||
| 155 | +16x |
- #' global_filters = "iris Species"+ checkmate::assert_class(modules, "teal_modules") |
||
| 24 | -+ | |||
| 156 | +16x |
- #' )+ checkmate::assert_character(datanames) |
||
| 25 | +157 |
- #' )+ |
||
| 26 | -+ | |||
| 158 | +16x |
- #'+ recursive_check_datanames <- function(modules, datanames) {
|
||
| 27 | +159 |
- #' app <- shinyApp(+ # check teal_modules against datanames |
||
| 28 | -+ | |||
| 160 | +34x |
- #' ui = fluidPage(+ if (inherits(modules, "teal_modules")) {
|
||
| 29 | -+ | |||
| 161 | +16x |
- #' teal:::filter_manager_modal_ui("manager")
+ sapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames)) |
||
| 30 | +162 |
- #' ),+ } else {
|
||
| 31 | -+ | |||
| 163 | +18x |
- #' server = function(input, output, session) {
+ extra_datanames <- setdiff(modules$datanames, c("all", datanames))
|
||
| 32 | -+ | |||
| 164 | +18x |
- #' teal:::filter_manager_modal_srv(+ if (length(extra_datanames)) {
|
||
| 33 | -+ | |||
| 165 | +2x |
- #' "manager",+ sprintf( |
||
| 34 | -+ | |||
| 166 | +2x |
- #' filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3),+ "- Module '%s' uses datanames not available in 'data': (%s) not in (%s)", |
||
| 35 | -+ | |||
| 167 | +2x |
- #' filter = filter+ modules$label, |
||
| 36 | -+ | |||
| 168 | +2x |
- #' )+ toString(dQuote(extra_datanames, q = FALSE)), |
||
| 37 | -+ | |||
| 169 | +2x |
- #' }+ toString(dQuote(datanames, q = FALSE)) |
||
| 38 | +170 |
- #' )+ ) |
||
| 39 | +171 |
- #' if (interactive()) {
+ } |
||
| 40 | +172 |
- #' shinyApp(app$ui, app$server)+ } |
||
| 41 | +173 |
- #' }+ } |
||
| 42 | -+ | |||
| 174 | +16x |
- #'+ check_datanames <- unlist(recursive_check_datanames(modules, datanames)) |
||
| 43 | -+ | |||
| 175 | +16x |
- #' @keywords internal+ if (length(check_datanames)) {
|
||
| 44 | -+ | |||
| 176 | +2x |
- #'+ paste(check_datanames, collapse = "\n") |
||
| 45 | +177 |
- NULL+ } else {
|
||
| 46 | -+ | |||
| 178 | +14x |
-
+ TRUE |
||
| 47 | +179 |
- #' @rdname module_filter_manager_modal+ } |
||
| 48 | +180 |
- filter_manager_modal_ui <- function(id) {
+ } |
||
| 49 | -! | +|||
| 181 | +
- ns <- NS(id)+ |
|||
| 50 | -! | +|||
| 182 | +
- tags$button(+ #' Check `datanames` in filters |
|||
| 51 | -! | +|||
| 183 | +
- id = ns("show"),
+ #' |
|||
| 52 | -! | +|||
| 184 | +
- class = "btn action-button filter_manager_button",+ #' This function checks whether `datanames` in filters correspond to those in `data`, |
|||
| 53 | -! | +|||
| 185 | +
- title = "Show filters manager modal",+ #' returning character vector with error messages or TRUE if all checks pass. |
|||
| 54 | -! | +|||
| 186 | +
- icon("gear")
+ #' |
|||
| 55 | +187 |
- )+ #' @param filters (`teal_slices`) object |
||
| 56 | +188 |
- }+ #' @param datanames (`character`) names of datasets available in the `data` object |
||
| 57 | +189 |
-
+ #' |
||
| 58 | +190 |
- #' @rdname module_filter_manager_modal+ #' @return A `character(1)` containing error message or TRUE if validation passes. |
||
| 59 | +191 |
- filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
+ #' @keywords internal |
||
| 60 | -3x | +|||
| 192 | +
- moduleServer(id, function(input, output, session) {
+ check_filter_datanames <- function(filters, datanames) {
|
|||
| 61 | -3x | +193 | +14x |
- observeEvent(input$show, {
+ checkmate::assert_class(filters, "teal_slices") |
| 62 | -! | +|||
| 194 | +14x |
- logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
+ checkmate::assert_character(datanames) |
||
| 63 | -! | +|||
| 195 | +
- showModal(+ |
|||
| 64 | -! | +|||
| 196 | +
- modalDialog(+ # check teal_slices against datanames |
|||
| 65 | -! | +|||
| 197 | +14x |
- filter_manager_ui(session$ns("filter_manager")),
+ out <- unlist(sapply( |
||
| 66 | -! | +|||
| 198 | +14x |
- size = "l",+ filters, function(filter) {
|
||
| 67 | -! | +|||
| 199 | +3x |
- footer = NULL,+ dataname <- shiny::isolate(filter$dataname) |
||
| 68 | -! | +|||
| 200 | +3x |
- easyClose = TRUE+ if (!dataname %in% datanames) {
|
||
| 69 | -+ | |||
| 201 | +2x |
- )+ sprintf( |
||
| 70 | -+ | |||
| 202 | +2x |
- )+ "- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)", |
||
| 71 | -+ | |||
| 203 | +2x |
- })+ shiny::isolate(filter$id), |
||
| 72 | -+ | |||
| 204 | +2x |
-
+ dQuote(dataname, q = FALSE), |
||
| 73 | -3x | +205 | +2x |
- filter_manager_srv("filter_manager", filtered_data_list, filter)
+ toString(dQuote(datanames, q = FALSE)) |
| 74 | +206 |
- })+ ) |
||
| 75 | +207 |
- }+ } |
||
| 76 | +208 |
-
+ } |
||
| 77 | +209 |
- #' @rdname module_filter_manager+ )) |
||
| 78 | +210 |
- filter_manager_ui <- function(id) {
- |
- ||
| 79 | -! | -
- ns <- NS(id)- |
- ||
| 80 | -! | -
- div(- |
- ||
| 81 | -! | -
- class = "filter_manager_content",- |
- ||
| 82 | -! | -
- tableOutput(ns("slices_table")),
- |
- ||
| 83 | -! | -
- snapshot_manager_ui(ns("snapshot_manager"))
+
|
||
| 84 | +211 |
- )+ |
||
| 85 | -+ | |||
| 212 | +14x |
- }+ if (length(out)) {
|
||
| 86 | -+ | |||
| 213 | +2x |
-
+ paste(out, collapse = "\n") |
||
| 87 | +214 |
- #' Manage multiple `FilteredData` objects+ } else {
|
||
| 88 | -+ | |||
| 215 | +12x |
- #'+ TRUE |
||
| 89 | +216 |
- #' Oversee filter states in the whole application.+ } |
||
| 90 | +217 |
- #'+ } |
| 91 | +1 |
- #' @rdname module_filter_manager+ #' Create a `teal` module for previewing a report |
||
| 92 | +2 |
- #' @details+ #' |
||
| 93 | +3 |
- #' This module observes the changes of the filters in each `FilteredData` object+ #' @description `r lifecycle::badge("experimental")`
|
||
| 94 | +4 |
- #' and keeps track of all filters used. A mapping of filters to modules+ #' This function wraps [teal.reporter::reporter_previewer_ui()] and |
||
| 95 | +5 |
- #' is kept in the `mapping_matrix` object (which is actually a `data.frame`)+ #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be |
||
| 96 | +6 |
- #' that tracks which filters (rows) are active in which modules (columns).+ #' used in `teal` applications. |
||
| 97 | +7 |
#' |
||
| 98 | +8 |
- #' @param id (`character(1)`)\cr+ #' If you are creating a `teal` application using [teal::init()] then this |
||
| 99 | +9 |
- #' `shiny` module id.+ #' module will be added to your application automatically if any of your `teal modules` |
||
| 100 | +10 |
- #' @param filtered_data_list (`named list`)\cr+ #' support report generation. |
||
| 101 | +11 |
- #' A list, possibly nested, of `FilteredData` objects.+ #' |
||
| 102 | +12 |
- #' Each `FilteredData` will be served to one module in the `teal` application.+ #' @inheritParams module |
||
| 103 | +13 |
- #' The structure of the list must reflect the nesting of modules in tabs+ #' @param server_args (`named list`)\cr |
||
| 104 | +14 |
- #' and names of the list must be the same as labels of their respective modules.+ #' Arguments passed to [teal.reporter::reporter_previewer_srv()]. |
||
| 105 | +15 |
- #' @inheritParams init+ #' @return `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer |
||
| 106 | +16 |
- #' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.+ #' functionality. |
||
| 107 | +17 |
- #' @keywords internal+ #' @export |
||
| 108 | +18 |
- #'+ reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
|
||
| 109 | -+ | |||
| 19 | +4x |
- filter_manager_srv <- function(id, filtered_data_list, filter) {
+ checkmate::assert_string(label) |
||
| 110 | -5x | +20 | +2x |
- moduleServer(id, function(input, output, session) {
+ checkmate::assert_list(server_args, names = "named") |
| 111 | -5x | +21 | +2x |
- logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
+ checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv)))) |
| 112 | +22 | |||
| 113 | -5x | +23 | +2x |
- is_module_specific <- isTRUE(attr(filter, "module_specific"))+ logger::log_info("Initializing reporter_previewer_module")
|
| 114 | +24 | |||
| 115 | -+ | |||
| 25 | +2x |
- # Create global list of slices.+ srv <- function(id, reporter, ...) {
|
||
| 116 | -+ | |||
| 26 | +! |
- # Contains all available teal_slice objects available to all modules.+ teal.reporter::reporter_previewer_srv(id, reporter, ...) |
||
| 117 | +27 |
- # Passed whole to instances of FilteredData used for individual modules.+ } |
||
| 118 | +28 |
- # Down there a subset that pertains to the data sets used in that module is applied and displayed.+ |
||
| 119 | -5x | +29 | +2x |
- slices_global <- reactiveVal(filter)+ ui <- function(id, ...) {
+ |
+
| 30 | +! | +
+ teal.reporter::reporter_previewer_ui(id, ...) |
||
| 120 | +31 |
-
+ } |
||
| 121 | -5x | +|||
| 32 | +
- filtered_data_list <-+ |
|||
| 122 | -5x | +33 | +2x |
- if (!is_module_specific) {
+ module <- module( |
| 123 | -+ | |||
| 34 | +2x |
- # Retrieve the first FilteredData from potentially nested list.+ label = "temporary label", |
||
| 124 | -+ | |||
| 35 | +2x |
- # List of length one is named "global_filters" because that name is forbidden for a module label.+ server = srv, ui = ui, |
||
| 125 | -4x | +36 | +2x |
- list(global_filters = unlist(filtered_data_list)[[1]])+ server_args = server_args, ui_args = list(), datanames = NULL |
| 126 | +37 |
- } else {
+ ) |
||
| 127 | +38 |
- # Flatten potentially nested list of FilteredData objects while maintaining useful names.+ # Module is created with a placeholder label and the label is changed later. |
||
| 128 | +39 |
- # Simply using `unlist` would result in concatenated names.- |
- ||
| 129 | -1x | -
- flatten_nested <- function(x, name = NULL) {
+ # This is to prevent another module being labeled "Report previewer". |
||
| 130 | -5x | +40 | +2x |
- if (inherits(x, "FilteredData")) {
+ class(module) <- c("teal_module_previewer", class(module))
|
| 131 | -3x | -
- setNames(list(x), name)- |
- ||
| 132 | -+ | 41 | +2x |
- } else {
+ module$label <- label |
| 133 | +42 | 2x |
- unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))+ module |
|
| 134 | +43 |
- }+ } |
| 135 | +1 |
- }- |
- ||
| 136 | -1x | -
- flatten_nested(filtered_data_list)+ setOldClass("teal_data_module")
|
||
| 137 | +2 |
- }+ |
||
| 138 | +3 |
-
+ #' Evaluate Code on `teal_data_module` |
||
| 139 | +4 |
- # Create mapping fo filters to modules in matrix form (presented as data.frame).+ #' |
||
| 140 | +5 |
- # Modules get NAs for filters that cannot be set for them.- |
- ||
| 141 | -5x | -
- mapping_matrix <- reactive({
- |
- ||
| 142 | -5x | -
- state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")- |
- ||
| 143 | -5x | -
- mapping_smooth <- lapply(filtered_data_list, function(x) {
- |
- ||
| 144 | -7x | -
- state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")+ #' @details |
||
| 145 | -7x | +|||
| 6 | +
- state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")+ #' `eval_code` evaluates given code in the environment of the `teal_data` object created by the `teal_data_module`. |
|||
| 146 | -7x | +|||
| 7 | +
- states_active <- state_ids_global %in% state_ids_local+ #' The code is added to the `@code` slot of the `teal_data`. |
|||
| 147 | -7x | +|||
| 8 | +
- ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)+ #' |
|||
| 148 | +9 |
- })+ #' @param object (`teal_data_module`) |
||
| 149 | +10 |
-
+ #' @inheritParams teal.code::eval_code |
||
| 150 | -5x | +|||
| 11 | +
- as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)+ #' |
|||
| 151 | +12 |
- })+ #' @return |
||
| 152 | +13 |
-
+ #' `eval_code` returns a `teal_data_module` object with a delayed evaluation of `code` when the module is run. |
||
| 153 | -5x | +|||
| 14 | +
- output$slices_table <- renderTable(+ #' |
|||
| 154 | -5x | +|||
| 15 | +
- expr = {
+ #' @examples |
|||
| 155 | +16 |
- # Display logical values as UTF characters.+ #' tdm <- teal_data_module( |
||
| 156 | -2x | +|||
| 17 | +
- mm <- mapping_matrix()+ #' ui = function(id) div(id = shiny::NS(id)("div_id")),
|
|||
| 157 | -2x | +|||
| 18 | +
- mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))+ #' server = function(id) {
|
|||
| 158 | -2x | +|||
| 19 | +
- mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))+ #' shiny::moduleServer(id, function(input, output, session) {
|
|||
| 159 | -2x | +|||
| 20 | +
- if (!is_module_specific) colnames(mm) <- "Global Filters"+ #' shiny::reactive(teal_data(IRIS = iris)) |
|||
| 160 | +21 |
-
+ #' }) |
||
| 161 | +22 |
- # Display placeholder if no filters defined.+ #' } |
||
| 162 | -2x | +|||
| 23 | +
- if (nrow(mm) == 0L) {
+ #' ) |
|||
| 163 | -2x | +|||
| 24 | +
- mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)+ #' eval_code(tdm, "IRIS <- subset(IRIS, Species == 'virginica')") |
|||
| 164 | -2x | +|||
| 25 | +
- rownames(mm) <- ""+ #' |
|||
| 165 | +26 |
- }+ #' @include teal_data_module.R |
||
| 166 | +27 |
-
+ #' @name eval_code |
||
| 167 | +28 |
- # Report Previewer will not be displayed.+ #' @rdname teal_data_module |
||
| 168 | -2x | +|||
| 29 | +
- mm[names(mm) != "Report previewer"]+ #' @aliases eval_code,teal_data_module,character-method |
|||
| 169 | +30 |
- },+ #' @aliases eval_code,teal_data_module,language-method |
||
| 170 | -5x | +|||
| 31 | +
- align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
+ #' @aliases eval_code,teal_data_module,expression-method |
|||
| 171 | -5x | +|||
| 32 | +
- rownames = TRUE+ #' |
|||
| 172 | +33 |
- )+ #' @importFrom methods setMethod |
||
| 173 | +34 |
-
+ #' @importMethodsFrom teal.code eval_code |
||
| 174 | +35 |
- # Create list of module calls.+ #' |
||
| 175 | -5x | +|||
| 36 | +
- modules_out <- lapply(names(filtered_data_list), function(module_name) {
+ setMethod("eval_code", signature = c("teal_data_module", "character"), function(object, code) {
|
|||
| 176 | -7x | +37 | +13x |
- filter_manager_module_srv(+ teal_data_module( |
| 177 | -7x | +38 | +13x |
- id = module_name,+ ui = function(id) {
|
| 178 | -7x | +39 | +1x |
- module_fd = filtered_data_list[[module_name]],+ ns <- NS(id) |
| 179 | -7x | +40 | +1x |
- slices_global = slices_global+ object$ui(ns("mutate_inner"))
|
| 180 | +41 |
- )+ },+ |
+ ||
| 42 | +13x | +
+ server = function(id) {
+ |
+ ||
| 43 | +11x | +
+ moduleServer(id, function(input, output, session) {
+ |
+ ||
| 44 | +11x | +
+ teal_data_rv <- object$server("mutate_inner")
|
||
| 181 | +45 |
- })+ + |
+ ||
| 46 | +11x | +
+ if (!is.reactive(teal_data_rv)) {
+ |
+ ||
| 47 | +1x | +
+ stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
|
||
| 182 | +48 |
-
+ } |
||
| 183 | +49 |
- # Call snapshot manager.+ |
||
| 184 | -5x | +50 | +10x |
- snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
+ td <- eventReactive(teal_data_rv(), |
| 185 | +51 |
-
+ {
|
||
| 186 | -5x | +52 | +10x |
- modules_out # returned for testing purpose+ if (inherits(teal_data_rv(), c("teal_data", "qenv.error"))) {
|
| 187 | -+ | |||
| 53 | +6x |
- })+ eval_code(teal_data_rv(), code) |
||
| 188 | +54 |
- }+ } else {
|
||
| 189 | -+ | |||
| 55 | +4x |
-
+ teal_data_rv() |
||
| 190 | +56 |
- #' Module specific filter manager+ } |
||
| 191 | +57 |
- #'+ }, |
||
| 192 | -+ | |||
| 58 | +10x |
- #' Track filter states in single module.+ ignoreNULL = FALSE |
||
| 193 | +59 |
- #'+ ) |
||
| 194 | -+ | |||
| 60 | +10x |
- #' This module tracks the state of a single `FilteredData` object and global `teal_slices`+ td |
||
| 195 | +61 |
- #' and updates both objects as necessary. Filter states added in different modules+ }) |
||
| 196 | +62 |
- #' Filter states added any individual module are added to global `teal_slices`+ } |
||
| 197 | +63 |
- #' and from there become available in other modules+ ) |
||
| 198 | +64 |
- #' by setting `private$available_teal_slices` in each `FilteredData`.+ }) |
||
| 199 | +65 |
- #'+ |
||
| 200 | +66 |
- #' @param id (`character(1)`)\cr+ setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
|
||
| 201 | -+ | |||
| 67 | +1x |
- #' `shiny` module id.+ eval_code(object, code = paste(lang2calls(code), collapse = "\n")) |
||
| 202 | +68 |
- #' @param module_fd (`FilteredData`)\cr+ }) |
||
| 203 | +69 |
- #' object to filter data in the teal-module+ |
||
| 204 | +70 |
- #' @param slices_global (`reactiveVal`)\cr+ setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
|
||
| 205 | -+ | |||
| 71 | +6x |
- #' stores `teal_slices` with all available filters; allows the following actions:+ eval_code(object, code = paste(lang2calls(code), collapse = "\n")) |
||
| 206 | +72 |
- #' - to disable/enable a specific filter in a module+ }) |
| 207 | +1 |
- #' - to restore saved filter settings+ #' Send input validation messages to output. |
|
| 208 | +2 |
- #' - to save current filter panel settings+ #' |
|
| 209 | +3 |
- #' @return A `reactive` expression containing the slices active in this module.+ #' Captures messages from `InputValidator` objects and collates them |
|
| 210 | +4 |
- #' @keywords internal+ #' into one message passed to `validate`. |
|
| 211 | +5 |
#' |
|
| 212 | +6 |
- filter_manager_module_srv <- function(id, module_fd, slices_global) {
- |
- |
| 213 | -7x | -
- moduleServer(id, function(input, output, session) {
+ #' `shiny::validate` is used to withhold rendering of an output element until |
|
| 214 | +7 |
- # Only operate on slices that refer to data sets present in this module.- |
- |
| 215 | -7x | -
- module_fd$set_available_teal_slices(reactive(slices_global()))+ #' certain conditions are met and to print a validation message in place |
|
| 216 | +8 |
-
+ #' of the output element. |
|
| 217 | +9 |
- # Track filter state of this module.- |
- |
| 218 | -7x | -
- slices_module <- reactive(module_fd$get_filter_state())+ #' `shinyvalidate::InputValidator` allows to validate input elements |
|
| 219 | +10 |
-
+ #' and to display specific messages in their respective input widgets. |
|
| 220 | +11 |
- # Reactive values for comparing states.- |
- |
| 221 | -7x | -
- previous_slices <- reactiveVal(isolate(slices_module()))- |
- |
| 222 | -7x | -
- slices_added <- reactiveVal(NULL)+ #' `validate_inputs` provides a hybrid solution. |
|
| 223 | +12 |
-
+ #' Given an `InputValidator` object, messages corresponding to inputs that fail validation |
|
| 224 | +13 |
- # Observe changes in module filter state and trigger appropriate actions.+ #' are extracted and placed in one validation message that is passed to a `validate`/`need` call. |
|
| 225 | -7x | +||
| 14 | +
- observeEvent(slices_module(), ignoreNULL = FALSE, {
+ #' This way the input `validator` messages are repeated in the output. |
||
| 226 | -2x | +||
| 15 | +
- logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
+ #' |
||
| 227 | -2x | +||
| 16 | +
- added <- setdiff_teal_slices(slices_module(), slices_global())+ #' The `...` argument accepts any number of `InputValidator` objects |
||
| 228 | -! | +||
| 17 | +
- if (length(added)) slices_added(added)+ #' or a nested list of such objects. |
||
| 229 | -2x | +||
| 18 | +
- previous_slices(slices_module())+ #' If `validators` are passed directly, all their messages are printed together |
||
| 230 | +19 |
- })+ #' under one (optional) header message specified by `header`. If a list is passed, |
|
| 231 | +20 |
-
+ #' messages are grouped by `validator`. The list's names are used as headers |
|
| 232 | -7x | +||
| 21 | +
- observeEvent(slices_added(), ignoreNULL = TRUE, {
+ #' for their respective message groups. |
||
| 233 | -! | +||
| 22 | +
- logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
+ #' If neither of the nested list elements is named, a header message is taken from `header`. |
||
| 234 | +23 |
- # In case the new state has the same id as an existing state, add a suffix to it.+ #' |
|
| 235 | -! | +||
| 24 | +
- global_ids <- vapply(slices_global(), `[[`, character(1L), "id")+ #' @param ... either any number of `InputValidator` objects |
||
| 236 | -! | +||
| 25 | +
- lapply(+ #' or an optionally named, possibly nested `list` of `InputValidator` |
||
| 237 | -! | +||
| 26 | +
- slices_added(),+ #' objects, see `Details` |
||
| 238 | -! | +||
| 27 | +
- function(slice) {
+ #' @param header `character(1)` generic validation message; set to NULL to omit |
||
| 239 | -! | +||
| 28 | +
- if (slice$id %in% global_ids) {
+ #' |
||
| 240 | -! | +||
| 29 | +
- slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)+ #' @return |
||
| 241 | +30 |
- }+ #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. |
|
| 242 | +31 |
- }+ #' |
|
| 243 | +32 |
- )+ #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`] |
|
| 244 | -! | +||
| 33 | +
- slices_global_new <- c(slices_global(), slices_added())+ #' |
||
| 245 | -! | +||
| 34 | +
- slices_global(slices_global_new)+ #' @examples |
||
| 246 | -! | +||
| 35 | +
- slices_added(NULL)+ #' library(shiny) |
||
| 247 | +36 |
- })+ #' library(shinyvalidate) |
|
| 248 | +37 |
-
+ #' |
|
| 249 | -7x | +||
| 38 | +
- slices_module # returned for testing purpose+ #' ui <- fluidPage( |
||
| 250 | +39 |
- })+ #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
|
|
| 251 | +40 |
- }+ #' sidebarLayout( |
| 1 | +41 |
- #' Data Module for `teal` Applications+ #' sidebarPanel( |
|
| 2 | +42 |
- #'+ #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
|
|
| 3 | +43 |
- #' @description+ #' selectInput("number", "select a number:", 1:6),
|
|
| 4 | +44 |
- #' `r lifecycle::badge("experimental")`
+ #' br(), |
|
| 5 | +45 |
- #'+ #' selectInput("color", "select a color:",
|
|
| 6 | +46 |
- #' Create a `teal_data_module` object and evaluate code on it with history tracking.+ #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
|
|
| 7 | +47 |
- #'+ #' multiple = TRUE |
|
| 8 | +48 |
- #' @details+ #' ), |
|
| 9 | +49 |
- #' `teal_data_module` creates a `shiny` module to supply or modify data in a `teal` application.+ #' sliderInput("size", "select point size:",
|
|
| 10 | +50 |
- #' The module allows for running data pre-processing code (creation _and_ some modification) after the app starts.+ #' min = 0.1, max = 4, value = 0.25 |
|
| 11 | +51 |
- #' The body of the server function will be run in the app rather than in the global environment.+ #' ) |
|
| 12 | +52 |
- #' This means it will be run every time the app starts, so use sparingly.\cr+ #' ), |
|
| 13 | +53 |
- #' Pass this module instead of a `teal_data` object in a call to [init()].+ #' mainPanel(plotOutput("plot"))
|
|
| 14 | +54 |
- #' Note that the server function must always return a `teal_data` object wrapped in a reactive expression.\cr+ #' ) |
|
| 15 | +55 |
- #' See vignette `vignette("data-as-shiny-module", package = "teal")` for more details.
+ #' ) |
|
| 16 | +56 |
#' |
|
| 17 | +57 |
- #' @param ui (`function(id)`)\cr+ #' server <- function(input, output) {
|
|
| 18 | +58 |
- #' `shiny` module `ui` function; must only take `id` argument+ #' # set up input validation |
|
| 19 | +59 |
- #' @param server (`function(id)`)\cr+ #' iv <- InputValidator$new() |
|
| 20 | +60 |
- #' `shiny` module `ui` function; must only take `id` argument;+ #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
|
|
| 21 | +61 |
- #' must return reactive expression containing `teal_data` object+ #' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
|
|
| 22 | +62 |
- #'+ #' iv$enable() |
|
| 23 | +63 |
- #' @return+ #' # more input validation |
|
| 24 | +64 |
- #' `teal_data_module` returns an object of class `teal_data_module`.+ #' iv_par <- InputValidator$new() |
|
| 25 | +65 |
- #'+ #' iv_par$add_rule("color", sv_required(message = "choose a color"))
|
|
| 26 | +66 |
- #' @examples+ #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color")
|
|
| 27 | +67 |
- #' data <- teal_data_module(+ #' iv_par$add_rule( |
|
| 28 | +68 |
- #' ui = function(id) {
+ #' "size", |
|
| 29 | +69 |
- #' ns <- NS(id)+ #' sv_between( |
|
| 30 | +70 |
- #' actionButton(ns("submit"), label = "Load data")
+ #' left = 0.5, right = 3, |
|
| 31 | +71 |
- #' },+ #' message_fmt = "choose a value between {left} and {right}"
|
|
| 32 | +72 |
- #' server = function(id) {
+ #' ) |
|
| 33 | +73 |
- #' moduleServer(id, function(input, output, session) {
+ #' ) |
|
| 34 | +74 |
- #' eventReactive(input$submit, {
+ #' iv_par$enable() |
|
| 35 | +75 |
- #' data <- within(+ #' |
|
| 36 | +76 |
- #' teal_data(),+ #' output$plot <- renderPlot({
|
|
| 37 | +77 |
- #' {
+ #' # validate output |
|
| 38 | +78 |
- #' dataset1 <- iris+ #' switch(input[["method"]], |
|
| 39 | +79 |
- #' dataset2 <- mtcars+ #' "sequential" = {
|
|
| 40 | +80 |
- #' }+ #' validate_inputs(iv) |
|
| 41 | +81 |
- #' )+ #' validate_inputs(iv_par, header = "Set proper graphical parameters") |
|
| 42 | +82 |
- #' datanames(data) <- c("dataset1", "dataset2")
+ #' }, |
|
| 43 | +83 |
- #'+ #' "combined" = validate_inputs(iv, iv_par), |
|
| 44 | +84 |
- #' data+ #' "grouped" = validate_inputs(list( |
|
| 45 | +85 |
- #' })+ #' "Some inputs require attention" = iv, |
|
| 46 | +86 |
- #' })+ #' "Set proper graphical parameters" = iv_par |
|
| 47 | +87 |
- #' }+ #' )) |
|
| 48 | +88 |
- #' )+ #' ) |
|
| 49 | +89 |
#' |
|
| 50 | +90 |
- #' @name teal_data_module+ #' plot(eruptions ~ waiting, faithful, |
|
| 51 | +91 |
- #' @rdname teal_data_module+ #' las = 1, pch = 16, |
|
| 52 | +92 |
- #'+ #' col = input[["color"]], cex = input[["size"]] |
|
| 53 | +93 |
- #' @seealso [`teal_data-class`], [`base::within()`], [`teal.code::within.qenv()`]+ #' ) |
|
| 54 | +94 |
- #'+ #' }) |
|
| 55 | +95 |
- #' @export+ #' } |
|
| 56 | +96 |
- teal_data_module <- function(ui, server) {
+ #' |
|
| 57 | -35x | +||
| 97 | +
- checkmate::assert_function(ui, args = "id", nargs = 1)+ #' if (interactive()) {
|
||
| 58 | -34x | +||
| 98 | +
- checkmate::assert_function(server, args = "id", nargs = 1)+ #' shinyApp(ui, server) |
||
| 59 | -33x | +||
| 99 | +
- structure(+ #' } |
||
| 60 | -33x | +||
| 100 | +
- list(ui = ui, server = server),+ #' |
||
| 61 | -33x | +||
| 101 | +
- class = "teal_data_module"+ #' @export |
||
| 62 | +102 |
- )+ #' |
|
| 63 | +103 |
- }+ validate_inputs <- function(..., header = "Some inputs require attention") {
|
| 1 | -+ | |||
| 104 | +36x |
- #' Validate that dataset has a minimum number of observations+ dots <- list(...) |
||
| 2 | -+ | |||
| 105 | +2x |
- #'+ if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
|
||
| 3 | +106 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 107 | +34x |
- #' @param x a data.frame+ messages <- extract_validator(dots, header) |
||
| 5 | -+ | |||
| 108 | +34x |
- #' @param min_nrow minimum number of rows in \code{x}
+ failings <- if (!any_names(dots)) {
|
||
| 6 | -+ | |||
| 109 | +29x |
- #' @param complete \code{logical} default \code{FALSE} when set to \code{TRUE} then complete cases are checked.
+ add_header(messages, header) |
||
| 7 | +110 |
- #' @param allow_inf \code{logical} default \code{TRUE} when set to \code{FALSE} then error thrown if any values are
+ } else {
|
||
| 8 | -+ | |||
| 111 | +5x |
- #' infinite.+ unlist(messages) |
||
| 9 | +112 |
- #' @param msg (`character(1)`) additional message to display alongside the default message.+ } |
||
| 10 | +113 |
- #'+ |
||
| 11 | -+ | |||
| 114 | +34x |
- #' @details This function is a wrapper for `shiny::validate`.+ shiny::validate(shiny::need(is.null(failings), failings)) |
||
| 12 | +115 |
- #'+ } |
||
| 13 | +116 |
- #' @export+ |
||
| 14 | +117 |
- #'+ ### internal functions |
||
| 15 | +118 |
- #' @examples+ |
||
| 16 | +119 |
- #' library(teal)+ #' @keywords internal |
||
| 17 | +120 |
- #' ui <- fluidPage(+ # recursive object type test |
||
| 18 | +121 |
- #' sliderInput("len", "Max Length of Sepal",
+ # returns logical of length 1 |
||
| 19 | +122 |
- #' min = 4.3, max = 7.9, value = 5+ is_validators <- function(x) {
|
||
| 20 | -+ | |||
| 123 | +118x |
- #' ),+ all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator")) |
||
| 21 | +124 |
- #' plotOutput("plot")
+ } |
||
| 22 | +125 |
- #' )+ |
||
| 23 | +126 |
- #'+ #' @keywords internal |
||
| 24 | +127 |
- #' server <- function(input, output) {
+ # test if an InputValidator object is enabled |
||
| 25 | +128 |
- #' output$plot <- renderPlot({
+ # returns logical of length 1 |
||
| 26 | +129 |
- #' df <- iris[iris$Sepal.Length <= input$len, ]+ # official method requested at https://github.com/rstudio/shinyvalidate/issues/64 |
||
| 27 | +130 |
- #' validate_has_data(+ validator_enabled <- function(x) {
|
||
| 28 | -+ | |||
| 131 | +49x |
- #' iris_f,+ x$.__enclos_env__$private$enabled |
||
| 29 | +132 |
- #' min_nrow = 10,+ } |
||
| 30 | +133 |
- #' complete = FALSE,+ |
||
| 31 | +134 |
- #' msg = "Please adjust Max Length of Sepal"+ #' @keywords internal |
||
| 32 | +135 |
- #' )+ # recursively extract messages from validator list |
||
| 33 | +136 |
- #'+ # returns character vector or a list of character vectors, possibly nested and named |
||
| 34 | +137 |
- #' hist(iris_f$Sepal.Length, breaks = 5)+ extract_validator <- function(iv, header) {
|
||
| 35 | -+ | |||
| 138 | +113x |
- #' })+ if (inherits(iv, "InputValidator")) {
|
||
| 36 | -+ | |||
| 139 | +49x |
- #' }+ add_header(gather_messages(iv), header) |
||
| 37 | +140 |
- #' if (interactive()) {
+ } else {
|
||
| 38 | -+ | |||
| 141 | +58x |
- #' shinyApp(ui, server)+ if (is.null(names(iv))) names(iv) <- rep("", length(iv))
+ |
+ ||
| 142 | +64x | +
+ mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE) |
||
| 39 | +143 |
- #' }+ } |
||
| 40 | +144 |
- #'+ } |
||
| 41 | +145 |
- validate_has_data <- function(x,+ |
||
| 42 | +146 |
- min_nrow = NULL,+ #' @keywords internal |
||
| 43 | +147 |
- complete = FALSE,+ # collate failing messages from validator |
||
| 44 | +148 |
- allow_inf = TRUE,+ # returns list |
||
| 45 | +149 |
- msg = NULL) {
+ gather_messages <- function(iv) {
|
||
| 46 | -17x | +150 | +49x |
- checkmate::assert_string(msg, null.ok = TRUE)+ if (validator_enabled(iv)) {
|
| 47 | -15x | +151 | +46x |
- checkmate::assert_data_frame(x)+ status <- iv$validate() |
| 48 | -15x | +152 | +46x |
- if (!is.null(min_nrow)) {
+ failing_inputs <- Filter(Negate(is.null), status) |
| 49 | -15x | +153 | +46x |
- if (complete) {
+ unique(lapply(failing_inputs, function(x) x[["message"]])) |
| 50 | -5x | +|||
| 154 | +
- complete_index <- stats::complete.cases(x)+ } else {
|
|||
| 51 | -5x | +155 | +3x |
- validate(need(+ logger::log_warn("Validator is disabled and will be omitted.")
|
| 52 | -5x | +156 | +3x |
- sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,+ list() |
| 53 | -5x | +|||
| 157 | +
- paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
+ } |
|||
| 54 | +158 |
- ))+ } |
||
| 55 | +159 |
- } else {
+
|
||
| 56 | -10x | +|||
| 160 | +
- validate(need(+ #' @keywords internal+ |
+ |||
| 161 | ++ |
+ # add optional header to failing messages+ |
+ ||
| 162 | ++ |
+ add_header <- function(messages, header = "") {
|
||
| 57 | -10x | +163 | +78x |
- nrow(x) >= min_nrow,+ ans <- unlist(messages) |
| 58 | -10x | +164 | +78x |
- paste(+ if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
|
| 59 | -10x | +165 | +31x |
- c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
+ ans <- c(paste0(header, "\n"), ans, "\n")+ |
+
| 166 | ++ |
+ } |
||
| 60 | -10x | +167 | +78x |
- collapse = "\n"+ ans |
| 61 | +168 |
- )+ } |
||
| 62 | +169 |
- ))+ |
||
| 63 | +170 |
- }+ #' @keywords internal |
||
| 64 | +171 |
-
+ # recursively check if the object contains a named list |
||
| 65 | -10x | +|||
| 172 | +
- if (!allow_inf) {
+ any_names <- function(x) {
|
|||
| 66 | -6x | +173 | +103x |
- validate(need(+ any( |
| 67 | -6x | +174 | +103x |
- all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))),+ if (is.list(x)) {
|
| 68 | -6x | +175 | +58x |
- "Dataframe contains Inf values which is not allowed."+ if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names)) |
| 69 | +176 |
- ))+ } else {
+ |
+ ||
| 177 | +40x | +
+ FALSE |
||
| 70 | +178 |
} |
||
| 71 | +179 |
- }+ ) |
||
| 72 | +180 |
} |
| 73 | +1 |
-
+ #' Add right filter panel into each of the top-level `teal_modules` UIs. |
|
| 74 | +2 |
- #' Validate that dataset has unique rows for key variables+ #' |
|
| 75 | +3 |
- #'+ #' The [ui_nested_tabs] function returns a nested tabbed UI corresponding |
|
| 76 | +4 |
- #' @description `r lifecycle::badge("stable")`
+ #' to the nested modules. |
|
| 77 | +5 |
- #' @param x a data.frame+ #' This function adds the right filter panel to each main tab. |
|
| 78 | +6 |
- #' @param key a vector of ID variables from \code{x} that identify unique records
+ #' |
|
| 79 | +7 |
- #'+ #' The right filter panel's filter choices affect the `datasets` object. Therefore, |
|
| 80 | +8 |
- #' @details This function is a wrapper for `shiny::validate`.+ #' all modules using the same `datasets` share the same filters. |
|
| 81 | +9 |
#' |
|
| 82 | +10 |
- #' @export+ #' This works with nested modules of depth greater than 2, though the filter |
|
| 83 | +11 |
- #'+ #' panel is inserted at the right of the modules at depth 1 and not at the leaves. |
|
| 84 | +12 |
- #' @examples+ #' |
|
| 85 | +13 |
- #' iris$id <- rep(1:50, times = 3)+ #' @name module_tabs_with_filters |
|
| 86 | +14 |
- #' ui <- fluidPage(+ #' |
|
| 87 | +15 |
- #' selectInput(+ #' @inheritParams module_teal |
|
| 88 | +16 |
- #' inputId = "species",+ #' |
|
| 89 | +17 |
- #' label = "Select species",+ #' @param datasets (`named list` of `FilteredData`)\cr |
|
| 90 | +18 |
- #' choices = c("setosa", "versicolor", "virginica"),
+ #' object to store filter state and filtered datasets, shared across modules. For more |
|
| 91 | +19 |
- #' selected = "setosa",+ #' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure |
|
| 92 | +20 |
- #' multiple = TRUE+ #' of the `modules` argument and list names must correspond to the labels in `modules`. |
|
| 93 | +21 |
- #' ),+ #' When filter is not module-specific then list contains the same object in all elements. |
|
| 94 | +22 |
- #' plotOutput("plot")
+ #' @param reporter (`Reporter`) object from `teal.reporter` |
|
| 95 | +23 |
- #' )+ #' |
|
| 96 | +24 |
- #' server <- function(input, output) {
+ #' @return A `tagList` of The main menu, place holders for filters and |
|
| 97 | +25 |
- #' output$plot <- renderPlot({
+ #' place holders for the teal modules |
|
| 98 | +26 |
- #' iris_f <- iris[iris$Species %in% input$species, ]+ #' |
|
| 99 | +27 |
- #' validate_one_row_per_id(iris_f, key = c("id"))
+ #' |
|
| 100 | +28 |
- #'+ #' @keywords internal |
|
| 101 | +29 |
- #' hist(iris_f$Sepal.Length, breaks = 5)+ #' |
|
| 102 | +30 |
- #' })+ #' @examples |
|
| 103 | +31 |
- #' }+ #' |
|
| 104 | +32 |
- #' if (interactive()) {
+ #' mods <- teal:::example_modules() |
|
| 105 | +33 |
- #' shinyApp(ui, server)+ #' datasets <- teal:::example_datasets() |
|
| 106 | +34 |
- #' }+ #' |
|
| 107 | +35 |
- #'+ #' app <- shinyApp( |
|
| 108 | +36 |
- validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
+ #' ui = function() {
|
|
| 109 | -! | +||
| 37 | +
- validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
+ #' tagList( |
||
| 110 | +38 |
- }+ #' teal:::include_teal_css_js(), |
|
| 111 | +39 |
-
+ #' textOutput("info"),
|
|
| 112 | +40 |
- #' Validates that vector includes all expected values+ #' fluidPage( # needed for nice tabs |
|
| 113 | +41 |
- #'+ #' ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
|
|
| 114 | +42 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
|
| 115 | +43 |
- #' @param x values to test. All must be in \code{choices}
+ #' ) |
|
| 116 | +44 |
- #' @param choices a vector to test for values of \code{x}
+ #' }, |
|
| 117 | +45 |
- #' @param msg warning message to display+ #' server = function(input, output, session) {
|
|
| 118 | +46 |
- #'+ #' output$info <- renderText({
|
|
| 119 | +47 |
- #' @details This function is a wrapper for `shiny::validate`.+ #' paste0("The currently active tab name is ", active_module()$label)
|
|
| 120 | +48 |
- #'+ #' }) |
|
| 121 | +49 |
- #' @export+ #' active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods) |
|
| 122 | +50 |
- #'+ #' } |
|
| 123 | +51 |
- #' @examples+ #' ) |
|
| 124 | +52 |
- #' ui <- fluidPage(+ #' if (interactive()) {
|
|
| 125 | +53 |
- #' selectInput(+ #' shinyApp(app$ui, app$server) |
|
| 126 | +54 |
- #' "species",+ #' } |
|
| 127 | +55 |
- #' "Select species",+ #' |
|
| 128 | +56 |
- #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
+ NULL |
|
| 129 | +57 |
- #' selected = "setosa",+ |
|
| 130 | +58 |
- #' multiple = FALSE+ #' @rdname module_tabs_with_filters |
|
| 131 | +59 |
- #' ),+ ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
|
|
| 132 | -+ | ||
| 60 | +! |
- #' verbatimTextOutput("summary")
+ checkmate::assert_class(modules, "teal_modules") |
|
| 133 | -+ | ||
| 61 | +! |
- #' )+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
|
| 134 | -+ | ||
| 62 | +! |
- #'+ checkmate::assert_class(filter, "teal_slices") |
|
| 135 | +63 |
- #' server <- function(input, output) {
+
|
|
| 136 | -+ | ||
| 64 | +! |
- #' output$summary <- renderPrint({
+ ns <- NS(id) |
|
| 137 | -+ | ||
| 65 | +! |
- #' validate_in(input$species, iris$Species, "Species does not exist.")+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
|
| 138 | +66 |
- #' nrow(iris[iris$Species == input$species, ])+ |
|
| 139 | -+ | ||
| 67 | +! |
- #' })+ teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
|
|
| 140 | -+ | ||
| 68 | +! |
- #' }+ filter_panel_btns <- tags$li( |
|
| 141 | -+ | ||
| 69 | +! |
- #' if (interactive()) {
+ class = "flex-grow", |
|
| 142 | -+ | ||
| 70 | +! |
- #' shinyApp(ui, server)+ tags$button( |
|
| 143 | -+ | ||
| 71 | +! |
- #' }+ class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger |
|
| 144 | -+ | ||
| 72 | +! |
- #'+ href = "javascript:void(0)", |
|
| 145 | -+ | ||
| 73 | +! |
- validate_in <- function(x, choices, msg) {
+ onclick = "toggleFilterPanel();", # see sidebar.js |
|
| 146 | +74 | ! |
- validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg))+ title = "Toggle filter panels", |
| 147 | -+ | ||
| 75 | +! |
- }+ icon("fas fa-bars")
|
|
| 148 | +76 |
-
+ ), |
|
| 149 | -+ | ||
| 77 | +! |
- #' Validates that vector has length greater than 0+ filter_manager_modal_ui(ns("filter_manager"))
|
|
| 150 | +78 |
- #'+ ) |
|
| 151 | -+ | ||
| 79 | +! |
- #' @description `r lifecycle::badge("stable")`
+ teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns) |
|
| 152 | +80 |
- #' @param x vector+ |
|
| 153 | -+ | ||
| 81 | +! |
- #' @param msg message to display+ if (!is_module_specific) {
|
|
| 154 | +82 |
- #'+ # need to rearrange html so that filter panel is within tabset |
|
| 155 | -+ | ||
| 83 | +! |
- #' @details This function is a wrapper for `shiny::validate`.+ tabset_bar <- teal_ui$children[[1]] |
|
| 156 | -+ | ||
| 84 | +! |
- #'+ teal_modules <- teal_ui$children[[2]] |
|
| 157 | -+ | ||
| 85 | +! |
- #' @export+ filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
|
|
| 158 | -+ | ||
| 86 | +! |
- #'+ list( |
|
| 159 | -+ | ||
| 87 | +! |
- #' @examples+ tabset_bar, |
|
| 160 | -+ | ||
| 88 | +! |
- #' data <- data.frame(+ tags$hr(class = "my-2"), |
|
| 161 | -+ | ||
| 89 | +! |
- #' id = c(1:10, 11:20, 1:10),+ fluidRow( |
|
| 162 | -+ | ||
| 90 | +! |
- #' strata = rep(c("A", "B"), each = 15)
+ column(width = 9, teal_modules, class = "teal_primary_col"), |
|
| 163 | -+ | ||
| 91 | +! |
- #' )+ column(width = 3, filter_ui, class = "teal_secondary_col") |
|
| 164 | +92 |
- #' ui <- fluidPage(+ ) |
|
| 165 | +93 |
- #' selectInput("ref1", "Select strata1 to compare",
+ ) |
|
| 166 | +94 |
- #' choices = c("A", "B", "C"), selected = "A"
+ } else {
|
|
| 167 | -+ | ||
| 95 | +! |
- #' ),+ teal_ui |
|
| 168 | +96 |
- #' selectInput("ref2", "Select strata2 to compare",
+ } |
|
| 169 | +97 |
- #' choices = c("A", "B", "C"), selected = "B"
+ } |
|
| 170 | +98 |
- #' ),+ |
|
| 171 | +99 |
- #' verbatimTextOutput("arm_summary")
+ #' @rdname module_tabs_with_filters |
|
| 172 | +100 |
- #' )+ srv_tabs_with_filters <- function(id, |
|
| 173 | +101 |
- #'+ datasets, |
|
| 174 | +102 |
- #' server <- function(input, output) {
+ modules, |
|
| 175 | +103 |
- #' output$arm_summary <- renderText({
+ reporter = teal.reporter::Reporter$new(), |
|
| 176 | +104 |
- #' sample_1 <- data$id[data$strata == input$ref1]+ filter = teal_slices()) {
|
|
| 177 | -+ | ||
| 105 | +5x |
- #' sample_2 <- data$id[data$strata == input$ref2]+ checkmate::assert_class(modules, "teal_modules") |
|
| 178 | -+ | ||
| 106 | +5x |
- #'+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
|
| 179 | -+ | ||
| 107 | +5x |
- #' validate_has_elements(sample_1, "No subjects in strata1.")+ checkmate::assert_class(reporter, "Reporter") |
|
| 180 | -+ | ||
| 108 | +3x |
- #' validate_has_elements(sample_2, "No subjects in strata2.")+ checkmate::assert_class(filter, "teal_slices") |
|
| 181 | +109 |
- #'+ |
|
| 182 | -+ | ||
| 110 | +3x |
- #' paste0(+ moduleServer(id, function(input, output, session) {
|
|
| 183 | -+ | ||
| 111 | +3x |
- #' "Number of samples in: strata1=", length(sample_1),+ logger::log_trace("srv_tabs_with_filters initializing the module.")
|
|
| 184 | +112 |
- #' " comparions strata2=", length(sample_2)+ |
|
| 185 | -+ | ||
| 113 | +3x |
- #' )+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
|
| 186 | -+ | ||
| 114 | +3x |
- #' })+ manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
|
|
| 187 | +115 |
- #' }+ |
|
| 188 | -+ | ||
| 116 | +3x |
- #' if (interactive()) {
+ active_module <- srv_nested_tabs( |
|
| 189 | -+ | ||
| 117 | +3x |
- #' shinyApp(ui, server)+ id = "root", |
|
| 190 | -+ | ||
| 118 | +3x |
- #' }+ datasets = datasets, |
|
| 191 | -+ | ||
| 119 | +3x |
- validate_has_elements <- function(x, msg) {
+ modules = modules, |
|
| 192 | -! | +||
| 120 | +3x |
- validate(need(length(x) > 0, msg))+ reporter = reporter, |
|
| 193 | -+ | ||
| 121 | +3x |
- }+ is_module_specific = is_module_specific |
|
| 194 | +122 |
-
+ ) |
|
| 195 | +123 |
- #' Validates no intersection between two vectors+ |
|
| 196 | -+ | ||
| 124 | +3x |
- #'+ if (!is_module_specific) {
|
|
| 197 | -+ | ||
| 125 | +3x |
- #' @description `r lifecycle::badge("stable")`
+ active_datanames <- reactive({
|
|
| 198 | -+ | ||
| 126 | +6x |
- #' @param x vector+ if (identical(active_module()$datanames, "all")) {
|
|
| 199 | -+ | ||
| 127 | +! |
- #' @param y vector+ singleton$datanames() |
|
| 200 | +128 |
- #' @param msg message to display if \code{x} and \code{y} intersect
+ } else {
|
|
| 201 | -+ | ||
| 129 | +5x |
- #'+ active_module()$datanames |
|
| 202 | +130 |
- #' @details This function is a wrapper for `shiny::validate`.+ } |
|
| 203 | +131 |
- #'+ }) |
|
| 204 | -+ | ||
| 132 | +3x |
- #' @export+ singleton <- unlist(datasets)[[1]] |
|
| 205 | -+ | ||
| 133 | +3x |
- #'+ singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
|
|
| 206 | +134 |
- #' @examples+ |
|
| 207 | -+ | ||
| 135 | +3x |
- #' data <- data.frame(+ observeEvent( |
|
| 208 | -+ | ||
| 136 | +3x |
- #' id = c(1:10, 11:20, 1:10),+ eventExpr = active_datanames(), |
|
| 209 | -+ | ||
| 137 | +3x |
- #' strata = rep(c("A", "B", "C"), each = 10)
+ handlerExpr = {
|
|
| 210 | -+ | ||
| 138 | +4x |
- #' )+ script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
|
|
| 211 | +139 |
- #'+ # hide the filter panel and disable the burger button |
|
| 212 | -+ | ||
| 140 | +! |
- #' ui <- fluidPage(+ "handleNoActiveDatasets();" |
|
| 213 | +141 |
- #' selectInput("ref1", "Select strata1 to compare",
+ } else {
|
|
| 214 | +142 |
- #' choices = c("A", "B", "C"),
+ # show the filter panel and enable the burger button |
|
| 215 | -+ | ||
| 143 | +4x |
- #' selected = "A"+ "handleActiveDatasetsPresent();" |
|
| 216 | +144 |
- #' ),+ } |
|
| 217 | -+ | ||
| 145 | +4x |
- #' selectInput("ref2", "Select strata2 to compare",
+ shinyjs::runjs(script) |
|
| 218 | +146 |
- #' choices = c("A", "B", "C"),
+ }, |
|
| 219 | -+ | ||
| 147 | +3x |
- #' selected = "B"+ ignoreNULL = FALSE |
|
| 220 | +148 |
- #' ),+ ) |
|
| 221 | +149 |
- #' verbatimTextOutput("summary")
+ } |
|
| 222 | +150 |
- #' )+ |
|
| 223 | -+ | ||
| 151 | +3x |
- #'+ showNotification("Data loaded - App fully started up")
|
|
| 224 | -+ | ||
| 152 | +3x |
- #' server <- function(input, output) {
+ logger::log_trace("srv_tabs_with_filters initialized the module")
|
|
| 225 | -+ | ||
| 153 | +3x |
- #' output$summary <- renderText({
+ return(active_module) |
|
| 226 | +154 |
- #' sample_1 <- data$id[data$strata == input$ref1]+ }) |
|
| 227 | +155 |
- #' sample_2 <- data$id[data$strata == input$ref2]+ } |
| 228 | +1 |
- #'+ #' Include `CSS` files from `/inst/css/` package directory to application header |
|
| 229 | +2 |
- #' validate_no_intersection(+ #' |
|
| 230 | +3 |
- #' sample_1, sample_2,+ #' `system.file` should not be used to access files in other packages, it does |
|
| 231 | +4 |
- #' "subjects within strata1 and strata2 cannot overlap"+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 232 | +5 |
- #' )+ #' as needed. Thus, we do not export this method |
|
| 233 | +6 |
- #' paste0(+ #' |
|
| 234 | +7 |
- #' "Number of subject in: reference treatment=", length(sample_1),+ #' @param pattern (`character`) pattern of files to be included |
|
| 235 | +8 |
- #' " comparions treatment=", length(sample_2)+ #' |
|
| 236 | +9 |
- #' )+ #' @return HTML code that includes `CSS` files |
|
| 237 | +10 |
- #' })+ #' @keywords internal |
|
| 238 | +11 |
- #' }+ include_css_files <- function(pattern = "*") {
|
|
| 239 | -+ | ||
| 12 | +12x |
- #' if (interactive()) {
+ css_files <- list.files( |
|
| 240 | -+ | ||
| 13 | +12x |
- #' shinyApp(ui, server)+ system.file("css", package = "teal", mustWork = TRUE),
|
|
| 241 | -+ | ||
| 14 | +12x |
- #' }+ pattern = pattern, full.names = TRUE |
|
| 242 | +15 |
- #'+ ) |
|
| 243 | -+ | ||
| 16 | +12x |
- validate_no_intersection <- function(x, y, msg) {
+ return( |
|
| 244 | -! | +||
| 17 | +12x |
- validate(need(length(intersect(x, y)) == 0, msg))+ shiny::singleton( |
|
| 245 | -+ | ||
| 18 | +12x |
- }+ shiny::tags$head(lapply(css_files, shiny::includeCSS)) |
|
| 246 | +19 |
-
+ ) |
|
| 247 | +20 |
-
+ ) |
|
| 248 | +21 |
- #' Validates that dataset contains specific variable+ } |
|
| 249 | +22 |
- #'+ |
|
| 250 | +23 |
- #' @description `r lifecycle::badge("stable")`
+ #' Include `JS` files from `/inst/js/` package directory to application header |
|
| 251 | +24 |
- #' @param data a data.frame+ #' |
|
| 252 | +25 |
- #' @param varname name of variable in \code{data}
+ #' `system.file` should not be used to access files in other packages, it does |
|
| 253 | +26 |
- #' @param msg message to display if \code{data} does not include \code{varname}
+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 254 | +27 |
- #'+ #' as needed. Thus, we do not export this method |
|
| 255 | +28 |
- #' @details This function is a wrapper for `shiny::validate`.+ #' |
|
| 256 | +29 |
- #'+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file` |
|
| 257 | +30 |
- #' @export+ #' @param except (`character`) vector of basename filenames to be excluded |
|
| 258 | +31 |
#' |
|
| 259 | +32 |
- #' @examples+ #' @return HTML code that includes `JS` files |
|
| 260 | +33 |
- #' data <- data.frame(+ #' @keywords internal |
|
| 261 | +34 |
- #' one = rep("a", length.out = 20),
+ include_js_files <- function(pattern = NULL, except = NULL) {
|
|
| 262 | -+ | ||
| 35 | +12x |
- #' two = rep(c("a", "b"), length.out = 20)
+ checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE) |
|
| 263 | -+ | ||
| 36 | +12x |
- #' )+ js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
|
|
| 264 | -+ | ||
| 37 | +12x |
- #' ui <- fluidPage(+ js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL |
|
| 265 | +38 |
- #' selectInput(+ |
|
| 266 | -+ | ||
| 39 | +12x |
- #' "var",+ return(singleton(lapply(js_files, includeScript))) |
|
| 267 | +40 |
- #' "Select variable",+ } |
|
| 268 | +41 |
- #' choices = c("one", "two", "three", "four"),
+
|
|
| 269 | +42 |
- #' selected = "one"+ #' Run `JS` file from `/inst/js/` package directory |
|
| 270 | +43 |
- #' ),+ #' |
|
| 271 | +44 |
- #' verbatimTextOutput("summary")
+ #' This is triggered from the server to execute on the client |
|
| 272 | +45 |
- #' )+ #' rather than triggered directly on the client. |
|
| 273 | +46 |
- #'+ #' Unlike `include_js_files` which includes `JavaScript` functions, |
|
| 274 | +47 |
- #' server <- function(input, output) {
+ #' the `run_js` actually executes `JavaScript` functions. |
|
| 275 | +48 |
- #' output$summary <- renderText({
+ #' |
|
| 276 | +49 |
- #' validate_has_variable(data, input$var)+ #' `system.file` should not be used to access files in other packages, it does |
|
| 277 | +50 |
- #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 278 | +51 |
- #' })+ #' as needed. Thus, we do not export this method |
|
| 279 | +52 |
- #' }+ #' |
|
| 280 | +53 |
- #' if (interactive()) {
+ #' @param files (`character`) vector of filenames |
|
| 281 | +54 |
- #' shinyApp(ui, server)+ #' @keywords internal |
|
| 282 | +55 |
- #' }+ run_js_files <- function(files) {
|
|
| 283 | -+ | ||
| 56 | +18x |
- validate_has_variable <- function(data, varname, msg) {
+ checkmate::assert_character(files, min.len = 1, any.missing = FALSE) |
|
| 284 | -! | +||
| 57 | +18x |
- if (length(varname) != 0) {
+ lapply(files, function(file) {
|
|
| 285 | -! | +||
| 58 | +18x |
- has_vars <- varname %in% names(data)+ shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
|
|
| 286 | +59 | - - | -|
| 287 | -! | -
- if (!all(has_vars)) {
+ }) |
|
| 288 | -! | +||
| 60 | +18x |
- if (missing(msg)) {
+ return(invisible(NULL)) |
|
| 289 | -! | +||
| 61 | +
- msg <- sprintf(+ } |
||
| 290 | -! | +||
| 62 | +
- "%s does not have the required variables: %s.",+ |
||
| 291 | -! | +||
| 63 | +
- deparse(substitute(data)),+ #' Code to include teal `CSS` and `JavaScript` files |
||
| 292 | -! | +||
| 64 | +
- toString(varname[!has_vars])+ #' |
||
| 293 | +65 |
- )+ #' This is useful when you want to use the same `JavaScript` and `CSS` files that are |
|
| 294 | +66 |
- }+ #' used with the teal application. |
|
| 295 | -! | +||
| 67 | +
- validate(need(FALSE, msg))+ #' This is also useful for running standalone modules in teal with the correct |
||
| 296 | +68 |
- }+ #' styles. |
|
| 297 | +69 |
- }+ #' Also initializes `shinyjs` so you can use it. |
|
| 298 | +70 |
- }+ #' |
|
| 299 | +71 |
-
+ #' @return HTML code to include |
|
| 300 | +72 |
- #' Validate that variables has expected number of levels+ #' @examples |
|
| 301 | +73 |
- #'+ #' shiny_ui <- tagList( |
|
| 302 | +74 |
- #' @description `r lifecycle::badge("stable")`
+ #' teal:::include_teal_css_js(), |
|
| 303 | +75 |
- #' @param x variable name. If \code{x} is not a factor, the unique values
+ #' p("Hello")
|
|
| 304 | +76 |
- #' are treated as levels.+ #' ) |
|
| 305 | +77 |
- #' @param min_levels cutoff for minimum number of levels of \code{x}
+ #' @keywords internal |
|
| 306 | +78 |
- #' @param max_levels cutoff for maximum number of levels of \code{x}
+ include_teal_css_js <- function() {
+ |
+ |
| 79 | +12x | +
+ tagList(+ |
+ |
| 80 | +12x | +
+ shinyjs::useShinyjs(),+ |
+ |
| 81 | +12x | +
+ include_css_files(), |
|
| 307 | +82 |
- #' @param var_name name of variable being validated for use in+ # init.js is executed from the server+ |
+ |
| 83 | +12x | +
+ include_js_files(except = "init.js"),+ |
+ |
| 84 | +12x | +
+ shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
|
|
| 308 | +85 |
- #' validation message+ ) |
|
| 309 | +86 |
- #'+ } |
| 310 | +1 |
- #' @details If the number of levels of \code{x} is less than \code{min_levels}
+ #' Validate that dataset has a minimum number of observations |
|
| 311 | +2 |
- #' or greater than \code{max_levels} the validation will fail.
+ #' |
|
| 312 | +3 |
- #' This function is a wrapper for `shiny::validate`.+ #' @description `r lifecycle::badge("stable")`
|
|
| 313 | +4 |
- #'+ #' @param x a data.frame |
|
| 314 | +5 |
- #' @export+ #' @param min_nrow minimum number of rows in \code{x}
|
|
| 315 | +6 |
- #' @examples+ #' @param complete \code{logical} default \code{FALSE} when set to \code{TRUE} then complete cases are checked.
|
|
| 316 | +7 |
- #' data <- data.frame(+ #' @param allow_inf \code{logical} default \code{TRUE} when set to \code{FALSE} then error thrown if any values are
|
|
| 317 | +8 |
- #' one = rep("a", length.out = 20),
+ #' infinite. |
|
| 318 | +9 |
- #' two = rep(c("a", "b"), length.out = 20),
+ #' @param msg (`character(1)`) additional message to display alongside the default message. |
|
| 319 | +10 |
- #' three = rep(c("a", "b", "c"), length.out = 20),
+ #' |
|
| 320 | +11 |
- #' four = rep(c("a", "b", "c", "d"), length.out = 20),
+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 321 | +12 |
- #' stringsAsFactors = TRUE+ #' |
|
| 322 | +13 |
- #' )+ #' @export |
|
| 323 | +14 |
- #' ui <- fluidPage(+ #' |
|
| 324 | +15 |
- #' selectInput(+ #' @examples |
|
| 325 | +16 |
- #' "var",+ #' library(teal) |
|
| 326 | +17 |
- #' "Select variable",+ #' ui <- fluidPage( |
|
| 327 | +18 |
- #' choices = c("one", "two", "three", "four"),
+ #' sliderInput("len", "Max Length of Sepal",
|
|
| 328 | +19 |
- #' selected = "one"+ #' min = 4.3, max = 7.9, value = 5 |
|
| 329 | +20 |
#' ), |
|
| 330 | +21 |
- #' verbatimTextOutput("summary")
+ #' plotOutput("plot")
|
|
| 331 | +22 |
#' ) |
|
| 332 | +23 |
#' |
|
| 333 | +24 |
#' server <- function(input, output) {
|
|
| 334 | +25 |
- #' output$summary <- renderText({
+ #' output$plot <- renderPlot({
|
|
| 335 | +26 |
- #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var)+ #' df <- iris[iris$Sepal.Length <= input$len, ] |
|
| 336 | +27 |
- #' paste0(+ #' validate_has_data( |
|
| 337 | +28 |
- #' "Levels of selected treatment variable: ",+ #' iris_f, |
|
| 338 | +29 |
- #' paste(levels(data[[input$var]]),+ #' min_nrow = 10, |
|
| 339 | +30 |
- #' collapse = ", "+ #' complete = FALSE, |
|
| 340 | +31 |
- #' )+ #' msg = "Please adjust Max Length of Sepal" |
|
| 341 | +32 |
#' ) |
|
| 342 | +33 |
- #' })+ #' |
|
| 343 | +34 |
- #' }+ #' hist(iris_f$Sepal.Length, breaks = 5) |
|
| 344 | +35 |
- #' if (interactive()) {
+ #' }) |
|
| 345 | +36 |
- #' shinyApp(ui, server)+ #' } |
|
| 346 | +37 |
- #' }+ #' if (interactive()) {
|
|
| 347 | +38 |
- validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
- |
- |
| 348 | -! | -
- x_levels <- if (is.factor(x)) {
- |
- |
| 349 | -! | -
- levels(x)+ #' shinyApp(ui, server) |
|
| 350 | +39 |
- } else {
+ #' } |
|
| 351 | -! | +||
| 40 | +
- unique(x)+ #' |
||
| 352 | +41 |
- }+ validate_has_data <- function(x, |
|
| 353 | +42 |
-
+ min_nrow = NULL, |
|
| 354 | -! | +||
| 43 | +
- if (!is.null(min_levels) && !(is.null(max_levels))) {
+ complete = FALSE, |
||
| 355 | -! | +||
| 44 | +
- validate(need(+ allow_inf = TRUE, |
||
| 356 | -! | +||
| 45 | +
- length(x_levels) >= min_levels && length(x_levels) <= max_levels,+ msg = NULL) {
|
||
| 357 | -! | +||
| 46 | +17x |
- sprintf(+ checkmate::assert_string(msg, null.ok = TRUE) |
|
| 358 | -! | +||
| 47 | +15x |
- "%s variable needs minimum %s level(s) and maximum %s level(s).",+ checkmate::assert_data_frame(x) |
|
| 359 | -! | +||
| 48 | +15x |
- var_name, min_levels, max_levels+ if (!is.null(min_nrow)) {
|
|
| 360 | -+ | ||
| 49 | +15x |
- )+ if (complete) {
|
|
| 361 | -+ | ||
| 50 | +5x |
- ))+ complete_index <- stats::complete.cases(x) |
|
| 362 | -! | +||
| 51 | +5x |
- } else if (!is.null(min_levels)) {
+ validate(need( |
|
| 363 | -! | +||
| 52 | +5x |
- validate(need(+ sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow, |
|
| 364 | -! | +||
| 53 | +5x |
- length(x_levels) >= min_levels,+ paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
|
|
| 365 | -! | +||
| 54 | +
- sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
+ )) |
||
| 366 | +55 |
- ))+ } else {
|
|
| 367 | -! | +||
| 56 | +10x |
- } else if (!is.null(max_levels)) {
+ validate(need( |
|
| 368 | -! | +||
| 57 | +10x |
- validate(need(+ nrow(x) >= min_nrow, |
|
| 369 | -! | +||
| 58 | +10x |
- length(x_levels) <= max_levels,+ paste( |
|
| 370 | -! | +||
| 59 | +10x |
- sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
+ c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
|
|
| 371 | -+ | ||
| 60 | +10x |
- ))+ collapse = "\n" |
|
| 372 | +61 |
- }+ ) |
|
| 373 | +62 |
- }+ )) |
| 1 | +63 |
- #' Store teal_slices object to a file+ } |
|
| 2 | +64 |
- #'+ |
|
| 3 | -+ | ||
| 65 | +10x |
- #' This function takes a `teal_slices` object and saves it to a file in `JSON` format.+ if (!allow_inf) {
|
|
| 4 | -+ | ||
| 66 | +6x |
- #' The `teal_slices` object contains information about filter states and can be used to+ validate(need( |
|
| 5 | -+ | ||
| 67 | +6x |
- #' create, modify, and delete filter states. The saved file can be later loaded using+ all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))), |
|
| 6 | -+ | ||
| 68 | +6x |
- #' the `slices_restore` function.+ "Dataframe contains Inf values which is not allowed." |
|
| 7 | +69 |
- #'+ )) |
|
| 8 | +70 |
- #' @param tss (`teal_slices`) object to be stored.+ } |
|
| 9 | +71 |
- #' @param file (`character(1)`) The file path where `teal_slices` object will be saved.+ } |
|
| 10 | +72 |
- #' The file extension should be `".json"`.+ } |
|
| 11 | +73 |
- #'+ |
|
| 12 | +74 |
- #' @details `Date` class is stored in `"ISO8601"` format (`YYYY-MM-DD`). `POSIX*t` classes are converted to a+ #' Validate that dataset has unique rows for key variables |
|
| 13 | +75 |
- #' character by using `format.POSIX*t(usetz = TRUE, tz = "UTC")` (`YYYY-MM-DD {N}{N}:{N}{N}:{N}{N} UTC`, where
+ #' |
|
| 14 | +76 |
- #' `{N} = [0-9]` is a number and `UTC` is `Coordinated Universal Time` timezone short-code).
+ #' @description `r lifecycle::badge("stable")`
|
|
| 15 | +77 |
- #' This format is assumed during `slices_restore`. All `POSIX*t` objects in `selected` or `choices` fields of+ #' @param x a data.frame |
|
| 16 | +78 |
- #' `teal_slice` objects are always printed in `UTC` timezone as well.+ #' @param key a vector of ID variables from \code{x} that identify unique records
|
|
| 17 | +79 |
#' |
|
| 18 | +80 |
- #' @return `NULL`, invisibly.+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 19 | +81 |
#' |
|
| 20 | +82 |
- #' @keywords internal+ #' @export |
|
| 21 | +83 |
#' |
|
| 22 | +84 |
#' @examples |
|
| 23 | +85 |
- #' # Create a teal_slices object+ #' iris$id <- rep(1:50, times = 3) |
|
| 24 | +86 |
- #' tss <- teal_slices(+ #' ui <- fluidPage( |
|
| 25 | +87 |
- #' teal_slice(dataname = "data", varname = "var"),+ #' selectInput( |
|
| 26 | +88 |
- #' teal_slice(dataname = "data", expr = "x > 0", id = "positive_x", title = "Positive x")+ #' inputId = "species", |
|
| 27 | +89 |
- #' )+ #' label = "Select species", |
|
| 28 | +90 |
- #'+ #' choices = c("setosa", "versicolor", "virginica"),
|
|
| 29 | +91 |
- #' if (interactive()) {
+ #' selected = "setosa", |
|
| 30 | +92 |
- #' # Store the teal_slices object to a file+ #' multiple = TRUE |
|
| 31 | +93 |
- #' slices_store(tss, "path/to/file.json")+ #' ), |
|
| 32 | +94 |
- #' }+ #' plotOutput("plot")
|
|
| 33 | +95 |
- #'+ #' ) |
|
| 34 | +96 |
- slices_store <- function(tss, file) {
- |
- |
| 35 | -9x | -
- checkmate::assert_class(tss, "teal_slices")+ #' server <- function(input, output) {
|
|
| 36 | -9x | +||
| 97 | +
- checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json")+ #' output$plot <- renderPlot({
|
||
| 37 | +98 |
-
+ #' iris_f <- iris[iris$Species %in% input$species, ] |
|
| 38 | -9x | +||
| 99 | +
- cat(format(tss, trim_lines = FALSE), "\n", file = file)+ #' validate_one_row_per_id(iris_f, key = c("id"))
|
||
| 39 | +100 |
- }+ #' |
|
| 40 | +101 |
-
+ #' hist(iris_f$Sepal.Length, breaks = 5) |
|
| 41 | +102 |
- #' Restore teal_slices object from a file+ #' }) |
|
| 42 | +103 |
- #'+ #' } |
|
| 43 | +104 |
- #' This function takes a file path to a `JSON` file containing a `teal_slices` object+ #' if (interactive()) {
|
|
| 44 | +105 |
- #' and restores it to its original form. The restored `teal_slices` object can be used+ #' shinyApp(ui, server) |
|
| 45 | +106 |
- #' to access filter states and their corresponding attributes.+ #' } |
|
| 46 | +107 |
#' |
|
| 47 | +108 |
- #' @param file Path to file where `teal_slices` is stored. Must have a `.json` extension and read access.+ validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
+ |
+ |
| 109 | +! | +
+ validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
|
|
| 48 | +110 |
- #'+ } |
|
| 49 | +111 |
- #' @return A `teal_slices` object restored from the file.+ |
|
| 50 | +112 |
- #'+ #' Validates that vector includes all expected values |
|
| 51 | +113 |
- #' @keywords internal+ #' |
|
| 52 | +114 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
|
| 53 | +115 |
- #' @examples+ #' @param x values to test. All must be in \code{choices}
|
|
| 54 | +116 |
- #' if (interactive()) {
+ #' @param choices a vector to test for values of \code{x}
|
|
| 55 | +117 |
- #' # Restore a teal_slices object from a file+ #' @param msg warning message to display |
|
| 56 | +118 |
- #' tss_restored <- slices_restore("path/to/file.json")
+ #' |
|
| 57 | +119 |
- #' }+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 58 | +120 |
#' |
|
| 59 | +121 |
- slices_restore <- function(file) {
+ #' @export |
|
| 60 | -9x | +||
| 122 | +
- checkmate::assert_file_exists(file, access = "r", extension = "json")+ #' |
||
| 61 | +123 |
-
+ #' @examples |
|
| 62 | -9x | +||
| 124 | +
- tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE)+ #' ui <- fluidPage( |
||
| 63 | -9x | +||
| 125 | +
- tss_json$slices <-+ #' selectInput( |
||
| 64 | -9x | +||
| 126 | +
- lapply(tss_json$slices, function(slice) {
+ #' "species", |
||
| 65 | -9x | +||
| 127 | +
- for (field in c("selected", "choices")) {
+ #' "Select species", |
||
| 66 | -18x | +||
| 128 | +
- if (!is.null(slice[[field]])) {
+ #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
|
||
| 67 | -12x | +||
| 129 | +
- if (length(slice[[field]]) > 0) {
+ #' selected = "setosa", |
||
| 68 | -9x | +||
| 130 | +
- date_partial_regex <- "^[0-9]{4}-[0-9]{2}-[0-9]{2}"
+ #' multiple = FALSE |
||
| 69 | -9x | +||
| 131 | +
- time_stamp_regex <- paste0(date_partial_regex, "\\s[0-9]{2}:[0-9]{2}:[0-9]{2}\\sUTC$")
+ #' ), |
||
| 70 | +132 |
-
+ #' verbatimTextOutput("summary")
|
|
| 71 | -9x | +||
| 133 | +
- slice[[field]] <-+ #' ) |
||
| 72 | -9x | +||
| 134 | +
- if (all(grepl(paste0(date_partial_regex, "$"), slice[[field]]))) {
+ #' |
||
| 73 | -3x | +||
| 135 | +
- as.Date(slice[[field]])+ #' server <- function(input, output) {
|
||
| 74 | -9x | +||
| 136 | +
- } else if (all(grepl(time_stamp_regex, slice[[field]]))) {
+ #' output$summary <- renderPrint({
|
||
| 75 | -3x | +||
| 137 | +
- as.POSIXct(slice[[field]], tz = "UTC")+ #' validate_in(input$species, iris$Species, "Species does not exist.") |
||
| 76 | +138 |
- } else {
+ #' nrow(iris[iris$Species == input$species, ]) |
|
| 77 | -3x | +||
| 139 | +
- slice[[field]]+ #' }) |
||
| 78 | +140 |
- }+ #' } |
|
| 79 | +141 |
- } else {
+ #' if (interactive()) {
|
|
| 80 | -3x | +||
| 142 | +
- slice[[field]] <- character(0)+ #' shinyApp(ui, server) |
||
| 81 | +143 |
- }+ #' } |
|
| 82 | +144 |
- }+ #' |
|
| 83 | +145 |
- }+ validate_in <- function(x, choices, msg) {
|
|
| 84 | -9x | +||
| 146 | +! |
- slice+ validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg)) |
|
| 85 | +147 |
- })+ } |
|
| 86 | +148 | ||
| 87 | -9x | +||
| 149 | +
- tss_elements <- lapply(tss_json$slices, as.teal_slice)+ #' Validates that vector has length greater than 0 |
||
| 88 | +150 |
-
+ #' |
|
| 89 | -9x | +||
| 151 | +
- do.call(teal_slices, c(tss_elements, tss_json$attributes))+ #' @description `r lifecycle::badge("stable")`
|
||
| 90 | +152 |
- }+ #' @param x vector |
| 1 | +153 |
- #' Get dummy `CDISC` data+ #' @param msg message to display |
|
| 2 | +154 |
#' |
|
| 3 | +155 |
- #' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`.+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 4 | +156 |
- #' Some NAs are also introduced to stress test.+ #' |
|
| 5 | +157 | ++ |
+ #' @export+ |
+
| 158 |
#' |
||
| 6 | +159 |
- #' @return `cdisc_data`+ #' @examples |
|
| 7 | +160 |
- #' @keywords internal+ #' data <- data.frame( |
|
| 8 | +161 |
- example_cdisc_data <- function() { # nolint
+ #' id = c(1:10, 11:20, 1:10), |
|
| 9 | -! | +||
| 162 | +
- ADSL <- data.frame( # nolint+ #' strata = rep(c("A", "B"), each = 15)
|
||
| 10 | -! | +||
| 163 | +
- STUDYID = "study",+ #' ) |
||
| 11 | -! | +||
| 164 | +
- USUBJID = 1:10,+ #' ui <- fluidPage( |
||
| 12 | -! | +||
| 165 | +
- SEX = sample(c("F", "M"), 10, replace = TRUE),
+ #' selectInput("ref1", "Select strata1 to compare",
|
||
| 13 | -! | +||
| 166 | +
- AGE = stats::rpois(10, 40)+ #' choices = c("A", "B", "C"), selected = "A"
|
||
| 14 | +167 |
- )+ #' ), |
|
| 15 | -! | +||
| 168 | +
- ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint+ #' selectInput("ref2", "Select strata2 to compare",
|
||
| 16 | -! | +||
| 169 | +
- ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
+ #' choices = c("A", "B", "C"), selected = "B"
|
||
| 17 | -! | +||
| 170 | +
- ADTTE$AVAL <- c( # nolint+ #' ), |
||
| 18 | -! | +||
| 171 | +
- stats::rnorm(10, mean = 700, sd = 200), # dummy OS level+ #' verbatimTextOutput("arm_summary")
|
||
| 19 | -! | +||
| 172 | +
- stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level+ #' ) |
||
| 20 | -! | +||
| 173 | +
- stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level+ #' |
||
| 21 | +174 |
- )+ #' server <- function(input, output) {
|
|
| 22 | +175 |
-
+ #' output$arm_summary <- renderText({
|
|
| 23 | -! | +||
| 176 | +
- ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint+ #' sample_1 <- data$id[data$strata == input$ref1] |
||
| 24 | -! | +||
| 177 | +
- ADSL$SEX[c(2, 5)] <- NA # nolint+ #' sample_2 <- data$id[data$strata == input$ref2] |
||
| 25 | +178 |
-
+ #' |
|
| 26 | -! | +||
| 179 | +
- res <- teal.data::cdisc_data(+ #' validate_has_elements(sample_1, "No subjects in strata1.") |
||
| 27 | -! | +||
| 180 | +
- ADSL = ADSL,+ #' validate_has_elements(sample_2, "No subjects in strata2.") |
||
| 28 | -! | +||
| 181 | +
- ADTTE = ADTTE,+ #' |
||
| 29 | -! | +||
| 182 | +
- code = '+ #' paste0( |
||
| 30 | -! | +||
| 183 | +
- ADSL <- data.frame(+ #' "Number of samples in: strata1=", length(sample_1), |
||
| 31 | -! | +||
| 184 | +
- STUDYID = "study",+ #' " comparions strata2=", length(sample_2) |
||
| 32 | -! | +||
| 185 | +
- USUBJID = 1:10,+ #' ) |
||
| 33 | -! | +||
| 186 | +
- SEX = sample(c("F", "M"), 10, replace = TRUE),
+ #' }) |
||
| 34 | -! | +||
| 187 | +
- AGE = rpois(10, 40)+ #' } |
||
| 35 | +188 |
- )+ #' if (interactive()) {
|
|
| 36 | -! | +||
| 189 | +
- ADTTE <- rbind(ADSL, ADSL, ADSL)+ #' shinyApp(ui, server) |
||
| 37 | -! | +||
| 190 | +
- ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
+ #' } |
||
| 38 | -! | +||
| 191 | +
- ADTTE$AVAL <- c(+ validate_has_elements <- function(x, msg) {
|
||
| 39 | +192 | ! |
- rnorm(10, mean = 700, sd = 200),+ validate(need(length(x) > 0, msg)) |
| 40 | -! | +||
| 193 | +
- rnorm(10, mean = 400, sd = 100),+ } |
||
| 41 | -! | +||
| 194 | +
- rnorm(10, mean = 450, sd = 200)+ |
||
| 42 | +195 |
- )+ #' Validates no intersection between two vectors |
|
| 43 | +196 |
-
+ #' |
|
| 44 | -! | +||
| 197 | +
- ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE)+ #' @description `r lifecycle::badge("stable")`
|
||
| 45 | -! | +||
| 198 | +
- ADSL$SEX[c(2, 5)] <- NA+ #' @param x vector |
||
| 46 | +199 |
- '+ #' @param y vector |
|
| 47 | +200 |
- )+ #' @param msg message to display if \code{x} and \code{y} intersect
|
|
| 48 | -! | +||
| 201 | +
- return(res)+ #' |
||
| 49 | +202 |
- }+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 50 | +203 |
-
+ #' |
|
| 51 | +204 |
- #' Get datasets to go with example modules.+ #' @export |
|
| 52 | +205 |
#' |
|
| 53 | +206 |
- #' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`.+ #' @examples |
|
| 54 | +207 |
- #' Each list leaf is the same `FilteredData` object.+ #' data <- data.frame( |
|
| 55 | +208 |
- #'+ #' id = c(1:10, 11:20, 1:10), |
|
| 56 | +209 |
- #' @return named list of `FilteredData` objects, each with `ADSL` set.+ #' strata = rep(c("A", "B", "C"), each = 10)
|
|
| 57 | +210 |
- #' @keywords internal+ #' ) |
|
| 58 | +211 |
- example_datasets <- function() { # nolint
+ #' |
|
| 59 | -! | +||
| 212 | +
- dummy_cdisc_data <- example_cdisc_data()+ #' ui <- fluidPage( |
||
| 60 | -! | +||
| 213 | +
- datasets <- teal_data_to_filtered_data(dummy_cdisc_data)+ #' selectInput("ref1", "Select strata1 to compare",
|
||
| 61 | -! | +||
| 214 | +
- list(+ #' choices = c("A", "B", "C"),
|
||
| 62 | -! | +||
| 215 | +
- "d2" = list(+ #' selected = "A" |
||
| 63 | -! | +||
| 216 | +
- "d3" = list(+ #' ), |
||
| 64 | -! | +||
| 217 | +
- "aaa1" = datasets,+ #' selectInput("ref2", "Select strata2 to compare",
|
||
| 65 | -! | +||
| 218 | +
- "aaa2" = datasets,+ #' choices = c("A", "B", "C"),
|
||
| 66 | -! | +||
| 219 | +
- "aaa3" = datasets+ #' selected = "B" |
||
| 67 | +220 |
- ),+ #' ), |
|
| 68 | -! | +||
| 221 | +
- "bbb" = datasets+ #' verbatimTextOutput("summary")
|
||
| 69 | +222 |
- ),+ #' ) |
|
| 70 | -! | +||
| 223 | +
- "ccc" = datasets+ #' |
||
| 71 | +224 |
- )+ #' server <- function(input, output) {
|
|
| 72 | +225 |
- }+ #' output$summary <- renderText({
|
|
| 73 | +226 |
-
+ #' sample_1 <- data$id[data$strata == input$ref1] |
|
| 74 | +227 |
- #' An example `teal` module+ #' sample_2 <- data$id[data$strata == input$ref2] |
|
| 75 | +228 |
#' |
|
| 76 | +229 |
- #' @description `r lifecycle::badge("experimental")`
+ #' validate_no_intersection( |
|
| 77 | +230 |
- #' @inheritParams module+ #' sample_1, sample_2, |
|
| 78 | +231 |
- #' @return A `teal` module which can be included in the `modules` argument to [teal::init()].+ #' "subjects within strata1 and strata2 cannot overlap" |
|
| 79 | +232 |
- #' @examples+ #' ) |
|
| 80 | +233 |
- #' app <- init(+ #' paste0( |
|
| 81 | +234 |
- #' data = teal_data(IRIS = iris, MTCARS = mtcars),+ #' "Number of subject in: reference treatment=", length(sample_1), |
|
| 82 | +235 |
- #' modules = example_module()+ #' " comparions treatment=", length(sample_2) |
|
| 83 | +236 |
- #' )+ #' ) |
|
| 84 | +237 |
- #' if (interactive()) {
+ #' }) |
|
| 85 | +238 |
- #' shinyApp(app$ui, app$server)+ #' } |
|
| 86 | +239 |
- #' }+ #' if (interactive()) {
|
|
| 87 | +240 |
- #' @export+ #' shinyApp(ui, server) |
|
| 88 | +241 |
- example_module <- function(label = "example teal module", datanames = "all") {
+ #' } |
|
| 89 | -44x | +||
| 242 | +
- checkmate::assert_string(label)+ #' |
||
| 90 | -44x | +||
| 243 | +
- module(+ validate_no_intersection <- function(x, y, msg) {
|
||
| 91 | -44x | +||
| 244 | +! |
- label,+ validate(need(length(intersect(x, y)) == 0, msg)) |
|
| 92 | -44x | +||
| 245 | +
- server = function(id, data) {
+ } |
||
| 93 | -! | +||
| 246 | +
- checkmate::assert_class(data(), "teal_data")+ |
||
| 94 | -! | +||
| 247 | +
- moduleServer(id, function(input, output, session) {
+
|
||
| 95 | -! | +||
| 248 | +
- ns <- session$ns+ #' Validates that dataset contains specific variable |
||
| 96 | -! | +||
| 249 | +
- updateSelectInput(session, "dataname", choices = isolate(teal.data::datanames(data())))+ #' |
||
| 97 | -! | +||
| 250 | +
- output$text <- renderPrint({
+ #' @description `r lifecycle::badge("stable")`
|
||
| 98 | -! | +||
| 251 | +
- req(input$dataname)+ #' @param data a data.frame |
||
| 99 | -! | +||
| 252 | +
- data()[[input$dataname]]+ #' @param varname name of variable in \code{data}
|
||
| 100 | +253 |
- })+ #' @param msg message to display if \code{data} does not include \code{varname}
|
|
| 101 | -! | +||
| 254 | +
- teal.widgets::verbatim_popup_srv(+ #' |
||
| 102 | -! | +||
| 255 | +
- id = "rcode",+ #' @details This function is a wrapper for `shiny::validate`. |
||
| 103 | -! | +||
| 256 | +
- verbatim_content = reactive(teal.code::get_code(data())),+ #' |
||
| 104 | -! | +||
| 257 | +
- title = "Association Plot"+ #' @export |
||
| 105 | +258 |
- )+ #' |
|
| 106 | +259 |
- })+ #' @examples |
|
| 107 | +260 |
- },+ #' data <- data.frame( |
|
| 108 | -44x | +||
| 261 | +
- ui = function(id) {
+ #' one = rep("a", length.out = 20),
|
||
| 109 | -! | +||
| 262 | +
- ns <- NS(id)+ #' two = rep(c("a", "b"), length.out = 20)
|
||
| 110 | -! | +||
| 263 | +
- teal.widgets::standard_layout(+ #' ) |
||
| 111 | -! | +||
| 264 | +
- output = verbatimTextOutput(ns("text")),
+ #' ui <- fluidPage( |
||
| 112 | -! | +||
| 265 | +
- encoding = div(+ #' selectInput( |
||
| 113 | -! | +||
| 266 | +
- selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
+ #' "var", |
||
| 114 | -! | +||
| 267 | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' "Select variable", |
||
| 115 | +268 |
- )+ #' choices = c("one", "two", "three", "four"),
|
|
| 116 | +269 |
- )+ #' selected = "one" |
|
| 117 | +270 |
- },+ #' ), |
|
| 118 | -44x | +||
| 271 | +
- datanames = datanames+ #' verbatimTextOutput("summary")
|
||
| 119 | +272 |
- )+ #' ) |
|
| 120 | +273 |
- }+ #' |
|
| 121 | +274 |
-
+ #' server <- function(input, output) {
|
|
| 122 | +275 |
-
+ #' output$summary <- renderText({
|
|
| 123 | +276 |
- #' Get example modules.+ #' validate_has_variable(data, input$var) |
|
| 124 | +277 |
- #'+ #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
|
|
| 125 | +278 |
- #' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created.+ #' }) |
|
| 126 | +279 |
- #' @param datanames (`character`)\cr+ #' } |
|
| 127 | +280 |
- #' names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`.+ #' if (interactive()) {
|
|
| 128 | +281 |
- #' @return `teal_modules`+ #' shinyApp(ui, server) |
|
| 129 | +282 |
- #' @keywords internal+ #' } |
|
| 130 | +283 |
- example_modules <- function(datanames = c("ADSL", "ADTTE")) {
+ validate_has_variable <- function(data, varname, msg) {
|
|
| 131 | +284 | ! |
- checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
+ if (length(varname) != 0) {
|
| 132 | +285 | ! |
- mods <- modules(+ has_vars <- varname %in% names(data) |
| 133 | -! | +||
| 286 | +
- label = "d1",+ |
||
| 134 | +287 | ! |
- modules(+ if (!all(has_vars)) {
|
| 135 | +288 | ! |
- label = "d2",+ if (missing(msg)) {
|
| 136 | +289 | ! |
- modules(+ msg <- sprintf( |
| 137 | +290 | ! |
- label = "d3",+ "%s does not have the required variables: %s.", |
| 138 | +291 | ! |
- example_module(label = "aaa1", datanames = datanames),+ deparse(substitute(data)), |
| 139 | +292 | ! |
- example_module(label = "aaa2", datanames = datanames),+ toString(varname[!has_vars]) |
| 140 | -! | +||
| 293 | +
- example_module(label = "aaa3", datanames = datanames)+ ) |
||
| 141 | +294 |
- ),+ } |
|
| 142 | +295 | ! |
- example_module(label = "bbb", datanames = datanames)+ validate(need(FALSE, msg)) |
| 143 | +296 |
- ),+ } |
|
| 144 | -! | +||
| 297 | +
- example_module(label = "ccc", datanames = datanames)+ } |
||
| 145 | +298 |
- )+ } |
|
| 146 | -! | +||
| 299 | +
- return(mods)+ |
||
| 147 | +300 |
- }+ #' Validate that variables has expected number of levels |
| 1 | +301 |
- setOldClass("teal_data_module")
+ #' |
|
| 2 | +302 |
-
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 303 | ++ |
+ #' @param x variable name. If \code{x} is not a factor, the unique values
+ |
+ |
| 304 | ++ |
+ #' are treated as levels.+ |
+ |
| 305 | ++ |
+ #' @param min_levels cutoff for minimum number of levels of \code{x}
+ |
+ |
| 306 | ++ |
+ #' @param max_levels cutoff for maximum number of levels of \code{x}
+ |
+ |
| 307 | ++ |
+ #' @param var_name name of variable being validated for use in |
|
| 3 | +308 |
- #' Evaluate Code on `teal_data_module`+ #' validation message |
|
| 4 | +309 |
#' |
|
| 5 | +310 |
- #' @details+ #' @details If the number of levels of \code{x} is less than \code{min_levels}
|
|
| 6 | +311 |
- #' `eval_code` evaluates given code in the environment of the `teal_data` object created by the `teal_data_module`.+ #' or greater than \code{max_levels} the validation will fail.
|
|
| 7 | +312 |
- #' The code is added to the `@code` slot of the `teal_data`.+ #' This function is a wrapper for `shiny::validate`. |
|
| 8 | +313 |
#' |
|
| 9 | +314 |
- #' @param object (`teal_data_module`)+ #' @export |
|
| 10 | +315 |
- #' @inheritParams teal.code::eval_code+ #' @examples |
|
| 11 | +316 |
- #'+ #' data <- data.frame( |
|
| 12 | +317 |
- #' @return+ #' one = rep("a", length.out = 20),
|
|
| 13 | +318 |
- #' `eval_code` returns a `teal_data_module` object with a delayed evaluation of `code` when the module is run.+ #' two = rep(c("a", "b"), length.out = 20),
|
|
| 14 | +319 |
- #'+ #' three = rep(c("a", "b", "c"), length.out = 20),
|
|
| 15 | +320 |
- #' @examples+ #' four = rep(c("a", "b", "c", "d"), length.out = 20),
|
|
| 16 | +321 |
- #' tdm <- teal_data_module(+ #' stringsAsFactors = TRUE |
|
| 17 | +322 |
- #' ui = function(id) div(id = shiny::NS(id)("div_id")),
+ #' ) |
|
| 18 | +323 |
- #' server = function(id) {
+ #' ui <- fluidPage( |
|
| 19 | +324 |
- #' shiny::moduleServer(id, function(input, output, session) {
+ #' selectInput( |
|
| 20 | +325 |
- #' shiny::reactive(teal_data(IRIS = iris))+ #' "var", |
|
| 21 | +326 |
- #' })+ #' "Select variable", |
|
| 22 | +327 |
- #' }+ #' choices = c("one", "two", "three", "four"),
|
|
| 23 | +328 |
- #' )+ #' selected = "one" |
|
| 24 | +329 |
- #' eval_code(tdm, "IRIS <- subset(IRIS, Species == 'virginica')")+ #' ), |
|
| 25 | +330 |
- #'+ #' verbatimTextOutput("summary")
|
|
| 26 | +331 |
- #' @include teal_data_module.R+ #' ) |
|
| 27 | +332 |
- #' @name eval_code+ #' |
|
| 28 | +333 |
- #' @rdname teal_data_module+ #' server <- function(input, output) {
|
|
| 29 | +334 |
- #' @aliases eval_code,teal_data_module,character-method+ #' output$summary <- renderText({
|
|
| 30 | +335 |
- #' @aliases eval_code,teal_data_module,language-method+ #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var) |
|
| 31 | +336 |
- #' @aliases eval_code,teal_data_module,expression-method+ #' paste0( |
|
| 32 | +337 |
- #'+ #' "Levels of selected treatment variable: ", |
|
| 33 | +338 |
- #' @importFrom methods setMethod+ #' paste(levels(data[[input$var]]), |
|
| 34 | +339 |
- #' @importMethodsFrom teal.code eval_code+ #' collapse = ", " |
|
| 35 | +340 |
- #'+ #' ) |
|
| 36 | +341 |
- setMethod("eval_code", signature = c("teal_data_module", "character"), function(object, code) {
+ #' ) |
|
| 37 | -13x | +||
| 342 | +
- teal_data_module(+ #' }) |
||
| 38 | -13x | +||
| 343 | +
- ui = function(id) {
+ #' } |
||
| 39 | -1x | +||
| 344 | +
- ns <- NS(id)+ #' if (interactive()) {
|
||
| 40 | -1x | +||
| 345 | +
- object$ui(ns("mutate_inner"))
+ #' shinyApp(ui, server) |
||
| 41 | +346 |
- },+ #' } |
|
| 42 | -13x | +||
| 347 | +
- server = function(id) {
+ validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
|
||
| 43 | -11x | +||
| 348 | +! |
- moduleServer(id, function(input, output, session) {
+ x_levels <- if (is.factor(x)) {
|
|
| 44 | -11x | +||
| 349 | +! |
- teal_data_rv <- object$server("mutate_inner")
+ levels(x) |
|
| 45 | +350 | - - | -|
| 46 | -11x | -
- if (!is.reactive(teal_data_rv)) {
+ } else {
|
|
| 47 | -1x | +||
| 351 | +! |
- stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
+ unique(x) |
|
| 48 | +352 |
- }+ } |
|
| 49 | +353 | ||
| 50 | -10x | -
- td <- eventReactive(teal_data_rv(),- |
- |
| 51 | -- |
- {
- |
- |
| 52 | -10x | +||
| 354 | +! |
- if (inherits(teal_data_rv(), c("teal_data", "qenv.error"))) {
+ if (!is.null(min_levels) && !(is.null(max_levels))) {
|
|
| 53 | -6x | +||
| 355 | +! |
- eval_code(teal_data_rv(), code)+ validate(need( |
|
| 54 | -+ | ||
| 356 | +! |
- } else {
+ length(x_levels) >= min_levels && length(x_levels) <= max_levels, |
|
| 55 | -4x | +||
| 357 | +! |
- teal_data_rv()+ sprintf( |
|
| 56 | -+ | ||
| 358 | +! |
- }+ "%s variable needs minimum %s level(s) and maximum %s level(s).", |
|
| 57 | -+ | ||
| 359 | +! |
- },+ var_name, min_levels, max_levels |
|
| 58 | -10x | +||
| 360 | +
- ignoreNULL = FALSE+ ) |
||
| 59 | +361 |
- )+ )) |
|
| 60 | -10x | +||
| 362 | +! |
- td+ } else if (!is.null(min_levels)) {
|
|
| 61 | -+ | ||
| 363 | +! |
- })+ validate(need( |
|
| 62 | -+ | ||
| 364 | +! |
- }+ length(x_levels) >= min_levels, |
|
| 63 | -+ | ||
| 365 | +! |
- )+ sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
|
|
| 64 | +366 |
- })+ )) |
|
| 65 | -+ | ||
| 367 | +! |
-
+ } else if (!is.null(max_levels)) {
|
|
| 66 | -+ | ||
| 368 | +! |
- setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
+ validate(need( |
|
| 67 | -1x | +||
| 369 | +! |
- eval_code(object, code = paste(lang2calls(code), collapse = "\n"))+ length(x_levels) <= max_levels, |
|
| 68 | -+ | ||
| 370 | +! |
- })+ sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
|
|
| 69 | +371 |
-
+ )) |
|
| 70 | +372 |
- setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
- |
- |
| 71 | -6x | -
- eval_code(object, code = paste(lang2calls(code), collapse = "\n"))+ } |
|
| 72 | +373 |
- })+ } |
| 1 |
- #' Generates library calls from current session info+ .onLoad <- function(libname, pkgname) { # nolint
|
||
| 2 |
- #'+ # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R |
||
| 3 | -+ | ! |
- #' Function to create multiple library calls out of current session info to make reproducible code works.+ teal_default_options <- list(teal.show_js_log = FALSE) |
| 4 |
- #'+ |
||
| 5 | -+ | ! |
- #' @return Character object contain code+ op <- options() |
| 6 | -+ | ! |
- #' @keywords internal+ toset <- !(names(teal_default_options) %in% names(op)) |
| 7 | -+ | ! |
- get_rcode_libraries <- function() {
+ if (any(toset)) options(teal_default_options[toset]) |
| 8 | -5x | +
- vapply(+ |
|
| 9 | -5x | +! |
- utils::sessionInfo()$otherPkgs,+ options("shiny.sanitize.errors" = FALSE)
|
| 10 | -5x | +
- function(x) {
+
|
|
| 11 | -80x | +
- paste0("library(", x$Package, ")")
+ # Set up the teal logger instance |
|
| 12 | -+ | ! |
- },+ teal.logger::register_logger("teal")
|
| 13 | -5x | +
- character(1)+ |
|
| 14 | -+ | ! |
- ) %>%+ invisible() |
| 15 |
- # put it into reverse order to correctly simulate executed code+ } |
||
| 16 | -5x | +
- rev() %>%+ |
|
| 17 | -5x | +
- paste0(sep = "\n") %>%+ .onAttach <- function(libname, pkgname) { # nolint
|
|
| 18 | -5x | +2x |
- paste0(collapse = "")+ packageStartupMessage( |
| 19 | -+ | 2x |
- }+ "\nYou are using teal version ", |
| 20 |
-
+ # `system.file` uses the `shim` of `system.file` by `teal` |
||
| 21 |
-
+ # we avoid `desc` dependency here to get the version |
||
| 22 | -+ | 2x |
-
+ read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
|
| 23 |
- get_rcode_str_install <- function() {
+ ) |
||
| 24 | -9x | +
- code_string <- getOption("teal.load_nest_code")
+ } |
|
| 26 | -9x | +
- if (!is.null(code_string) && is.character(code_string)) {
+ # This one is here because setdiff_teal_slice should not be exported from teal.slice. |
|
| 27 | -2x | +
- return(code_string)+ setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
|
|
| 28 |
- }+ # This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice. |
||
| 29 |
-
+ coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
|
||
| 30 | -7x | +
- return("# Add any code to install/load your NEST environment here\n")
+ # all *Block objects are private in teal.reporter |
|
| 31 |
- }+ RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint
|
||
| 33 |
- #' Get datasets code+ # Use non-exported function(s) from teal.code |
||
| 34 |
- #'+ # This one is here because lang2calls should not be exported from teal.code |
||
| 35 |
- #' Get combined code from `FilteredData` and from `CodeClass` object.+ lang2calls <- getFromNamespace("lang2calls", "teal.code")
|
| 36 | +1 |
- #'+ #' Get dummy `CDISC` data |
|
| 37 | +2 |
- #' @param datanames (`character`) names of datasets to extract code from+ #' |
|
| 38 | +3 |
- #' @param datasets (`FilteredData`) object+ #' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`. |
|
| 39 | +4 |
- #' @param hashes named (`list`) of hashes per dataset+ #' Some NAs are also introduced to stress test. |
|
| 40 | +5 |
#' |
|
| 41 | +6 |
- #' @return Character string concatenated from the following elements:+ #' @return `cdisc_data` |
|
| 42 | +7 |
- #' - data pre-processing code (from `data` argument in `init`)+ #' @keywords internal |
|
| 43 | +8 |
- #' - hash check of loaded objects+ example_cdisc_data <- function() { # nolint
|
|
| 44 | -+ | ||
| 9 | +! |
- #' - filter code (if any)+ ADSL <- data.frame( # nolint+ |
+ |
| 10 | +! | +
+ STUDYID = "study",+ |
+ |
| 11 | +! | +
+ USUBJID = 1:10,+ |
+ |
| 12 | +! | +
+ SEX = sample(c("F", "M"), 10, replace = TRUE),
+ |
+ |
| 13 | +! | +
+ AGE = stats::rpois(10, 40) |
|
| 45 | +14 |
- #'+ )+ |
+ |
| 15 | +! | +
+ ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint+ |
+ |
| 16 | +! | +
+ ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
+ |
+ |
| 17 | +! | +
+ ADTTE$AVAL <- c( # nolint+ |
+ |
| 18 | +! | +
+ stats::rnorm(10, mean = 700, sd = 200), # dummy OS level+ |
+ |
| 19 | +! | +
+ stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level+ |
+ |
| 20 | +! | +
+ stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level |
|
| 46 | +21 |
- #' @keywords internal+ ) |
|
| 47 | +22 |
- get_datasets_code <- function(datanames, datasets, hashes) {
+
+ |
+ |
| 23 | +! | +
+ ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint+ |
+ |
| 24 | +! | +
+ ADSL$SEX[c(2, 5)] <- NA # nolint |
|
| 48 | +25 |
- # preprocessing code+ |
|
| 49 | -4x | +||
| 26 | +! |
- str_prepro <- teal.data:::get_code_dependency(attr(datasets, "preprocessing_code"), names = datanames)+ res <- teal.data::cdisc_data( |
|
| 50 | -4x | +||
| 27 | +! |
- if (length(str_prepro) == 0) {
+ ADSL = ADSL, |
|
| 51 | +28 | ! |
- str_prepro <- "message('Preprocessing is empty')"
+ ADTTE = ADTTE, |
| 52 | -+ | ||
| 29 | +! |
- } else {
+ code = ' |
|
| 53 | -4x | +||
| 30 | +! |
- str_prepro <- paste(str_prepro, collapse = "\n")+ ADSL <- data.frame( |
|
| 54 | -+ | ||
| 31 | +! |
- }+ STUDYID = "study", |
|
| 55 | -+ | ||
| 32 | +! |
-
+ USUBJID = 1:10,+ |
+ |
| 33 | +! | +
+ SEX = sample(c("F", "M"), 10, replace = TRUE),
+ |
+ |
| 34 | +! | +
+ AGE = rpois(10, 40) |
|
| 56 | +35 |
- # hash checks+ ) |
|
| 57 | -4x | +||
| 36 | +! |
- str_hash <- vapply(datanames, function(dataname) {
+ ADTTE <- rbind(ADSL, ADSL, ADSL) |
|
| 58 | -6x | +||
| 37 | +! |
- sprintf(+ ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
+ |
+ |
| 38 | +! | +
+ ADTTE$AVAL <- c(+ |
+ |
| 39 | +! | +
+ rnorm(10, mean = 700, sd = 200), |
|
| 59 | -6x | +||
| 40 | +! |
- "stopifnot(%s == %s)",+ rnorm(10, mean = 400, sd = 100), |
|
| 60 | -6x | +||
| 41 | +! |
- deparse1(bquote(rlang::hash(.(as.name(dataname))))),+ rnorm(10, mean = 450, sd = 200) |
|
| 61 | -6x | +||
| 42 | +
- deparse1(hashes[[dataname]])+ ) |
||
| 62 | +43 |
- )+ |
|
| 63 | -4x | +||
| 44 | +! |
- }, character(1))+ ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) |
|
| 64 | -4x | +||
| 45 | +! |
- str_hash <- paste(str_hash, collapse = "\n")+ ADSL$SEX[c(2, 5)] <- NA |
|
| 65 | +46 |
-
+ ' |
|
| 66 | +47 |
- # filter expressions+ ) |
|
| 67 | -4x | +||
| 48 | +! |
- str_filter <- teal.slice::get_filter_expr(datasets, datanames)+ return(res) |
|
| 68 | -4x | +||
| 49 | +
- if (str_filter == "") {
+ } |
||
| 69 | -3x | +||
| 50 | +
- str_filter <- character(0)+ |
||
| 70 | +51 |
- }+ #' Get datasets to go with example modules. |
|
| 71 | +52 |
-
+ #' |
|
| 72 | +53 |
- # concatenate all code+ #' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`. |
|
| 73 | -4x | +||
| 54 | +
- str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n")+ #' Each list leaf is the same `FilteredData` object. |
||
| 74 | -4x | +||
| 55 | +
- sprintf("%s\n", str_code)
+ #' |
||
| 75 | +56 |
- }+ #' @return named list of `FilteredData` objects, each with `ADSL` set. |
| 1 | +57 |
- #' Landing Popup Module+ #' @keywords internal |
|
| 2 | +58 |
- #'+ example_datasets <- function() { # nolint
|
|
| 3 | -+ | ||
| 59 | +! |
- #' @description Creates a landing welcome popup for `teal` applications.+ dummy_cdisc_data <- example_cdisc_data() |
|
| 4 | -+ | ||
| 60 | +! |
- #'+ datasets <- teal_data_to_filtered_data(dummy_cdisc_data) |
|
| 5 | -+ | ||
| 61 | +! |
- #' This module is used to display a popup dialog when the application starts.+ list( |
|
| 6 | -+ | ||
| 62 | +! |
- #' The dialog blocks the access to the application and must be closed with a button before the application is viewed.+ "d2" = list( |
|
| 7 | -+ | ||
| 63 | +! |
- #'+ "d3" = list( |
|
| 8 | -+ | ||
| 64 | +! |
- #' @param label `character(1)` the label of the module.+ "aaa1" = datasets, |
|
| 9 | -+ | ||
| 65 | +! |
- #' @param title `character(1)` the text to be displayed as a title of the popup.+ "aaa2" = datasets, |
|
| 10 | -+ | ||
| 66 | +! |
- #' @param content The content of the popup. Passed to `...` of `shiny::modalDialog`. Can be a `character`+ "aaa3" = datasets |
|
| 11 | +67 |
- #' or a list of `shiny.tag`s. See examples.+ ), |
|
| 12 | -+ | ||
| 68 | +! |
- #' @param buttons `shiny.tag` or a list of tags (`tagList`). Typically a `modalButton` or `actionButton`. See examples.+ "bbb" = datasets |
|
| 13 | +69 |
- #'+ ),+ |
+ |
| 70 | +! | +
+ "ccc" = datasets |
|
| 14 | +71 |
- #' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications.+ ) |
|
| 15 | +72 |
- #'+ } |
|
| 16 | +73 |
- #' @examples+ |
|
| 17 | +74 |
- #' app1 <- teal::init(+ #' An example `teal` module |
|
| 18 | +75 |
- #' data = teal_data(iris = iris),+ #' |
|
| 19 | +76 |
- #' modules = teal::modules(+ #' @description `r lifecycle::badge("experimental")`
|
|
| 20 | +77 |
- #' teal::landing_popup_module(+ #' @inheritParams module |
|
| 21 | +78 |
- #' content = "A place for the welcome message or a disclaimer statement.",+ #' @return A `teal` module which can be included in the `modules` argument to [teal::init()]. |
|
| 22 | +79 |
- #' buttons = modalButton("Proceed")
+ #' @examples |
|
| 23 | +80 |
- #' ),+ #' app <- init( |
|
| 24 | +81 |
- #' example_module()+ #' data = teal_data(IRIS = iris, MTCARS = mtcars), |
|
| 25 | +82 |
- #' )+ #' modules = example_module() |
|
| 26 | +83 |
#' ) |
|
| 27 | +84 |
#' if (interactive()) {
|
|
| 28 | +85 |
- #' shinyApp(app1$ui, app1$server)+ #' shinyApp(app$ui, app$server) |
|
| 29 | +86 |
#' } |
|
| 30 | +87 |
- #'+ #' @export |
|
| 31 | +88 |
- #' app2 <- teal::init(+ example_module <- function(label = "example teal module", datanames = "all") {
|
|
| 32 | -+ | ||
| 89 | +44x |
- #' data = teal_data(iris = iris),+ checkmate::assert_string(label) |
|
| 33 | -+ | ||
| 90 | +44x |
- #' modules = teal::modules(+ module( |
|
| 34 | -+ | ||
| 91 | +44x |
- #' teal::landing_popup_module(+ label, |
|
| 35 | -+ | ||
| 92 | +44x |
- #' title = "Welcome",+ server = function(id, data) {
|
|
| 36 | -+ | ||
| 93 | +! |
- #' content = tags$b(+ checkmate::assert_class(data(), "teal_data") |
|
| 37 | -+ | ||
| 94 | +! |
- #' "A place for the welcome message or a disclaimer statement.",+ moduleServer(id, function(input, output, session) {
|
|
| 38 | -+ | ||
| 95 | +! |
- #' style = "color: red;"+ ns <- session$ns |
|
| 39 | -+ | ||
| 96 | +! |
- #' ),+ updateSelectInput(session, "dataname", choices = isolate(teal.data::datanames(data()))) |
|
| 40 | -+ | ||
| 97 | +! |
- #' buttons = tagList(+ output$text <- renderPrint({
|
|
| 41 | -+ | ||
| 98 | +! |
- #' modalButton("Proceed"),
+ req(input$dataname) |
|
| 42 | -+ | ||
| 99 | +! |
- #' actionButton("read", "Read more",
+ data()[[input$dataname]] |
|
| 43 | +100 |
- #' onclick = "window.open('http://google.com', '_blank')"
+ }) |
|
| 44 | -+ | ||
| 101 | +! |
- #' ),+ teal.widgets::verbatim_popup_srv( |
|
| 45 | -+ | ||
| 102 | +! |
- #' actionButton("close", "Reject", onclick = "window.close()")
+ id = "rcode", |
|
| 46 | -+ | ||
| 103 | +! |
- #' )+ verbatim_content = reactive(teal.code::get_code(data())), |
|
| 47 | -+ | ||
| 104 | +! |
- #' ),+ title = "Association Plot" |
|
| 48 | +105 |
- #' example_module()+ ) |
|
| 49 | +106 |
- #' )+ }) |
|
| 50 | +107 |
- #' )+ }, |
|
| 51 | -+ | ||
| 108 | +44x |
- #'+ ui = function(id) {
|
|
| 52 | -+ | ||
| 109 | +! |
- #' if (interactive()) {
+ ns <- NS(id) |
|
| 53 | -+ | ||
| 110 | +! |
- #' shinyApp(app2$ui, app2$server)+ teal.widgets::standard_layout( |
|
| 54 | -+ | ||
| 111 | +! |
- #' }+ output = verbatimTextOutput(ns("text")),
|
|
| 55 | -+ | ||
| 112 | +! |
- #'+ encoding = div(+ |
+ |
| 113 | +! | +
+ selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
+ |
+ |
| 114 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 56 | +115 |
- #' @export+ ) |
|
| 57 | +116 |
- landing_popup_module <- function(label = "Landing Popup",+ ) |
|
| 58 | +117 |
- title = NULL,+ },+ |
+ |
| 118 | +44x | +
+ datanames = datanames |
|
| 59 | +119 |
- content = NULL,+ ) |
|
| 60 | +120 |
- buttons = modalButton("Accept")) {
+ } |
|
| 61 | -! | +||
| 121 | +
- checkmate::assert_string(label)+ |
||
| 62 | -! | +||
| 122 | +
- checkmate::assert_string(title, null.ok = TRUE)+ |
- ||
| 63 | -! | +||
| 123 | +
- checkmate::assert_multi_class(+ #' Get example modules. |
||
| 64 | -! | +||
| 124 | +
- content,+ #' |
||
| 65 | -! | +||
| 125 | +
- classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
+ #' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created. |
||
| 66 | +126 |
- )+ #' @param datanames (`character`)\cr |
|
| 67 | -! | +||
| 127 | +
- checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
+ #' names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`. |
||
| 68 | +128 |
-
+ #' @return `teal_modules` |
|
| 69 | -! | +||
| 129 | +
- logger::log_info("Initializing landing_popup_module")
+ #' @keywords internal |
||
| 70 | +130 |
-
+ example_modules <- function(datanames = c("ADSL", "ADTTE")) {
|
|
| 71 | +131 | ! |
- module <- module(+ checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
|
| 72 | +132 | ! |
- label = label,+ mods <- modules( |
| 73 | +133 | ! |
- server = function(id) {
+ label = "d1", |
| 74 | +134 | ! |
- moduleServer(id, function(input, output, session) {
+ modules( |
| 75 | +135 | ! |
- showModal(+ label = "d2", |
| 76 | +136 | ! |
- modalDialog(+ modules( |
| 77 | +137 | ! |
- id = "landingpopup",+ label = "d3", |
| 78 | +138 | ! |
- title = title,+ example_module(label = "aaa1", datanames = datanames), |
| 79 | +139 | ! |
- content,+ example_module(label = "aaa2", datanames = datanames), |
| 80 | +140 | ! |
- footer = buttons+ example_module(label = "aaa3", datanames = datanames) |
| 81 | +141 |
- )+ ), |
|
| 82 | -+ | ||
| 142 | +! |
- )+ example_module(label = "bbb", datanames = datanames) |
|
| 83 | +143 |
- })+ ), |
|
| 84 | -+ | ||
| 144 | +! |
- }+ example_module(label = "ccc", datanames = datanames) |
|
| 85 | +145 |
) |
|
| 86 | -! | -
- class(module) <- c("teal_module_landing", class(module))
- |
- |
| 87 | +146 | ! |
- module+ return(mods) |
| 88 | +147 |
}@@ -28243,14 +28223,14 @@ teal coverage - 63.32% |
| 1 |
- #' Send input validation messages to output.+ #' Generates library calls from current session info |
||
| 3 |
- #' Captures messages from `InputValidator` objects and collates them+ #' Function to create multiple library calls out of current session info to make reproducible code works. |
||
| 4 |
- #' into one message passed to `validate`.+ #' |
||
| 5 |
- #'+ #' @return Character object contain code |
||
| 6 |
- #' `shiny::validate` is used to withhold rendering of an output element until+ #' @keywords internal |
||
| 7 |
- #' certain conditions are met and to print a validation message in place+ get_rcode_libraries <- function() {
|
||
| 8 | -+ | 5x |
- #' of the output element.+ vapply( |
| 9 | -+ | 5x |
- #' `shinyvalidate::InputValidator` allows to validate input elements+ utils::sessionInfo()$otherPkgs, |
| 10 | -+ | 5x |
- #' and to display specific messages in their respective input widgets.+ function(x) {
|
| 11 | -+ | 80x |
- #' `validate_inputs` provides a hybrid solution.+ paste0("library(", x$Package, ")")
|
| 12 |
- #' Given an `InputValidator` object, messages corresponding to inputs that fail validation+ }, |
||
| 13 | -+ | 5x |
- #' are extracted and placed in one validation message that is passed to a `validate`/`need` call.+ character(1) |
| 14 |
- #' This way the input `validator` messages are repeated in the output.+ ) %>% |
||
| 15 |
- #'+ # put it into reverse order to correctly simulate executed code |
||
| 16 | -+ | 5x |
- #' The `...` argument accepts any number of `InputValidator` objects+ rev() %>% |
| 17 | -+ | 5x |
- #' or a nested list of such objects.+ paste0(sep = "\n") %>% |
| 18 | -+ | 5x |
- #' If `validators` are passed directly, all their messages are printed together+ paste0(collapse = "") |
| 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 |
- #'+ get_rcode_str_install <- function() {
|
||
| 24 | -+ | 9x |
- #' @param ... either any number of `InputValidator` objects+ code_string <- getOption("teal.load_nest_code")
|
| 25 |
- #' or an optionally named, possibly nested `list` of `InputValidator`+ |
||
| 26 | -+ | 9x |
- #' objects, see `Details`+ if (!is.null(code_string) && is.character(code_string)) {
|
| 27 | -+ | 2x |
- #' @param header `character(1)` generic validation message; set to NULL to omit+ return(code_string) |
| 28 |
- #'+ } |
||
| 29 |
- #' @return+ |
||
| 30 | -+ | 7x |
- #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails.+ return("# Add any code to install/load your NEST environment here\n")
|
| 31 |
- #'+ } |
||
| 32 |
- #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`]+ |
||
| 33 |
- #'+ #' Get datasets code |
||
| 34 |
- #' @examples+ #' |
||
| 35 |
- #' library(shiny)+ #' Get combined code from `FilteredData` and from `CodeClass` object. |
||
| 36 |
- #' library(shinyvalidate)+ #' |
||
| 37 |
- #'+ #' @param datanames (`character`) names of datasets to extract code from |
||
| 38 |
- #' ui <- fluidPage(+ #' @param datasets (`FilteredData`) object |
||
| 39 |
- #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
+ #' @param hashes named (`list`) of hashes per dataset |
||
| 40 |
- #' sidebarLayout(+ #' |
||
| 41 |
- #' sidebarPanel(+ #' @return Character string concatenated from the following elements: |
||
| 42 |
- #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
+ #' - data pre-processing code (from `data` argument in `init`) |
||
| 43 |
- #' selectInput("number", "select a number:", 1:6),
+ #' - hash check of loaded objects |
||
| 44 |
- #' br(),+ #' - filter code (if any) |
||
| 45 |
- #' selectInput("color", "select a color:",
+ #' |
||
| 46 |
- #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
+ #' @keywords internal |
||
| 47 |
- #' multiple = TRUE+ get_datasets_code <- function(datanames, datasets, hashes) {
|
||
| 48 |
- #' ),+ # preprocessing code |
||
| 49 | -+ | 4x |
- #' sliderInput("size", "select point size:",
+ str_prepro <- |
| 50 | -+ | 4x |
- #' min = 0.1, max = 4, value = 0.25+ teal.data:::get_code_dependency(attr(datasets, "preprocessing_code"), names = datanames, check_names = FALSE) |
| 51 | -+ | 4x |
- #' )+ if (length(str_prepro) == 0) {
|
| 52 | -+ | ! |
- #' ),+ str_prepro <- "message('Preprocessing is empty')"
|
| 53 |
- #' mainPanel(plotOutput("plot"))
+ } else {
|
||
| 54 | -+ | 4x |
- #' )+ str_prepro <- paste(str_prepro, collapse = "\n") |
| 55 |
- #' )+ } |
||
| 56 |
- #'+ |
||
| 57 |
- #' server <- function(input, output) {
+ # hash checks |
||
| 58 | -+ | 4x |
- #' # set up input validation+ str_hash <- vapply(datanames, function(dataname) {
|
| 59 | -+ | 6x |
- #' iv <- InputValidator$new()+ sprintf( |
| 60 | -+ | 6x |
- #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
+ "stopifnot(%s == %s)", |
| 61 | -+ | 6x |
- #' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
+ deparse1(bquote(rlang::hash(.(as.name(dataname))))), |
| 62 | -+ | 6x |
- #' iv$enable()+ deparse1(hashes[[dataname]]) |
| 63 |
- #' # more input validation+ ) |
||
| 64 | -+ | 4x |
- #' iv_par <- InputValidator$new()+ }, character(1)) |
| 65 | -+ | 4x |
- #' iv_par$add_rule("color", sv_required(message = "choose a color"))
+ str_hash <- paste(str_hash, collapse = "\n") |
| 66 |
- #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color")
+
|
||
| 67 |
- #' iv_par$add_rule(+ # filter expressions |
||
| 68 | -+ | 4x |
- #' "size",+ str_filter <- teal.slice::get_filter_expr(datasets, datanames) |
| 69 | -+ | 4x |
- #' sv_between(+ if (str_filter == "") {
|
| 70 | -+ | 3x |
- #' left = 0.5, right = 3,+ str_filter <- character(0) |
| 71 |
- #' message_fmt = "choose a value between {left} and {right}"
+ } |
||
| 72 |
- #' )+ |
||
| 73 |
- #' )+ # concatenate all code |
||
| 74 | +4x | +
+ str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n")+ |
+ |
| 75 | +4x | +
+ sprintf("%s\n", str_code)
+ |
+ |
| 76 |
- #' iv_par$enable()+ }+ |
+
| 1 | ++ |
+ #' Evaluate Expression on `teal_data_module` |
||
| 75 | +2 |
#' |
||
| 76 | +3 |
- #' output$plot <- renderPlot({
+ #' @details |
||
| 77 | +4 |
- #' # validate output+ #' `within` is a convenience function for evaluating inline code inside the environment of a `teal_data_module`. |
||
| 78 | +5 |
- #' switch(input[["method"]],+ #' |
||
| 79 | +6 |
- #' "sequential" = {
+ #' @param data (`teal_data_module`) object |
||
| 80 | +7 |
- #' validate_inputs(iv)+ #' @param expr (`expression`) to evaluate. Must be inline code. See |
||
| 81 | +8 |
- #' validate_inputs(iv_par, header = "Set proper graphical parameters")+ #' @param ... See `Details`. |
||
| 82 | +9 |
- #' },+ #' |
||
| 83 | +10 |
- #' "combined" = validate_inputs(iv, iv_par),+ #' @return |
||
| 84 | +11 |
- #' "grouped" = validate_inputs(list(+ #' `within` returns a `teal_data_module` object with a delayed evaluation of `expr` when the module is run. |
||
| 85 | +12 |
- #' "Some inputs require attention" = iv,+ #' |
||
| 86 | +13 |
- #' "Set proper graphical parameters" = iv_par+ #' @examples |
||
| 87 | +14 |
- #' ))+ #' tdm <- teal_data_module( |
||
| 88 | +15 |
- #' )+ #' ui = function(id) div(id = shiny::NS(id)("div_id")),
|
||
| 89 | +16 |
- #'+ #' server = function(id) {
+ |
+ ||
| 17 | ++ |
+ #' shiny::moduleServer(id, function(input, output, session) {
+ |
+ ||
| 18 | ++ |
+ #' shiny::reactive(teal_data(IRIS = iris))+ |
+ ||
| 19 | ++ |
+ #' })+ |
+ ||
| 20 | ++ |
+ #' }+ |
+ ||
| 21 | ++ |
+ #' )+ |
+ ||
| 22 | ++ |
+ #' within(tdm, IRIS <- subset(IRIS, Species == "virginica")) |
||
| 90 | +23 |
- #' plot(eruptions ~ waiting, faithful,+ #' |
||
| 91 | +24 |
- #' las = 1, pch = 16,+ #' @include teal_data_module.R |
||
| 92 | +25 |
- #' col = input[["color"]], cex = input[["size"]]+ #' @name within |
||
| 93 | +26 |
- #' )+ #' @rdname teal_data_module |
||
| 94 | +27 |
- #' })+ #' |
||
| 95 | +28 |
- #' }+ #' @export |
||
| 96 | +29 |
#' |
||
| 97 | +30 |
- #' if (interactive()) {
+ within.teal_data_module <- function(data, expr, ...) {
|
||
| 98 | -+ | |||
| 31 | +6x |
- #' shinyApp(ui, server)+ expr <- substitute(expr) |
||
| 99 | -+ | |||
| 32 | +6x |
- #' }+ extras <- list(...) |
||
| 100 | +33 |
- #'+ |
||
| 101 | +34 |
- #' @export+ # Add braces for consistency.+ |
+ ||
| 35 | +6x | +
+ if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
+ |
+ ||
| 36 | +6x | +
+ expr <- call("{", expr)
|
||
| 102 | +37 |
- #'+ } |
||
| 103 | +38 |
- validate_inputs <- function(..., header = "Some inputs require attention") {
+
|
||
| 104 | -36x | +39 | +6x |
- dots <- list(...)+ calls <- as.list(expr)[-1] |
| 105 | -2x | +|||
| 40 | +
- if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
+
|
|||
| 106 | +41 |
-
+ # Inject extra values into expressions. |
||
| 107 | -34x | +42 | +6x |
- messages <- extract_validator(dots, header)+ calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras))) |
| 108 | -34x | +|||
| 43 | +
- failings <- if (!any_names(dots)) {
+
|
|||
| 109 | -29x | +44 | +6x |
- add_header(messages, header)+ eval_code(object = data, code = as.expression(calls)) |
| 110 | +45 |
- } else {
+ } |
||
| 111 | -5x | +
| 1 | +
- unlist(messages)+ #' Show R Code Modal |
||
| 112 | +2 |
- }+ #' |
|
| 113 | +3 |
-
+ #' @export |
|
| 114 | -34x | +||
| 4 | +
- shiny::validate(shiny::need(is.null(failings), failings))+ #' @description `r lifecycle::badge("stable")`
|
||
| 115 | +5 |
- }+ #' Use the [shiny::showModal()] function to show the R code inside. |
|
| 116 | +6 |
-
+ #' |
|
| 117 | +7 |
- ### internal functions+ #' @param title (`character(1)`)\cr |
|
| 118 | +8 |
-
+ #' Title of the modal, displayed in the first comment of the R-code. |
|
| 119 | +9 |
- #' @keywords internal+ #' @param rcode (`character`)\cr |
|
| 120 | +10 |
- # recursive object type test+ #' vector with R code to show inside the modal. |
|
| 121 | +11 |
- # returns logical of length 1+ #' @param session (`ShinySession` optional)\cr |
|
| 122 | +12 |
- is_validators <- function(x) {
+ #' `shiny` Session object, if missing then [shiny::getDefaultReactiveDomain()] is used. |
|
| 123 | -118x | +||
| 13 | +
- all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))+ #' |
||
| 124 | +14 |
- }+ #' @references [shiny::showModal()] |
|
| 125 | +15 |
-
+ show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) {
+ |
+ |
| 16 | +! | +
+ rcode <- paste(rcode, collapse = "\n") |
|
| 126 | +17 |
- #' @keywords internal+ + |
+ |
| 18 | +! | +
+ ns <- session$ns+ |
+ |
| 19 | +! | +
+ showModal(modalDialog(+ |
+ |
| 20 | +! | +
+ tagList(+ |
+ |
| 21 | +! | +
+ tags$div(+ |
+ |
| 22 | +! | +
+ actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ |
+ |
| 23 | +! | +
+ modalButton("Dismiss"),
+ |
+ |
| 24 | +! | +
+ style = "mb-4" |
|
| 127 | +25 |
- # test if an InputValidator object is enabled+ ), |
|
| 128 | -+ | ||
| 26 | +! |
- # returns logical of length 1+ tags$div(tags$pre(id = ns("r_code"), rcode)),
|
|
| 129 | +27 |
- # official method requested at https://github.com/rstudio/shinyvalidate/issues/64+ ), |
|
| 130 | -+ | ||
| 28 | +! |
- validator_enabled <- function(x) {
+ title = title, |
|
| 131 | -49x | +||
| 29 | +! |
- x$.__enclos_env__$private$enabled+ footer = tagList( |
|
| 132 | -+ | ||
| 30 | +! |
- }+ actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
|
|
| 133 | -+ | ||
| 31 | +! |
-
+ modalButton("Dismiss")
|
|
| 134 | +32 |
- #' @keywords internal+ ), |
|
| 135 | -+ | ||
| 33 | +! |
- # recursively extract messages from validator list+ size = "l",+ |
+ |
| 34 | +! | +
+ easyClose = TRUE |
|
| 136 | +35 |
- # returns character vector or a list of character vectors, possibly nested and named+ )) |
|
| 137 | +36 |
- extract_validator <- function(iv, header) {
+
|
|
| 138 | -113x | +||
| 37 | +! |
- if (inherits(iv, "InputValidator")) {
+ return(NULL) |
|
| 139 | -49x | +||
| 38 | +
- add_header(gather_messages(iv), header)+ } |
| 140 | +1 |
- } else {
+ #' Store teal_slices object to a file |
||
| 141 | -58x | +|||
| 2 | +
- if (is.null(names(iv))) names(iv) <- rep("", length(iv))
+ #' |
|||
| 142 | -64x | +|||
| 3 | +
- mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)+ #' This function takes a `teal_slices` object and saves it to a file in `JSON` format. |
|||
| 143 | +4 |
- }+ #' The `teal_slices` object contains information about filter states and can be used to |
||
| 144 | +5 |
- }+ #' create, modify, and delete filter states. The saved file can be later loaded using |
||
| 145 | +6 |
-
+ #' the `slices_restore` function. |
||
| 146 | +7 |
- #' @keywords internal+ #' |
||
| 147 | +8 |
- # collate failing messages from validator+ #' @param tss (`teal_slices`) object to be stored. |
||
| 148 | +9 |
- # returns list+ #' @param file (`character(1)`) The file path where `teal_slices` object will be saved. |
||
| 149 | +10 |
- gather_messages <- function(iv) {
+ #' The file extension should be `".json"`. |
||
| 150 | -49x | +|||
| 11 | +
- if (validator_enabled(iv)) {
+ #' |
|||
| 151 | -46x | +|||
| 12 | +
- status <- iv$validate()+ #' @details `Date` class is stored in `"ISO8601"` format (`YYYY-MM-DD`). `POSIX*t` classes are converted to a |
|||
| 152 | -46x | +|||
| 13 | +
- failing_inputs <- Filter(Negate(is.null), status)+ #' character by using `format.POSIX*t(usetz = TRUE, tz = "UTC")` (`YYYY-MM-DD {N}{N}:{N}{N}:{N}{N} UTC`, where
|
|||
| 153 | -46x | +|||
| 14 | +
- unique(lapply(failing_inputs, function(x) x[["message"]]))+ #' `{N} = [0-9]` is a number and `UTC` is `Coordinated Universal Time` timezone short-code).
|
|||
| 154 | +15 |
- } else {
+ #' This format is assumed during `slices_restore`. All `POSIX*t` objects in `selected` or `choices` fields of |
||
| 155 | -3x | +|||
| 16 | +
- logger::log_warn("Validator is disabled and will be omitted.")
+ #' `teal_slice` objects are always printed in `UTC` timezone as well. |
|||
| 156 | -3x | +|||
| 17 | +
- list()+ #' |
|||
| 157 | +18 |
- }+ #' @return `NULL`, invisibly. |
||
| 158 | +19 |
- }+ #' |
||
| 159 | +20 |
-
+ #' @keywords internal |
||
| 160 | +21 |
- #' @keywords internal+ #' |
||
| 161 | +22 |
- # add optional header to failing messages+ #' @examples |
||
| 162 | +23 |
- add_header <- function(messages, header = "") {
+ #' # Create a teal_slices object |
||
| 163 | -78x | +|||
| 24 | +
- ans <- unlist(messages)+ #' tss <- teal_slices( |
|||
| 164 | -78x | +|||
| 25 | +
- if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
+ #' teal_slice(dataname = "data", varname = "var"), |
|||
| 165 | -31x | +|||
| 26 | +
- ans <- c(paste0(header, "\n"), ans, "\n")+ #' teal_slice(dataname = "data", expr = "x > 0", id = "positive_x", title = "Positive x") |
|||
| 166 | +27 |
- }+ #' ) |
||
| 167 | -78x | +|||
| 28 | +
- ans+ #' |
|||
| 168 | +29 |
- }+ #' if (interactive()) {
|
||
| 169 | +30 |
-
+ #' # Store the teal_slices object to a file |
||
| 170 | +31 |
- #' @keywords internal+ #' slices_store(tss, "path/to/file.json") |
||
| 171 | +32 |
- # recursively check if the object contains a named list+ #' } |
||
| 172 | +33 |
- any_names <- function(x) {
+ #' |
||
| 173 | -103x | +|||
| 34 | +
- any(+ slices_store <- function(tss, file) {
|
|||
| 174 | -103x | +35 | +9x |
- if (is.list(x)) {
+ checkmate::assert_class(tss, "teal_slices") |
| 175 | -58x | +36 | +9x |
- if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))+ checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json") |
| 176 | +37 |
- } else {
+
|
||
| 177 | -40x | +38 | +9x |
- FALSE+ cat(format(tss, trim_lines = FALSE), "\n", file = file) |
| 178 | +39 |
- }+ } |
||
| 179 | +40 |
- )+ |
||
| 180 | +41 |
- }+ #' Restore teal_slices object from a file |
| 1 | +42 |
- #' Evaluate Expression on `teal_data_module`+ #' |
||
| 2 | +43 |
- #'+ #' This function takes a file path to a `JSON` file containing a `teal_slices` object |
||
| 3 | +44 |
- #' @details+ #' and restores it to its original form. The restored `teal_slices` object can be used |
||
| 4 | +45 |
- #' `within` is a convenience function for evaluating inline code inside the environment of a `teal_data_module`.+ #' to access filter states and their corresponding attributes. |
||
| 5 | +46 |
#' |
||
| 6 | +47 |
- #' @param data (`teal_data_module`) object+ #' @param file Path to file where `teal_slices` is stored. Must have a `.json` extension and read access. |
||
| 7 | +48 |
- #' @param expr (`expression`) to evaluate. Must be inline code. See+ #' |
||
| 8 | +49 |
- #' @param ... See `Details`.+ #' @return A `teal_slices` object restored from the file. |
||
| 9 | +50 |
#' |
||
| 10 | +51 |
- #' @return+ #' @keywords internal |
||
| 11 | +52 |
- #' `within` returns a `teal_data_module` object with a delayed evaluation of `expr` when the module is run.+ #' |
||
| 12 | +53 |
- #'+ #' @examples |
||
| 13 | +54 |
- #' @examples+ #' if (interactive()) {
|
||
| 14 | +55 |
- #' tdm <- teal_data_module(+ #' # Restore a teal_slices object from a file |
||
| 15 | +56 |
- #' ui = function(id) div(id = shiny::NS(id)("div_id")),
+ #' tss_restored <- slices_restore("path/to/file.json")
|
||
| 16 | +57 |
- #' server = function(id) {
+ #' } |
||
| 17 | +58 |
- #' shiny::moduleServer(id, function(input, output, session) {
+ #' |
||
| 18 | +59 |
- #' shiny::reactive(teal_data(IRIS = iris))+ slices_restore <- function(file) {
|
||
| 19 | -+ | |||
| 60 | +9x |
- #' })+ checkmate::assert_file_exists(file, access = "r", extension = "json") |
||
| 20 | +61 |
- #' }+ |
||
| 21 | -+ | |||
| 62 | +9x |
- #' )+ tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE) |
||
| 22 | -+ | |||
| 63 | +9x |
- #' within(tdm, IRIS <- subset(IRIS, Species == "virginica"))+ tss_json$slices <- |
||
| 23 | -+ | |||
| 64 | +9x |
- #'+ lapply(tss_json$slices, function(slice) {
|
||
| 24 | -+ | |||
| 65 | +9x |
- #' @include teal_data_module.R+ for (field in c("selected", "choices")) {
|
||
| 25 | -+ | |||
| 66 | +18x |
- #' @name within+ if (!is.null(slice[[field]])) {
|
||
| 26 | -+ | |||
| 67 | +12x |
- #' @rdname teal_data_module+ if (length(slice[[field]]) > 0) {
|
||
| 27 | -+ | |||
| 68 | +9x |
- #'+ date_partial_regex <- "^[0-9]{4}-[0-9]{2}-[0-9]{2}"
|
||
| 28 | -+ | |||
| 69 | +9x |
- #' @export+ time_stamp_regex <- paste0(date_partial_regex, "\\s[0-9]{2}:[0-9]{2}:[0-9]{2}\\sUTC$")
|
||
| 29 | +70 |
- #'+ |
||
| 30 | -+ | |||
| 71 | +9x |
- within.teal_data_module <- function(data, expr, ...) {
+ slice[[field]] <- |
||
| 31 | -6x | +72 | +9x | +
+ if (all(grepl(paste0(date_partial_regex, "$"), slice[[field]]))) {
+ |
+
| 73 | +3x | +
+ as.Date(slice[[field]])+ |
+ ||
| 74 | +9x | +
+ } else if (all(grepl(time_stamp_regex, slice[[field]]))) {
+ |
+ ||
| 75 | +3x | +
+ as.POSIXct(slice[[field]], tz = "UTC")+ |
+ ||
| 76 | +
- expr <- substitute(expr)+ } else {
|
|||
| 32 | -6x | +77 | +3x |
- extras <- list(...)+ slice[[field]] |
| 33 | +78 |
-
+ } |
||
| 34 | +79 |
- # Add braces for consistency.+ } else {
|
||
| 35 | -6x | +80 | +3x |
- if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
+ slice[[field]] <- character(0) |
| 36 | -6x | +|||
| 81 | +
- expr <- call("{", expr)
+ } |
|||
| 37 | +82 |
- }+ } |
||
| 38 | +83 |
-
+ } |
||
| 39 | -6x | +84 | +9x |
- calls <- as.list(expr)[-1]+ slice |
| 40 | +85 |
-
+ }) |
||
| 41 | +86 |
- # Inject extra values into expressions.+ |
||
| 42 | -6x | +87 | +9x |
- calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))+ tss_elements <- lapply(tss_json$slices, as.teal_slice) |
| 43 | +88 | |||
| 44 | -6x | +89 | +9x |
- eval_code(object = data, code = as.expression(calls))+ do.call(teal_slices, c(tss_elements, tss_json$attributes)) |
| 45 | +90 |
}@@ -29830,49 +29990,49 @@ teal coverage - 63.32% |
| 1 |
- # This file contains Shiny modules useful for debugging and developing teal.+ #' Data Module for `teal` Applications |
||
| 2 |
- # We do not export the functions in this file. They are for+ #' |
||
| 3 |
- # developers only and can be accessed via `:::`.+ #' @description |
||
| 4 |
-
+ #' `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' Dummy module to show the filter calls generated by the right encoding panel+ #' |
||
| 6 |
- #'+ #' Create a `teal_data_module` object and evaluate code on it with history tracking. |
||
| 8 |
- #' Please do not remove, this is useful for debugging teal without+ #' @details |
||
| 9 |
- #' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
+ #' `teal_data_module` creates a `shiny` module to supply or modify data in a `teal` application. |
||
| 10 |
- #' and avoids session restarts!+ #' The module allows for running data pre-processing code (creation _and_ some modification) after the app starts. |
||
| 11 |
- #'+ #' The body of the server function will be run in the app rather than in the global environment. |
||
| 12 |
- #' @param label `character` label of module+ #' This means it will be run every time the app starts, so use sparingly.\cr |
||
| 13 |
- #' @keywords internal+ #' Pass this module instead of a `teal_data` object in a call to [init()]. |
||
| 14 |
- #'+ #' Note that the server function must always return a `teal_data` object wrapped in a reactive expression.\cr |
||
| 15 |
- #' @examples+ #' See vignette `vignette("data-as-shiny-module", package = "teal")` for more details.
|
||
| 16 |
- #' app <- init(+ #' |
||
| 17 |
- #' data = teal_data(iris = iris, mtcars = mtcars),+ #' @param ui (`function(id)`)\cr |
||
| 18 |
- #' modules = teal:::filter_calls_module(),+ #' `shiny` module `ui` function; must only take `id` argument |
||
| 19 |
- #' header = "Simple teal app"+ #' @param server (`function(id)`)\cr |
||
| 20 |
- #' )- |
- ||
| 21 | -- |
- #' if (interactive()) {
- |
- |
| 22 | -- |
- #' shinyApp(app$ui, app$server)- |
- |
| 23 | -- |
- #' }- |
- |
| 24 | -- |
- filter_calls_module <- function(label = "Filter Calls Module") { # nolint
- |
- |
| 25 | -! | -
- checkmate::assert_string(label)- |
- |
| 26 | -- | - - | -|
| 27 | -! | -
- module(- |
- |
| 28 | -! | -
- label = label,- |
- |
| 29 | -! | -
- server = function(input, output, session, data) {
- |
- |
| 30 | -! | -
- checkmate::assert_class(data, "reactive")- |
- |
| 31 | -! | -
- checkmate::assert_class(isolate(data()), "teal_data")- |
- |
| 32 | -- | - - | -|
| 33 | -! | -
- output$filter_calls <- renderText({
- |
- |
| 34 | -! | -
- teal.data::get_code(data())- |
- |
| 35 | -- |
- })- |
- |
| 36 | -- |
- },- |
- |
| 37 | -! | -
- ui = function(id, ...) {
- |
- |
| 38 | -! | -
- ns <- NS(id)- |
- |
| 39 | -! | -
- div(- |
- |
| 40 | -! | -
- h2("The following filter calls are generated:"),
- |
- |
| 41 | -! | -
- verbatimTextOutput(ns("filter_calls"))
+ #' `shiny` module `ui` function; must only take `id` argument; |
|
| 42 | +21 |
- )+ #' must return reactive expression containing `teal_data` object |
|
| 43 | +22 |
- },+ #' |
|
| 44 | -! | +||
| 23 | +
- datanames = "all"+ #' @return |
||
| 45 | +24 |
- )+ #' `teal_data_module` returns an object of class `teal_data_module`. |
|
| 46 | +25 |
- }+ #' |
| 1 | +26 |
- #' Show R Code Modal+ #' @examples |
|
| 2 | +27 |
- #'+ #' data <- teal_data_module( |
|
| 3 | +28 |
- #' @export+ #' ui = function(id) {
|
|
| 4 | +29 |
- #' @description `r lifecycle::badge("stable")`
+ #' ns <- NS(id) |
|
| 5 | +30 |
- #' Use the [shiny::showModal()] function to show the R code inside.+ #' actionButton(ns("submit"), label = "Load data")
|
|
| 6 | +31 |
- #'+ #' }, |
|
| 7 | +32 |
- #' @param title (`character(1)`)\cr+ #' server = function(id) {
|
|
| 8 | +33 |
- #' Title of the modal, displayed in the first comment of the R-code.+ #' moduleServer(id, function(input, output, session) {
|
|
| 9 | +34 |
- #' @param rcode (`character`)\cr+ #' eventReactive(input$submit, {
|
|
| 10 | +35 |
- #' vector with R code to show inside the modal.+ #' data <- within( |
|
| 11 | +36 |
- #' @param session (`ShinySession` optional)\cr+ #' teal_data(), |
|
| 12 | +37 |
- #' `shiny` Session object, if missing then [shiny::getDefaultReactiveDomain()] is used.+ #' {
|
|
| 13 | +38 |
- #'+ #' dataset1 <- iris |
|
| 14 | +39 |
- #' @references [shiny::showModal()]+ #' dataset2 <- mtcars |
|
| 15 | +40 |
- show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) {
+ #' } |
|
| 16 | -! | +||
| 41 | +
- rcode <- paste(rcode, collapse = "\n")+ #' ) |
||
| 17 | +42 |
-
+ #' datanames(data) <- c("dataset1", "dataset2")
|
|
| 18 | -! | +||
| 43 | +
- ns <- session$ns+ #' |
||
| 19 | -! | +||
| 44 | +
- showModal(modalDialog(+ #' data |
||
| 20 | -! | +||
| 45 | +
- tagList(+ #' }) |
||
| 21 | -! | +||
| 46 | +
- tags$div(+ #' }) |
||
| 22 | -! | +||
| 47 | +
- actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ #' } |
||
| 23 | -! | +||
| 48 | +
- modalButton("Dismiss"),
+ #' ) |
||
| 24 | -! | +||
| 49 | +
- style = "mb-4"+ #' |
||
| 25 | +50 |
- ),+ #' @name teal_data_module |
|
| 26 | -! | +||
| 51 | +
- tags$div(tags$pre(id = ns("r_code"), rcode)),
+ #' @rdname teal_data_module |
||
| 27 | +52 |
- ),+ #' |
|
| 28 | -! | +||
| 53 | +
- title = title,+ #' @seealso [`teal_data-class`], [`base::within()`], [`teal.code::within.qenv()`] |
||
| 29 | -! | +||
| 54 | +
- footer = tagList(+ #' |
||
| 30 | -! | +||
| 55 | +
- actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ #' @export |
||
| 31 | -! | +||
| 56 | +
- modalButton("Dismiss")
+ teal_data_module <- function(ui, server) {
|
||
| 32 | -+ | ||
| 57 | +35x |
- ),+ checkmate::assert_function(ui, args = "id", nargs = 1) |
|
| 33 | -! | +||
| 58 | +34x |
- size = "l",+ checkmate::assert_function(server, args = "id", nargs = 1) |
|
| 34 | -! | +||
| 59 | +33x |
- easyClose = TRUE+ structure( |
|
| 35 | -+ | ||
| 60 | +33x |
- ))+ list(ui = ui, server = server), |
|
| 36 | -+ | ||
| 61 | +33x |
-
+ class = "teal_data_module" |
|
| 37 | -! | +||
| 62 | +
- return(NULL)+ ) |
||
| 38 | +63 |
} |