| 1 |
- #' Filter state snapshot management+ #' Filter panel module in teal |
||
| 3 |
- #' Capture and restore snapshots of the global (app) filter state.+ #' Creates filter panel module from `teal_data` object and returns `teal_data`. It is build in a way |
||
| 4 |
- #'+ #' that filter panel changes and anything what happens before (e.g. [`module_init_data`]) is triggering |
||
| 5 |
- #' This module introduces snapshots: stored descriptions of the filter state of the entire application.+ #' further reactive events only if something has changed and if the module is visible. Thanks to |
||
| 6 |
- #' Snapshots allow the user to save the current filter state of the application for later use in the session,+ #' this special implementation all modules' data are recalculated only for those modules which are |
||
| 7 |
- #' as well as to save it to file in order to share it with an app developer or other users,+ #' currently displayed. |
||
| 8 |
- #' who in turn can upload it to their own session.+ #' |
||
| 9 |
- #'+ #' @return A `eventReactive` containing `teal_data` containing filtered objects and filter code. |
||
| 10 |
- #' The snapshot manager is accessed with the camera icon in the tabset bar.+ #' `eventReactive` triggers only if all conditions are met: |
||
| 11 |
- #' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow.+ #' - tab is selected (`is_active`) |
||
| 12 |
- #' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file+ #' - when filters are changed (`get_filter_expr` is different than previous) |
||
| 13 |
- #' and applies the filter states therein, and clicking the arrow resets initial application state.+ #' |
||
| 14 |
- #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.+ #' @inheritParams module_teal_module |
||
| 15 |
- #'+ #' @param active_datanames (`reactive` returning `character`) this module's data names |
||
| 16 |
- #' @section Server logic:+ #' @name module_filter_data |
||
| 17 |
- #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance+ #' @keywords internal |
||
| 18 |
- #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`+ NULL |
||
| 19 |
- #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation+ |
||
| 20 |
- #' (attributes are maintained).+ #' @rdname module_filter_data |
||
| 21 |
- #'+ ui_filter_data <- function(id) {
|
||
| 22 | -+ | ! |
- #' Snapshots are stored in a `reactiveVal` as a named list.+ ns <- shiny::NS(id) |
| 23 | -+ | ! |
- #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.+ uiOutput(ns("panel"))
|
| 24 |
- #'+ } |
||
| 25 |
- #' For every snapshot except the initial one, a piece of UI is generated that contains+ |
||
| 26 |
- #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.+ #' @rdname module_filter_data |
||
| 27 |
- #' The initial snapshot is restored by a separate "reset" button.+ srv_filter_data <- function(id, datasets, active_datanames, data, is_active) {
|
||
| 28 | -+ | 86x |
- #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.+ assert_reactive(datasets) |
| 29 | -+ | 86x |
- #'+ moduleServer(id, function(input, output, session) {
|
| 30 | -+ | 86x |
- #' @section Snapshot mechanics:+ active_corrected <- reactive(intersect(active_datanames(), datasets()$datanames())) |
| 31 |
- #' When a snapshot is captured, the user is prompted to name it.+ |
||
| 32 | -+ | 86x |
- #' Names are displayed as is but since they are used to create button ids,+ output$panel <- renderUI({
|
| 33 | -+ | 88x |
- #' under the hood they are converted to syntactically valid strings.+ req(inherits(datasets(), "FilteredData")) |
| 34 | -+ | 88x |
- #' New snapshot names are validated so that their valid versions are unique.+ isolate({
|
| 35 |
- #' Leading and trailing white space is trimmed.+ # render will be triggered only when FilteredData object changes (not when filters change) |
||
| 36 |
- #'+ # technically it means that teal_data_module needs to be refreshed |
||
| 37 | -+ | 88x |
- #' The module can read the global state of the application from `slices_global` and `mapping_matrix`.+ logger::log_debug("srv_filter_panel rendering filter panel.")
|
| 38 | -+ | 88x |
- #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.+ if (length(active_corrected())) {
|
| 39 | -+ | 86x |
- #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.+ datasets()$srv_active("filters", active_datanames = active_corrected)
|
| 40 | -+ | 86x |
- #' The snapshot contains the `mapping` attribute of the initial application state+ datasets()$ui_active(session$ns("filters"), active_datanames = active_corrected)
|
| 41 |
- #' (or one that has been restored), which may not reflect the current one,+ } |
||
| 42 |
- #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,+ }) |
||
| 43 |
- #' when passed to the `mapping` argument of [teal_slices()], would result in the current mapping.+ }) |
||
| 44 |
- #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.+ |
||
| 45 | -+ | 86x |
- #'+ trigger_data <- .observe_active_filter_changed(datasets, is_active, active_corrected, data) |
| 46 |
- #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.+ |
||
| 47 | -+ | 86x |
- #' Then state of all `FilteredData` objects (provided in `datasets`) is cleared+ eventReactive(trigger_data(), {
|
| 48 | -+ | 89x |
- #' and set anew according to the `mapping` attribute of the snapshot.+ .make_filtered_teal_data(modules, data = data(), datasets = datasets(), datanames = active_corrected()) |
| 49 |
- #' The snapshot is then set as the current content of `slices_global`.+ }) |
||
| 50 |
- #'+ }) |
||
| 51 |
- #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,+ } |
||
| 52 |
- #' and then saved to file with [slices_store()].+ |
||
| 53 |
- #'+ #' @rdname module_filter_data |
||
| 54 |
- #' When a snapshot is uploaded, it will first be added to storage just like a newly created one,+ .make_filtered_teal_data <- function(modules, data, datasets = NULL, datanames) {
|
||
| 55 | -+ | 89x |
- #' and then used to restore app state much like a snapshot taken from storage.+ data <- eval_code( |
| 56 | -+ | 89x |
- #' Upon clicking the upload icon the user will be prompted for a file to upload+ data, |
| 57 | -+ | 89x |
- #' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped)+ paste0( |
| 58 | -+ | 89x |
- #' and normal naming rules apply. Loading the file yields a `teal_slices` object,+ ".raw_data <- list2env(list(",
|
| 59 | -+ | 89x |
- #' which is disassembled for storage and used directly for restoring app state.+ toString(sprintf("%1$s = %1$s", sapply(datanames, as.name))),
|
| 60 | -+ | 89x |
- #'+ "))\n", |
| 61 | -+ | 89x |
- #' @section Transferring snapshots:+ "lockEnvironment(.raw_data) # @linksto .raw_data" # this is environment and it is shared by qenvs. CAN'T MODIFY! |
| 62 |
- #' Snapshots uploaded from disk should only be used in the same application they come from,+ ) |
||
| 63 |
- #' _i.e._ an application that uses the same data and the same modules.+ ) |
||
| 64 | -+ | 89x |
- #' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of+ filtered_code <- .get_filter_expr(datasets = datasets, datanames = datanames) |
| 65 | -+ | 89x |
- #' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that+ filtered_teal_data <- .append_evaluated_code(data, filtered_code) |
| 66 | -+ | 89x |
- #' of the current app state and only if the match is the snapshot admitted to the session.+ filtered_datasets <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE) |
| 67 | -+ | 89x |
- #'+ filtered_teal_data <- .append_modified_data(filtered_teal_data, filtered_datasets) |
| 68 | -+ | 89x |
- #' @section Bookmarks:+ filtered_teal_data |
| 69 |
- #' An `onBookmark` callback creates a snapshot of the current filter state.+ } |
||
| 70 |
- #' This is done on the app session, not the module session.+ |
||
| 71 |
- #' (The snapshot will be retrieved by `module_teal` in order to set initial app state in a restored app.)+ #' @rdname module_filter_data |
||
| 72 |
- #' Then that snapshot, and the previous snapshot history are dumped into the `values.rds` file in `<bookmark_dir>`.+ .observe_active_filter_changed <- function(datasets, is_active, active_datanames, data) {
|
||
| 73 | -+ | 86x |
- #'+ previous_signature <- reactiveVal(NULL) |
| 74 | -+ | 86x |
- #' @param id (`character(1)`) `shiny` module instance id.+ filter_changed <- reactive({
|
| 75 | -+ | 195x |
- #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object+ req(inherits(datasets(), "FilteredData")) |
| 76 | -+ | 195x |
- #' containing all `teal_slice`s existing in the app, both active and inactive.+ new_signature <- c( |
| 77 | -+ | 195x |
- #'+ teal.code::get_code(data()), |
| 78 | -+ | 195x |
- #' @return `list` containing the snapshot history, where each element is an unlisted `teal_slices` object.+ .get_filter_expr(datasets = datasets(), datanames = active_datanames()) |
| 79 |
- #'+ ) |
||
| 80 | -+ | 195x |
- #' @name module_snapshot_manager+ if (!identical(previous_signature(), new_signature)) {
|
| 81 | -+ | 94x |
- #' @rdname module_snapshot_manager+ previous_signature(new_signature) |
| 82 | -+ | 94x |
- #'+ TRUE |
| 83 |
- #' @author Aleksander Chlebowski+ } else {
|
||
| 84 | -+ | 101x |
- #' @keywords internal+ FALSE |
| 85 |
- NULL+ } |
||
| 86 |
-
+ }) |
||
| 87 |
- #' @rdname module_snapshot_manager+ |
||
| 88 | -+ | 86x |
- ui_snapshot_manager_panel <- function(id) {
+ trigger_data <- reactiveVal(NULL) |
| 89 | -! | +86x |
- ns <- NS(id)+ observe({
|
| 90 | -! | +208x |
- tags$button(+ if (isTRUE(is_active() && filter_changed())) {
|
| 91 | -! | +94x |
- id = ns("show_snapshot_manager"),
+ isolate({
|
| 92 | -! | +94x |
- class = "btn action-button wunder_bar_button",+ if (is.null(trigger_data())) {
|
| 93 | -! | +86x |
- title = "View filter mapping",+ trigger_data(0) |
| 94 | -! | +
- suppressMessages(icon("fas fa-camera"))
+ } else {
|
|
| 95 | -+ | 8x |
- )+ trigger_data(trigger_data() + 1) |
| 96 |
- }+ } |
||
| 97 |
-
+ }) |
||
| 98 |
- #' @rdname module_snapshot_manager+ } |
||
| 99 |
- srv_snapshot_manager_panel <- function(id, slices_global) {
+ }) |
||
| 100 | -87x | +
- moduleServer(id, function(input, output, session) {
+
|
|
| 101 | -87x | +86x |
- logger::log_debug("srv_snapshot_manager_panel initializing")
+ trigger_data |
| 102 | -87x | +
- setBookmarkExclude(c("show_snapshot_manager"))
+ } |
|
| 103 | -87x | +
- observeEvent(input$show_snapshot_manager, {
+
|
|
| 104 | -! | +
- logger::log_debug("srv_snapshot_manager_panel@1 show_snapshot_manager button has been clicked.")
+ #' @rdname module_filter_data |
|
| 105 | -! | +
- showModal(+ .get_filter_expr <- function(datasets, datanames) {
|
|
| 106 | -! | +284x |
- modalDialog(+ if (length(datanames)) {
|
| 107 | -! | +278x |
- ui_snapshot_manager(session$ns("module")),
+ teal.slice::get_filter_expr(datasets = datasets, datanames = datanames) |
| 108 | -! | +
- class = "snapshot_manager_modal",+ } else {
|
|
| 109 | -! | +6x |
- size = "m",+ NULL |
| 110 | -! | +
- footer = NULL,+ } |
|
| 111 | -! | +
- easyClose = TRUE+ } |
| 112 | +1 |
- )+ #' `teal` main module |
||
| 113 | +2 |
- )+ #' |
||
| 114 | +3 |
- })+ #' @description |
||
| 115 | -87x | +|||
| 4 | +
- srv_snapshot_manager("module", slices_global = slices_global)
+ #' `r lifecycle::badge("stable")`
|
|||
| 116 | +5 |
- })+ #' Module to create a `teal` app. This module can be called directly instead of [init()] and |
||
| 117 | +6 |
- }+ #' included in your custom application. Please note that [init()] adds `reporter_previewer_module` |
||
| 118 | +7 |
-
+ #' automatically, which is not a case when calling `ui/srv_teal` directly. |
||
| 119 | +8 |
- #' @rdname module_snapshot_manager+ #' |
||
| 120 | +9 |
- ui_snapshot_manager <- function(id) {
+ #' @details |
||
| 121 | -! | +|||
| 10 | +
- ns <- NS(id)+ #' |
|||
| 122 | -! | +|||
| 11 | +
- tags$div(+ #' Module is responsible for creating the main `shiny` app layout and initializing all the necessary |
|||
| 123 | -! | -
- class = "manager_content",- |
- ||
| 124 | -! | -
- tags$div(- |
- ||
| 125 | -! | -
- class = "manager_table_row",- |
- ||
| 126 | -! | -
- tags$span(tags$b("Snapshot manager")),
- |
- ||
| 127 | -! | -
- actionLink(ns("snapshot_add"), label = NULL, icon = icon("fas fa-camera"), title = "add snapshot"),
- |
- ||
| 128 | -! | -
- actionLink(ns("snapshot_load"), label = NULL, icon = icon("fas fa-upload"), title = "upload snapshot"),
- |
- ||
| 129 | -! | +|||
| 12 | +
- actionLink(ns("snapshot_reset"), label = NULL, icon = icon("fas fa-undo"), title = "reset initial state"),
+ #' components. This module establishes reactive connection between the input `data` and every other |
|||
| 130 | -! | +|||
| 13 | +
- NULL+ #' component in the app. Reactive change of the `data` passed as an argument, reloads the app and |
|||
| 131 | +14 |
- ),+ #' possibly keeps all input settings the same so the user can continue where one left off. |
||
| 132 | -! | +|||
| 15 | +
- uiOutput(ns("snapshot_list"))
+ #' |
|||
| 133 | +16 |
- )+ #' ## data flow in `teal` application |
||
| 134 | +17 |
- }+ #' |
||
| 135 | +18 |
-
+ #' This module supports multiple data inputs but eventually, they are all converted to `reactive` |
||
| 136 | +19 |
- #' @rdname module_snapshot_manager+ #' returning `teal_data` in this module. On this `reactive teal_data` object several actions are |
||
| 137 | +20 |
- srv_snapshot_manager <- function(id, slices_global) {
+ #' performed: |
||
| 138 | -87x | +|||
| 21 | +
- checkmate::assert_character(id)+ #' - data loading in [`module_init_data`] |
|||
| 139 | +22 |
-
+ #' - data filtering in [`module_filter_data`] |
||
| 140 | -87x | +|||
| 23 | +
- moduleServer(id, function(input, output, session) {
+ #' - data transformation in [`module_transform_data`] |
|||
| 141 | -87x | +|||
| 24 | +
- logger::log_debug("srv_snapshot_manager initializing")
+ #' |
|||
| 142 | +25 |
-
+ #' ## Fallback on failure |
||
| 143 | +26 |
- # Set up bookmarking callbacks ----+ #' |
||
| 144 | +27 |
- # Register bookmark exclusions (all buttons and text fields).+ #' `teal` is designed in such way that app will never crash if the error is introduced in any |
||
| 145 | -87x | +|||
| 28 | +
- setBookmarkExclude(c(+ #' custom `shiny` module provided by app developer (e.g. [teal_data_module()], [teal_transform_module()]). |
|||
| 146 | -87x | +|||
| 29 | +
- "snapshot_add", "snapshot_load", "snapshot_reset",+ #' If any module returns a failing object, the app will halt the evaluation and display a warning message. |
|||
| 147 | -87x | +|||
| 30 | +
- "snapshot_name_accept", "snaphot_file_accept",+ #' App user should always have a chance to fix the improper input and continue without restarting the session. |
|||
| 148 | -87x | +|||
| 31 | +
- "snapshot_name", "snapshot_file"+ #' |
|||
| 149 | +32 |
- ))+ #' @rdname module_teal |
||
| 150 | +33 |
- # Add snapshot history to bookmark.+ #' @name module_teal |
||
| 151 | -87x | +|||
| 34 | +
- session$onBookmark(function(state) {
+ #' |
|||
| 152 | -! | +|||
| 35 | +
- logger::log_debug("srv_snapshot_manager@onBookmark: storing snapshot and bookmark history")
+ #' @inheritParams module_init_data |
|||
| 153 | -! | +|||
| 36 | +
- state$values$snapshot_history <- snapshot_history() # isolate this?+ #' @inheritParams init |
|||
| 154 | +37 |
- })+ #' |
||
| 155 | +38 |
-
+ #' @return `NULL` invisibly |
||
| 156 | -87x | +|||
| 39 | +
- ns <- session$ns+ NULL |
|||
| 157 | +40 | |||
| 158 | +41 |
- # Track global filter states ----- |
- ||
| 159 | -87x | -
- snapshot_history <- reactiveVal({
+ #' @rdname module_teal |
||
| 160 | +42 |
- # Restore directly from bookmarked state, if applicable.- |
- ||
| 161 | -87x | -
- restoreValue(- |
- ||
| 162 | -87x | -
- ns("snapshot_history"),
+ #' @export |
||
| 163 | -87x | +|||
| 43 | +
- list("Initial application state" = shiny::isolate(as.list(slices_global$all_slices(), recursive = TRUE)))
+ ui_teal <- function(id, |
|||
| 164 | +44 |
- )+ modules, |
||
| 165 | +45 |
- })+ title = build_app_title(), |
||
| 166 | +46 |
-
+ header = tags$p(), |
||
| 167 | +47 |
- # Snapshot current application state ----+ footer = tags$p()) {
|
||
| 168 | -+ | |||
| 48 | +! |
- # Name snaphsot.+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
||
| 169 | -87x | +|||
| 49 | +! |
- observeEvent(input$snapshot_add, {
+ checkmate::assert( |
||
| 170 | +50 | ! |
- logger::log_debug("srv_snapshot_manager: snapshot_add button clicked")
+ .var.name = "title", |
|
| 171 | +51 | ! |
- showModal(+ checkmate::check_string(title), |
|
| 172 | +52 | ! |
- modalDialog(+ checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+ |
| 53 | ++ |
+ ) |
||
| 173 | +54 | ! |
- textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
+ checkmate::assert( |
|
| 174 | +55 | ! |
- footer = tagList(+ .var.name = "header", |
|
| 175 | +56 | ! |
- actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("far fa-thumbs-up")),
+ checkmate::check_string(header), |
|
| 176 | +57 | ! |
- modalButton(label = "Cancel", icon = icon("far fa-thumbs-down"))
+ checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
|
|
| 177 | +58 |
- ),+ ) |
||
| 178 | +59 | ! |
- size = "s"+ checkmate::assert( |
|
| 179 | -+ | |||
| 60 | +! |
- )+ .var.name = "footer", |
||
| 180 | -+ | |||
| 61 | +! |
- )+ checkmate::check_string(footer), |
||
| 181 | -+ | |||
| 62 | +! |
- })+ checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
|
||
| 182 | +63 |
- # Store snaphsot.+ ) |
||
| 183 | -87x | +|||
| 64 | +
- observeEvent(input$snapshot_name_accept, {
+
|
|||
| 184 | +65 | ! |
- logger::log_debug("srv_snapshot_manager: snapshot_name_accept button clicked")
+ if (is.character(title)) {
|
|
| 185 | +66 | ! |
- snapshot_name <- trimws(input$snapshot_name)+ title <- build_app_title(title) |
|
| 186 | -! | +|||
| 67 | +
- if (identical(snapshot_name, "")) {
+ } else {
|
|||
| 187 | +68 | ! |
- logger::log_debug("srv_snapshot_manager: snapshot name rejected")
+ validate_app_title_tag(title) |
|
| 188 | -! | +|||
| 69 | +
- showNotification(+ }+ |
+ |||
| 70 | ++ | + | ||
| 189 | +71 | ! |
- "Please name the snapshot.",+ if (checkmate::test_string(header)) {
|
|
| 190 | +72 | ! |
- type = "message"+ header <- tags$p(header) |
|
| 191 | +73 |
- )+ } |
||
| 192 | -! | +|||
| 74 | +
- updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ |
|||
| 193 | +75 | ! |
- } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ if (checkmate::test_string(footer)) {
|
|
| 194 | +76 | ! |
- logger::log_debug("srv_snapshot_manager: snapshot name rejected")
+ footer <- tags$p(footer) |
|
| 195 | -! | +|||
| 77 | +
- showNotification(+ } |
|||
| 196 | -! | +|||
| 78 | +
- "This name is in conflict with other snapshot names. Please choose a different one.",+ |
|||
| 197 | +79 | ! |
- type = "message"+ ns <- NS(id) |
|
| 198 | +80 |
- )- |
- ||
| 199 | -! | -
- updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ |
||
| 200 | +81 |
- } else {
+ # show busy icon when `shiny` session is busy computing stuff |
||
| 201 | -! | +|||
| 82 | +
- logger::log_debug("srv_snapshot_manager: snapshot name accepted, adding snapshot")
+ # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length. |
|||
| 202 | +83 | ! |
- snapshot <- as.list(slices_global$all_slices(), recursive = TRUE)+ shiny_busy_message_panel <- conditionalPanel( |
|
| 203 | +84 | ! |
- snapshot_update <- c(snapshot_history(), list(snapshot))+ condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
|
|
| 204 | +85 | ! |
- names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ tags$div( |
|
| 205 | +86 | ! |
- snapshot_history(snapshot_update)+ icon("arrows-rotate", class = "fa-spin", prefer_type = "solid"),
|
|
| 206 | +87 | ! |
- removeModal()+ "Computing ...", |
|
| 207 | +88 |
- # Reopen filter manager modal by clicking button in the main application.+ # CSS defined in `custom.css` |
||
| 208 | +89 | ! |
- shinyjs::click(id = "teal-wunder_bar-show_snapshot_manager", asis = TRUE)+ class = "shinybusymessage" |
|
| 209 | +90 |
- }+ ) |
||
| 210 | +91 |
- })+ ) |
||
| 211 | +92 | |||
| 212 | -+ | |||
| 93 | +! |
- # Upload a snapshot file ----- |
- ||
| 213 | -- |
- # Select file.- |
- ||
| 214 | -87x | -
- observeEvent(input$snapshot_load, {
- |
- ||
| 215 | -! | -
- logger::log_debug("srv_snapshot_manager: snapshot_load button clicked")
+ fluidPage( |
||
| 216 | +94 | ! |
- showModal(+ id = id, |
|
| 217 | +95 | ! |
- modalDialog(+ title = title, |
|
| 218 | +96 | ! |
- fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
+ theme = get_teal_bs_theme(), |
|
| 219 | +97 | ! |
- textInput(+ include_teal_css_js(), |
|
| 220 | +98 | ! |
- ns("snapshot_name"),
+ tags$header(header), |
|
| 221 | +99 | ! |
- "Name the snapshot (optional)",+ tags$hr(class = "my-2"), |
|
| 222 | +100 | ! |
- width = "100%",+ shiny_busy_message_panel, |
|
| 223 | +101 | ! |
- placeholder = "Meaningful, unique name"- |
- |
| 224 | -- |
- ),+ tags$div( |
||
| 225 | +102 | ! |
- footer = tagList(+ id = ns("tabpanel_wrapper"),
|
|
| 226 | +103 | ! |
- actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("far fa-thumbs-up")),
+ class = "teal-body", |
|
| 227 | +104 | ! |
- modalButton(label = "Cancel", icon = icon("far fa-thumbs-down"))
- |
- |
| 228 | -- |
- )- |
- ||
| 229 | -- |
- )- |
- ||
| 230 | -- |
- )- |
- ||
| 231 | -- |
- })+ ui_teal_module(id = ns("teal_modules"), modules = modules)
|
||
| 232 | +105 |
- # Store new snapshot to list and restore filter states.- |
- ||
| 233 | -87x | -
- observeEvent(input$snaphot_file_accept, {
+ ), |
||
| 234 | +106 | ! |
- logger::log_debug("srv_snapshot_manager: snapshot_file_accept button clicked")
+ tags$div( |
|
| 235 | +107 | ! |
- snapshot_name <- trimws(input$snapshot_name)+ id = ns("options_buttons"),
|
|
| 236 | +108 | ! |
- if (identical(snapshot_name, "")) {
+ style = "position: absolute; right: 10px;", |
|
| 237 | +109 | ! |
- logger::log_debug("srv_snapshot_manager: no snapshot name provided, naming after file")
+ ui_bookmark_panel(ns("bookmark_manager"), modules),
|
|
| 238 | +110 | ! |
- snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)- |
- |
| 239 | -- |
- }+ tags$button( |
||
| 240 | +111 | ! |
- if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger |
|
| 241 | +112 | ! |
- logger::log_debug("srv_snapshot_manager: snapshot name rejected")
+ href = "javascript:void(0)", |
|
| 242 | +113 | ! |
- showNotification(+ onclick = sprintf("toggleFilterPanel('%s');", ns("tabpanel_wrapper")),
|
|
| 243 | +114 | ! |
- "This name is in conflict with other snapshot names. Please choose a different one.",+ title = "Toggle filter panel", |
|
| 244 | +115 | ! |
- type = "message"+ icon("fas fa-bars")
|
|
| 245 | +116 |
- )+ ), |
||
| 246 | +117 | ! |
- updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
|
|
| 247 | -+ | |||
| 118 | +! |
- } else {
+ ui_filter_manager_panel(ns("filter_manager_panel"))
|
||
| 248 | +119 |
- # Restore snapshot and verify app compatibility.- |
- ||
| 249 | -! | -
- logger::log_debug("srv_snapshot_manager: snapshot name accepted, loading snapshot")
+ ), |
||
| 250 | +120 | ! |
- snapshot_state <- try(slices_restore(input$snapshot_file$datapath))+ tags$script( |
|
| 251 | +121 | ! |
- if (!inherits(snapshot_state, "modules_teal_slices")) {
+ HTML( |
|
| 252 | +122 | ! |
- logger::log_debug("srv_snapshot_manager: snapshot file corrupt")
+ sprintf( |
|
| 253 | -! | +|||
| 123 | +
- showNotification(+ " |
|||
| 254 | +124 | ! |
- "File appears to be corrupt.",+ $(document).ready(function() {
|
|
| 255 | +125 | ! |
- type = "error"+ $('#%s').appendTo('#%s');
|
|
| 256 | +126 |
- )- |
- ||
| 257 | -! | -
- } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global$all_slices(), "app_id"))) {
- |
- ||
| 258 | -! | -
- logger::log_debug("srv_snapshot_manager: snapshot not compatible with app")
+ }); |
||
| 259 | -! | +|||
| 127 | +
- showNotification(+ ", |
|||
| 260 | +128 | ! |
- "This snapshot file is not compatible with the app and cannot be loaded.",+ ns("options_buttons"),
|
|
| 261 | +129 | ! |
- type = "warning"+ ns("teal_modules-active_tab")
|
|
| 262 | +130 |
- )+ ) |
||
| 263 | +131 |
- } else {
+ ) |
||
| 264 | +132 |
- # Add to snapshot history.+ ), |
||
| 265 | +133 | ! |
- logger::log_debug("srv_snapshot_manager: snapshot loaded, adding to history")
+ tags$hr(), |
|
| 266 | +134 | ! |
- snapshot <- as.list(slices_global$all_slices(), recursive = TRUE)+ tags$footer( |
|
| 267 | +135 | ! |
- snapshot_update <- c(snapshot_history(), list(snapshot))+ tags$div( |
|
| 268 | +136 | ! |
- names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ footer, |
|
| 269 | +137 | ! |
- snapshot_history(snapshot_update)- |
- |
| 270 | -- |
- ### Begin simplified restore procedure. ###+ teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
|
||
| 271 | +138 | ! |
- logger::log_debug("srv_snapshot_manager: restoring snapshot")
+ br(), |
|
| 272 | +139 | ! |
- slices_global$slices_set(snapshot_state)+ ui_teal_lockfile(ns("lockfile")),
|
|
| 273 | +140 | ! |
- removeModal()+ textOutput(ns("identifier"))
|
|
| 274 | +141 |
- ### End simplified restore procedure. ###+ ) |
||
| 275 | +142 |
- }+ ) |
||
| 276 | +143 |
- }+ ) |
||
| 277 | +144 |
- })+ } |
||
| 278 | +145 |
- # Apply newly added snapshot.+ |
||
| 279 | +146 |
-
+ #' @rdname module_teal |
||
| 280 | +147 |
- # Restore initial state ----+ #' @export |
||
| 281 | -87x | +|||
| 148 | +
- observeEvent(input$snapshot_reset, {
+ srv_teal <- function(id, data, modules, filter = teal_slices()) {
|
|||
| 282 | -2x | +149 | +89x |
- logger::log_debug("srv_snapshot_manager: snapshot_reset button clicked, restoring snapshot")
+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
| 283 | -2x | +150 | +89x |
- s <- "Initial application state"+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
|
| 284 | -+ | |||
| 151 | +88x |
- ### Begin restore procedure. ###+ checkmate::assert_class(modules, "teal_modules") |
||
| 285 | -2x | +152 | +88x |
- snapshot <- snapshot_history()[[s]]+ checkmate::assert_class(filter, "teal_slices") |
| 286 | -2x | +|||
| 153 | +
- snapshot_state <- as.teal_slices(snapshot)+ |
|||
| 287 | -2x | +154 | +88x |
- slices_global$slices_set(snapshot_state)+ moduleServer(id, function(input, output, session) {
|
| 288 | -2x | +155 | +88x |
- removeModal()+ logger::log_debug("srv_teal initializing.")
|
| 289 | +156 |
- ### End restore procedure. ###+ |
||
| 290 | -+ | |||
| 157 | +88x |
- })+ if (getOption("teal.show_js_log", default = FALSE)) {
|
||
| 291 | -+ | |||
| 158 | +! |
-
+ shinyjs::showLog() |
||
| 292 | +159 |
- # Build snapshot table ----+ } |
||
| 293 | +160 |
- # Create UI elements and server logic for the snapshot table.+ |
||
| 294 | -+ | |||
| 161 | +88x |
- # Observers must be tracked to avoid duplication and excess reactivity.+ srv_teal_lockfile("lockfile")
|
||
| 295 | +162 |
- # Remaining elements are tracked likewise for consistency and a slight speed margin.+ |
||
| 296 | -87x | +163 | +88x |
- observers <- reactiveValues()+ output$identifier <- renderText( |
| 297 | -87x | +164 | +88x |
- handlers <- reactiveValues()+ paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
|
| 298 | -87x | +|||
| 165 | +
- divs <- reactiveValues()+ ) |
|||
| 299 | +166 | |||
| 300 | -87x | +167 | +88x |
- observeEvent(snapshot_history(), {
+ teal.widgets::verbatim_popup_srv( |
| 301 | -77x | +168 | +88x |
- logger::log_debug("srv_snapshot_manager: snapshot history modified, updating snapshot list")
+ "sessionInfo", |
| 302 | -77x | -
- lapply(names(snapshot_history())[-1L], function(s) {
- |
- ||
| 303 | -! | +169 | +88x |
- id_pickme <- sprintf("pickme_%s", make.names(s))
+ verbatim_content = utils::capture.output(utils::sessionInfo()), |
| 304 | -! | +|||
| 170 | +88x |
- id_saveme <- sprintf("saveme_%s", make.names(s))
+ title = "SessionInfo" |
||
| 305 | -! | +|||
| 171 | +
- id_rowme <- sprintf("rowme_%s", make.names(s))
+ ) |
|||
| 306 | +172 | |||
| 307 | +173 |
- # Observer for restoring snapshot.+ # `JavaScript` code |
||
| 308 | -! | +|||
| 174 | +88x |
- if (!is.element(id_pickme, names(observers))) {
+ run_js_files(files = "init.js") |
||
| 309 | -! | +|||
| 175 | +
- observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
+
|
|||
| 310 | +176 |
- ### Begin restore procedure. ###+ # set timezone in shiny app |
||
| 311 | -! | -
- snapshot <- snapshot_history()[[s]]- |
- ||
| 312 | -! | +|||
| 177 | +
- snapshot_state <- as.teal_slices(snapshot)+ # timezone is set in the early beginning so it will be available also |
|||
| 313 | +178 |
-
+ # for `DDL` and all shiny modules+ |
+ ||
| 179 | +88x | +
+ get_client_timezone(session$ns)+ |
+ ||
| 180 | +88x | +
+ observeEvent(+ |
+ ||
| 181 | +88x | +
+ eventExpr = input$timezone,+ |
+ ||
| 182 | +88x | +
+ once = TRUE,+ |
+ ||
| 183 | +88x | +
+ handlerExpr = {
|
||
| 314 | +184 | ! |
- slices_global$slices_set(snapshot_state)+ session$userData$timezone <- input$timezone |
|
| 315 | +185 | ! |
- removeModal()+ logger::log_debug("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
|
|
| 316 | +186 |
- ### End restore procedure. ###+ } |
||
| 317 | +187 |
- })+ ) |
||
| 318 | +188 |
- }+ + |
+ ||
| 189 | +88x | +
+ data_handled <- srv_init_data("data", data = data)
|
||
| 319 | +190 |
- # Create handler for downloading snapshot.+ |
||
| 320 | -! | +|||
| 191 | +87x |
- if (!is.element(id_saveme, names(handlers))) {
+ validate_ui <- tags$div( |
||
| 321 | -! | +|||
| 192 | +87x |
- output[[id_saveme]] <- downloadHandler(+ id = session$ns("validate_messages"),
|
||
| 322 | -! | +|||
| 193 | +87x |
- filename = function() {
+ class = "teal_validated", |
||
| 323 | -! | +|||
| 194 | +87x |
- sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
+ ui_check_class_teal_data(session$ns("class_teal_data")),
|
||
| 324 | -+ | |||
| 195 | +87x |
- },+ ui_validate_error(session$ns("silent_error")),
|
||
| 325 | -! | +|||
| 196 | +87x |
- content = function(file) {
+ ui_check_module_datanames(session$ns("datanames_warning"))
|
||
| 326 | -! | +|||
| 197 | +
- snapshot <- snapshot_history()[[s]]+ ) |
|||
| 327 | -! | +|||
| 198 | +87x |
- snapshot_state <- as.teal_slices(snapshot)+ srv_check_class_teal_data("class_teal_data", data_handled)
|
||
| 328 | -! | +|||
| 199 | +87x |
- slices_store(tss = snapshot_state, file = file)+ srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
|
||
| 329 | -+ | |||
| 200 | +87x |
- }+ srv_check_module_datanames("datanames_warning", data_handled, modules)
|
||
| 330 | +201 |
- )+ |
||
| 331 | -! | +|||
| 202 | +87x |
- handlers[[id_saveme]] <- id_saveme+ data_validated <- .trigger_on_success(data_handled) |
||
| 332 | +203 |
- }+ |
||
| 333 | -+ | |||
| 204 | +87x |
- # Create a row for the snapshot table.+ data_signatured <- reactive({
|
||
| 334 | -! | +|||
| 205 | +152x |
- if (!is.element(id_rowme, names(divs))) {
+ req(inherits(data_validated(), "teal_data")) |
||
| 335 | -! | +|||
| 206 | +75x |
- divs[[id_rowme]] <- tags$div(+ is_filter_ok <- check_filter_datanames(filter, names(data_validated())) |
||
| 336 | -! | +|||
| 207 | +75x |
- class = "manager_table_row",+ if (!isTRUE(is_filter_ok)) {
|
||
| 337 | -! | +|||
| 208 | +2x |
- tags$span(tags$h5(s)),+ showNotification( |
||
| 338 | -! | +|||
| 209 | +2x |
- actionLink(inputId = ns(id_pickme), label = icon("far fa-circle-check"), title = "select"),
+ "Some filters were not applied because of incompatibility with data. Contact app developer.", |
||
| 339 | -! | +|||
| 210 | +2x |
- downloadLink(outputId = ns(id_saveme), label = icon("far fa-save"), title = "save to file")
+ type = "warning", |
||
| 340 | -+ | |||
| 211 | +2x |
- )+ duration = 10 |
||
| 341 | +212 |
- }+ ) |
||
| 342 | -+ | |||
| 213 | +2x |
- })+ warning(is_filter_ok) |
||
| 343 | +214 |
- })+ } |
||
| 344 | -+ | |||
| 215 | +75x |
-
+ .add_signature_to_data(data_validated()) |
||
| 345 | +216 |
- # Create table to display list of snapshots and their actions.+ }) |
||
| 346 | -87x | +|||
| 217 | +
- output$snapshot_list <- renderUI({
+
|
|||
| 347 | -77x | +218 | +87x |
- rows <- rev(reactiveValuesToList(divs))+ data_load_status <- reactive({
|
| 348 | -77x | +219 | +80x |
- if (length(rows) == 0L) {
+ if (inherits(data_handled(), "teal_data")) {
|
| 349 | -77x | +220 | +75x |
- tags$div(+ "ok" |
| 350 | -77x | +221 | +5x |
- class = "manager_placeholder",+ } else if (inherits(data, "teal_data_module")) {
|
| 351 | -77x | -
- "Snapshots will appear here."- |
- ||
| 352 | -+ | 222 | +5x |
- )+ "teal_data_module failed" |
| 353 | +223 |
} else {
|
||
| 354 | +224 | ! |
- rows+ "external failed" |
|
| 355 | +225 |
} |
||
| 356 | +226 |
}) |
||
| 357 | +227 | |||
| 358 | +228 | 87x |
- snapshot_history+ datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
|
|
| 359 | -+ | |||
| 229 | +76x |
- })+ eventReactive(data_signatured(), {
|
||
| 360 | -+ | |||
| 230 | +66x |
- }+ req(inherits(data_signatured(), "teal_data")) |
| 1 | -+ | |||
| 231 | +66x |
- #' Filter panel module in teal+ logger::log_debug("srv_teal@1 initializing FilteredData")
|
||
| 2 | -+ | |||
| 232 | +66x |
- #'+ teal_data_to_filtered_data(data_signatured()) |
||
| 3 | +233 |
- #' Creates filter panel module from `teal_data` object and returns `teal_data`. It is build in a way+ }) |
||
| 4 | +234 |
- #' that filter panel changes and anything what happens before (e.g. [`module_init_data`]) is triggering+ } |
||
| 5 | +235 |
- #' further reactive events only if something has changed and if the module is visible. Thanks to+ |
||
| 6 | +236 |
- #' this special implementation all modules' data are recalculated only for those modules which are+ |
||
| 7 | +237 |
- #' currently displayed.+ |
||
| 8 | -+ | |||
| 238 | +87x |
- #'+ if (inherits(data, "teal_data_module")) {
|
||
| 9 | -+ | |||
| 239 | +9x |
- #' @return A `eventReactive` containing `teal_data` containing filtered objects and filter code.+ setBookmarkExclude(c("teal_modules-active_tab"))
|
||
| 10 | -+ | |||
| 240 | +9x |
- #' `eventReactive` triggers only if all conditions are met:+ shiny::insertTab( |
||
| 11 | -+ | |||
| 241 | +9x |
- #' - tab is selected (`is_active`)+ inputId = "teal_modules-active_tab", |
||
| 12 | -+ | |||
| 242 | +9x |
- #' - when filters are changed (`get_filter_expr` is different than previous)+ position = "before", |
||
| 13 | -+ | |||
| 243 | +9x |
- #'+ select = TRUE, |
||
| 14 | -+ | |||
| 244 | +9x |
- #' @inheritParams module_teal_module+ tabPanel( |
||
| 15 | -+ | |||
| 245 | +9x |
- #' @param active_datanames (`reactive` returning `character`) this module's data names+ title = icon("fas fa-database"),
|
||
| 16 | -+ | |||
| 246 | +9x |
- #' @name module_filter_data+ value = "teal_data_module", |
||
| 17 | -+ | |||
| 247 | +9x |
- #' @keywords internal+ tags$div( |
||
| 18 | -+ | |||
| 248 | +9x |
- NULL+ ui_init_data(session$ns("data")),
|
||
| 19 | -+ | |||
| 249 | +9x |
-
+ validate_ui |
||
| 20 | +250 |
- #' @rdname module_filter_data+ ) |
||
| 21 | +251 |
- ui_filter_data <- function(id) {
- |
- ||
| 22 | -! | -
- ns <- shiny::NS(id)- |
- ||
| 23 | -! | -
- uiOutput(ns("panel"))
+ ) |
||
| 24 | +252 |
- }+ ) |
||
| 25 | +253 | |||
| 26 | -- |
- #' @rdname module_filter_data- |
- ||
| 27 | -- |
- srv_filter_data <- function(id, datasets, active_datanames, data, is_active) {
- |
- ||
| 28 | -86x | +254 | +9x |
- assert_reactive(datasets)+ if (attr(data, "once")) {
|
| 29 | -86x | +255 | +9x |
- moduleServer(id, function(input, output, session) {
+ observeEvent(data_signatured(), once = TRUE, {
|
| 30 | -86x | +256 | +4x |
- active_corrected <- reactive(intersect(active_datanames(), datasets()$datanames()))+ logger::log_debug("srv_teal@2 removing data tab.")
|
| 31 | +257 |
-
+ # when once = TRUE we pull data once and then remove data tab |
||
| 32 | -86x | +258 | +4x |
- output$panel <- renderUI({
+ removeTab("teal_modules-active_tab", target = "teal_data_module")
|
| 33 | -88x | +|||
| 259 | +
- req(inherits(datasets(), "FilteredData"))+ }) |
|||
| 34 | -88x | +|||
| 260 | +
- isolate({
+ } |
|||
| 35 | +261 |
- # render will be triggered only when FilteredData object changes (not when filters change)+ } else {
|
||
| 36 | +262 |
- # technically it means that teal_data_module needs to be refreshed+ # when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab) |
||
| 37 | -88x | +263 | +78x |
- logger::log_debug("srv_filter_panel rendering filter panel.")
+ insertUI( |
| 38 | -88x | +264 | +78x |
- if (length(active_corrected())) {
+ selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
|
| 39 | -86x | +265 | +78x |
- datasets()$srv_active("filters", active_datanames = active_corrected)
+ where = "beforeBegin", |
| 40 | -86x | -
- datasets()$ui_active(session$ns("filters"), active_datanames = active_corrected)
- |
- ||
| 41 | -+ | 266 | +78x |
- }+ ui = tags$div(validate_ui, tags$br()) |
| 42 | +267 |
- })+ ) |
||
| 43 | +268 |
- })+ } |
||
| 44 | +269 | |||
| 45 | -86x | +270 | +87x |
- trigger_data <- .observe_active_filter_changed(datasets, is_active, active_corrected, data)+ module_labels <- unlist(module_labels(modules), use.names = FALSE) |
| 46 | -+ | |||
| 271 | +87x |
-
+ slices_global <- methods::new(".slicesGlobal", filter, module_labels)
|
||
| 47 | -86x | +272 | +87x |
- eventReactive(trigger_data(), {
+ modules_output <- srv_teal_module( |
| 48 | -89x | +273 | +87x |
- .make_filtered_teal_data(modules, data = data(), datasets = datasets(), datanames = active_corrected())+ id = "teal_modules", |
| 49 | -+ | |||
| 274 | +87x |
- })+ data = data_signatured, |
||
| 50 | -+ | |||
| 275 | +87x |
- })+ datasets = datasets_rv, |
||
| 51 | -+ | |||
| 276 | +87x |
- }+ modules = modules, |
||
| 52 | -+ | |||
| 277 | +87x |
-
+ slices_global = slices_global, |
||
| 53 | -+ | |||
| 278 | +87x |
- #' @rdname module_filter_data+ data_load_status = data_load_status |
||
| 54 | +279 |
- .make_filtered_teal_data <- function(modules, data, datasets = NULL, datanames) {
+ ) |
||
| 55 | -89x | +280 | +87x |
- data <- eval_code(+ mapping_table <- srv_filter_manager_panel("filter_manager_panel", slices_global = slices_global)
|
| 56 | -89x | +281 | +87x |
- data,+ snapshots <- srv_snapshot_manager_panel("snapshot_manager_panel", slices_global = slices_global)
|
| 57 | -89x | +282 | +87x |
- paste0(+ srv_bookmark_panel("bookmark_manager", modules)
|
| 58 | -89x | +|||
| 283 | +
- ".raw_data <- list2env(list(",
+ }) |
|||
| 59 | -89x | +|||
| 284 | +
- toString(sprintf("%1$s = %1$s", sapply(datanames, as.name))),
+
|
|||
| 60 | -89x | +285 | +87x |
- "))\n",+ invisible(NULL) |
| 61 | -89x | +|||
| 286 | +
- "lockEnvironment(.raw_data) # @linksto .raw_data" # this is environment and it is shared by qenvs. CAN'T MODIFY!+ } |
| 62 | +1 |
- )+ #' Filter settings for `teal` applications |
|
| 63 | +2 |
- )+ #' |
|
| 64 | -89x | +||
| 3 | +
- filtered_code <- .get_filter_expr(datasets = datasets, datanames = datanames)+ #' Specify initial filter states and filtering settings for a `teal` app. |
||
| 65 | -89x | +||
| 4 | +
- filtered_teal_data <- .append_evaluated_code(data, filtered_code)+ #' |
||
| 66 | -89x | +||
| 5 | +
- filtered_datasets <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)+ #' Produces a `teal_slices` object. |
||
| 67 | -89x | +||
| 6 | +
- filtered_teal_data <- .append_modified_data(filtered_teal_data, filtered_datasets)+ #' The `teal_slice` components will specify filter states that will be active when the app starts. |
||
| 68 | -89x | +||
| 7 | +
- filtered_teal_data+ #' Attributes (created with the named arguments) will configure the way the app applies filters. |
||
| 69 | +8 |
- }+ #' See argument descriptions for details. |
|
| 70 | +9 |
-
+ #' |
|
| 71 | +10 |
- #' @rdname module_filter_data+ #' @inheritParams teal.slice::teal_slices |
|
| 72 | +11 |
- .observe_active_filter_changed <- function(datasets, is_active, active_datanames, data) {
+ #' |
|
| 73 | -86x | +||
| 12 | +
- previous_signature <- reactiveVal(NULL)+ #' @param module_specific (`logical(1)`) optional, |
||
| 74 | -86x | +||
| 13 | +
- filter_changed <- reactive({
+ #' - `FALSE` (default) when one filter panel applied to all modules. |
||
| 75 | -195x | +||
| 14 | +
- req(inherits(datasets(), "FilteredData"))+ #' All filters will be shared by all modules. |
||
| 76 | -195x | +||
| 15 | +
- new_signature <- c(+ #' - `TRUE` when filter panel module-specific. |
||
| 77 | -195x | +||
| 16 | +
- teal.code::get_code(data()),+ #' Modules can have different set of filters specified - see `mapping` argument. |
||
| 78 | -195x | +||
| 17 | +
- .get_filter_expr(datasets = datasets(), datanames = active_datanames())+ #' @param mapping `r lifecycle::badge("experimental")`
|
||
| 79 | +18 |
- )+ #' _This is a new feature. Do kindly share your opinions on |
|
| 80 | -195x | +||
| 19 | +
- if (!identical(previous_signature(), new_signature)) {
+ #' [`teal`'s GitHub repository](https://github.com/insightsengineering/teal/)._ |
||
| 81 | -94x | +||
| 20 | +
- previous_signature(new_signature)+ #' |
||
| 82 | -94x | +||
| 21 | +
- TRUE+ #' (named `list`) specifies which filters will be active in which modules on app start. |
||
| 83 | +22 |
- } else {
+ #' Elements should contain character vector of `teal_slice` `id`s (see [`teal.slice::teal_slice`]). |
|
| 84 | -101x | +||
| 23 | +
- FALSE+ #' Names of the list should correspond to `teal_module` `label` set in [module()] function. |
||
| 85 | +24 |
- }+ #' - `id`s listed under `"global_filters` will be active in all modules. |
|
| 86 | +25 |
- })+ #' - If missing, all filters will be applied to all modules. |
|
| 87 | +26 |
-
+ #' - If empty list, all filters will be available to all modules but will start inactive. |
|
| 88 | -86x | +||
| 27 | +
- trigger_data <- reactiveVal(NULL)+ #' - If `module_specific` is `FALSE`, only `global_filters` will be active on start. |
||
| 89 | -86x | +||
| 28 | +
- observe({
+ #' @param app_id (`character(1)`) |
||
| 90 | -208x | +||
| 29 | +
- if (isTRUE(is_active() && filter_changed())) {
+ #' For internal use only, do not set manually. |
||
| 91 | -94x | +||
| 30 | +
- isolate({
+ #' Added by `init` so that a `teal_slices` can be matched to the app in which it was used. |
||
| 92 | -94x | +||
| 31 | +
- if (is.null(trigger_data())) {
+ #' Used for verifying snapshots uploaded from file. See `snapshot`. |
||
| 93 | -86x | +||
| 32 | +
- trigger_data(0)+ #' |
||
| 94 | +33 |
- } else {
+ #' @param x (`list`) of lists to convert to `teal_slices` |
|
| 95 | -8x | +||
| 34 | +
- trigger_data(trigger_data() + 1)+ #' |
||
| 96 | +35 |
- }+ #' @return |
|
| 97 | +36 |
- })+ #' A `teal_slices` object. |
|
| 98 | +37 |
- }+ #' |
|
| 99 | +38 |
- })+ #' @seealso [`teal.slice::teal_slices`], [`teal.slice::teal_slice`], [slices_store()] |
|
| 100 | +39 |
-
+ #' |
|
| 101 | -86x | +||
| 40 | +
- trigger_data+ #' @examples |
||
| 102 | +41 |
- }+ #' filter <- teal_slices( |
|
| 103 | +42 |
-
+ #' teal_slice(dataname = "iris", varname = "Species", id = "species"), |
|
| 104 | +43 |
- #' @rdname module_filter_data+ #' teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"), |
|
| 105 | +44 |
- .get_filter_expr <- function(datasets, datanames) {
+ #' teal_slice( |
|
| 106 | -284x | +||
| 45 | +
- if (length(datanames)) {
+ #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5" |
||
| 107 | -278x | +||
| 46 | +
- teal.slice::get_filter_expr(datasets = datasets, datanames = datanames)+ #' ), |
||
| 108 | +47 |
- } else {
+ #' teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"), |
|
| 109 | -6x | +||
| 48 | +
- NULL+ #' mapping = list( |
||
| 110 | +49 |
- }+ #' module1 = c("species", "sepal_length"),
|
|
| 111 | +50 |
- }+ #' module2 = c("mtcars_mpg"),
|
| 1 | +51 |
- #' Get client timezone+ #' global_filters = "long_petals" |
||
| 2 | +52 |
- #'+ #' ) |
||
| 3 | +53 |
- #' User timezone in the browser may be different to the one on the server.+ #' ) |
||
| 4 | +54 |
- #' This script can be run to register a `shiny` input which contains information about the timezone in the browser.+ #' |
||
| 5 | +55 |
- #'+ #' app <- init( |
||
| 6 | +56 |
- #' @param ns (`function`) namespace function passed from the `session` object in the `shiny` server.+ #' data = teal_data(iris = iris, mtcars = mtcars), |
||
| 7 | +57 |
- #' For `shiny` modules this will allow for proper name spacing of the registered input.+ #' modules = list( |
||
| 8 | +58 |
- #'+ #' module("module1"),
|
||
| 9 | +59 |
- #' @return `NULL`, invisibly.+ #' module("module2")
|
||
| 10 | +60 |
- #'+ #' ), |
||
| 11 | +61 |
- #' @keywords internal+ #' filter = filter |
||
| 12 | +62 | ++ |
+ #' )+ |
+ |
| 63 |
#' |
|||
| 13 | +64 |
- get_client_timezone <- function(ns) {
+ #' if (interactive()) {
|
||
| 14 | -88x | +|||
| 65 | +
- script <- sprintf(+ #' shinyApp(app$ui, app$server) |
|||
| 15 | -88x | +|||
| 66 | +
- "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",+ #' } |
|||
| 16 | -88x | +|||
| 67 | +
- ns("timezone")
+ #' |
|||
| 17 | +68 |
- )+ #' @export |
||
| 18 | -88x | +|||
| 69 | +
- shinyjs::runjs(script) # function does not return anything+ teal_slices <- function(..., |
|||
| 19 | -88x | +|||
| 70 | +
- invisible(NULL)+ exclude_varnames = NULL, |
|||
| 20 | +71 |
- }+ include_varnames = NULL, |
||
| 21 | +72 |
-
+ count_type = NULL, |
||
| 22 | +73 |
- #' Resolve the expected bootstrap theme+ allow_add = TRUE, |
||
| 23 | +74 |
- #' @noRd+ module_specific = FALSE, |
||
| 24 | +75 |
- #' @keywords internal+ mapping, |
||
| 25 | +76 |
- get_teal_bs_theme <- function() {
+ app_id = NULL) {
|
||
| 26 | -4x | +77 | +170x |
- bs_theme <- getOption("teal.bs_theme")
+ shiny::isolate({
|
| 27 | -+ | |||
| 78 | +170x |
-
+ checkmate::assert_flag(allow_add) |
||
| 28 | -4x | +79 | +170x |
- if (is.null(bs_theme)) {
+ checkmate::assert_flag(module_specific) |
| 29 | -1x | +80 | +53x |
- return(NULL)+ if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
|
| 30 | -+ | |||
| 81 | +167x |
- }+ checkmate::assert_string(app_id, null.ok = TRUE) |
||
| 31 | +82 | |||
| 32 | -3x | +83 | +167x |
- if (!checkmate::test_class(bs_theme, "bs_theme")) {
+ slices <- list(...) |
| 33 | -2x | +84 | +167x |
- warning(+ all_slice_id <- vapply(slices, `[[`, character(1L), "id")+ |
+
| 85 | ++ | + | ||
| 34 | -2x | +86 | +167x |
- "Assertion on 'teal.bs_theme' option value failed: ",+ if (missing(mapping)) {
|
| 35 | -2x | +87 | +117x |
- checkmate::check_class(bs_theme, "bs_theme"),+ mapping <- if (length(all_slice_id)) {
|
| 36 | -2x | +88 | +26x |
- ". The default Shiny Bootstrap theme will be used."+ list(global_filters = all_slice_id) |
| 37 | +89 |
- )+ } else {
|
||
| 38 | -2x | +90 | +91x |
- return(NULL)+ list() |
| 39 | +91 |
- }+ } |
||
| 40 | +92 | ++ |
+ }+ |
+ |
| 93 | ||||
| 41 | -1x | +94 | +167x |
- bs_theme+ if (!module_specific) {
+ |
+
| 95 | +148x | +
+ mapping[setdiff(names(mapping), "global_filters")] <- NULL |
||
| 42 | +96 |
- }+ } |
||
| 43 | +97 | |||
| 44 | -+ | |||
| 98 | +167x |
- #' Return parentnames along with datanames.+ failed_slice_id <- setdiff(unlist(mapping), all_slice_id)+ |
+ ||
| 99 | +167x | +
+ if (length(failed_slice_id)) {
+ |
+ ||
| 100 | +1x | +
+ stop(sprintf(+ |
+ ||
| 101 | +1x | +
+ "Filters in mapping don't match any available filter.\n %s not in %s",+ |
+ ||
| 102 | +1x | +
+ toString(failed_slice_id),+ |
+ ||
| 103 | +1x | +
+ toString(all_slice_id) |
||
| 45 | +104 |
- #' @noRd+ )) |
||
| 46 | +105 |
- #' @keywords internal+ } |
||
| 47 | +106 |
- .include_parent_datanames <- function(datanames, join_keys) {
+
|
||
| 48 | -32x | +107 | +166x |
- ordered_datanames <- datanames+ tss <- teal.slice::teal_slices( |
| 49 | -32x | +|||
| 108 | +
- for (current in datanames) {
+ ..., |
|||
| 50 | -62x | +109 | +166x |
- parents <- character(0L)+ exclude_varnames = exclude_varnames, |
| 51 | -62x | +110 | +166x |
- while (length(current) > 0) {
+ include_varnames = include_varnames, |
| 52 | -64x | +111 | +166x |
- current <- teal.data::parent(join_keys, current)+ count_type = count_type, |
| 53 | -64x | +112 | +166x |
- parents <- c(current, parents)+ allow_add = allow_add |
| 54 | +113 |
- }+ ) |
||
| 55 | -62x | -
- ordered_datanames <- c(parents, ordered_datanames)- |
- ||
| 56 | -+ | 114 | +166x |
- }+ attr(tss, "mapping") <- mapping |
| 57 | -+ | |||
| 115 | +166x |
-
+ attr(tss, "module_specific") <- module_specific |
||
| 58 | -32x | +116 | +166x |
- unique(ordered_datanames)+ attr(tss, "app_id") <- app_id |
| 59 | -+ | |||
| 117 | +166x |
- }+ class(tss) <- c("modules_teal_slices", class(tss))
|
||
| 60 | -+ | |||
| 118 | +166x |
-
+ tss |
||
| 61 | +119 |
- #' Create a `FilteredData`+ }) |
||
| 62 | +120 |
- #'+ } |
||
| 63 | +121 |
- #' Create a `FilteredData` object from a `teal_data` object.+ |
||
| 64 | +122 |
- #'+ |
||
| 65 | +123 |
- #' @param x (`teal_data`) object+ #' @rdname teal_slices |
||
| 66 | +124 |
- #' @param datanames (`character`) vector of data set names to include; must be subset of `names(x)`+ #' @export |
||
| 67 | +125 |
- #' @return A `FilteredData` object.+ #' @keywords internal |
||
| 68 | +126 |
- #' @keywords internal+ #' |
||
| 69 | +127 |
- teal_data_to_filtered_data <- function(x, datanames = names(x)) {
+ as.teal_slices <- function(x) { # nolint: object_name.
|
||
| 70 | -83x | +128 | +15x |
- checkmate::assert_class(x, "teal_data")+ checkmate::assert_list(x) |
| 71 | -83x | +129 | +15x |
- checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)+ lapply(x, checkmate::assert_list, names = "named", .var.name = "list element") |
| 72 | +130 |
- # Otherwise, FilteredData will be created in the modules' scope later+ |
||
| 73 | -83x | +131 | +15x |
- teal.slice::init_filtered_data(+ attrs <- attributes(unclass(x)) |
| 74 | -83x | +132 | +15x |
- x = Filter(length, sapply(datanames, function(dn) x[[dn]], simplify = FALSE)),+ ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x)) |
| 75 | -83x | -
- join_keys = teal.data::join_keys(x)- |
- ||
| 76 | -+ | 133 | +15x |
- )+ do.call(teal_slices, c(ans, attrs)) |
| 77 | +134 |
} |
||
| 78 | +135 | |||
| 79 | +136 | |||
| 80 | +137 |
- #' Template function for `TealReportCard` creation and customization+ #' @rdname teal_slices |
||
| 81 | +138 |
- #'+ #' @export |
||
| 82 | +139 |
- #' This function generates a report card with a title,+ #' @keywords internal |
||
| 83 | +140 |
- #' an optional description, and the option to append the filter state list.+ #' |
||
| 84 | +141 |
- #'+ c.teal_slices <- function(...) {
|
||
| 85 | +||||
| 142 | +6x | +
+ x <- list(...)+ |
+ ||
| 143 | +6x | +
+ checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ |
+ ||
| 144 |
- #' @param title (`character(1)`) title of the card (unless overwritten by label)+ + |
+ |||
| 145 | +6x | +
+ all_attributes <- lapply(x, attributes)+ |
+ ||
| 146 | +6x | +
+ all_attributes <- coalesce_r(all_attributes)+ |
+ ||
| 147 | +6x | +
+ all_attributes <- all_attributes[names(all_attributes) != "class"] |
||
| 86 | +148 |
- #' @param label (`character(1)`) label provided by the user when adding the card+ + |
+ ||
| 149 | +6x | +
+ do.call(+ |
+ ||
| 150 | +6x | +
+ teal_slices,+ |
+ ||
| 151 | +6x | +
+ c(+ |
+ ||
| 152 | +6x | +
+ unique(unlist(x, recursive = FALSE)),+ |
+ ||
| 153 | +6x | +
+ all_attributes |
||
| 87 | +154 |
- #' @param description (`character(1)`) optional, additional description+ ) |
||
| 88 | +155 |
- #' @param with_filter (`logical(1)`) flag indicating to add filter state+ ) |
||
| 89 | +156 |
- #' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation+ } |
||
| 90 | +157 |
- #' of the filter state in the report+ |
||
| 91 | +158 |
- #'+ |
||
| 92 | +159 |
- #' @return (`TealReportCard`) populated with a title, description and filter state.+ #' Deep copy `teal_slices` |
||
| 93 | +160 |
#' |
||
| 94 | +161 |
- #' @export+ #' it's important to create a new copy of `teal_slices` when |
||
| 95 | +162 |
- report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
+ #' starting a new `shiny` session. Otherwise, object will be shared |
||
| 96 | -2x | +|||
| 163 | +
- checkmate::assert_string(title)+ #' by multiple users as it is created in global environment before |
|||
| 97 | -2x | +|||
| 164 | +
- checkmate::assert_string(label)+ #' `shiny` session starts. |
|||
| 98 | -2x | +|||
| 165 | +
- checkmate::assert_string(description, null.ok = TRUE)+ #' @param filter (`teal_slices`) |
|||
| 99 | -2x | +|||
| 166 | +
- checkmate::assert_flag(with_filter)+ #' @return `teal_slices` |
|||
| 100 | -2x | +|||
| 167 | +
- checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")+ #' @keywords internal |
|||
| 101 | +168 |
-
+ deep_copy_filter <- function(filter) {
|
||
| 102 | -2x | +169 | +1x |
- card <- teal::TealReportCard$new()+ checkmate::assert_class(filter, "teal_slices") |
| 103 | -2x | +170 | +1x |
- title <- if (label == "") title else label+ shiny::isolate({
|
| 104 | -2x | +171 | +1x |
- card$set_name(title)+ filter_copy <- lapply(filter, function(slice) {
|
| 105 | +172 | 2x |
- card$append_text(title, "header2")+ teal.slice::as.teal_slice(as.list(slice))+ |
+ |
| 173 | ++ |
+ }) |
||
| 106 | +174 | 1x |
- if (!is.null(description)) card$append_text(description, "header3")+ attributes(filter_copy) <- attributes(filter) |
|
| 107 | +175 | 1x |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ filter_copy |
|
| 108 | -2x | +|||
| 176 | +
- card+ }) |
|||
| 109 | +177 |
} |
| 110 | +1 |
-
+ #' Data module for `teal` transformations and output customization |
||
| 111 | +2 |
-
+ #' |
||
| 112 | +3 |
- #' Check `datanames` in modules+ #' @description |
||
| 113 | +4 |
- #'+ #' `r lifecycle::badge("experimental")`
|
||
| 114 | +5 |
- #' These functions check if specified `datanames` in modules match those in the data object,+ #' |
||
| 115 | +6 |
- #' returning error messages or `TRUE` for successful validation. Two functions return error message+ #' `teal_transform_module` provides a `shiny` module that enables data transformations within a `teal` application |
||
| 116 | +7 |
- #' in different forms:+ #' and allows for customization of outputs generated by modules. |
||
| 117 | +8 |
- #' - `check_modules_datanames` returns `character(1)` for basic assertion usage+ #' |
||
| 118 | +9 |
- #' - `check_modules_datanames_html` returns `shiny.tag.list` to display it in the app.+ #' # Transforming Module Inputs in `teal` |
||
| 119 | +10 |
#' |
||
| 120 | +11 |
- #' @param modules (`teal_modules`) object+ #' Data transformations occur after data has been filtered in `teal`. |
||
| 121 | +12 |
- #' @param datanames (`character`) names of datasets available in the `data` object+ #' The transformed data is then passed to the `server` of [`teal_module()`] and managed by `teal`'s internal processes. |
||
| 122 | +13 |
- #'+ #' The primary advantage of `teal_transform_module` over custom modules is in its error handling, where all warnings and |
||
| 123 | +14 |
- #' @return `TRUE` if validation passes, otherwise `character(1)` or `shiny.tag.list`+ #' errors are managed by `teal`, allowing developers to focus on transformation logic. |
||
| 124 | +15 |
- #' @keywords internal+ #' |
||
| 125 | +16 |
- check_modules_datanames <- function(modules, datanames) {
+ #' For more details, see the vignette: `vignette("data-transform-as-shiny-module", package = "teal")`.
|
||
| 126 | -11x | +|||
| 17 | +
- out <- check_modules_datanames_html(modules, datanames)+ #' |
|||
| 127 | -11x | +|||
| 18 | +
- if (inherits(out, "shiny.tag.list")) {
+ #' # Customizing Module Outputs |
|||
| 128 | -5x | +|||
| 19 | +
- out_with_ticks <- gsub("<code>|</code>", "`", toString(out))
+ #' |
|||
| 129 | -5x | +|||
| 20 | +
- out_text <- gsub("<[^<>]+>", "", toString(out_with_ticks))
+ #' `teal_transform_module` also allows developers to modify any object created within [`teal.data::teal_data`]. |
|||
| 130 | -5x | +|||
| 21 | +
- trimws(gsub("[[:space:]]+", " ", out_text))
+ #' This means you can use it to customize not only datasets but also tables, listings, and graphs. |
|||
| 131 | +22 |
- } else {
+ #' Some [`teal_modules`] permit developers to inject custom `shiny` modules to enhance displayed outputs. |
||
| 132 | -6x | +|||
| 23 | +
- out+ #' To manage these `decorators` within your module, use [`ui_transform_teal_data()`] and [`srv_transform_teal_data()`]. |
|||
| 133 | +24 |
- }+ #' (For further guidance on managing decorators, refer to `ui_args` and `srv_args` in the vignette documentation.) |
||
| 134 | +25 |
- }+ #' |
||
| 135 | +26 |
-
+ #' See the vignette `vignette("decorate-modules-output", package = "teal")` for additional examples.
|
||
| 136 | +27 |
- #' @rdname check_modules_datanames+ #' |
||
| 137 | +28 |
- check_reserved_datanames <- function(datanames) {
+ #' # `server` as a language |
||
| 138 | -190x | +|||
| 29 | +
- reserved_datanames <- datanames[datanames %in% c("all", ".raw_data")]
+ #' |
|||
| 139 | -190x | +|||
| 30 | +
- if (length(reserved_datanames) == 0L) {
+ #' The `server` function in `teal_transform_module` must return a reactive [`teal.data::teal_data`] object. |
|||
| 140 | -184x | +|||
| 31 | +
- return(NULL)+ #' For simple transformations without complex reactivity, the `server` function might look like this:s |
|||
| 141 | +32 |
- }+ #' |
||
| 142 | +33 |
-
+ #' ``` |
||
| 143 | -6x | +|||
| 34 | +
- tags$span(+ #' function(id, data) {
|
|||
| 144 | -6x | +|||
| 35 | +
- to_html_code_list(reserved_datanames),+ #' moduleServer(id, function(input, output, session) {
|
|||
| 145 | -6x | +|||
| 36 | +
- sprintf(+ #' reactive({
|
|||
| 146 | -6x | +|||
| 37 | +
- "%s reserved for internal use. Please avoid using %s as %s.",+ #' within( |
|||
| 147 | -6x | +|||
| 38 | +
- pluralize(reserved_datanames, "is", "are"),+ #' data(), |
|||
| 148 | -6x | +|||
| 39 | +
- pluralize(reserved_datanames, "it", "them"),+ #' expr = x <- subset(x, col == level), |
|||
| 149 | -6x | +|||
| 40 | +
- pluralize(reserved_datanames, "a dataset name", "dataset names")+ #' level = input$level |
|||
| 150 | +41 |
- )+ #' ) |
||
| 151 | +42 |
- )+ #' }) |
||
| 152 | +43 |
- }+ #' }) |
||
| 153 | +44 |
-
+ #' } |
||
| 154 | +45 |
- #' @rdname check_modules_datanames+ #' ``` |
||
| 155 | +46 |
- check_modules_datanames_html <- function(modules, datanames) {
+ #' |
||
| 156 | -190x | +|||
| 47 | +
- check_datanames <- check_modules_datanames_recursive(modules, datanames)+ #' The example above can be simplified using `make_teal_transform_server`, where `level` is automatically matched to the |
|||
| 157 | -190x | +|||
| 48 | +
- show_module_info <- inherits(modules, "teal_modules") # used in two contexts - module and app+ #' corresponding `input` parameter: |
|||
| 158 | +49 |
-
+ #' |
||
| 159 | -190x | +|||
| 50 | +
- reserved_datanames <- check_reserved_datanames(datanames)+ #' ``` |
|||
| 160 | +51 |
-
+ #' make_teal_transform_server(expr = expression(x <- subset(x, col == level))) |
||
| 161 | -190x | +|||
| 52 | +
- if (!length(check_datanames)) {
+ #' ``` |
|||
| 162 | -172x | +|||
| 53 | +
- out <- if (is.null(reserved_datanames)) {
+ #' @inheritParams teal_data_module |
|||
| 163 | -166x | +|||
| 54 | +
- TRUE+ #' @param server (`function(id, data)` or `expression`) |
|||
| 164 | +55 |
- } else {
+ #' A `shiny` module server function that takes `id` and `data` as arguments, where `id` is the module id and `data` |
||
| 165 | -6x | +|||
| 56 | +
- shiny::tagList(reserved_datanames)+ #' is the reactive `teal_data` input. The `server` function must return a reactive expression containing a `teal_data` |
|||
| 166 | +57 |
- }+ #' object. For simplified syntax, use [`make_teal_transform_server()`]. |
||
| 167 | -172x | +|||
| 58 | +
- return(out)+ #' @param datanames (`character`) |
|||
| 168 | +59 |
- }+ #' Specifies the names of datasets relevant to the module. Only filters for the specified `datanames` will be displayed |
||
| 169 | -18x | +|||
| 60 | +
- shiny::tagList(+ #' in the filter panel. The keyword `"all"` can be used to display filters for all datasets. `datanames` are |
|||
| 170 | -18x | +|||
| 61 | +
- reserved_datanames,+ #' automatically appended to the [`modules()`] `datanames`. |
|||
| 171 | -18x | +|||
| 62 | +
- lapply(+ #' |
|||
| 172 | -18x | +|||
| 63 | +
- check_datanames,+ #' |
|||
| 173 | -18x | +|||
| 64 | +
- function(mod) {
+ #' @examples |
|||
| 174 | -18x | +|||
| 65 | +
- tagList(+ #' data_transformators <- list( |
|||
| 175 | -18x | +|||
| 66 | +
- tags$span(+ #' teal_transform_module( |
|||
| 176 | -18x | +|||
| 67 | +
- tags$span(pluralize(mod$missing_datanames, "Dataset")),+ #' label = "Static transformator for iris", |
|||
| 177 | -18x | +|||
| 68 | +
- to_html_code_list(mod$missing_datanames),+ #' datanames = "iris", |
|||
| 178 | -18x | +|||
| 69 | +
- tags$span(+ #' server = function(id, data) {
|
|||
| 179 | -18x | +|||
| 70 | +
- sprintf(+ #' moduleServer(id, function(input, output, session) {
|
|||
| 180 | -18x | +|||
| 71 | +
- "%s missing%s.",+ #' reactive({
|
|||
| 181 | -18x | +|||
| 72 | +
- pluralize(mod$missing_datanames, "is", "are"),+ #' within(data(), {
|
|||
| 182 | -18x | +|||
| 73 | +
- if (show_module_info) sprintf(" for module '%s'", mod$label) else ""
+ #' iris <- head(iris, 5) |
|||
| 183 | +74 |
- )+ #' }) |
||
| 184 | +75 |
- )+ #' }) |
||
| 185 | +76 |
- ),+ #' }) |
||
| 186 | -18x | +|||
| 77 | +
- if (length(datanames) >= 1) {
+ #' } |
|||
| 187 | -16x | +|||
| 78 | +
- tagList(+ #' ), |
|||
| 188 | -16x | +|||
| 79 | +
- tags$span(pluralize(datanames, "Dataset")),+ #' teal_transform_module( |
|||
| 189 | -16x | +|||
| 80 | +
- tags$span("available in data:"),
+ #' label = "Interactive transformator for iris", |
|||
| 190 | -16x | +|||
| 81 | +
- tagList(+ #' datanames = "iris", |
|||
| 191 | -16x | +|||
| 82 | +
- tags$span(+ #' ui = function(id) {
|
|||
| 192 | -16x | +|||
| 83 | +
- to_html_code_list(datanames),+ #' ns <- NS(id) |
|||
| 193 | -16x | +|||
| 84 | +
- tags$span(".", .noWS = "outside"),
+ #' tags$div( |
|||
| 194 | -16x | +|||
| 85 | +
- .noWS = c("outside")
+ #' numericInput(ns("n_cols"), "Show n columns", value = 5, min = 1, max = 5, step = 1)
|
|||
| 195 | +86 |
- )+ #' ) |
||
| 196 | +87 |
- )+ #' }, |
||
| 197 | +88 |
- )+ #' server = function(id, data) {
|
||
| 198 | +89 |
- } else {
+ #' moduleServer(id, function(input, output, session) {
|
||
| 199 | -2x | +|||
| 90 | +
- tags$span("No datasets are available in data.")
+ #' reactive({
|
|||
| 200 | +91 |
- },+ #' within(data(), |
||
| 201 | -18x | +|||
| 92 | +
- tags$br(.noWS = "before")+ #' {
|
|||
| 202 | +93 |
- )+ #' iris <- iris[, 1:n_cols] |
||
| 203 | +94 |
- }+ #' }, |
||
| 204 | +95 |
- )+ #' n_cols = input$n_cols |
||
| 205 | +96 |
- )+ #' ) |
||
| 206 | +97 |
- }+ #' }) |
||
| 207 | +98 |
-
+ #' }) |
||
| 208 | +99 |
- #' Recursively checks modules and returns list for every datanames mismatch between module and data+ #' } |
||
| 209 | +100 |
- #' @noRd+ #' ) |
||
| 210 | +101 |
- check_modules_datanames_recursive <- function(modules, datanames) { # nolint: object_name_length
+ #' ) |
||
| 211 | -296x | +|||
| 102 | +
- checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
+ #' |
|||
| 212 | -296x | +|||
| 103 | +
- checkmate::assert_character(datanames)+ #' output_decorator <- teal_transform_module( |
|||
| 213 | -296x | +|||
| 104 | +
- if (inherits(modules, "teal_modules")) {
+ #' server = make_teal_transform_server( |
|||
| 214 | -86x | +|||
| 105 | +
- unlist(+ #' expression( |
|||
| 215 | -86x | +|||
| 106 | +
- lapply(modules$children, check_modules_datanames_recursive, datanames = datanames),+ #' object <- rev(object) |
|||
| 216 | -86x | +|||
| 107 | +
- recursive = FALSE+ #' ) |
|||
| 217 | +108 |
- )+ #' ) |
||
| 218 | +109 |
- } else {
+ #' ) |
||
| 219 | -210x | +|||
| 110 | +
- missing_datanames <- setdiff(modules$datanames, c("all", datanames))
+ #' |
|||
| 220 | -210x | +|||
| 111 | +
- if (length(missing_datanames)) {
+ #' app <- init( |
|||
| 221 | -18x | +|||
| 112 | +
- list(list(+ #' data = teal_data(iris = iris), |
|||
| 222 | -18x | +|||
| 113 | +
- label = modules$label,+ #' modules = example_module( |
|||
| 223 | -18x | +|||
| 114 | +
- missing_datanames = missing_datanames+ #' transformators = data_transformators, |
|||
| 224 | +115 |
- ))+ #' decorators = list(output_decorator) |
||
| 225 | +116 |
- }+ #' ) |
||
| 226 | +117 |
- }+ #' ) |
||
| 227 | +118 |
- }+ #' if (interactive()) {
|
||
| 228 | +119 |
-
+ #' shinyApp(app$ui, app$server) |
||
| 229 | +120 |
- #' Convert character vector to html code separated with commas and "and"+ #' } |
||
| 230 | +121 |
- #' @noRd+ #' |
||
| 231 | +122 |
- to_html_code_list <- function(x) {
+ #' @name teal_transform_module |
||
| 232 | -40x | +|||
| 123 | +
- checkmate::assert_character(x)+ #' |
|||
| 233 | -40x | +|||
| 124 | +
- do.call(+ #' @export |
|||
| 234 | -40x | +|||
| 125 | +
- tagList,+ teal_transform_module <- function(ui = NULL, |
|||
| 235 | -40x | +|||
| 126 | +
- lapply(seq_along(x), function(.ix) {
+ server = function(id, data) data, |
|||
| 236 | -56x | +|||
| 127 | +
- tagList(+ label = "transform module", |
|||
| 237 | -56x | +|||
| 128 | +
- tags$code(x[.ix]),+ datanames = "all") {
|
|||
| 238 | -56x | +129 | +25x |
- if (.ix != length(x)) {
+ structure( |
| 239 | -1x | +130 | +25x |
- if (.ix == length(x) - 1) tags$span(" and ") else tags$span(", ", .noWS = "before")
+ list( |
| 240 | -+ | |||
| 131 | +25x |
- }+ ui = ui, |
||
| 241 | -+ | |||
| 132 | +25x |
- )+ server = function(id, data) {
|
||
| 242 | -+ | |||
| 133 | +26x |
- })+ data_out <- server(id, data) |
||
| 243 | +134 |
- )+ |
||
| 244 | -+ | |||
| 135 | +26x |
- }+ if (inherits(data_out, "reactive.event")) {
|
||
| 245 | +136 |
-
+ # This warning message partially detects when `eventReactive` is used in `data_module`. |
||
| 246 | -+ | |||
| 137 | +1x |
-
+ warning( |
||
| 247 | -+ | |||
| 138 | +1x |
- #' Check `datanames` in filters+ "teal_transform_module() ", |
||
| 248 | -+ | |||
| 139 | +1x |
- #'+ "Using eventReactive in teal_transform module server code should be avoided as it ", |
||
| 249 | -+ | |||
| 140 | +1x |
- #' This function checks whether `datanames` in filters correspond to those in `data`,+ "may lead to unexpected behavior. See the vignettes for more information ", |
||
| 250 | -+ | |||
| 141 | +1x |
- #' returning character vector with error messages or `TRUE` if all checks pass.+ "(`vignette(\"data-transform-as-shiny-module\", package = \"teal\")`).", |
||
| 251 | -+ | |||
| 142 | +1x |
- #'+ call. = FALSE |
||
| 252 | +143 |
- #' @param filters (`teal_slices`) object+ ) |
||
| 253 | +144 |
- #' @param datanames (`character`) names of datasets available in the `data` object+ } |
||
| 254 | +145 |
- #'+ |
||
| 255 | +146 |
- #' @return A `character(1)` containing error message or TRUE if validation passes.+ |
||
| 256 | -+ | |||
| 147 | +26x |
- #' @keywords internal+ decorate_err_msg( |
||
| 257 | -+ | |||
| 148 | +26x |
- check_filter_datanames <- function(filters, datanames) {
+ assert_reactive(data_out), |
||
| 258 | -86x | +149 | +26x |
- checkmate::assert_class(filters, "teal_slices")+ pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
|
| 259 | -86x | +150 | +26x |
- checkmate::assert_character(datanames)+ post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter. |
| 260 | +151 |
-
+ ) |
||
| 261 | +152 |
- # check teal_slices against datanames- |
- ||
| 262 | -86x | -
- out <- unlist(sapply(- |
- ||
| 263 | -86x | -
- filters, function(filter) {
- |
- ||
| 264 | -24x | -
- dataname <- shiny::isolate(filter$dataname)+ } |
||
| 265 | -24x | +|||
| 153 | +
- if (!dataname %in% datanames) {
+ ), |
|||
| 266 | -3x | +154 | +25x |
- sprintf(+ label = label, |
| 267 | -3x | +155 | +25x |
- "- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)",+ datanames = datanames, |
| 268 | -3x | +156 | +25x |
- shiny::isolate(filter$id),+ class = c("teal_transform_module", "teal_data_module")
|
| 269 | -3x | +|||
| 157 | +
- dQuote(dataname, q = FALSE),+ ) |
|||
| 270 | -3x | +|||
| 158 | +
- toString(dQuote(datanames, q = FALSE))+ } |
|||
| 271 | +159 |
- )+ |
||
| 272 | +160 |
- }+ #' Make teal_transform_module's server |
||
| 273 | +161 |
- }+ #' |
||
| 274 | +162 |
- ))+ #' A factory function to simplify creation of a [`teal_transform_module`]'s server. Specified `expr` |
||
| 275 | +163 |
-
+ #' is wrapped in a shiny module function and output can be passed to the `server` argument in |
||
| 276 | +164 |
-
+ #' [teal_transform_module()] call. Such a server function can be linked with ui and values from the |
||
| 277 | -86x | +|||
| 165 | +
- if (length(out)) {
+ #' inputs can be used in the expression. Object names specified in the expression will be substituted |
|||
| 278 | -3x | +|||
| 166 | +
- paste(out, collapse = "\n")+ #' with the value of the respective input (matched by the name) - for example in |
|||
| 279 | +167 |
- } else {
+ #' `expression(graph <- graph + ggtitle(title))` object `title` will be replaced with the value of |
||
| 280 | -83x | +|||
| 168 | +
- TRUE+ #' `input$title`. |
|||
| 281 | +169 |
- }+ #' @param expr (`language`) |
||
| 282 | +170 |
- }+ #' An R call which will be evaluated within [`teal.data::teal_data`] environment. |
||
| 283 | +171 |
-
+ #' @return `function(id, data)` returning `shiny` module |
||
| 284 | +172 |
- #' Function for validating the title parameter of `teal::init`+ #' @examples |
||
| 285 | +173 |
#' |
||
| 286 | +174 |
- #' Checks if the input of the title from `teal::init` will create a valid title and favicon tag.+ #' trim_iris <- teal_transform_module( |
||
| 287 | +175 |
- #' @param shiny_tag (`shiny.tag`) Object to validate for a valid title.+ #' label = "Simplified interactive transformator for iris", |
||
| 288 | +176 |
- #' @keywords internal+ #' datanames = "iris", |
||
| 289 | +177 |
- validate_app_title_tag <- function(shiny_tag) {
- |
- ||
| 290 | -7x | -
- checkmate::assert_class(shiny_tag, "shiny.tag")- |
- ||
| 291 | -7x | -
- checkmate::assert_true(shiny_tag$name == "head")- |
- ||
| 292 | -6x | -
- child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name")- |
- ||
| 293 | -6x | -
- checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags")
- |
- ||
| 294 | -4x | -
- rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel+ #' ui = function(id) {
|
||
| 295 | -4x | +|||
| 178 | +
- checkmate::assert_subset(+ #' ns <- NS(id) |
|||
| 296 | -4x | +|||
| 179 | +
- rel_attr,+ #' numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
|
|||
| 297 | -4x | +|||
| 180 | +
- c("icon", "shortcut icon"),
+ #' }, |
|||
| 298 | -4x | +|||
| 181 | +
- .var.name = "Link tag's rel attribute",+ #' server = make_teal_transform_server(expression(iris <- head(iris, n_rows))) |
|||
| 299 | -4x | +|||
| 182 | +
- empty.ok = FALSE+ #' ) |
|||
| 300 | +183 |
- )+ #' |
||
| 301 | +184 |
- }+ #' app <- init( |
||
| 302 | +185 |
-
+ #' data = teal_data(iris = iris), |
||
| 303 | +186 |
- #' Build app title with favicon+ #' modules = example_module(transformators = trim_iris) |
||
| 304 | +187 |
- #'+ #' ) |
||
| 305 | +188 |
- #' A helper function to create the browser title along with a logo.+ #' if (interactive()) {
|
||
| 306 | +189 |
- #'+ #' shinyApp(app$ui, app$server) |
||
| 307 | +190 |
- #' @param title (`character`) The browser title for the `teal` app.+ #' } |
||
| 308 | +191 |
- #' @param favicon (`character`) The path for the icon for the title.+ #' |
||
| 309 | +192 |
- #' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/`+ #' @export |
||
| 310 | +193 |
- #'+ make_teal_transform_server <- function(expr) {
|
||
| 311 | -+ | |||
| 194 | +3x |
- #' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app.+ if (is.call(expr)) {
|
||
| 312 | -+ | |||
| 195 | +1x |
- #' @export+ expr <- as.expression(expr) |
||
| 313 | +196 |
- build_app_title <- function(+ } |
||
| 314 | -+ | |||
| 197 | +3x |
- title = "teal app",+ checkmate::assert_multi_class(expr, c("call", "expression"))
|
||
| 315 | +198 |
- favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
+
|
||
| 316 | -15x | +199 | +3x |
- checkmate::assert_string(title, null.ok = TRUE)+ function(id, data) {
|
| 317 | -15x | +200 | +3x |
- checkmate::assert_string(favicon, null.ok = TRUE)+ moduleServer(id, function(input, output, session) {
|
| 318 | -15x | +201 | +3x |
- tags$head(+ list_env <- reactive( |
| 319 | -15x | +202 | +3x |
- tags$title(title),+ lapply(rlang::set_names(names(input)), function(x) input[[x]]) |
| 320 | -15x | +|||
| 203 | +
- tags$link(+ )+ |
+ |||
| 204 | ++ | + | ||
| 321 | -15x | +205 | +3x |
- rel = "icon",+ reactive({
|
| 322 | -15x | +206 | +4x |
- href = favicon,+ call_with_inputs <- lapply(expr, function(x) {
|
| 323 | -15x | +207 | +4x |
- sizes = "any"+ do.call(what = substitute, args = list(expr = x, env = list_env())) |
| 324 | +208 |
- )+ })+ |
+ ||
| 209 | +4x | +
+ eval_code(object = data(), code = as.expression(call_with_inputs)) |
||
| 325 | +210 |
- )+ }) |
||
| 326 | +211 |
- }+ }) |
||
| 327 | +212 |
-
+ } |
||
| 328 | +213 |
- #' Application ID+ } |
||
| 329 | +214 |
- #'+ |
||
| 330 | +215 |
- #' Creates App ID used to match filter snapshots to application.+ #' Extract all `transformators` from `modules`. |
||
| 331 | +216 |
#' |
||
| 332 | +217 |
- #' Calculate app ID that will be used to stamp filter state snapshots.+ #' @param modules `teal_modules` or `teal_module` |
||
| 333 | +218 |
- #' App ID is a hash of the app's data and modules.+ #' @return A list of `teal_transform_module` nested in the same way as input `modules`. |
||
| 334 | +219 |
- #' See "transferring snapshots" section in ?snapshot.+ #' @keywords internal |
||
| 335 | +220 |
- #'+ extract_transformators <- function(modules) {
|
||
| 336 | -+ | |||
| 221 | +10x |
- #' @param data (`teal_data` or `teal_data_module`) as accepted by `init`+ if (inherits(modules, "teal_module")) {
+ |
+ ||
| 222 | +5x | +
+ modules$transformators+ |
+ ||
| 223 | +5x | +
+ } else if (inherits(modules, "teal_modules")) {
+ |
+ ||
| 224 | +5x | +
+ lapply(modules$children, extract_transformators) |
||
| 337 | +225 |
- #' @param modules (`teal_modules`) object as accepted by `init`+ } |
||
| 338 | +226 |
- #'+ } |
| 339 | +1 |
- #' @return A single character string.+ #' Filter state snapshot management |
||
| 340 | +2 |
#' |
||
| 341 | +3 |
- #' @keywords internal+ #' Capture and restore snapshots of the global (app) filter state. |
||
| 342 | +4 |
- create_app_id <- function(data, modules) {
+ #' |
||
| 343 | -23x | +|||
| 5 | +
- checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
+ #' This module introduces snapshots: stored descriptions of the filter state of the entire application. |
|||
| 344 | -22x | +|||
| 6 | +
- checkmate::assert_class(modules, "teal_modules")+ #' Snapshots allow the user to save the current filter state of the application for later use in the session, |
|||
| 345 | +7 |
-
+ #' as well as to save it to file in order to share it with an app developer or other users, |
||
| 346 | -21x | +|||
| 8 | +
- data <- if (inherits(data, "teal_data")) {
+ #' who in turn can upload it to their own session. |
|||
| 347 | -19x | +|||
| 9 | +
- as.list(data)+ #' |
|||
| 348 | -21x | +|||
| 10 | +
- } else if (inherits(data, "teal_data_module")) {
+ #' The snapshot manager is accessed with the camera icon in the tabset bar. |
|||
| 349 | -2x | +|||
| 11 | +
- deparse1(body(data$server))+ #' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow. |
|||
| 350 | +12 |
- }+ #' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file |
||
| 351 | -21x | +|||
| 13 | +
- modules <- lapply(modules, defunction)+ #' and applies the filter states therein, and clicking the arrow resets initial application state. |
|||
| 352 | +14 |
-
+ #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button. |
||
| 353 | -21x | +|||
| 15 | +
- rlang::hash(list(data = data, modules = modules))+ #' |
|||
| 354 | +16 |
- }+ #' @section Server logic: |
||
| 355 | +17 |
-
+ #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance |
||
| 356 | +18 |
- #' Go through list and extract bodies of encountered functions as string, recursively.+ #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices` |
||
| 357 | +19 |
- #' @keywords internal+ #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation |
||
| 358 | +20 |
- #' @noRd+ #' (attributes are maintained). |
||
| 359 | +21 |
- defunction <- function(x) {
+ #' |
||
| 360 | -297x | +|||
| 22 | +
- if (is.list(x)) {
+ #' Snapshots are stored in a `reactiveVal` as a named list. |
|||
| 361 | -121x | +|||
| 23 | +
- lapply(x, defunction)+ #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit. |
|||
| 362 | -176x | +|||
| 24 | +
- } else if (is.function(x)) {
+ #' |
|||
| 363 | -54x | +|||
| 25 | +
- deparse1(body(x))+ #' For every snapshot except the initial one, a piece of UI is generated that contains |
|||
| 364 | +26 |
- } else {
+ #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file. |
||
| 365 | -122x | +|||
| 27 | +
- x+ #' The initial snapshot is restored by a separate "reset" button. |
|||
| 366 | +28 |
- }+ #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that. |
||
| 367 | +29 |
- }+ #' |
||
| 368 | +30 |
-
+ #' @section Snapshot mechanics: |
||
| 369 | +31 |
- #' Get unique labels+ #' When a snapshot is captured, the user is prompted to name it. |
||
| 370 | +32 |
- #'+ #' Names are displayed as is but since they are used to create button ids, |
||
| 371 | +33 |
- #' Get unique labels for the modules to avoid namespace conflicts.+ #' under the hood they are converted to syntactically valid strings. |
||
| 372 | +34 |
- #'+ #' New snapshot names are validated so that their valid versions are unique. |
||
| 373 | +35 |
- #' @param labels (`character`) vector of labels+ #' Leading and trailing white space is trimmed. |
||
| 374 | +36 |
#' |
||
| 375 | +37 |
- #' @return (`character`) vector of unique labels+ #' The module can read the global state of the application from `slices_global` and `mapping_matrix`. |
||
| 376 | +38 |
- #'+ #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module. |
||
| 377 | +39 |
- #' @keywords internal+ #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot. |
||
| 378 | +40 |
- get_unique_labels <- function(labels) {
- |
- ||
| 379 | -141x | -
- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
+ #' The snapshot contains the `mapping` attribute of the initial application state |
||
| 380 | +41 |
- }+ #' (or one that has been restored), which may not reflect the current one, |
||
| 381 | +42 |
-
+ #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that, |
||
| 382 | +43 |
- #' @keywords internal+ #' when passed to the `mapping` argument of [teal_slices()], would result in the current mapping. |
||
| 383 | +44 |
- #' @noRd+ #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list. |
||
| 384 | -4x | +|||
| 45 | +
- pasten <- function(...) paste0(..., "\n")+ #' |
|||
| 385 | +46 |
-
+ #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object. |
||
| 386 | +47 |
- #' Convert character list to human readable html with commas and "and"+ #' Then state of all `FilteredData` objects (provided in `datasets`) is cleared |
||
| 387 | +48 |
- #' @noRd+ #' and set anew according to the `mapping` attribute of the snapshot. |
||
| 388 | +49 |
- paste_datanames_character <- function(x,+ #' The snapshot is then set as the current content of `slices_global`. |
||
| 389 | +50 |
- tags = list(span = shiny::tags$span, code = shiny::tags$code),+ #' |
||
| 390 | +51 |
- tagList = shiny::tagList) { # nolint: object_name.
+ #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring, |
||
| 391 | -! | +|||
| 52 | +
- checkmate::assert_character(x)+ #' and then saved to file with [slices_store()]. |
|||
| 392 | -! | +|||
| 53 | +
- do.call(+ #' |
|||
| 393 | -! | +|||
| 54 | +
- tagList,+ #' When a snapshot is uploaded, it will first be added to storage just like a newly created one, |
|||
| 394 | -! | +|||
| 55 | +
- lapply(seq_along(x), function(.ix) {
+ #' and then used to restore app state much like a snapshot taken from storage. |
|||
| 395 | -! | +|||
| 56 | +
- tagList(+ #' Upon clicking the upload icon the user will be prompted for a file to upload |
|||
| 396 | -! | +|||
| 57 | +
- tags$code(x[.ix]),+ #' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped) |
|||
| 397 | -! | +|||
| 58 | +
- if (.ix != length(x)) {
+ #' and normal naming rules apply. Loading the file yields a `teal_slices` object, |
|||
| 398 | -! | +|||
| 59 | +
- tags$span(if (.ix == length(x) - 1) " and " else ", ")+ #' which is disassembled for storage and used directly for restoring app state. |
|||
| 399 | +60 |
- }+ #' |
||
| 400 | +61 |
- )+ #' @section Transferring snapshots: |
||
| 401 | +62 |
- })+ #' Snapshots uploaded from disk should only be used in the same application they come from, |
||
| 402 | +63 |
- )+ #' _i.e._ an application that uses the same data and the same modules. |
||
| 403 | +64 |
- }+ #' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of |
||
| 404 | +65 |
-
+ #' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that |
||
| 405 | +66 |
- #' Build datanames error string for error message+ #' of the current app state and only if the match is the snapshot admitted to the session. |
||
| 406 | +67 |
#' |
||
| 407 | +68 |
- #' tags and tagList are overwritten in arguments allowing to create strings for+ #' @section Bookmarks: |
||
| 408 | +69 |
- #' logging purposes+ #' An `onBookmark` callback creates a snapshot of the current filter state. |
||
| 409 | +70 |
- #' @noRd+ #' This is done on the app session, not the module session. |
||
| 410 | +71 |
- build_datanames_error_message <- function(label = NULL,+ #' (The snapshot will be retrieved by `module_teal` in order to set initial app state in a restored app.) |
||
| 411 | +72 |
- datanames,+ #' Then that snapshot, and the previous snapshot history are dumped into the `values.rds` file in `<bookmark_dir>`. |
||
| 412 | +73 |
- extra_datanames,+ #' |
||
| 413 | +74 |
- tags = list(span = shiny::tags$span, code = shiny::tags$code),+ #' @param id (`character(1)`) `shiny` module instance id. |
||
| 414 | +75 |
- tagList = shiny::tagList) { # nolint: object_name.
+ #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object |
||
| 415 | -! | +|||
| 76 | +
- tags$span(+ #' containing all `teal_slice`s existing in the app, both active and inactive. |
|||
| 416 | -! | +|||
| 77 | +
- tags$span(pluralize(extra_datanames, "Dataset")),+ #' |
|||
| 417 | -! | +|||
| 78 | +
- paste_datanames_character(extra_datanames, tags, tagList),+ #' @return `list` containing the snapshot history, where each element is an unlisted `teal_slices` object. |
|||
| 418 | -! | +|||
| 79 | +
- tags$span(+ #' |
|||
| 419 | -! | +|||
| 80 | +
- sprintf(+ #' @name module_snapshot_manager |
|||
| 420 | -! | +|||
| 81 | +
- "%s missing%s",+ #' @rdname module_snapshot_manager |
|||
| 421 | -! | +|||
| 82 | +
- pluralize(extra_datanames, "is", "are"),+ #' |
|||
| 422 | -! | +|||
| 83 | +
- if (is.null(label)) "" else sprintf(" for tab '%s'", label)
+ #' @author Aleksander Chlebowski |
|||
| 423 | +84 |
- )+ #' @keywords internal |
||
| 424 | +85 |
- ),+ NULL |
||
| 425 | -! | +|||
| 86 | +
- if (length(datanames) >= 1) {
+
|
|||
| 426 | -! | +|||
| 87 | +
- tagList(+ #' @rdname module_snapshot_manager |
|||
| 427 | -! | +|||
| 88 | +
- tags$span(pluralize(datanames, "Dataset")),+ ui_snapshot_manager_panel <- function(id) {
|
|||
| 428 | +89 | ! |
- tags$span("available in data:"),
+ ns <- NS(id) |
|
| 429 | +90 | ! |
- tagList(+ tags$button( |
|
| 430 | +91 | ! |
- tags$span(+ id = ns("show_snapshot_manager"),
|
|
| 431 | +92 | ! |
- paste_datanames_character(datanames, tags, tagList),+ class = "btn action-button wunder_bar_button", |
|
| 432 | +93 | ! |
- tags$span(".", .noWS = "outside"),
+ title = "View filter mapping", |
|
| 433 | +94 | ! |
- .noWS = c("outside")
+ suppressMessages(icon("fas fa-camera"))
|
|
| 434 | +95 |
- )+ ) |
||
| 435 | +96 |
- )+ } |
||
| 436 | +97 |
- )+ |
||
| 437 | +98 |
- } else {
+ #' @rdname module_snapshot_manager+ |
+ ||
| 99 | ++ |
+ srv_snapshot_manager_panel <- function(id, slices_global) {
+ |
+ ||
| 100 | +87x | +
+ moduleServer(id, function(input, output, session) {
+ |
+ ||
| 101 | +87x | +
+ logger::log_debug("srv_snapshot_manager_panel initializing")
+ |
+ ||
| 102 | +87x | +
+ setBookmarkExclude(c("show_snapshot_manager"))
+ |
+ ||
| 103 | +87x | +
+ observeEvent(input$show_snapshot_manager, {
|
||
| 438 | +104 | ! |
- tags$span("No datasets are available in data.")
+ logger::log_debug("srv_snapshot_manager_panel@1 show_snapshot_manager button has been clicked.")
|
|
| 439 | -+ | |||
| 105 | +! |
- }+ showModal( |
||
| 440 | -+ | |||
| 106 | +! |
- )+ modalDialog( |
||
| 441 | -+ | |||
| 107 | +! |
- }+ ui_snapshot_manager(session$ns("module")),
+ |
+ ||
| 108 | +! | +
+ class = "snapshot_manager_modal",+ |
+ ||
| 109 | +! | +
+ size = "m",+ |
+ ||
| 110 | +! | +
+ footer = NULL,+ |
+ ||
| 111 | +! | +
+ easyClose = TRUE |
||
| 442 | +112 |
-
+ ) |
||
| 443 | +113 |
- #' Smart `rbind`+ ) |
||
| 444 | +114 |
- #'+ })+ |
+ ||
| 115 | +87x | +
+ srv_snapshot_manager("module", slices_global = slices_global)
|
||
| 445 | +116 |
- #' Combine `data.frame` objects which have different columns+ }) |
||
| 446 | +117 |
- #'+ } |
||
| 447 | +118 |
- #' @param ... (`data.frame`)+ |
||
| 448 | +119 |
- #' @keywords internal+ #' @rdname module_snapshot_manager |
||
| 449 | +120 |
- .smart_rbind <- function(...) {
+ ui_snapshot_manager <- function(id) {
|
||
| 450 | -89x | +|||
| 121 | +! |
- dots <- list(...)+ ns <- NS(id) |
||
| 451 | -89x | +|||
| 122 | +! |
- checkmate::assert_list(dots, "data.frame", .var.name = "...")+ tags$div( |
||
| 452 | -89x | +|||
| 123 | +! |
- Reduce(+ class = "manager_content", |
||
| 453 | -89x | +|||
| 124 | +! |
- x = dots,+ tags$div( |
||
| 454 | -89x | +|||
| 125 | +! |
- function(x, y) {
+ class = "manager_table_row", |
||
| 455 | -72x | +|||
| 126 | +! |
- all_columns <- union(colnames(x), colnames(y))+ tags$span(tags$b("Snapshot manager")),
|
||
| 456 | -72x | +|||
| 127 | +! |
- x[setdiff(all_columns, colnames(x))] <- NA+ actionLink(ns("snapshot_add"), label = NULL, icon = icon("fas fa-camera"), title = "add snapshot"),
|
||
| 457 | -72x | +|||
| 128 | +! |
- y[setdiff(all_columns, colnames(y))] <- NA+ actionLink(ns("snapshot_load"), label = NULL, icon = icon("fas fa-upload"), title = "upload snapshot"),
|
||
| 458 | -72x | +|||
| 129 | +! |
- rbind(x, y)+ actionLink(ns("snapshot_reset"), label = NULL, icon = icon("fas fa-undo"), title = "reset initial state"),
|
||
| 459 | -+ | |||
| 130 | +! |
- }+ NULL |
||
| 460 | +131 |
- )+ ), |
||
| 461 | -+ | |||
| 132 | +! |
- }+ uiOutput(ns("snapshot_list"))
|
||
| 462 | +133 |
-
+ ) |
||
| 463 | +134 |
- #' Pluralize a word depending on the size of the input+ } |
||
| 464 | +135 |
- #'+ |
||
| 465 | +136 |
- #' @param x (`object`) to check length for plural.+ #' @rdname module_snapshot_manager |
||
| 466 | +137 |
- #' @param singular (`character`) singular form of the word.+ srv_snapshot_manager <- function(id, slices_global) {
|
||
| 467 | -+ | |||
| 138 | +87x |
- #' @param plural (optional `character`) plural form of the word. If not given an "s"+ checkmate::assert_character(id) |
||
| 468 | +139 |
- #' is added to the singular form.+ |
||
| 469 | -+ | |||
| 140 | +87x |
- #'+ moduleServer(id, function(input, output, session) {
+ |
+ ||
| 141 | +87x | +
+ logger::log_debug("srv_snapshot_manager initializing")
|
||
| 470 | +142 |
- #' @return A `character` that correctly represents the size of the `x` argument.+ |
||
| 471 | +143 |
- #' @keywords internal+ # Set up bookmarking callbacks ---- |
||
| 472 | +144 |
- pluralize <- function(x, singular, plural = NULL) {
+ # Register bookmark exclusions (all buttons and text fields). |
||
| 473 | -70x | +145 | +87x |
- checkmate::assert_string(singular)+ setBookmarkExclude(c( |
| 474 | -70x | +146 | +87x |
- checkmate::assert_string(plural, null.ok = TRUE)+ "snapshot_add", "snapshot_load", "snapshot_reset", |
| 475 | -70x | +147 | +87x |
- if (length(x) == 1L) { # Zero length object should use plural form.
+ "snapshot_name_accept", "snaphot_file_accept", |
| 476 | -42x | +148 | +87x |
- singular+ "snapshot_name", "snapshot_file" |
| 477 | +149 |
- } else {
- |
- ||
| 478 | -28x | -
- if (is.null(plural)) {
- |
- ||
| 479 | -12x | -
- sprintf("%ss", singular)
+ )) |
||
| 480 | +150 |
- } else {
+ # Add snapshot history to bookmark. |
||
| 481 | -16x | +151 | +87x |
- plural+ session$onBookmark(function(state) {
|
| 482 | -+ | |||
| 152 | +! |
- }+ logger::log_debug("srv_snapshot_manager@onBookmark: storing snapshot and bookmark history")
|
||
| 483 | -+ | |||
| 153 | +! |
- }+ state$values$snapshot_history <- snapshot_history() # isolate this? |
||
| 484 | +154 |
- }+ }) |
| 1 | +155 |
- setOldClass("teal_module")
+
|
||
| 2 | -+ | |||
| 156 | +87x |
- setOldClass("teal_modules")
+ ns <- session$ns |
||
| 3 | +157 | |||
| 4 | +158 |
- #' Create `teal_module` and `teal_modules` objects+ # Track global filter states ---- |
||
| 5 | -+ | |||
| 159 | +87x |
- #'+ snapshot_history <- reactiveVal({
|
||
| 6 | +160 |
- #' @description+ # Restore directly from bookmarked state, if applicable. |
||
| 7 | -+ | |||
| 161 | +87x |
- #' `r lifecycle::badge("stable")`
+ restoreValue( |
||
| 8 | -+ | |||
| 162 | +87x |
- #' Create a nested tab structure to embed modules in a `teal` application.+ ns("snapshot_history"),
|
||
| 9 | -+ | |||
| 163 | +87x |
- #'+ list("Initial application state" = shiny::isolate(as.list(slices_global$all_slices(), recursive = TRUE)))
|
||
| 10 | +164 |
- #' @details+ ) |
||
| 11 | +165 |
- #' `module()` creates an instance of a `teal_module` that can be placed in a `teal` application.+ }) |
||
| 12 | +166 |
- #' `modules()` shapes the structure of a the application by organizing `teal_module` within the navigation panel.+ |
||
| 13 | +167 |
- #' It wraps `teal_module` and `teal_modules` objects in a `teal_modules` object,+ # Snapshot current application state ---- |
||
| 14 | +168 |
- #' which results in a nested structure corresponding to the nested tabs in the final application.+ # Name snaphsot. |
||
| 15 | -+ | |||
| 169 | +87x |
- #'+ observeEvent(input$snapshot_add, {
|
||
| 16 | -- |
- #' Note that for `modules()` `label` comes after `...`, so it must be passed as a named argument,- |
- ||
| 17 | -+ | |||
| 170 | +! |
- #' otherwise it will be captured by `...`.+ logger::log_debug("srv_snapshot_manager: snapshot_add button clicked")
|
||
| 18 | -+ | |||
| 171 | +! |
- #'+ showModal( |
||
| 19 | -+ | |||
| 172 | +! |
- #' The labels `"global_filters"` and `"Report previewer"` are reserved+ modalDialog( |
||
| 20 | -+ | |||
| 173 | +! |
- #' because they are used by the `mapping` argument of [teal_slices()]+ textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
|
||
| 21 | -+ | |||
| 174 | +! |
- #' and the report previewer module [reporter_previewer_module()], respectively.+ footer = tagList( |
||
| 22 | -+ | |||
| 175 | +! |
- #'+ actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("far fa-thumbs-up")),
|
||
| 23 | -+ | |||
| 176 | +! |
- #' # Restricting datasets used by `teal_module`:+ modalButton(label = "Cancel", icon = icon("far fa-thumbs-down"))
|
||
| 24 | +177 |
- #' The `datanames` argument controls which datasets are used by the module’s server. These datasets,+ ), |
||
| 25 | -+ | |||
| 178 | +! |
- #' passed via server's `data` argument, are the only ones shown in the module's tab.+ size = "s" |
||
| 26 | +179 |
- #'+ ) |
||
| 27 | +180 |
- #' When `datanames` is set to `"all"`, all datasets in the data object are treated as relevant.+ ) |
||
| 28 | +181 |
- #' However, this may include unnecessary datasets, such as:+ }) |
||
| 29 | +182 |
- #' - Proxy variables for column modifications+ # Store snaphsot. |
||
| 30 | -+ | |||
| 183 | +87x |
- #' - Temporary datasets used to create final versions+ observeEvent(input$snapshot_name_accept, {
|
||
| 31 | -+ | |||
| 184 | +! |
- #' - Connection objects+ logger::log_debug("srv_snapshot_manager: snapshot_name_accept button clicked")
|
||
| 32 | -+ | |||
| 185 | +! |
- #'+ snapshot_name <- trimws(input$snapshot_name) |
||
| 33 | -+ | |||
| 186 | +! |
- #' To exclude irrelevant datasets, use the [set_datanames()] function to change `datanames` from+ if (identical(snapshot_name, "")) {
|
||
| 34 | -+ | |||
| 187 | +! |
- #' `"all"` to specific names. Trying to modify non-`"all"` values with [set_datanames()] will result+ logger::log_debug("srv_snapshot_manager: snapshot name rejected")
|
||
| 35 | -+ | |||
| 188 | +! |
- #' in a warning. Datasets with names starting with . are ignored globally unless explicitly listed+ showNotification( |
||
| 36 | -+ | |||
| 189 | +! |
- #' in `datanames`.+ "Please name the snapshot.", |
||
| 37 | -+ | |||
| 190 | +! |
- #'+ type = "message" |
||
| 38 | +191 |
- #' # `datanames` with `transformators`+ ) |
||
| 39 | -+ | |||
| 192 | +! |
- #' When transformators are specified, their `datanames` are added to the module’s `datanames`, which+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
||
| 40 | -+ | |||
| 193 | +! |
- #' changes the behavior as follows:+ } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
|
||
| 41 | -+ | |||
| 194 | +! |
- #' - If `module(datanames)` is `NULL` and the `transformators` have defined `datanames`, the sidebar+ logger::log_debug("srv_snapshot_manager: snapshot name rejected")
|
||
| 42 | -+ | |||
| 195 | +! |
- #' will appear showing the `transformators`' datasets, instead of being hidden.+ showNotification( |
||
| 43 | -+ | |||
| 196 | +! |
- #' - If `module(datanames)` is set to specific values and any `transformator` has `datanames = "all"`,+ "This name is in conflict with other snapshot names. Please choose a different one.", |
||
| 44 | -+ | |||
| 197 | +! |
- #' the module may receive extra datasets that could be unnecessary+ type = "message" |
||
| 45 | +198 |
- #'+ ) |
||
| 46 | -+ | |||
| 199 | +! |
- #' @param label (`character(1)`) Label shown in the navigation item for the module or module group.+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
||
| 47 | +200 |
- #' For `modules()` defaults to `"root"`. See `Details`.+ } else {
|
||
| 48 | -+ | |||
| 201 | +! |
- #' @param server (`function`) `shiny` module with following arguments:+ logger::log_debug("srv_snapshot_manager: snapshot name accepted, adding snapshot")
|
||
| 49 | -+ | |||
| 202 | +! |
- #' - `id` - `teal` will set proper `shiny` namespace for this module (see [shiny::moduleServer()]).+ snapshot <- as.list(slices_global$all_slices(), recursive = TRUE) |
||
| 50 | -+ | |||
| 203 | +! |
- #' - `input`, `output`, `session` - (optional; not recommended) When provided, then [shiny::callModule()]+ snapshot_update <- c(snapshot_history(), list(snapshot)) |
||
| 51 | -+ | |||
| 204 | +! |
- #' will be used to call a module. From `shiny` 1.5.0, the recommended way is to use+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name |
||
| 52 | -+ | |||
| 205 | +! |
- #' [shiny::moduleServer()] instead which doesn't require these arguments.+ snapshot_history(snapshot_update) |
||
| 53 | -+ | |||
| 206 | +! |
- #' - `data` (optional) When provided, the module will be called with `teal_data` object (i.e. a list of+ removeModal() |
||
| 54 | +207 |
- #' reactive (filtered) data specified in the `filters` argument) as the value of this argument.+ # Reopen filter manager modal by clicking button in the main application. |
||
| 55 | -+ | |||
| 208 | +! |
- #' - `datasets` (optional) When provided, the module will be called with `FilteredData` object as the+ shinyjs::click(id = "teal-wunder_bar-show_snapshot_manager", asis = TRUE) |
||
| 56 | +209 |
- #' value of this argument. (See [`teal.slice::FilteredData`]).+ } |
||
| 57 | +210 |
- #' - `reporter` (optional) When provided, the module will be called with `Reporter` object as the value+ }) |
||
| 58 | +211 |
- #' of this argument. (See [`teal.reporter::Reporter`]).+ |
||
| 59 | +212 |
- #' - `filter_panel_api` (optional) When provided, the module will be called with `FilterPanelAPI` object+ # Upload a snapshot file ---- |
||
| 60 | +213 |
- #' as the value of this argument. (See [`teal.slice::FilterPanelAPI`]).+ # Select file. |
||
| 61 | -+ | |||
| 214 | +87x |
- #' - `...` (optional) When provided, `server_args` elements will be passed to the module named argument+ observeEvent(input$snapshot_load, {
|
||
| 62 | -+ | |||
| 215 | +! |
- #' or to the `...`.+ logger::log_debug("srv_snapshot_manager: snapshot_load button clicked")
|
||
| 63 | -+ | |||
| 216 | +! |
- #' @param ui (`function`) `shiny` UI module function with following arguments:+ showModal( |
||
| 64 | -+ | |||
| 217 | +! |
- #' - `id` - `teal` will set proper `shiny` namespace for this module.+ modalDialog( |
||
| 65 | -+ | |||
| 218 | +! |
- #' - `...` (optional) When provided, `ui_args` elements will be passed to the module named argument+ fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
|
||
| 66 | -+ | |||
| 219 | +! |
- #' or to the `...`.+ textInput( |
||
| 67 | -+ | |||
| 220 | +! |
- #' @param filters (`character`) Deprecated. Use `datanames` instead.+ ns("snapshot_name"),
|
||
| 68 | -+ | |||
| 221 | +! |
- #' @param datanames (`character`) Names of the datasets relevant to the item.+ "Name the snapshot (optional)", |
||
| 69 | -+ | |||
| 222 | +! |
- #' There are 2 reserved values that have specific behaviors:+ width = "100%", |
||
| 70 | -+ | |||
| 223 | +! |
- #' - The keyword `"all"` includes all datasets available in the data passed to the teal application.+ placeholder = "Meaningful, unique name" |
||
| 71 | +224 |
- #' - `NULL` hides the sidebar panel completely.+ ), |
||
| 72 | -+ | |||
| 225 | +! |
- #' - If `transformators` are specified, their `datanames` are automatically added to this `datanames`+ footer = tagList( |
||
| 73 | -+ | |||
| 226 | +! |
- #' argument.+ actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("far fa-thumbs-up")),
|
||
| 74 | -+ | |||
| 227 | +! |
- #' @param server_args (named `list`) with additional arguments passed on to the server function.+ modalButton(label = "Cancel", icon = icon("far fa-thumbs-down"))
|
||
| 75 | +228 |
- #' @param ui_args (named `list`) with additional arguments passed on to the UI function.+ ) |
||
| 76 | +229 |
- #' @param x (`teal_module` or `teal_modules`) Object to format/print.+ ) |
||
| 77 | +230 |
- #' @param transformators (`list` of `teal_transform_module`) that will be applied to transformator module's data input.+ ) |
||
| 78 | +231 |
- #'+ }) |
||
| 79 | +232 |
- #'+ # Store new snapshot to list and restore filter states. |
||
| 80 | -+ | |||
| 233 | +87x |
- #' @param ...+ observeEvent(input$snaphot_file_accept, {
|
||
| 81 | -+ | |||
| 234 | +! |
- #' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab.+ logger::log_debug("srv_snapshot_manager: snapshot_file_accept button clicked")
|
||
| 82 | -+ | |||
| 235 | +! |
- #' - For `format()` and `print()`: Arguments passed to other methods.+ snapshot_name <- trimws(input$snapshot_name) |
||
| 83 | -+ | |||
| 236 | +! |
- #'+ if (identical(snapshot_name, "")) {
|
||
| 84 | -+ | |||
| 237 | +! |
- #' @return+ logger::log_debug("srv_snapshot_manager: no snapshot name provided, naming after file")
|
||
| 85 | -+ | |||
| 238 | +! |
- #' `module()` returns an object of class `teal_module`.+ snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name) |
||
| 86 | +239 |
- #'+ } |
||
| 87 | -+ | |||
| 240 | +! |
- #' `modules()` returns a `teal_modules` object which contains following fields:+ if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
|
||
| 88 | -+ | |||
| 241 | +! |
- #' - `label`: taken from the `label` argument.+ logger::log_debug("srv_snapshot_manager: snapshot name rejected")
|
||
| 89 | -+ | |||
| 242 | +! |
- #' - `children`: a list containing objects passed in `...`. List elements are named after+ showNotification( |
||
| 90 | -+ | |||
| 243 | +! |
- #' their `label` attribute converted to a valid `shiny` id.+ "This name is in conflict with other snapshot names. Please choose a different one.", |
||
| 91 | -+ | |||
| 244 | +! |
- #'+ type = "message" |
||
| 92 | +245 |
- #' @name teal_modules+ ) |
||
| 93 | -+ | |||
| 246 | +! |
- #' @aliases teal_module+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
||
| 94 | +247 |
- #'+ } else {
|
||
| 95 | +248 |
- #' @examples+ # Restore snapshot and verify app compatibility. |
||
| 96 | -+ | |||
| 249 | +! |
- #' library(shiny)+ logger::log_debug("srv_snapshot_manager: snapshot name accepted, loading snapshot")
|
||
| 97 | -+ | |||
| 250 | +! |
- #'+ snapshot_state <- try(slices_restore(input$snapshot_file$datapath)) |
||
| 98 | -+ | |||
| 251 | +! |
- #' module_1 <- module(+ if (!inherits(snapshot_state, "modules_teal_slices")) {
|
||
| 99 | -+ | |||
| 252 | +! |
- #' label = "a module",+ logger::log_debug("srv_snapshot_manager: snapshot file corrupt")
|
||
| 100 | -+ | |||
| 253 | +! |
- #' server = function(id, data) {
+ showNotification( |
||
| 101 | -+ | |||
| 254 | +! |
- #' moduleServer(+ "File appears to be corrupt.", |
||
| 102 | -+ | |||
| 255 | +! |
- #' id,+ type = "error" |
||
| 103 | +256 |
- #' module = function(input, output, session) {
+ ) |
||
| 104 | -+ | |||
| 257 | +! |
- #' output$data <- renderDataTable(data()[["iris"]])+ } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global$all_slices(), "app_id"))) {
|
||
| 105 | -+ | |||
| 258 | +! |
- #' }+ logger::log_debug("srv_snapshot_manager: snapshot not compatible with app")
|
||
| 106 | -+ | |||
| 259 | +! |
- #' )+ showNotification( |
||
| 107 | -+ | |||
| 260 | +! |
- #' },+ "This snapshot file is not compatible with the app and cannot be loaded.", |
||
| 108 | -+ | |||
| 261 | +! |
- #' ui = function(id) {
+ type = "warning" |
||
| 109 | +262 |
- #' ns <- NS(id)+ ) |
||
| 110 | +263 |
- #' tagList(dataTableOutput(ns("data")))
+ } else {
|
||
| 111 | +264 |
- #' },+ # Add to snapshot history. |
||
| 112 | -+ | |||
| 265 | +! |
- #' datanames = "all"+ logger::log_debug("srv_snapshot_manager: snapshot loaded, adding to history")
|
||
| 113 | -+ | |||
| 266 | +! |
- #' )+ snapshot <- as.list(slices_global$all_slices(), recursive = TRUE) |
||
| 114 | -+ | |||
| 267 | +! |
- #'+ snapshot_update <- c(snapshot_history(), list(snapshot)) |
||
| 115 | -+ | |||
| 268 | +! |
- #' module_2 <- module(+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name |
||
| 116 | -+ | |||
| 269 | +! |
- #' label = "another module",+ snapshot_history(snapshot_update) |
||
| 117 | +270 |
- #' server = function(id) {
+ ### Begin simplified restore procedure. ### |
||
| 118 | -+ | |||
| 271 | +! |
- #' moduleServer(+ logger::log_debug("srv_snapshot_manager: restoring snapshot")
|
||
| 119 | -+ | |||
| 272 | +! |
- #' id,+ slices_global$slices_set(snapshot_state) |
||
| 120 | -+ | |||
| 273 | +! |
- #' module = function(input, output, session) {
+ removeModal() |
||
| 121 | +274 |
- #' output$text <- renderText("Another Module")
+ ### End simplified restore procedure. ### |
||
| 122 | +275 |
- #' }+ } |
||
| 123 | +276 |
- #' )+ } |
||
| 124 | +277 |
- #' },+ }) |
||
| 125 | +278 |
- #' ui = function(id) {
+ # Apply newly added snapshot. |
||
| 126 | +279 |
- #' ns <- NS(id)+ |
||
| 127 | +280 |
- #' tagList(textOutput(ns("text")))
+ # Restore initial state ---- |
||
| 128 | -+ | |||
| 281 | +87x |
- #' },+ observeEvent(input$snapshot_reset, {
|
||
| 129 | -+ | |||
| 282 | +2x |
- #' datanames = NULL+ logger::log_debug("srv_snapshot_manager: snapshot_reset button clicked, restoring snapshot")
|
||
| 130 | -+ | |||
| 283 | +2x |
- #' )+ s <- "Initial application state" |
||
| 131 | +284 |
- #'+ ### Begin restore procedure. ### |
||
| 132 | -+ | |||
| 285 | +2x |
- #' modules <- modules(+ snapshot <- snapshot_history()[[s]] |
||
| 133 | -+ | |||
| 286 | +2x |
- #' label = "modules",+ snapshot_state <- as.teal_slices(snapshot) |
||
| 134 | -+ | |||
| 287 | +2x |
- #' modules(+ slices_global$slices_set(snapshot_state) |
||
| 135 | -+ | |||
| 288 | +2x |
- #' label = "nested modules",+ removeModal() |
||
| 136 | +289 |
- #' module_1+ ### End restore procedure. ### |
||
| 137 | +290 |
- #' ),+ }) |
||
| 138 | +291 |
- #' module_2+ |
||
| 139 | +292 |
- #' )+ # Build snapshot table ---- |
||
| 140 | +293 |
- #'+ # Create UI elements and server logic for the snapshot table. |
||
| 141 | +294 |
- #' app <- init(+ # Observers must be tracked to avoid duplication and excess reactivity. |
||
| 142 | +295 |
- #' data = teal_data(iris = iris),+ # Remaining elements are tracked likewise for consistency and a slight speed margin. |
||
| 143 | -+ | |||
| 296 | +87x |
- #' modules = modules+ observers <- reactiveValues() |
||
| 144 | -+ | |||
| 297 | +87x |
- #' )+ handlers <- reactiveValues() |
||
| 145 | -+ | |||
| 298 | +87x |
- #'+ divs <- reactiveValues() |
||
| 146 | +299 |
- #' if (interactive()) {
+
|
||
| 147 | -+ | |||
| 300 | +87x |
- #' shinyApp(app$ui, app$server)+ observeEvent(snapshot_history(), {
|
||
| 148 | -+ | |||
| 301 | +77x |
- #' }+ logger::log_debug("srv_snapshot_manager: snapshot history modified, updating snapshot list")
|
||
| 149 | -+ | |||
| 302 | +77x |
- #' @rdname teal_modules+ lapply(names(snapshot_history())[-1L], function(s) {
|
||
| 150 | -+ | |||
| 303 | +! |
- #' @export+ id_pickme <- sprintf("pickme_%s", make.names(s))
|
||
| 151 | -+ | |||
| 304 | +! |
- #'+ id_saveme <- sprintf("saveme_%s", make.names(s))
|
||
| 152 | -+ | |||
| 305 | +! |
- module <- function(label = "module",+ id_rowme <- sprintf("rowme_%s", make.names(s))
|
||
| 153 | +306 |
- server = function(id, data, ...) moduleServer(id, function(input, output, session) NULL),+ |
||
| 154 | +307 |
- ui = function(id, ...) tags$p(paste0("This module has no UI (id: ", id, " )")),
+ # Observer for restoring snapshot. |
||
| 155 | -+ | |||
| 308 | +! |
- filters,+ if (!is.element(id_pickme, names(observers))) {
|
||
| 156 | -+ | |||
| 309 | +! |
- datanames = "all",+ observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
|
||
| 157 | +310 |
- server_args = NULL,+ ### Begin restore procedure. ### |
||
| 158 | -+ | |||
| 311 | +! |
- ui_args = NULL,+ snapshot <- snapshot_history()[[s]] |
||
| 159 | -+ | |||
| 312 | +! |
- transformators = list()) {
+ snapshot_state <- as.teal_slices(snapshot) |
||
| 160 | +313 |
- # argument checking (independent)+ |
||
| 161 | -+ | |||
| 314 | +! |
- ## `label`+ slices_global$slices_set(snapshot_state) |
||
| 162 | -220x | +|||
| 315 | +! |
- checkmate::assert_string(label)+ removeModal() |
||
| 163 | -217x | +|||
| 316 | +
- if (label == "global_filters") {
+ ### End restore procedure. ### |
|||
| 164 | -1x | +|||
| 317 | +
- stop(+ }) |
|||
| 165 | -1x | +|||
| 318 | +
- sprintf("module(label = \"%s\", ...\n ", label),
+ } |
|||
| 166 | -1x | +|||
| 319 | +
- "Label 'global_filters' is reserved in teal. Please change to something else.",+ # Create handler for downloading snapshot. |
|||
| 167 | -1x | +|||
| 320 | +! |
- call. = FALSE+ if (!is.element(id_saveme, names(handlers))) {
|
||
| 168 | -+ | |||
| 321 | +! |
- )+ output[[id_saveme]] <- downloadHandler( |
||
| 169 | -+ | |||
| 322 | +! |
- }+ filename = function() {
|
||
| 170 | -216x | +|||
| 323 | +! |
- if (label == "Report previewer") {
+ sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
+ |
+ ||
| 324 | ++ |
+ }, |
||
| 171 | +325 | ! |
- stop(+ content = function(file) {
|
|
| 172 | +326 | ! |
- sprintf("module(label = \"%s\", ...\n ", label),
+ snapshot <- snapshot_history()[[s]] |
|
| 173 | +327 | ! |
- "Label 'Report previewer' is reserved in teal. Please change to something else.",+ snapshot_state <- as.teal_slices(snapshot) |
|
| 174 | +328 | ! |
- call. = FALSE+ slices_store(tss = snapshot_state, file = file) |
|
| 175 | +329 |
- )+ } |
||
| 176 | +330 |
- }+ )+ |
+ ||
| 331 | +! | +
+ handlers[[id_saveme]] <- id_saveme |
||
| 177 | +332 |
-
+ } |
||
| 178 | +333 |
- ## server+ # Create a row for the snapshot table. |
||
| 179 | -216x | +|||
| 334 | +! |
- checkmate::assert_function(server)+ if (!is.element(id_rowme, names(divs))) {
|
||
| 180 | -216x | +|||
| 335 | +! |
- server_formals <- names(formals(server))+ divs[[id_rowme]] <- tags$div( |
||
| 181 | -216x | +|||
| 336 | +! |
- if (!(+ class = "manager_table_row", |
||
| 182 | -216x | +|||
| 337 | +! |
- "id" %in% server_formals ||+ tags$span(tags$h5(s)), |
||
| 183 | -216x | +|||
| 338 | +! |
- all(c("input", "output", "session") %in% server_formals)
+ actionLink(inputId = ns(id_pickme), label = icon("far fa-circle-check"), title = "select"),
+ |
+ ||
| 339 | +! | +
+ downloadLink(outputId = ns(id_saveme), label = icon("far fa-save"), title = "save to file")
|
||
| 184 | +340 |
- )) {
+ ) |
||
| 185 | -2x | +|||
| 341 | +
- stop(+ } |
|||
| 186 | -2x | +|||
| 342 | +
- "\nmodule() `server` argument requires a function with following arguments:",+ }) |
|||
| 187 | -2x | +|||
| 343 | +
- "\n - id - `teal` will set proper `shiny` namespace for this module.",+ }) |
|||
| 188 | -2x | +|||
| 344 | +
- "\n - input, output, session (not recommended) - then `shiny::callModule` will be used to call a module.",+ |
|||
| 189 | -2x | +|||
| 345 | +
- "\n\nFollowing arguments can be used optionaly:",+ # Create table to display list of snapshots and their actions. |
|||
| 190 | -2x | +346 | +87x |
- "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",+ output$snapshot_list <- renderUI({
|
| 191 | -2x | +347 | +77x |
- "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ rows <- rev(reactiveValuesToList(divs)) |
| 192 | -2x | +348 | +77x |
- "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",+ if (length(rows) == 0L) {
|
| 193 | -2x | +349 | +77x |
- "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",+ tags$div( |
| 194 | -2x | +350 | +77x |
- "\n - `...` server_args elements will be passed to the module named argument or to the `...`"+ class = "manager_placeholder", |
| 195 | -+ | |||
| 351 | +77x |
- )+ "Snapshots will appear here." |
||
| 196 | +352 |
- }+ ) |
||
| 197 | +353 | - - | -||
| 198 | -214x | -
- if ("datasets" %in% server_formals) {
+ } else {
|
||
| 199 | -2x | +|||
| 354 | +! |
- warning(+ rows |
||
| 200 | -2x | +|||
| 355 | +
- sprintf("Called from module(label = \"%s\", ...)\n ", label),
+ } |
|||
| 201 | -2x | +|||
| 356 | +
- "`datasets` argument in the server is deprecated and will be removed in the next release. ",+ }) |
|||
| 202 | -2x | +|||
| 357 | +
- "Please use `data` instead.",+ |
|||
| 203 | -2x | +358 | +87x |
- call. = FALSE+ snapshot_history |
| 204 | +359 |
- )+ }) |
||
| 205 | +360 |
- }+ } |
| 206 | +1 |
-
+ #' Calls all `modules` |
||
| 207 | +2 |
- ## UI+ #' |
||
| 208 | -214x | +|||
| 3 | +
- checkmate::assert_function(ui)+ #' On the UI side each `teal_modules` is translated to a `tabsetPanel` and each `teal_module` is a |
|||
| 209 | -214x | +|||
| 4 | +
- ui_formals <- names(formals(ui))+ #' `tabPanel`. Both, UI and server are called recursively so that each tab is a separate module and |
|||
| 210 | -214x | +|||
| 5 | +
- if (!"id" %in% ui_formals) {
+ #' reflect nested structure of `modules` argument. |
|||
| 211 | -1x | +|||
| 6 | +
- stop(+ #' |
|||
| 212 | -1x | +|||
| 7 | +
- "\nmodule() `ui` argument requires a function with following arguments:",+ #' @name module_teal_module |
|||
| 213 | -1x | +|||
| 8 | +
- "\n - id - `teal` will set proper `shiny` namespace for this module.",+ #' |
|||
| 214 | -1x | +|||
| 9 | +
- "\n\nFollowing arguments can be used optionally:",+ #' @inheritParams module_teal |
|||
| 215 | -1x | +|||
| 10 | +
- "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"+ #' |
|||
| 216 | +11 |
- )+ #' @param data (`reactive` returning `teal_data`) |
||
| 217 | +12 |
- }+ #' |
||
| 218 | +13 |
-
+ #' @param slices_global (`reactiveVal` returning `modules_teal_slices`) |
||
| 219 | -213x | +|||
| 14 | +
- if (any(c("data", "datasets") %in% ui_formals)) {
+ #' see [`module_filter_manager`] |
|||
| 220 | -2x | +|||
| 15 | +
- stop(+ #' |
|||
| 221 | -2x | +|||
| 16 | +
- sprintf("Called from module(label = \"%s\", ...)\n ", label),
+ #' @param depth (`integer(1)`) |
|||
| 222 | -2x | +|||
| 17 | +
- "UI with `data` or `datasets` argument is no longer accepted.\n ",+ #' number which helps to determine depth of the modules nesting. |
|||
| 223 | -2x | +|||
| 18 | +
- "If some UI inputs depend on data, please move the logic to your server instead.\n ",+ #' |
|||
| 224 | -2x | +|||
| 19 | +
- "Possible solutions are renderUI() or updateXyzInput() functions."+ #' @param datasets (`reactive` returning `FilteredData` or `NULL`) |
|||
| 225 | +20 |
- )+ #' When `datasets` is passed from the parent module (`srv_teal`) then `dataset` is a singleton |
||
| 226 | +21 |
- }+ #' which implies in filter-panel to be "global". When `NULL` then filter-panel is "module-specific". |
||
| 227 | +22 |
-
+ #' |
||
| 228 | +23 |
- ## `filters`+ #' @param data_load_status (`reactive` returning `character`) |
||
| 229 | -211x | +|||
| 24 | +
- if (!missing(filters)) {
+ #' Determines action dependent on a data loading status: |
|||
| 230 | -! | +|||
| 25 | +
- datanames <- filters+ #' - `"ok"` when `teal_data` is returned from the data loading. |
|||
| 231 | -! | +|||
| 26 | +
- msg <-+ #' - `"teal_data_module failed"` when [teal_data_module()] didn't return `teal_data`. Disables tabs buttons. |
|||
| 232 | -! | +|||
| 27 | +
- "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."+ #' - `"external failed"` when a `reactive` passed to `srv_teal(data)` didn't return `teal_data`. Hides the whole tab |
|||
| 233 | -! | +|||
| 28 | +
- warning(msg)+ #' panel. |
|||
| 234 | +29 |
- }+ #' |
||
| 235 | +30 |
-
+ #' @return |
||
| 236 | +31 |
- ## `datanames` (also including deprecated `filters`)+ #' output of currently active module. |
||
| 237 | +32 |
- # please note a race condition between datanames set when filters is not missing and data arg in server function+ #' - `srv_teal_module.teal_module` returns `reactiveVal` containing output of the called module. |
||
| 238 | -211x | +|||
| 33 | +
- if (!is.element("data", server_formals) && !is.null(datanames)) {
+ #' - `srv_teal_module.teal_modules` returns output of module selected by `input$active_tab`. |
|||
| 239 | -12x | +|||
| 34 | +
- message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
+ #' |
|||
| 240 | -12x | +|||
| 35 | +
- datanames <- NULL+ #' @keywords internal |
|||
| 241 | +36 |
- }+ NULL |
||
| 242 | -211x | +|||
| 37 | +
- checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ |
|||
| 243 | +38 |
-
+ #' @rdname module_teal_module |
||
| 244 | +39 |
- ## `server_args`+ ui_teal_module <- function(id, modules, depth = 0L) {
|
||
| 245 | -210x | +|||
| 40 | +! |
- checkmate::assert_list(server_args, null.ok = TRUE, names = "named")+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module", "shiny.tag"))
|
||
| 246 | -208x | +|||
| 41 | +! |
- srv_extra_args <- setdiff(names(server_args), server_formals)+ checkmate::assert_count(depth) |
||
| 247 | -208x | +|||
| 42 | +! |
- if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
+ UseMethod("ui_teal_module", modules)
|
||
| 248 | -1x | +|||
| 43 | +
- stop(+ } |
|||
| 249 | -1x | +|||
| 44 | +
- "\nFollowing `server_args` elements have no equivalent in the formals of the server:\n",+ |
|||
| 250 | -1x | +|||
| 45 | +
- paste(paste(" -", srv_extra_args), collapse = "\n"),
+ #' @rdname module_teal_module |
|||
| 251 | -1x | +|||
| 46 | +
- "\n\nUpdate the server arguments by including above or add `...`"+ #' @export |
|||
| 252 | +47 |
- )+ ui_teal_module.default <- function(id, modules, depth = 0L) {
|
||
| 253 | -+ | |||
| 48 | +! |
- }+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
|
||
| 254 | +49 |
-
+ } |
||
| 255 | +50 |
- ## `ui_args`+ |
||
| 256 | -207x | +|||
| 51 | +
- checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")+ #' @rdname module_teal_module |
|||
| 257 | -205x | +|||
| 52 | +
- ui_extra_args <- setdiff(names(ui_args), ui_formals)+ #' @export |
|||
| 258 | -205x | +|||
| 53 | +
- if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
+ ui_teal_module.teal_modules <- function(id, modules, depth = 0L) {
|
|||
| 259 | -1x | +|||
| 54 | +! |
- stop(+ ns <- NS(id) |
||
| 260 | -1x | +|||
| 55 | +! |
- "\nFollowing `ui_args` elements have no equivalent in the formals of UI:\n",+ tags$div( |
||
| 261 | -1x | +|||
| 56 | +! |
- paste(paste(" -", ui_extra_args), collapse = "\n"),
+ id = ns("wrapper"),
|
||
| 262 | -1x | +|||
| 57 | +! |
- "\n\nUpdate the UI arguments by including above or add `...`"+ do.call( |
||
| 263 | -+ | |||
| 58 | +! |
- )+ tabsetPanel, |
||
| 264 | -+ | |||
| 59 | +! |
- }+ c( |
||
| 265 | +60 |
-
+ # by giving an id, we can reactively respond to tab changes |
||
| 266 | -+ | |||
| 61 | +! |
- ## `transformators`+ list( |
||
| 267 | -204x | +|||
| 62 | +! |
- if (inherits(transformators, "teal_transform_module")) {
+ id = ns("active_tab"),
|
||
| 268 | -1x | +|||
| 63 | +! |
- transformators <- list(transformators)+ type = if (modules$label == "root") "pills" else "tabs" |
||
| 269 | +64 |
- }+ ), |
||
| 270 | -204x | +|||
| 65 | +! |
- checkmate::assert_list(transformators, types = "teal_transform_module")+ lapply( |
||
| 271 | -204x | +|||
| 66 | +! |
- transform_datanames <- unlist(lapply(transformators, attr, "datanames"))+ names(modules$children), |
||
| 272 | -204x | +|||
| 67 | +! |
- combined_datanames <- if (identical(datanames, "all")) {
+ function(module_id) {
|
||
| 273 | -151x | +|||
| 68 | +! |
- "all"+ module_label <- modules$children[[module_id]]$label |
||
| 274 | -+ | |||
| 69 | +! |
- } else {
+ if (is.null(module_label)) {
|
||
| 275 | -53x | +|||
| 70 | +! |
- union(datanames, transform_datanames)+ module_label <- icon("fas fa-database")
|
||
| 276 | +71 |
- }+ } |
||
| 277 | -+ | |||
| 72 | +! |
-
+ tabPanel( |
||
| 278 | -204x | +|||
| 73 | +! |
- structure(+ title = module_label, |
||
| 279 | -204x | +|||
| 74 | +! |
- list(+ value = module_id, # when clicked this tab value changes input$<tabset panel id> |
||
| 280 | -204x | +|||
| 75 | +! |
- label = label,+ ui_teal_module( |
||
| 281 | -204x | +|||
| 76 | +! |
- server = server,+ id = ns(module_id), |
||
| 282 | -204x | +|||
| 77 | +! |
- ui = ui,+ modules = modules$children[[module_id]], |
||
| 283 | -204x | +|||
| 78 | +! |
- datanames = combined_datanames,+ depth = depth + 1L |
||
| 284 | -204x | +|||
| 79 | +
- server_args = server_args,+ ) |
|||
| 285 | -204x | +|||
| 80 | +
- ui_args = ui_args,+ ) |
|||
| 286 | -204x | +|||
| 81 | +
- transformators = transformators+ } |
|||
| 287 | +82 |
- ),+ ) |
||
| 288 | -204x | +|||
| 83 | +
- class = "teal_module"+ ) |
|||
| 289 | +84 | ++ |
+ )+ |
+ |
| 85 |
) |
|||
| 290 | +86 |
} |
||
| 291 | +87 | |||
| 292 | +88 |
- #' @rdname teal_modules+ #' @rdname module_teal_module |
||
| 293 | +89 |
#' @export |
||
| 294 | +90 |
- #'+ ui_teal_module.teal_module <- function(id, modules, depth = 0L) {
|
||
| 295 | -+ | |||
| 91 | +! |
- modules <- function(..., label = "root") {
+ ns <- NS(id) |
||
| 296 | -144x | +|||
| 92 | +! |
- checkmate::assert_string(label)+ args <- c(list(id = ns("module")), modules$ui_args)
|
||
| 297 | -142x | +|||
| 93 | +
- submodules <- list(...)+ |
|||
| 298 | -142x | +|||
| 94 | +! |
- if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
+ ui_teal <- tagList( |
||
| 299 | -2x | +|||
| 95 | +! |
- stop(+ shinyjs::hidden( |
||
| 300 | -2x | +|||
| 96 | +! |
- "The only character argument to modules() must be 'label' and it must be named, ",+ tags$div( |
||
| 301 | -2x | +|||
| 97 | +! |
- "change modules('lab', ...) to modules(label = 'lab', ...)"
+ id = ns("transform_failure_info"),
|
||
| 302 | -+ | |||
| 98 | +! |
- )+ class = "teal_validated", |
||
| 303 | -+ | |||
| 99 | +! |
- }+ div( |
||
| 304 | -+ | |||
| 100 | +! |
-
+ class = "teal-output-warning", |
||
| 305 | -140x | +|||
| 101 | +! |
- checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+ "One of transformators failed. Please check its inputs." |
||
| 306 | +102 |
- # name them so we can more easily access the children+ ) |
||
| 307 | +103 |
- # beware however that the label of the submodules should not be changed as it must be kept synced+ ) |
||
| 308 | -137x | +|||
| 104 | +
- labels <- vapply(submodules, function(submodule) submodule$label, character(1))+ ), |
|||
| 309 | -137x | +|||
| 105 | +! |
- names(submodules) <- get_unique_labels(labels)+ tags$div( |
||
| 310 | -137x | +|||
| 106 | +! |
- structure(+ id = ns("teal_module_ui"),
|
||
| 311 | -137x | +|||
| 107 | +! |
- list(+ tags$div( |
||
| 312 | -137x | +|||
| 108 | +! |
- label = label,+ class = "teal_validated", |
||
| 313 | -137x | +|||
| 109 | +! |
- children = submodules+ ui_check_module_datanames(ns("validate_datanames"))
|
||
| 314 | +110 |
- ),+ ), |
||
| 315 | -137x | +|||
| 111 | +! |
- class = "teal_modules"+ do.call(modules$ui, args) |
||
| 316 | +112 |
- )+ ) |
||
| 317 | +113 |
- }+ ) |
||
| 318 | +114 | |||
| 319 | -+ | |||
| 115 | +! |
- # printing methods ----+ div( |
||
| 320 | -+ | |||
| 116 | +! |
-
+ id = id, |
||
| 321 | -+ | |||
| 117 | +! |
- #' @rdname teal_modules+ class = "teal_module", |
||
| 322 | -+ | |||
| 118 | +! |
- #' @param is_last (`logical(1)`) Whether this is the last item in its parent's children list.+ uiOutput(ns("data_reactive"), inline = TRUE),
|
||
| 323 | -+ | |||
| 119 | +! |
- #' Affects the tree branch character used (L- vs |-)+ tagList( |
||
| 324 | -+ | |||
| 120 | +! |
- #' @param parent_prefix (`character(1)`) The prefix inherited from parent nodes,+ if (depth >= 2L) tags$div(style = "mt-6"), |
||
| 325 | -+ | |||
| 121 | +! |
- #' used to maintain the tree structure in nested levels+ if (!is.null(modules$datanames)) {
|
||
| 326 | -+ | |||
| 122 | +! |
- #' @param is_root (`logical(1)`) Whether this is the root node of the tree. Only used in+ fluidRow( |
||
| 327 | -+ | |||
| 123 | +! |
- #' format.teal_modules(). Determines whether to show "TEAL ROOT" header+ column(width = 9, ui_teal, class = "teal_primary_col"), |
||
| 328 | -+ | |||
| 124 | +! |
- #' @param what (`character`) Specifies which metadata to display.+ column( |
||
| 329 | -+ | |||
| 125 | +! |
- #' Possible values: "datasets", "properties", "ui_args", "server_args", "transformators"+ width = 3,+ |
+ ||
| 126 | +! | +
+ ui_data_summary(ns("data_summary")),
+ |
+ ||
| 127 | +! | +
+ ui_filter_data(ns("filter_panel")),
+ |
+ ||
| 128 | +! | +
+ ui_transform_teal_data(ns("data_transform"), transformators = modules$transformators, class = "well"),
+ |
+ ||
| 129 | +! | +
+ class = "teal_secondary_col" |
||
| 330 | +130 |
- #' @examples+ ) |
||
| 331 | +131 |
- #' mod <- module(+ ) |
||
| 332 | +132 |
- #' label = "My Custom Module",+ } else {
+ |
+ ||
| 133 | +! | +
+ ui_teal |
||
| 333 | +134 |
- #' server = function(id, data, ...) {},
+ } |
||
| 334 | +135 |
- #' ui = function(id, ...) {},
+ ) |
||
| 335 | +136 |
- #' datanames = c("ADSL", "ADTTE"),
+ ) |
||
| 336 | +137 |
- #' transformators = list(),+ } |
||
| 337 | +138 |
- #' ui_args = list(a = 1, b = "b"),+ |
||
| 338 | +139 |
- #' server_args = list(x = 5, y = list(p = 1))+ #' @rdname module_teal_module |
||
| 339 | +140 |
- #' )+ srv_teal_module <- function(id, |
||
| 340 | +141 |
- #' cat(format(mod))+ data, |
||
| 341 | +142 |
- #' @export+ modules, |
||
| 342 | +143 |
- format.teal_module <- function(x,+ datasets = NULL, |
||
| 343 | +144 |
- is_last = FALSE,+ slices_global, |
||
| 344 | +145 |
- parent_prefix = "",+ reporter = teal.reporter::Reporter$new(), |
||
| 345 | +146 |
- what = c("datasets", "properties", "ui_args", "server_args", "transformators"),
+ data_load_status = reactive("ok"),
|
||
| 346 | +147 |
- ...) {
+ is_active = reactive(TRUE)) {
|
||
| 347 | -3x | +148 | +199x |
- empty_text <- ""+ checkmate::assert_string(id) |
| 348 | -3x | +149 | +199x |
- branch <- if (is_last) "L-" else "|-"+ assert_reactive(data) |
| 349 | -3x | +150 | +199x |
- current_prefix <- paste0(parent_prefix, branch, " ")+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
| 350 | -3x | +151 | +199x |
- content_prefix <- paste0(parent_prefix, if (is_last) " " else "| ")+ assert_reactive(datasets, null.ok = TRUE) |
| 351 | -+ | |||
| 152 | +199x |
-
+ checkmate::assert_class(slices_global, ".slicesGlobal") |
||
| 352 | -3x | +153 | +199x |
- format_list <- function(lst, empty = empty_text, label_width = 0) {
+ checkmate::assert_class(reporter, "Reporter") |
| 353 | -6x | +154 | +199x |
- if (is.null(lst) || length(lst) == 0) {
+ assert_reactive(data_load_status) |
| 354 | -6x | +155 | +199x |
- empty+ UseMethod("srv_teal_module", modules)
|
| 355 | +156 |
- } else {
+ } |
||
| 356 | -! | +|||
| 157 | +
- colon_space <- paste(rep(" ", label_width), collapse = "")
+
|
|||
| 357 | +158 |
-
+ #' @rdname module_teal_module |
||
| 358 | -! | +|||
| 159 | +
- first_item <- sprintf("%s (%s)", names(lst)[1], cli::col_silver(class(lst[[1]])[1]))
+ #' @export |
|||
| 359 | -! | +|||
| 160 | +
- rest_items <- if (length(lst) > 1) {
+ srv_teal_module.default <- function(id, |
|||
| 360 | -! | +|||
| 161 | +
- paste(+ data, |
|||
| 361 | -! | +|||
| 162 | +
- vapply(+ modules, |
|||
| 362 | -! | +|||
| 163 | +
- names(lst)[-1],+ datasets = NULL, |
|||
| 363 | -! | +|||
| 164 | +
- function(name) {
+ slices_global, |
|||
| 364 | -! | +|||
| 165 | +
- sprintf(+ reporter = teal.reporter::Reporter$new(), |
|||
| 365 | -! | +|||
| 166 | +
- "%s%s (%s)",+ data_load_status = reactive("ok"),
|
|||
| 366 | -! | +|||
| 167 | +
- paste0(content_prefix, "| ", colon_space),+ is_active = reactive(TRUE)) {
|
|||
| 367 | +168 | ! |
- name,+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
|
|
| 368 | -! | +|||
| 169 | +
- cli::col_silver(class(lst[[name]])[1])+ } |
|||
| 369 | +170 |
- )+ |
||
| 370 | +171 |
- },+ #' @rdname module_teal_module |
||
| 371 | -! | +|||
| 172 | +
- character(1)+ #' @export |
|||
| 372 | +173 |
- ),+ srv_teal_module.teal_modules <- function(id, |
||
| 373 | -! | +|||
| 174 | +
- collapse = "\n"+ data, |
|||
| 374 | +175 |
- )+ modules, |
||
| 375 | +176 |
- }+ datasets = NULL, |
||
| 376 | -! | +|||
| 177 | +
- if (length(lst) > 1) paste0(first_item, "\n", rest_items) else first_item+ slices_global, |
|||
| 377 | +178 |
- }+ reporter = teal.reporter::Reporter$new(), |
||
| 378 | +179 |
- }+ data_load_status = reactive("ok"),
|
||
| 379 | +180 |
-
+ is_active = reactive(TRUE)) {
|
||
| 380 | -3x | +181 | +87x |
- bookmarkable <- isTRUE(attr(x, "teal_bookmarkable"))+ moduleServer(id = id, module = function(input, output, session) {
|
| 381 | -3x | +182 | +87x |
- reportable <- "reporter" %in% names(formals(x$server))+ logger::log_debug("srv_teal_module.teal_modules initializing the module { deparse1(modules$label) }.")
|
| 382 | +183 | |||
| 383 | -3x | +184 | +87x |
- transformators <- if (length(x$transformators) > 0) {
+ observeEvent(data_load_status(), {
|
| 384 | -! | +|||
| 185 | +80x |
- paste(sapply(x$transformators, function(t) attr(t, "label")), collapse = ", ")+ tabs_selector <- sprintf("#%s li a", session$ns("active_tab"))
|
||
| 385 | -+ | |||
| 186 | +80x |
- } else {
+ if (identical(data_load_status(), "ok")) {
|
||
| 386 | -3x | +187 | +75x |
- empty_text+ logger::log_debug("srv_teal_module@1 enabling modules tabs.")
|
| 387 | -+ | |||
| 188 | +75x |
- }+ shinyjs::show("wrapper")
|
||
| 388 | -+ | |||
| 189 | +75x |
-
+ shinyjs::enable(selector = tabs_selector) |
||
| 389 | -3x | +190 | +5x |
- output <- pasten(current_prefix, cli::bg_white(cli::col_black(x$label)))+ } else if (identical(data_load_status(), "teal_data_module failed")) {
|
| 390 | -+ | |||
| 191 | +5x |
-
+ logger::log_debug("srv_teal_module@1 disabling modules tabs.")
|
||
| 391 | -3x | +192 | +5x |
- if ("datasets" %in% what) {
+ shinyjs::disable(selector = tabs_selector) |
| 392 | -3x | +|||
| 193 | +! |
- output <- paste0(+ } else if (identical(data_load_status(), "external failed")) {
|
||
| 393 | -3x | +|||
| 194 | +! |
- output,+ logger::log_debug("srv_teal_module@1 hiding modules tabs.")
|
||
| 394 | -3x | +|||
| 195 | +! |
- content_prefix, "|- ", cli::col_yellow("Datasets : "), paste(x$datanames, collapse = ", "), "\n"
+ shinyjs::hide("wrapper")
|
||
| 395 | +196 |
- )+ } |
||
| 396 | +197 |
- }+ }) |
||
| 397 | -3x | +|||
| 198 | +
- if ("properties" %in% what) {
+
|
|||
| 398 | -3x | +199 | +87x |
- output <- paste0(- |
-
| 399 | -3x | -
- output,+ modules_output <- sapply( |
||
| 400 | -3x | +200 | +87x |
- content_prefix, "|- ", cli::col_blue("Properties:"), "\n",
+ names(modules$children), |
| 401 | -3x | +201 | +87x |
- content_prefix, "| |- ", cli::col_cyan("Bookmarkable : "), bookmarkable, "\n",
+ function(module_id) {
|
| 402 | -3x | -
- content_prefix, "| L- ", cli::col_cyan("Reportable : "), reportable, "\n"
- |
- ||
| 403 | -- |
- )- |
- ||
| 404 | -+ | 202 | +112x |
- }+ srv_teal_module( |
| 405 | -3x | +203 | +112x |
- if ("ui_args" %in% what) {
+ id = module_id, |
| 406 | -3x | +204 | +112x |
- ui_args_formatted <- format_list(x$ui_args, label_width = 19)+ data = data, |
| 407 | -3x | +205 | +112x |
- output <- paste0(+ modules = modules$children[[module_id]], |
| 408 | -3x | +206 | +112x |
- output,+ datasets = datasets, |
| 409 | -3x | -
- content_prefix, "|- ", cli::col_green("UI Arguments : "), ui_args_formatted, "\n"
- |
- ||
| 410 | -- |
- )- |
- ||
| 411 | -+ | 207 | +112x |
- }+ slices_global = slices_global, |
| 412 | -3x | +208 | +112x |
- if ("server_args" %in% what) {
+ reporter = reporter, |
| 413 | -3x | +209 | +112x |
- server_args_formatted <- format_list(x$server_args, label_width = 19)+ is_active = reactive( |
| 414 | -3x | +210 | +112x |
- output <- paste0(+ is_active() && |
| 415 | -3x | +211 | +112x |
- output,+ input$active_tab == module_id && |
| 416 | -3x | +212 | +112x |
- content_prefix, "|- ", cli::col_green("Server Arguments : "), server_args_formatted, "\n"
+ identical(data_load_status(), "ok") |
| 417 | +213 |
- )+ ) |
||
| 418 | +214 |
- }- |
- ||
| 419 | -3x | -
- if ("transformators" %in% what) {
- |
- ||
| 420 | -3x | -
- output <- paste0(+ ) |
||
| 421 | -3x | +|||
| 215 | +
- output,+ }, |
|||
| 422 | -3x | +216 | +87x |
- content_prefix, "L- ", cli::col_magenta("Transformators : "), transformators, "\n"
+ simplify = FALSE |
| 423 | +217 |
) |
||
| 424 | -- |
- }- |
- ||
| 425 | +218 | |||
| 426 | -3x | +219 | +87x |
- output+ modules_output |
| 427 | +220 |
- }+ }) |
||
| 428 | +221 |
-
+ } |
||
| 429 | +222 |
- #' @rdname teal_modules+ |
||
| 430 | +223 |
- #' @examples+ #' @rdname module_teal_module |
||
| 431 | +224 |
- #' custom_module <- function(+ #' @export |
||
| 432 | +225 |
- #' label = "label", ui_args = NULL, server_args = NULL,+ srv_teal_module.teal_module <- function(id, |
||
| 433 | +226 |
- #' datanames = "all", transformators = list(), bk = FALSE) {
+ data, |
||
| 434 | +227 |
- #' ans <- module(+ modules, |
||
| 435 | +228 |
- #' label,+ datasets = NULL, |
||
| 436 | +229 |
- #' server = function(id, data, ...) {},
+ slices_global, |
||
| 437 | +230 |
- #' ui = function(id, ...) {
+ reporter = teal.reporter::Reporter$new(), |
||
| 438 | +231 |
- #' },+ data_load_status = reactive("ok"),
|
||
| 439 | +232 |
- #' datanames = datanames,+ is_active = reactive(TRUE)) {
|
||
| 440 | -+ | |||
| 233 | +112x |
- #' transformators = transformators,+ logger::log_debug("srv_teal_module.teal_module initializing the module: { deparse1(modules$label) }.")
|
||
| 441 | -+ | |||
| 234 | +112x |
- #' ui_args = ui_args,+ moduleServer(id = id, module = function(input, output, session) {
|
||
| 442 | -+ | |||
| 235 | +112x |
- #' server_args = server_args+ module_out <- reactiveVal() |
||
| 443 | +236 |
- #' )+ |
||
| 444 | -+ | |||
| 237 | +112x |
- #' attr(ans, "teal_bookmarkable") <- bk+ active_datanames <- reactive({
|
||
| 445 | -+ | |||
| 238 | +89x |
- #' ans+ .resolve_module_datanames(data = data(), modules = modules) |
||
| 446 | +239 |
- #' }+ }) |
||
| 447 | -+ | |||
| 240 | +112x |
- #'+ if (is.null(datasets)) {
|
||
| 448 | -+ | |||
| 241 | +20x |
- #' dummy_transformator <- teal_transform_module(+ datasets <- eventReactive(data(), {
|
||
| 449 | -+ | |||
| 242 | +16x |
- #' label = "Dummy Transform",+ req(inherits(data(), "teal_data")) |
||
| 450 | -+ | |||
| 243 | +16x |
- #' ui = function(id) div("(does nothing)"),
+ logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
|
||
| 451 | -+ | |||
| 244 | +16x |
- #' server = function(id, data) {
+ teal_data_to_filtered_data(data(), datanames = active_datanames()) |
||
| 452 | +245 |
- #' moduleServer(id, function(input, output, session) data)+ }) |
||
| 453 | +246 |
- #' }+ } |
||
| 454 | +247 |
- #' )+ |
||
| 455 | +248 |
- #'+ # manage module filters on the module level |
||
| 456 | +249 |
- #' plot_transformator <- teal_transform_module(+ # important: |
||
| 457 | +250 |
- #' label = "Plot Settings",+ # filter_manager_module_srv needs to be called before filter_panel_srv |
||
| 458 | +251 |
- #' ui = function(id) div("(does nothing)"),
+ # Because available_teal_slices is used in FilteredData$srv_available_slices (via srv_filter_panel) |
||
| 459 | +252 |
- #' server = function(id, data) {
+ # and if it is not set, then it won't be available in the srv_filter_panel |
||
| 460 | -+ | |||
| 253 | +112x |
- #' moduleServer(id, function(input, output, session) data)+ srv_module_filter_manager(modules$label, module_fd = datasets, slices_global = slices_global) |
||
| 461 | +254 |
- #' }+ |
||
| 462 | -+ | |||
| 255 | +112x |
- #' )+ call_once_when(is_active(), {
|
||
| 463 | -+ | |||
| 256 | +86x |
- #'+ filtered_teal_data <- srv_filter_data( |
||
| 464 | -+ | |||
| 257 | +86x |
- #' complete_modules <- modules(+ "filter_panel", |
||
| 465 | -+ | |||
| 258 | +86x |
- #' custom_module(+ datasets = datasets, |
||
| 466 | -+ | |||
| 259 | +86x |
- #' label = "Data Overview",+ active_datanames = active_datanames, |
||
| 467 | -+ | |||
| 260 | +86x |
- #' datanames = c("ADSL", "ADAE", "ADVS"),
+ data = data, |
||
| 468 | -+ | |||
| 261 | +86x |
- #' ui_args = list(+ is_active = is_active |
||
| 469 | +262 |
- #' view_type = "table",+ ) |
||
| 470 | -+ | |||
| 263 | +86x |
- #' page_size = 10,+ is_transform_failed <- reactiveValues() |
||
| 471 | -+ | |||
| 264 | +86x |
- #' filters = c("ARM", "SEX", "RACE")
+ transformed_teal_data <- srv_transform_teal_data( |
||
| 472 | -+ | |||
| 265 | +86x |
- #' ),+ "data_transform", |
||
| 473 | -+ | |||
| 266 | +86x |
- #' server_args = list(+ data = filtered_teal_data, |
||
| 474 | -+ | |||
| 267 | +86x |
- #' cache = TRUE,+ transformators = modules$transformators, |
||
| 475 | -+ | |||
| 268 | +86x |
- #' debounce = 1000+ modules = modules, |
||
| 476 | -+ | |||
| 269 | +86x |
- #' ),+ is_transform_failed = is_transform_failed |
||
| 477 | +270 |
- #' transformators = list(dummy_transformator),+ ) |
||
| 478 | -+ | |||
| 271 | +86x |
- #' bk = TRUE+ any_transform_failed <- reactive({
|
||
| 479 | -+ | |||
| 272 | +86x |
- #' ),+ any(unlist(reactiveValuesToList(is_transform_failed))) |
||
| 480 | +273 |
- #' modules(+ }) |
||
| 481 | +274 |
- #' label = "Nested 1",+ |
||
| 482 | -+ | |||
| 275 | +86x |
- #' custom_module(+ observeEvent(any_transform_failed(), {
|
||
| 483 | -+ | |||
| 276 | +86x |
- #' label = "Interactive Plots",+ if (isTRUE(any_transform_failed())) {
|
||
| 484 | -+ | |||
| 277 | +6x |
- #' datanames = c("ADSL", "ADVS"),
+ shinyjs::hide("teal_module_ui")
|
||
| 485 | -+ | |||
| 278 | +6x |
- #' ui_args = list(+ shinyjs::show("transform_failure_info")
|
||
| 486 | +279 |
- #' plot_type = c("scatter", "box", "line"),
+ } else {
|
||
| 487 | -+ | |||
| 280 | +80x |
- #' height = 600,+ shinyjs::show("teal_module_ui")
|
||
| 488 | -+ | |||
| 281 | +80x |
- #' width = 800,+ shinyjs::hide("transform_failure_info")
|
||
| 489 | +282 |
- #' color_scheme = "viridis"+ } |
||
| 490 | +283 |
- #' ),+ }) |
||
| 491 | +284 |
- #' server_args = list(+ |
||
| 492 | -+ | |||
| 285 | +86x |
- #' render_type = "svg",+ module_teal_data <- reactive({
|
||
| 493 | -+ | |||
| 286 | +94x |
- #' cache_plots = TRUE+ req(inherits(transformed_teal_data(), "teal_data")) |
||
| 494 | -+ | |||
| 287 | +88x |
- #' ),+ all_teal_data <- transformed_teal_data() |
||
| 495 | -+ | |||
| 288 | +88x |
- #' transformators = list(dummy_transformator, plot_transformator),+ module_datanames <- .resolve_module_datanames(data = all_teal_data, modules = modules) |
||
| 496 | -+ | |||
| 289 | +88x |
- #' bk = TRUE+ all_teal_data[c(module_datanames, ".raw_data")] |
||
| 497 | +290 |
- #' ),+ }) |
||
| 498 | +291 |
- #' modules(+ |
||
| 499 | -+ | |||
| 292 | +86x |
- #' label = "Nested 2",+ srv_check_module_datanames( |
||
| 500 | -+ | |||
| 293 | +86x |
- #' custom_module(+ "validate_datanames", |
||
| 501 | -+ | |||
| 294 | +86x |
- #' label = "Summary Statistics",+ data = module_teal_data, |
||
| 502 | -+ | |||
| 295 | +86x |
- #' datanames = "ADSL",+ modules = modules |
||
| 503 | +296 |
- #' ui_args = list(+ ) |
||
| 504 | +297 |
- #' stats = c("mean", "median", "sd", "range"),
+
|
||
| 505 | -+ | |||
| 298 | +86x |
- #' grouping = c("ARM", "SEX")
+ summary_table <- srv_data_summary("data_summary", module_teal_data)
|
||
| 506 | +299 |
- #' )+ |
||
| 507 | +300 |
- #' ),+ # Call modules. |
||
| 508 | -+ | |||
| 301 | +86x |
- #' modules(+ if (!inherits(modules, "teal_module_previewer")) {
|
||
| 509 | -+ | |||
| 302 | +86x |
- #' label = "Labeled nested modules",+ obs_module <- call_once_when( |
||
| 510 | -+ | |||
| 303 | +86x |
- #' custom_module(+ !is.null(module_teal_data()), |
||
| 511 | -+ | |||
| 304 | +86x |
- #' label = "Subgroup Analysis",+ ignoreNULL = TRUE, |
||
| 512 | -+ | |||
| 305 | +86x |
- #' datanames = c("ADSL", "ADAE"),
+ handlerExpr = {
|
||
| 513 | -+ | |||
| 306 | +80x |
- #' ui_args = list(+ module_out(.call_teal_module(modules, datasets, module_teal_data, reporter)) |
||
| 514 | +307 |
- #' subgroups = c("AGE", "SEX", "RACE"),
+ } |
||
| 515 | +308 |
- #' analysis_type = "stratified"+ ) |
||
| 516 | +309 |
- #' ),+ } else {
|
||
| 517 | +310 |
- #' bk = TRUE+ # Report previewer must be initiated on app start for report cards to be included in bookmarks. |
||
| 518 | +311 |
- #' )+ # When previewer is delayed, cards are bookmarked only if previewer has been initiated (visited). |
||
| 519 | -+ | |||
| 312 | +! |
- #' ),+ module_out(.call_teal_module(modules, datasets, module_teal_data, reporter)) |
||
| 520 | +313 |
- #' modules(custom_module(label = "Subgroup Analysis in non-labled modules"))+ } |
||
| 521 | +314 |
- #' )+ }) |
||
| 522 | +315 |
- #' ),+ + |
+ ||
| 316 | +112x | +
+ module_out |
||
| 523 | +317 |
- #' custom_module("Non-nested module")
+ }) |
||
| 524 | +318 |
- #' )+ } |
||
| 525 | +319 |
- #'+ |
||
| 526 | +320 |
- #' cat(format(complete_modules))+ # This function calls a module server function. |
||
| 527 | +321 |
- #' cat(format(complete_modules, what = c("ui_args", "server_args", "transformators")))
+ .call_teal_module <- function(modules, datasets, data, reporter) {
+ |
+ ||
| 322 | +80x | +
+ assert_reactive(data) |
||
| 528 | +323 |
- #' @export+ |
||
| 529 | +324 |
- format.teal_modules <- function(x, is_root = TRUE, is_last = FALSE, parent_prefix = "", ...) {
+ # collect arguments to run teal_module |
||
| 530 | -1x | +325 | +80x |
- if (is_root) {
+ args <- c(list(id = "module"), modules$server_args) |
| 531 | -1x | +326 | +80x |
- header <- pasten(cli::style_bold("TEAL ROOT"))
+ if (is_arg_used(modules$server, "reporter")) {
|
| 532 | +327 | 1x |
- new_parent_prefix <- " " #' Initial indent for root level+ args <- c(args, list(reporter = reporter)) |
|
| 533 | +328 |
- } else {
- |
- ||
| 534 | -! | -
- if (!is.null(x$label)) {
- |
- ||
| 535 | -! | -
- branch <- if (is_last) "L-" else "|-"- |
- ||
| 536 | -! | -
- header <- pasten(parent_prefix, branch, " ", cli::style_bold(x$label))- |
- ||
| 537 | -! | -
- new_parent_prefix <- paste0(parent_prefix, if (is_last) " " else "| ")+ } |
||
| 538 | +329 |
- } else {
+
|
||
| 539 | -! | +|||
| 330 | +80x |
- header <- ""+ if (is_arg_used(modules$server, "datasets")) {
|
||
| 540 | -! | +|||
| 331 | +1x |
- new_parent_prefix <- parent_prefix+ args <- c(args, datasets = datasets()) |
||
| 541 | -+ | |||
| 332 | +1x |
- }+ warning("datasets argument is not reactive and therefore it won't be updated when data is refreshed.")
|
||
| 542 | +333 |
} |
||
| 543 | +334 | |||
| 544 | -1x | +335 | +80x |
- if (length(x$children) > 0) {
+ if (is_arg_used(modules$server, "data")) {
|
| 545 | -1x | +336 | +76x |
- children_output <- character(0)+ args <- c(args, data = list(data)) |
| 546 | -1x | +|||
| 337 | +
- n_children <- length(x$children)+ } |
|||
| 547 | +338 | |||
| 548 | -1x | +339 | +80x |
- for (i in seq_along(x$children)) {
+ if (is_arg_used(modules$server, "filter_panel_api")) {
|
| 549 | -3x | +340 | +1x |
- child <- x$children[[i]]+ args <- c(args, filter_panel_api = teal.slice::FilterPanelAPI$new(datasets())) |
| 550 | -3x | +|||
| 341 | +
- is_last_child <- (i == n_children)+ } |
|||
| 551 | +342 | |||
| 552 | -3x | -
- if (inherits(child, "teal_modules")) {
- |
- ||
| 553 | -! | -
- children_output <- c(- |
- ||
| 554 | -! | -
- children_output,- |
- ||
| 555 | -! | +343 | +80x |
- format(child,+ if (is_arg_used(modules$server, "id")) {
|
| 556 | -! | +|||
| 344 | +80x |
- is_root = FALSE,+ do.call(modules$server, args) |
||
| 557 | -! | +|||
| 345 | +
- is_last = is_last_child,+ } else {
|
|||
| 558 | +346 | ! |
- parent_prefix = new_parent_prefix,+ do.call(callModule, c(args, list(module = modules$server))) |
|
| 559 | +347 |
- ...+ } |
||
| 560 | +348 |
- )+ } |
||
| 561 | +349 |
- )+ |
||
| 562 | +350 |
- } else {
+ .resolve_module_datanames <- function(data, modules) {
|
||
| 563 | -3x | +351 | +177x |
- children_output <- c(+ stopifnot("data must be teal_data object." = inherits(data, "teal_data"))
|
| 564 | -3x | +352 | +177x |
- children_output,+ if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
|
| 565 | -3x | +353 | +145x |
- format(child,+ names(data) |
| 566 | -3x | +|||
| 354 | +
- is_last = is_last_child,+ } else {
|
|||
| 567 | -3x | +355 | +32x |
- parent_prefix = new_parent_prefix,+ intersect( |
| 568 | -+ | |||
| 356 | +32x |
- ...+ names(data), # Keep topological order from teal.data::names() |
||
| 569 | -+ | |||
| 357 | +32x |
- )+ .include_parent_datanames(modules$datanames, teal.data::join_keys(data)) |
||
| 570 | +358 |
- )+ ) |
||
| 571 | +359 |
- }+ } |
||
| 572 | +360 |
- }+ } |
||
| 573 | +361 | |||
| 574 | -1x | +|||
| 362 | +
- paste0(header, paste(children_output, collapse = ""))+ #' Calls expression when condition is met |
|||
| 575 | +363 |
- } else {
+ #' |
||
| 576 | -! | +|||
| 364 | +
- header+ #' Function postpones `handlerExpr` to the moment when `eventExpr` (condition) returns `TRUE`, |
|||
| 577 | +365 |
- }+ #' otherwise nothing happens. |
||
| 578 | +366 |
- }+ #' @param eventExpr A (quoted or unquoted) logical expression that represents the event; |
||
| 579 | +367 |
-
+ #' this can be a simple reactive value like input$click, a call to a reactive expression |
||
| 580 | +368 |
- #' @rdname teal_modules+ #' like dataset(), or even a complex expression inside curly braces. |
||
| 581 | +369 |
- #' @export+ #' @param ... additional arguments passed to `observeEvent` with the exception of `eventExpr` that is not allowed. |
||
| 582 | +370 |
- print.teal_module <- function(x, ...) {
+ #' @inheritParams shiny::observeEvent |
||
| 583 | -! | +|||
| 371 | +
- cat(format(x, ...))+ #' |
|||
| 584 | -! | +|||
| 372 | +
- invisible(x)+ #' @return An observer. |
|||
| 585 | +373 |
- }+ #' |
||
| 586 | +374 |
-
+ #' @keywords internal |
||
| 587 | +375 |
- #' @rdname teal_modules+ call_once_when <- function(eventExpr, # nolint: object_name. |
||
| 588 | +376 |
- #' @export+ handlerExpr, # nolint: object_name. |
||
| 589 | +377 |
- print.teal_modules <- function(x, ...) {
+ event.env = parent.frame(), # nolint: object_name. |
||
| 590 | -! | +|||
| 378 | +
- cat(format(x, ...))+ handler.env = parent.frame(), # nolint: object_name. |
|||
| 591 | -! | +|||
| 379 | +
- invisible(x)+ ...) {
|
|||
| 592 | -+ | |||
| 380 | +198x |
- }+ event_quo <- rlang::new_quosure(substitute(eventExpr), env = event.env)+ |
+ ||
| 381 | +198x | +
+ handler_quo <- rlang::new_quosure(substitute(handlerExpr), env = handler.env) |
||
| 593 | +382 | |||
| 594 | +383 |
- #' @param modules (`teal_module` or `teal_modules`)+ # When `condExpr` is TRUE, then `handlerExpr` is evaluated once. |
||
| 595 | -+ | |||
| 384 | +198x |
- #' @rdname teal_modules+ activator <- reactive({
|
||
| 596 | -+ | |||
| 385 | +198x |
- #' @examples+ if (isTRUE(rlang::eval_tidy(event_quo))) {
|
||
| 597 | -+ | |||
| 386 | +166x |
- #' # change the module's datanames+ TRUE |
||
| 598 | +387 |
- #' set_datanames(module(datanames = "all"), "a")+ } |
||
| 599 | +388 |
- #'+ }) |
||
| 600 | +389 |
- #' # change modules' datanames+ |
||
| 601 | -+ | |||
| 390 | +198x |
- #' set_datanames(+ observeEvent( |
||
| 602 | -+ | |||
| 391 | +198x |
- #' modules(+ eventExpr = activator(), |
||
| 603 | -+ | |||
| 392 | +198x |
- #' module(datanames = "all"),+ once = TRUE, |
||
| 604 | -+ | |||
| 393 | +198x |
- #' module(datanames = "a")+ handlerExpr = rlang::eval_tidy(handler_quo), |
||
| 605 | +394 |
- #' ),+ ... |
||
| 606 | +395 |
- #' "b"+ ) |
||
| 607 | +396 |
- #' )+ } |
| 608 | +1 |
- #' @export+ #' Data summary |
||
| 609 | +2 |
- set_datanames <- function(modules, datanames) {
+ #' @description |
||
| 610 | -! | +|||
| 3 | +
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ #' Module and its utils to display the number of rows and subjects in the filtered and unfiltered data. |
|||
| 611 | -! | +|||
| 4 | +
- if (inherits(modules, "teal_modules")) {
+ #' |
|||
| 612 | -! | +|||
| 5 | +
- modules$children <- lapply(modules$children, set_datanames, datanames)+ #' @details Handling different data classes: |
|||
| 613 | +6 |
- } else {
+ #' `get_filter_overview()` is a pseudo S3 method which has variants for: |
||
| 614 | -! | +|||
| 7 | +
- if (identical(modules$datanames, "all")) {
+ #' - `array` (`data.frame`, `DataFrame`, `array`, `Matrix` and `SummarizedExperiment`): Method variant |
|||
| 615 | -! | +|||
| 8 | +
- modules$datanames <- datanames+ #' can be applied to any two-dimensional objects on which [ncol()] can be used. |
|||
| 616 | +9 |
- } else {
+ #' - `MultiAssayExperiment`: for which summary contains counts for `colData` and all `experiments`. |
||
| 617 | -! | +|||
| 10 | +
- warning(+ #' - For other data types module displays data name with warning icon and no more details. |
|||
| 618 | -! | +|||
| 11 | +
- "Not possible to modify datanames of the module ", modules$label,+ #' |
|||
| 619 | -! | +|||
| 12 | +
- ". set_datanames() can only change datanames if it was set to \"all\".",+ #' Module includes also "Show/Hide unsupported" button to toggle rows of the summary table |
|||
| 620 | -! | +|||
| 13 | +
- call. = FALSE+ #' containing datasets where number of observations are not calculated. |
|||
| 621 | +14 |
- )+ #' |
||
| 622 | +15 |
- }+ #' @param id (`character(1)`) `shiny` module instance id. |
||
| 623 | +16 |
- }+ #' @param teal_data (`reactive` returning `teal_data`) |
||
| 624 | -! | +|||
| 17 | +
- modules+ #' |
|||
| 625 | +18 |
- }+ #' @name module_data_summary |
||
| 626 | +19 |
-
+ #' @rdname module_data_summary |
||
| 627 | +20 |
- # utilities ----+ #' @keywords internal |
||
| 628 | +21 |
- ## subset or modify modules ----+ #' @return `NULL`. |
||
| 629 | +22 |
-
+ NULL |
||
| 630 | +23 |
- #' Append a `teal_module` to `children` of a `teal_modules` object+ |
||
| 631 | +24 |
- #' @keywords internal+ #' @rdname module_data_summary |
||
| 632 | +25 |
- #' @param modules (`teal_modules`)+ ui_data_summary <- function(id) {
|
||
| 633 | -+ | |||
| 26 | +! |
- #' @param module (`teal_module`) object to be appended onto the children of `modules`+ ns <- NS(id) |
||
| 634 | -+ | |||
| 27 | +! |
- #' @return A `teal_modules` object with `module` appended.+ content_id <- ns("filters_overview_contents")
|
||
| 635 | -+ | |||
| 28 | +! |
- append_module <- function(modules, module) {
+ tags$div( |
||
| 636 | -8x | +|||
| 29 | +! |
- checkmate::assert_class(modules, "teal_modules")+ id = id, |
||
| 637 | -6x | +|||
| 30 | +! |
- checkmate::assert_class(module, "teal_module")+ class = "well", |
||
| 638 | -4x | +|||
| 31 | +! |
- modules$children <- c(modules$children, list(module))+ tags$div( |
||
| 639 | -4x | +|||
| 32 | +! |
- labels <- vapply(modules$children, function(submodule) submodule$label, character(1))+ class = "row", |
||
| 640 | -4x | +|||
| 33 | +! |
- names(modules$children) <- get_unique_labels(labels)+ tags$div( |
||
| 641 | -4x | +|||
| 34 | +! |
- modules+ class = "col-sm-9", |
||
| 642 | -+ | |||
| 35 | +! |
- }+ tags$label("Active Filter Summary", class = "text-primary mb-4")
|
||
| 643 | +36 |
-
+ ), |
||
| 644 | -+ | |||
| 37 | +! |
- #' Extract/Remove module(s) of specific class+ tags$div( |
||
| 645 | -+ | |||
| 38 | +! |
- #'+ class = "col-sm-3", |
||
| 646 | -+ | |||
| 39 | +! |
- #' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`.+ tags$i( |
||
| 647 | -+ | |||
| 40 | +! |
- #'+ class = "remove pull-right fa fa-angle-down", |
||
| 648 | -+ | |||
| 41 | +! |
- #' @param modules (`teal_modules`)+ style = "cursor: pointer;", |
||
| 649 | -+ | |||
| 42 | +! |
- #' @param class The class name of `teal_module` to be extracted or dropped.+ title = "fold/expand data summary panel", |
||
| 650 | -+ | |||
| 43 | +! |
- #' @keywords internal+ onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", content_id)
|
||
| 651 | +44 |
- #' @return+ ) |
||
| 652 | +45 |
- #' - For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`.+ ) |
||
| 653 | +46 |
- #' - For `drop_module`, the opposite, which is all `teal_modules` of class other than `class`.- |
- ||
| 654 | -- |
- #' @rdname module_management+ ), |
||
| 655 | -+ | |||
| 47 | +! |
- extract_module <- function(modules, class) {
+ tags$div( |
||
| 656 | -28x | +|||
| 48 | +! |
- if (inherits(modules, class)) {
+ id = content_id, |
||
| 657 | +49 | ! |
- modules+ tags$div( |
|
| 658 | -28x | +|||
| 50 | +! |
- } else if (inherits(modules, "teal_module")) {
+ class = "teal_active_summary_filter_panel", |
||
| 659 | -15x | +|||
| 51 | +! |
- NULL+ tableOutput(ns("table"))
|
||
| 660 | -13x | +|||
| 52 | +
- } else if (inherits(modules, "teal_modules")) {
+ ) |
|||
| 661 | -13x | +|||
| 53 | +
- Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class))+ ) |
|||
| 662 | +54 |
- }+ ) |
||
| 663 | +55 |
} |
||
| 664 | +56 | |||
| 665 | +57 |
- #' @keywords internal+ #' @rdname module_data_summary |
||
| 666 | +58 |
- #' @return `teal_modules`+ srv_data_summary <- function(id, data) {
|
||
| 667 | -+ | |||
| 59 | +86x |
- #' @rdname module_management+ assert_reactive(data) |
||
| 668 | -+ | |||
| 60 | +86x |
- drop_module <- function(modules, class) {
+ moduleServer( |
||
| 669 | -! | +|||
| 61 | +86x |
- if (inherits(modules, class)) {
+ id = id, |
||
| 670 | -! | +|||
| 62 | +86x |
- NULL+ function(input, output, session) {
|
||
| 671 | -! | +|||
| 63 | +86x |
- } else if (inherits(modules, "teal_module")) {
+ logger::log_debug("srv_data_summary initializing")
|
||
| 672 | -! | +|||
| 64 | +
- modules+ |
|||
| 673 | -! | +|||
| 65 | +86x |
- } else if (inherits(modules, "teal_modules")) {
+ summary_table <- reactive({
|
||
| 674 | -! | +|||
| 66 | +94x |
- do.call(+ req(inherits(data(), "teal_data")) |
||
| 675 | -! | +|||
| 67 | +88x |
- "modules",+ if (!length(data())) {
|
||
| 676 | +68 | ! |
- c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label)+ return(NULL) |
|
| 677 | +69 |
- )+ } |
||
| 678 | -+ | |||
| 70 | +88x |
- }+ get_filter_overview_wrapper(data) |
||
| 679 | +71 |
- }+ }) |
||
| 680 | +72 | |||
| 681 | -+ | |||
| 73 | +86x |
- ## read modules ----+ output$table <- renderUI({
|
||
| 682 | -+ | |||
| 74 | +94x |
-
+ summary_table_out <- try(summary_table(), silent = TRUE) |
||
| 683 | -+ | |||
| 75 | +94x |
- #' Does the object make use of the `arg`+ if (inherits(summary_table_out, "try-error")) {
|
||
| 684 | +76 |
- #'+ # Ignore silent shiny error |
||
| 685 | -+ | |||
| 77 | +6x |
- #' @param modules (`teal_module` or `teal_modules`) object+ if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
|
||
| 686 | -+ | |||
| 78 | +! |
- #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.+ stop("Error occurred during data processing. See details in the main panel.")
|
||
| 687 | +79 |
- #' @return `logical` whether the object makes use of `arg`.+ } |
||
| 688 | -+ | |||
| 80 | +88x |
- #' @rdname is_arg_used+ } else if (is.null(summary_table_out)) {
|
||
| 689 | -+ | |||
| 81 | +2x |
- #' @keywords internal+ "no datasets to show" |
||
| 690 | +82 |
- is_arg_used <- function(modules, arg) {
+ } else {
|
||
| 691 | -519x | +83 | +86x |
- checkmate::assert_string(arg)+ is_unsupported <- apply(summary_table(), 1, function(x) all(is.na(x[-1]))) |
| 692 | -516x | +84 | +86x |
- if (inherits(modules, "teal_modules")) {
+ summary_table_out[is.na(summary_table_out)] <- "" |
| 693 | -20x | +85 | +86x |
- any(unlist(lapply(modules$children, is_arg_used, arg)))+ body_html <- apply( |
| 694 | -496x | +86 | +86x |
- } else if (inherits(modules, "teal_module")) {
+ summary_table_out, |
| 695 | -32x | +87 | +86x |
- is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg)+ 1, |
| 696 | -464x | +88 | +86x |
- } else if (is.function(modules)) {
+ function(x) {
|
| 697 | -462x | -
- isTRUE(arg %in% names(formals(modules)))- |
- ||
| 698 | -+ | 89 | +162x |
- } else {
+ is_supported <- !all(x[-1] == "") |
| 699 | -2x | -
- stop("is_arg_used function not implemented for this object")
- |
- ||
| 700 | -+ | 90 | +162x |
- }+ if (is_supported) {
|
| 701 | -+ | |||
| 91 | +153x |
- }+ tags$tr( |
||
| 702 | -+ | |||
| 92 | +153x |
-
+ tagList( |
||
| 703 | -+ | |||
| 93 | +153x |
-
+ tags$td(x[1]), |
||
| 704 | -+ | |||
| 94 | +153x |
- #' Get module depth+ lapply(x[-1], tags$td) |
||
| 705 | +95 |
- #'+ ) |
||
| 706 | +96 |
- #' Depth starts at 0, so a single `teal.module` has depth 0.+ ) |
||
| 707 | +97 |
- #' Nesting it increases overall depth by 1.+ } |
||
| 708 | +98 |
- #'+ } |
||
| 709 | +99 |
- #' @inheritParams init+ ) |
||
| 710 | +100 |
- #' @param depth optional integer determining current depth level+ |
||
| 711 | -+ | |||
| 101 | +86x |
- #'+ header_labels <- tools::toTitleCase(names(summary_table_out)) |
||
| 712 | -+ | |||
| 102 | +86x |
- #' @return Depth level for given module.+ header_labels[header_labels == "Dataname"] <- "Data Name" |
||
| 713 | -+ | |||
| 103 | +86x |
- #' @keywords internal+ header_html <- tags$tr(tagList(lapply(header_labels, tags$td))) |
||
| 714 | +104 |
- modules_depth <- function(modules, depth = 0L) {
+
|
||
| 715 | -12x | +105 | +86x |
- checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
+ table_html <- tags$table( |
| 716 | -12x | +106 | +86x |
- checkmate::assert_int(depth, lower = 0)+ class = "table custom-table", |
| 717 | -11x | +107 | +86x |
- if (inherits(modules, "teal_modules")) {
+ tags$thead(header_html), |
| 718 | -4x | +108 | +86x |
- max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))+ tags$tbody(body_html) |
| 719 | +109 |
- } else {
+ ) |
||
| 720 | -7x | +110 | +86x |
- depth+ div( |
| 721 | -+ | |||
| 111 | +86x |
- }+ table_html, |
||
| 722 | -+ | |||
| 112 | +86x |
- }+ if (any(is_unsupported)) {
|
||
| 723 | -+ | |||
| 113 | +9x |
-
+ p( |
||
| 724 | -+ | |||
| 114 | +9x |
- #' Retrieve labels from `teal_modules`+ class = c("pull-right", "float-right", "text-secondary"),
|
||
| 725 | -+ | |||
| 115 | +9x |
- #'+ style = "font-size: 0.8em;", |
||
| 726 | -+ | |||
| 116 | +9x |
- #' @param modules (`teal_modules`)+ sprintf("And %s more unfilterable object(s)", sum(is_unsupported)),
|
||
| 727 | -+ | |||
| 117 | +9x |
- #' @return A `list` containing the labels of the modules. If the modules are nested,+ icon( |
||
| 728 | -+ | |||
| 118 | +9x |
- #' the function returns a nested `list` of labels.+ name = "far fa-circle-question", |
||
| 729 | -+ | |||
| 119 | +9x |
- #' @keywords internal+ title = paste( |
||
| 730 | -+ | |||
| 120 | +9x |
- module_labels <- function(modules) {
+ sep = "", |
||
| 731 | -199x | +121 | +9x |
- if (inherits(modules, "teal_modules")) {
+ collapse = "\n", |
| 732 | -87x | +122 | +9x |
- lapply(modules$children, module_labels)+ shQuote(summary_table()[is_unsupported, "dataname"]), |
| 733 | +123 |
- } else {
+ " (",
|
||
| 734 | -112x | +124 | +9x |
- modules$label+ vapply( |
| 735 | -+ | |||
| 125 | +9x |
- }+ summary_table()[is_unsupported, "dataname"], |
||
| 736 | -+ | |||
| 126 | +9x |
- }+ function(x) class(data()[[x]])[1], |
||
| 737 | -+ | |||
| 127 | +9x |
-
+ character(1L) |
||
| 738 | +128 |
- #' Retrieve `teal_bookmarkable` attribute from `teal_modules`+ ), |
||
| 739 | +129 |
- #'+ ")" |
||
| 740 | +130 |
- #' @param modules (`teal_modules` or `teal_module`) object+ ) |
||
| 741 | +131 |
- #' @return named list of the same structure as `modules` with `TRUE` or `FALSE` values indicating+ ) |
||
| 742 | +132 |
- #' whether the module is bookmarkable.+ ) |
||
| 743 | +133 |
- #' @keywords internal+ } |
||
| 744 | +134 |
- modules_bookmarkable <- function(modules) {
- |
- ||
| 745 | -199x | -
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
- |
- ||
| 746 | -199x | -
- if (inherits(modules, "teal_modules")) {
- |
- ||
| 747 | -87x | -
- setNames(- |
- ||
| 748 | -87x | -
- lapply(modules$children, modules_bookmarkable),+ ) |
||
| 749 | -87x | +|||
| 135 | +
- vapply(modules$children, `[[`, "label", FUN.VALUE = character(1))+ } |
|||
| 750 | +136 |
- )+ }) |
||
| 751 | +137 |
- } else {
+
|
||
| 752 | -112x | -
- attr(modules, "teal_bookmarkable", exact = TRUE)- |
- ||
| 753 | -+ | 138 | +86x |
- }+ NULL |
| 754 | +139 |
- }+ } |
| 1 | +140 |
- #' Data summary+ ) |
||
| 2 | +141 |
- #' @description+ } |
||
| 3 | +142 |
- #' Module and its utils to display the number of rows and subjects in the filtered and unfiltered data.+ |
||
| 4 | +143 |
- #'+ #' @rdname module_data_summary |
||
| 5 | +144 |
- #' @details Handling different data classes:+ get_filter_overview_wrapper <- function(teal_data) {
|
||
| 6 | +145 |
- #' `get_filter_overview()` is a pseudo S3 method which has variants for:+ # Sort datanames in topological order |
||
| 7 | -+ | |||
| 146 | +88x |
- #' - `array` (`data.frame`, `DataFrame`, `array`, `Matrix` and `SummarizedExperiment`): Method variant+ datanames <- names(teal_data()) |
||
| 8 | -+ | |||
| 147 | +88x |
- #' can be applied to any two-dimensional objects on which [ncol()] can be used.+ joinkeys <- teal.data::join_keys(teal_data()) |
||
| 9 | +148 |
- #' - `MultiAssayExperiment`: for which summary contains counts for `colData` and all `experiments`.+ |
||
| 10 | -+ | |||
| 149 | +88x |
- #' - For other data types module displays data name with warning icon and no more details.+ current_data_objs <- sapply( |
||
| 11 | -+ | |||
| 150 | +88x |
- #'+ datanames, |
||
| 12 | -+ | |||
| 151 | +88x |
- #' Module includes also "Show/Hide unsupported" button to toggle rows of the summary table+ function(name) teal_data()[[name]], |
||
| 13 | -+ | |||
| 152 | +88x |
- #' containing datasets where number of observations are not calculated.+ simplify = FALSE |
||
| 14 | +153 |
- #'+ ) |
||
| 15 | -+ | |||
| 154 | +88x |
- #' @param id (`character(1)`) `shiny` module instance id.+ initial_data_objs <- teal_data()[[".raw_data"]] |
||
| 16 | +155 |
- #' @param teal_data (`reactive` returning `teal_data`)+ |
||
| 17 | -+ | |||
| 156 | +88x |
- #'+ out <- lapply( |
||
| 18 | -+ | |||
| 157 | +88x |
- #' @name module_data_summary+ datanames, |
||
| 19 | -+ | |||
| 158 | +88x |
- #' @rdname module_data_summary+ function(dataname) {
|
||
| 20 | -+ | |||
| 159 | +157x |
- #' @keywords internal+ parent <- teal.data::parent(joinkeys, dataname) |
||
| 21 | -+ | |||
| 160 | +157x |
- #' @return `NULL`.+ subject_keys <- if (length(parent) > 0) {
|
||
| 22 | -+ | |||
| 161 | +8x |
- NULL+ names(joinkeys[dataname, parent]) |
||
| 23 | +162 |
-
+ } else {
|
||
| 24 | -+ | |||
| 163 | +149x |
- #' @rdname module_data_summary+ joinkeys[dataname, dataname] |
||
| 25 | +164 |
- ui_data_summary <- function(id) {
+ } |
||
| 26 | -! | +|||
| 165 | +157x |
- ns <- NS(id)+ get_filter_overview( |
||
| 27 | -! | +|||
| 166 | +157x |
- content_id <- ns("filters_overview_contents")
+ current_data = current_data_objs[[dataname]], |
||
| 28 | -! | +|||
| 167 | +157x |
- tags$div(+ initial_data = initial_data_objs[[dataname]], |
||
| 29 | -! | +|||
| 168 | +157x |
- id = id,+ dataname = dataname, |
||
| 30 | -! | +|||
| 169 | +157x |
- class = "well",+ subject_keys = subject_keys |
||
| 31 | -! | +|||
| 170 | +
- tags$div(+ ) |
|||
| 32 | -! | +|||
| 171 | +
- class = "row",+ } |
|||
| 33 | -! | +|||
| 172 | +
- tags$div(+ ) |
|||
| 34 | -! | +|||
| 173 | +
- class = "col-sm-9",+ |
|||
| 35 | -! | +|||
| 174 | +88x |
- tags$label("Active Filter Summary", class = "text-primary mb-4")
+ do.call(.smart_rbind, out) |
||
| 36 | +175 |
- ),+ } |
||
| 37 | -! | +|||
| 176 | +
- tags$div(+ |
|||
| 38 | -! | +|||
| 177 | +
- class = "col-sm-3",+ |
|||
| 39 | -! | +|||
| 178 | +
- tags$i(+ #' @rdname module_data_summary |
|||
| 40 | -! | +|||
| 179 | +
- class = "remove pull-right fa fa-angle-down",+ #' @param current_data (`object`) current object (after filtering and transforming). |
|||
| 41 | -! | +|||
| 180 | +
- style = "cursor: pointer;",+ #' @param initial_data (`object`) initial object. |
|||
| 42 | -! | +|||
| 181 | +
- title = "fold/expand data summary panel",+ #' @param dataname (`character(1)`) |
|||
| 43 | -! | +|||
| 182 | +
- onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", content_id)
+ #' @param subject_keys (`character`) names of the columns which determine a single unique subjects |
|||
| 44 | +183 |
- )+ get_filter_overview <- function(current_data, initial_data, dataname, subject_keys) {
|
||
| 45 | -+ | |||
| 184 | +162x |
- )+ if (inherits(current_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
|
||
| 46 | -+ | |||
| 185 | +152x |
- ),+ get_filter_overview_array(current_data, initial_data, dataname, subject_keys) |
||
| 47 | -! | +|||
| 186 | +10x |
- tags$div(+ } else if (inherits(current_data, "MultiAssayExperiment")) {
|
||
| 48 | -! | +|||
| 187 | +1x |
- id = content_id,+ get_filter_overview_MultiAssayExperiment(current_data, initial_data, dataname) |
||
| 49 | -! | +|||
| 188 | +
- tags$div(+ } else {
|
|||
| 50 | -! | +|||
| 189 | +9x |
- class = "teal_active_summary_filter_panel",+ data.frame(dataname = dataname) |
||
| 51 | -! | +|||
| 190 | +
- tableOutput(ns("table"))
+ } |
|||
| 52 | +191 |
- )+ } |
||
| 53 | +192 |
- )+ |
||
| 54 | +193 |
- )+ #' @rdname module_data_summary |
||
| 55 | +194 |
- }+ get_filter_overview_array <- function(current_data, |
||
| 56 | +195 |
-
+ initial_data, |
||
| 57 | +196 |
- #' @rdname module_data_summary+ dataname, |
||
| 58 | +197 |
- srv_data_summary <- function(id, data) {
+ subject_keys) {
|
||
| 59 | -86x | +198 | +152x |
- assert_reactive(data)+ if (length(subject_keys) == 0) {
|
| 60 | -86x | +199 | +138x |
- moduleServer(+ data.frame( |
| 61 | -86x | +200 | +138x |
- id = id,+ dataname = dataname, |
| 62 | -86x | +201 | +138x |
- function(input, output, session) {
+ obs = if (!is.null(initial_data)) {
|
| 63 | -86x | +202 | +127x |
- logger::log_debug("srv_data_summary initializing")
+ sprintf("%s/%s", nrow(current_data), nrow(initial_data))
|
| 64 | +203 | - - | -||
| 65 | -86x | -
- summary_table <- reactive({
+ } else {
|
||
| 66 | -94x | +204 | +11x |
- req(inherits(data(), "teal_data"))+ nrow(current_data) |
| 67 | -88x | +|||
| 205 | +
- if (!length(data())) {
+ } |
|||
| 68 | -! | +|||
| 206 | +
- return(NULL)+ ) |
|||
| 69 | +207 |
- }+ } else {
|
||
| 70 | -88x | +208 | +14x |
- get_filter_overview_wrapper(data)+ data.frame( |
| 71 | -+ | |||
| 209 | +14x |
- })+ dataname = dataname, |
||
| 72 | -+ | |||
| 210 | +14x |
-
+ obs = if (!is.null(initial_data)) {
|
||
| 73 | -86x | +211 | +13x |
- output$table <- renderUI({
+ sprintf("%s/%s", nrow(current_data), nrow(initial_data))
|
| 74 | -94x | +|||
| 212 | +
- summary_table_out <- try(summary_table(), silent = TRUE)+ } else {
|
|||
| 75 | -94x | +213 | +1x |
- if (inherits(summary_table_out, "try-error")) {
+ nrow(current_data) |
| 76 | +214 |
- # Ignore silent shiny error+ }, |
||
| 77 | -6x | +215 | +14x |
- if (!inherits(attr(summary_table_out, "condition"), "shiny.silent.error")) {
+ subjects = if (!is.null(initial_data)) {
|
| 78 | -! | +|||
| 216 | +13x |
- stop("Error occurred during data processing. See details in the main panel.")
+ sprintf("%s/%s", nrow(unique(current_data[subject_keys])), nrow(unique(initial_data[subject_keys])))
|
||
| 79 | +217 |
- }+ } else {
|
||
| 80 | -88x | +218 | +1x |
- } else if (is.null(summary_table_out)) {
+ nrow(unique(current_data[subject_keys])) |
| 81 | -2x | +|||
| 219 | +
- "no datasets to show"+ } |
|||
| 82 | +220 |
- } else {
+ ) |
||
| 83 | -86x | +|||
| 221 | +
- is_unsupported <- apply(summary_table(), 1, function(x) all(is.na(x[-1])))+ } |
|||
| 84 | -86x | +|||
| 222 | +
- summary_table_out[is.na(summary_table_out)] <- ""+ } |
|||
| 85 | -86x | +|||
| 223 | +
- body_html <- apply(+ |
|||
| 86 | -86x | +|||
| 224 | +
- summary_table_out,+ #' @rdname module_data_summary |
|||
| 87 | -86x | +|||
| 225 | +
- 1,+ get_filter_overview_MultiAssayExperiment <- function(current_data, # nolint: object_length, object_name. |
|||
| 88 | -86x | +|||
| 226 | +
- function(x) {
+ initial_data, |
|||
| 89 | -162x | +|||
| 227 | +
- is_supported <- !all(x[-1] == "")+ dataname) {
|
|||
| 90 | -162x | +228 | +1x |
- if (is_supported) {
+ experiment_names <- names(current_data) |
| 91 | -153x | +229 | +1x |
- tags$tr(+ mae_info <- data.frame( |
| 92 | -153x | +230 | +1x |
- tagList(+ dataname = dataname, |
| 93 | -153x | +231 | +1x |
- tags$td(x[1]),+ subjects = if (!is.null(initial_data)) {
|
| 94 | -153x | +|||
| 232 | +! |
- lapply(x[-1], tags$td)+ sprintf("%s/%s", nrow(current_data@colData), nrow(initial_data@colData))
|
||
| 95 | +233 |
- )+ } else {
|
||
| 96 | -+ | |||
| 234 | +1x |
- )+ nrow(current_data@colData) |
||
| 97 | +235 |
- }+ } |
||
| 98 | +236 |
- }+ ) |
||
| 99 | +237 |
- )+ |
||
| 100 | -+ | |||
| 238 | +1x |
-
+ experiment_obs_info <- do.call("rbind", lapply(
|
||
| 101 | -86x | +239 | +1x |
- header_labels <- tools::toTitleCase(names(summary_table_out))+ experiment_names, |
| 102 | -86x | +240 | +1x |
- header_labels[header_labels == "Dataname"] <- "Data Name"+ function(experiment_name) {
|
| 103 | -86x | +241 | +5x |
- header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))+ transform( |
| 104 | -+ | |||
| 242 | +5x |
-
+ get_filter_overview( |
||
| 105 | -86x | +243 | +5x |
- table_html <- tags$table(+ current_data[[experiment_name]], |
| 106 | -86x | +244 | +5x |
- class = "table custom-table",+ initial_data[[experiment_name]], |
| 107 | -86x | +245 | +5x |
- tags$thead(header_html),+ dataname = experiment_name, |
| 108 | -86x | +246 | +5x |
- tags$tbody(body_html)+ subject_keys = join_keys() # empty join keys |
| 109 | +247 |
- )+ ), |
||
| 110 | -86x | +248 | +5x |
- div(+ dataname = paste0(" - ", experiment_name)
|
| 111 | -86x | +|||
| 249 | +
- table_html,+ ) |
|||
| 112 | -86x | +|||
| 250 | +
- if (any(is_unsupported)) {
+ } |
|||
| 113 | -9x | +|||
| 251 | +
- p(+ )) |
|||
| 114 | -9x | +|||
| 252 | +
- class = c("pull-right", "float-right", "text-secondary"),
+
|
|||
| 115 | -9x | +253 | +1x |
- style = "font-size: 0.8em;",+ get_experiment_keys <- function(mae, experiment) {
|
| 116 | -9x | +254 | +5x |
- sprintf("And %s more unfilterable object(s)", sum(is_unsupported)),
+ sample_subset <- mae@sampleMap[mae@sampleMap$colname %in% colnames(experiment), ] |
| 117 | -9x | +255 | +5x |
- icon(+ length(unique(sample_subset$primary)) |
| 118 | -9x | +|||
| 256 | +
- name = "far fa-circle-question",+ } |
|||
| 119 | -9x | +|||
| 257 | +
- title = paste(+ |
|||
| 120 | -9x | +258 | +1x |
- sep = "",+ experiment_subjects_info <- do.call("rbind", lapply(
|
| 121 | -9x | +259 | +1x |
- collapse = "\n",+ experiment_names, |
| 122 | -9x | -
- shQuote(summary_table()[is_unsupported, "dataname"]),- |
- ||
| 123 | -+ | 260 | +1x |
- " (",
+ function(experiment_name) {
|
| 124 | -9x | +261 | +5x |
- vapply(+ data.frame( |
| 125 | -9x | +262 | +5x |
- summary_table()[is_unsupported, "dataname"],+ subjects = if (!is.null(initial_data)) {
|
| 126 | -9x | +|||
| 263 | +! |
- function(x) class(data()[[x]])[1],+ sprintf( |
||
| 127 | -9x | +|||
| 264 | +! |
- character(1L)+ "%s/%s", |
||
| 128 | -+ | |||
| 265 | +! |
- ),+ get_experiment_keys(current_data, current_data[[experiment_name]]), |
||
| 129 | -+ | |||
| 266 | +! |
- ")"+ get_experiment_keys(current_data, initial_data[[experiment_name]]) |
||
| 130 | +267 |
- )+ ) |
||
| 131 | +268 |
- )+ } else {
|
||
| 132 | -+ | |||
| 269 | +5x |
- )+ get_experiment_keys(current_data, current_data[[experiment_name]]) |
||
| 133 | +270 |
- }+ } |
||
| 134 | +271 |
- )+ ) |
||
| 135 | +272 |
- }+ } |
||
| 136 | +273 |
- })+ )) |
||
| 137 | +274 | |||
| 138 | -86x | +275 | +1x |
- NULL+ experiment_info <- cbind(experiment_obs_info, experiment_subjects_info) |
| 139 | -+ | |||
| 276 | +1x |
- }+ .smart_rbind(mae_info, experiment_info) |
||
| 140 | +277 |
- )+ } |
| 141 | +1 |
- }+ #' Generate lockfile for application's environment reproducibility |
||
| 142 | +2 |
-
+ #' |
||
| 143 | +3 |
- #' @rdname module_data_summary+ #' @param lockfile_path (`character`) path to the lockfile. |
||
| 144 | +4 |
- get_filter_overview_wrapper <- function(teal_data) {
+ #' |
||
| 145 | +5 |
- # Sort datanames in topological order- |
- ||
| 146 | -88x | -
- datanames <- names(teal_data())- |
- ||
| 147 | -88x | -
- joinkeys <- teal.data::join_keys(teal_data())+ #' @section Different ways of creating lockfile: |
||
| 148 | +6 | - - | -||
| 149 | -88x | -
- current_data_objs <- sapply(- |
- ||
| 150 | -88x | -
- datanames,+ #' `teal` leverages [renv::snapshot()], which offers multiple methods for lockfile creation. |
||
| 151 | -88x | +|||
| 7 | +
- function(name) teal_data()[[name]],+ #' |
|||
| 152 | -88x | +|||
| 8 | +
- simplify = FALSE+ #' - **Working directory lockfile**: `teal`, by default, will create an `implicit` type lockfile that uses |
|||
| 153 | +9 |
- )+ #' `renv::dependencies()` to detect all R packages in the current project's working directory. |
||
| 154 | -88x | +|||
| 10 | +
- initial_data_objs <- teal_data()[[".raw_data"]]+ #' - **`DESCRIPTION`-based lockfile**: To generate a lockfile based on a `DESCRIPTION` file in your working |
|||
| 155 | +11 |
-
+ #' directory, set `renv::settings$snapshot.type("explicit")`. The naming convention for `type` follows
|
||
| 156 | -88x | +|||
| 12 | +
- out <- lapply(+ #' `renv::snapshot()`. For the `"explicit"` type, refer to `renv::settings$package.dependency.fields()` for the |
|||
| 157 | -88x | +|||
| 13 | +
- datanames,+ #' `DESCRIPTION` fields included in the lockfile. |
|||
| 158 | -88x | +|||
| 14 | +
- function(dataname) {
+ #' - **Custom files-based lockfile**: To specify custom files as the basis for the lockfile, set |
|||
| 159 | -157x | +|||
| 15 | +
- parent <- teal.data::parent(joinkeys, dataname)+ #' `renv::settings$snapshot.type("custom")` and configure the `renv.snapshot.filter` option.
|
|||
| 160 | -157x | +|||
| 16 | +
- subject_keys <- if (length(parent) > 0) {
+ #' |
|||
| 161 | -8x | +|||
| 17 | +
- names(joinkeys[dataname, parent])+ #' @section lockfile usage: |
|||
| 162 | +18 |
- } else {
+ #' After creating the lockfile, you can restore the application's environment using `renv::restore()`. |
||
| 163 | -149x | +|||
| 19 | +
- joinkeys[dataname, dataname]+ #' |
|||
| 164 | +20 |
- }+ #' @seealso [renv::snapshot()], [renv::restore()]. |
||
| 165 | -157x | +|||
| 21 | +
- get_filter_overview(+ #' |
|||
| 166 | -157x | +|||
| 22 | +
- current_data = current_data_objs[[dataname]],+ #' @return `NULL` |
|||
| 167 | -157x | +|||
| 23 | +
- initial_data = initial_data_objs[[dataname]],+ #' |
|||
| 168 | -157x | +|||
| 24 | +
- dataname = dataname,+ #' @name module_teal_lockfile |
|||
| 169 | -157x | +|||
| 25 | +
- subject_keys = subject_keys+ #' @rdname module_teal_lockfile |
|||
| 170 | +26 |
- )+ #' |
||
| 171 | +27 |
- }+ #' @keywords internal |
||
| 172 | +28 |
- )+ NULL |
||
| 173 | +29 | |||
| 174 | -88x | +|||
| 30 | +
- do.call(.smart_rbind, out)+ #' @rdname module_teal_lockfile |
|||
| 175 | +31 |
- }+ ui_teal_lockfile <- function(id) {
|
||
| 176 | -+ | |||
| 32 | +! |
-
+ ns <- NS(id) |
||
| 177 | -+ | |||
| 33 | +! |
-
+ shiny::tagList( |
||
| 178 | -+ | |||
| 34 | +! |
- #' @rdname module_data_summary+ tags$span("", id = ns("lockFileStatus")),
+ |
+ ||
| 35 | +! | +
+ shinyjs::disabled(downloadLink(ns("lockFileLink"), "Download lockfile"))
|
||
| 179 | +36 |
- #' @param current_data (`object`) current object (after filtering and transforming).+ ) |
||
| 180 | +37 |
- #' @param initial_data (`object`) initial object.+ } |
||
| 181 | +38 |
- #' @param dataname (`character(1)`)+ |
||
| 182 | +39 |
- #' @param subject_keys (`character`) names of the columns which determine a single unique subjects+ #' @rdname module_teal_lockfile |
||
| 183 | +40 |
- get_filter_overview <- function(current_data, initial_data, dataname, subject_keys) {
+ srv_teal_lockfile <- function(id) {
|
||
| 184 | -162x | +41 | +88x |
- if (inherits(current_data, c("data.frame", "DataFrame", "array", "Matrix", "SummarizedExperiment"))) {
+ moduleServer(id, function(input, output, session) {
|
| 185 | -152x | +42 | +88x |
- get_filter_overview_array(current_data, initial_data, dataname, subject_keys)+ logger::log_debug("Initialize srv_teal_lockfile.")
|
| 186 | -10x | +43 | +88x |
- } else if (inherits(current_data, "MultiAssayExperiment")) {
+ enable_lockfile_download <- function() {
|
| 187 | -1x | +|||
| 44 | +! |
- get_filter_overview_MultiAssayExperiment(current_data, initial_data, dataname)+ shinyjs::html("lockFileStatus", "Application lockfile ready.")
|
||
| 188 | -+ | |||
| 45 | +! |
- } else {
+ shinyjs::hide("lockFileStatus", anim = TRUE)
|
||
| 189 | -9x | +|||
| 46 | +! |
- data.frame(dataname = dataname)+ shinyjs::enable("lockFileLink")
|
||
| 190 | -+ | |||
| 47 | +! |
- }+ output$lockFileLink <- shiny::downloadHandler( |
||
| 191 | -+ | |||
| 48 | +! |
- }+ filename = function() {
|
||
| 192 | -+ | |||
| 49 | +! |
-
+ "renv.lock" |
||
| 193 | +50 |
- #' @rdname module_data_summary+ }, |
||
| 194 | -+ | |||
| 51 | +! |
- get_filter_overview_array <- function(current_data,+ content = function(file) {
|
||
| 195 | -+ | |||
| 52 | +! |
- initial_data,+ file.copy(lockfile_path, file) |
||
| 196 | -+ | |||
| 53 | +! |
- dataname,+ file |
||
| 197 | +54 |
- subject_keys) {
- |
- ||
| 198 | -152x | -
- if (length(subject_keys) == 0) {
+ }, |
||
| 199 | -138x | +|||
| 55 | +! |
- data.frame(+ contentType = "application/json" |
||
| 200 | -138x | +|||
| 56 | +
- dataname = dataname,+ ) |
|||
| 201 | -138x | +|||
| 57 | +
- obs = if (!is.null(initial_data)) {
+ } |
|||
| 202 | -127x | +58 | +88x |
- sprintf("%s/%s", nrow(current_data), nrow(initial_data))
+ disable_lockfile_download <- function() {
|
| 203 | -+ | |||
| 59 | +! |
- } else {
+ warning("Lockfile creation failed.", call. = FALSE)
|
||
| 204 | -11x | +|||
| 60 | +! |
- nrow(current_data)+ shinyjs::html("lockFileStatus", "Lockfile creation failed.")
|
||
| 205 | -+ | |||
| 61 | +! |
- }+ shinyjs::hide("lockFileLink")
|
||
| 206 | +62 |
- )+ } |
||
| 207 | +63 |
- } else {
+
|
||
| 208 | -14x | +64 | +88x |
- data.frame(+ shiny::onStop(function() {
|
| 209 | -14x | +65 | +88x |
- dataname = dataname,+ if (file.exists(lockfile_path) && !shiny::isRunning()) {
|
| 210 | -14x | +66 | +1x |
- obs = if (!is.null(initial_data)) {
+ logger::log_debug("Removing lockfile after shutting down the app")
|
| 211 | -13x | +67 | +1x |
- sprintf("%s/%s", nrow(current_data), nrow(initial_data))
+ file.remove(lockfile_path) |
| 212 | +68 |
- } else {
+ } |
||
| 213 | -1x | +|||
| 69 | +
- nrow(current_data)+ }) |
|||
| 214 | +70 |
- },+ |
||
| 215 | -14x | +71 | +88x |
- subjects = if (!is.null(initial_data)) {
+ lockfile_path <- "teal_app.lock" |
| 216 | -13x | +72 | +88x |
- sprintf("%s/%s", nrow(unique(current_data[subject_keys])), nrow(unique(initial_data[subject_keys])))
+ mode <- getOption("teal.lockfile.mode", default = "")
|
| 217 | +73 |
- } else {
+
|
||
| 218 | -1x | +74 | +88x |
- nrow(unique(current_data[subject_keys]))+ if (!(mode %in% c("auto", "enabled", "disabled"))) {
|
| 219 | -+ | |||
| 75 | +! |
- }+ stop("'teal.lockfile.mode' option can only be one of \"auto\", \"disabled\" or \"disabled\". ")
|
||
| 220 | +76 |
- )+ } |
||
| 221 | +77 |
- }+ |
||
| 222 | -+ | |||
| 78 | +88x |
- }+ if (mode == "disabled") {
|
||
| 223 | -+ | |||
| 79 | +1x |
-
+ logger::log_debug("'teal.lockfile.mode' option is set to 'disabled'. Hiding lockfile download button.")
|
||
| 224 | -+ | |||
| 80 | +1x |
- #' @rdname module_data_summary+ shinyjs::hide("lockFileLink")
|
||
| 225 | -+ | |||
| 81 | +1x |
- get_filter_overview_MultiAssayExperiment <- function(current_data, # nolint: object_length, object_name.+ return(NULL) |
||
| 226 | +82 |
- initial_data,+ } |
||
| 227 | +83 |
- dataname) {
- |
- ||
| 228 | -1x | -
- experiment_names <- names(current_data)- |
- ||
| 229 | -1x | -
- mae_info <- data.frame(- |
- ||
| 230 | -1x | -
- dataname = dataname,+ |
||
| 231 | -1x | +84 | +87x |
- subjects = if (!is.null(initial_data)) {
+ if (file.exists(lockfile_path)) {
|
| 232 | +85 | ! |
- sprintf("%s/%s", nrow(current_data@colData), nrow(initial_data@colData))
+ logger::log_debug("Lockfile has already been created for this app - skipping automatic creation.")
|
|
| 233 | -+ | |||
| 86 | +! |
- } else {
+ enable_lockfile_download() |
||
| 234 | -1x | +|||
| 87 | +! |
- nrow(current_data@colData)+ return(NULL) |
||
| 235 | +88 |
} |
||
| 236 | -- |
- )- |
- ||
| 237 | +89 | |||
| 238 | -1x | +90 | +87x |
- experiment_obs_info <- do.call("rbind", lapply(
+ if (mode == "auto" && .is_disabled_lockfile_scenario()) {
|
| 239 | -1x | +91 | +86x |
- experiment_names,+ logger::log_debug( |
| 240 | -1x | +92 | +86x |
- function(experiment_name) {
+ "Automatic lockfile creation disabled. Execution scenario satisfies teal:::.is_disabled_lockfile_scenario()." |
| 241 | -5x | +|||
| 93 | +
- transform(+ ) |
|||
| 242 | -5x | +94 | +86x |
- get_filter_overview(+ shinyjs::hide("lockFileLink")
|
| 243 | -5x | +95 | +86x |
- current_data[[experiment_name]],+ return(NULL) |
| 244 | -5x | +|||
| 96 | +
- initial_data[[experiment_name]],+ } |
|||
| 245 | -5x | +|||
| 97 | +
- dataname = experiment_name,+ |
|||
| 246 | -5x | +98 | +1x |
- subject_keys = join_keys() # empty join keys+ if (!.is_lockfile_deps_installed()) {
|
| 247 | -+ | |||
| 99 | +! |
- ),+ warning("Automatic lockfile creation disabled. `mirai` and `renv` packages must be installed.")
|
||
| 248 | -5x | +|||
| 100 | +! |
- dataname = paste0(" - ", experiment_name)
+ shinyjs::hide("lockFileLink")
|
||
| 249 | -+ | |||
| 101 | +! |
- )+ return(NULL) |
||
| 250 | +102 |
} |
||
| 251 | +103 |
- ))+ |
||
| 252 | +104 | - - | -||
| 253 | -1x | -
- get_experiment_keys <- function(mae, experiment) {
- |
- ||
| 254 | -5x | -
- sample_subset <- mae@sampleMap[mae@sampleMap$colname %in% colnames(experiment), ]- |
- ||
| 255 | -5x | -
- length(unique(sample_subset$primary))+ # - Will be run only if the lockfile doesn't exist (see the if-s above) |
||
| 256 | +105 |
- }+ # - We render to the tempfile because the process might last after session is closed and we don't |
||
| 257 | +106 |
-
+ # want to make a "teal_app.renv" then. This is why we copy only during active session. |
||
| 258 | +107 | 1x |
- experiment_subjects_info <- do.call("rbind", lapply(
+ process <- .teal_lockfile_process_invoke(lockfile_path) |
|
| 259 | +108 | 1x |
- experiment_names,+ observeEvent(process$status(), {
|
|
| 260 | -1x | +|||
| 109 | +! |
- function(experiment_name) {
+ if (process$status() %in% c("initial", "running")) {
|
||
| 261 | -5x | +|||
| 110 | +! |
- data.frame(+ shinyjs::html("lockFileStatus", "Creating lockfile...")
|
||
| 262 | -5x | +|||
| 111 | +! |
- subjects = if (!is.null(initial_data)) {
+ } else if (process$status() == "success") {
|
||
| 263 | +112 | ! |
- sprintf(+ result <- process$result() |
|
| 264 | +113 | ! |
- "%s/%s",+ if (any(grepl("Lockfile written to", result$out))) {
|
|
| 265 | +114 | ! |
- get_experiment_keys(current_data, current_data[[experiment_name]]),+ logger::log_debug("Lockfile containing { length(result$res$Packages) } packages created.")
|
|
| 266 | +115 | ! |
- get_experiment_keys(current_data, initial_data[[experiment_name]])+ if (any(grepl("(WARNING|ERROR):", result$out))) {
|
|
| 267 | -+ | |||
| 116 | +! |
- )+ warning("Lockfile created with warning(s) or error(s):", call. = FALSE)
|
||
| 268 | -+ | |||
| 117 | +! |
- } else {
+ for (i in result$out) {
|
||
| 269 | -5x | +|||
| 118 | +! |
- get_experiment_keys(current_data, current_data[[experiment_name]])+ warning(i, call. = FALSE) |
||
| 270 | +119 |
- }+ } |
||
| 271 | +120 |
- )+ } |
||
| 272 | -+ | |||
| 121 | +! |
- }+ enable_lockfile_download() |
||
| 273 | +122 |
- ))+ } else {
+ |
+ ||
| 123 | +! | +
+ disable_lockfile_download() |
||
| 274 | +124 |
-
+ } |
||
| 275 | -1x | +|||
| 125 | +! |
- experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)+ } else if (process$status() == "error") {
|
||
| 276 | -1x | +|||
| 126 | +! |
- .smart_rbind(mae_info, experiment_info)+ disable_lockfile_download() |
||
| 277 | +127 |
- }+ } |
| 1 | +128 |
- #' Generate lockfile for application's environment reproducibility+ }) |
||
| 2 | +129 |
- #'+ |
||
| 3 | -+ | |||
| 130 | +1x |
- #' @param lockfile_path (`character`) path to the lockfile.+ NULL |
||
| 4 | +131 |
- #'+ }) |
||
| 5 | +132 |
- #' @section Different ways of creating lockfile:+ } |
||
| 6 | +133 |
- #' `teal` leverages [renv::snapshot()], which offers multiple methods for lockfile creation.+ |
||
| 7 | +134 |
- #'+ utils::globalVariables(c("opts", "sysenv", "libpaths", "wd", "lockfilepath", "run")) # needed for mirai call
|
||
| 8 | +135 |
- #' - **Working directory lockfile**: `teal`, by default, will create an `implicit` type lockfile that uses+ #' @rdname module_teal_lockfile |
||
| 9 | +136 |
- #' `renv::dependencies()` to detect all R packages in the current project's working directory.+ .teal_lockfile_process_invoke <- function(lockfile_path) {
|
||
| 10 | -+ | |||
| 137 | +1x |
- #' - **`DESCRIPTION`-based lockfile**: To generate a lockfile based on a `DESCRIPTION` file in your working+ mirai_obj <- NULL |
||
| 11 | -+ | |||
| 138 | +1x |
- #' directory, set `renv::settings$snapshot.type("explicit")`. The naming convention for `type` follows
+ process <- shiny::ExtendedTask$new(function() {
|
||
| 12 | -+ | |||
| 139 | +1x |
- #' `renv::snapshot()`. For the `"explicit"` type, refer to `renv::settings$package.dependency.fields()` for the+ m <- mirai::mirai( |
||
| 13 | +140 |
- #' `DESCRIPTION` fields included in the lockfile.+ {
|
||
| 14 | -+ | |||
| 141 | +1x |
- #' - **Custom files-based lockfile**: To specify custom files as the basis for the lockfile, set+ options(opts) |
||
| 15 | -+ | |||
| 142 | +1x |
- #' `renv::settings$snapshot.type("custom")` and configure the `renv.snapshot.filter` option.
+ do.call(Sys.setenv, sysenv) |
||
| 16 | -+ | |||
| 143 | +1x |
- #'+ .libPaths(libpaths) |
||
| 17 | -+ | |||
| 144 | +1x |
- #' @section lockfile usage:+ setwd(wd) |
||
| 18 | -+ | |||
| 145 | +1x |
- #' After creating the lockfile, you can restore the application's environment using `renv::restore()`.+ run(lockfile_path = lockfile_path) |
||
| 19 | +146 |
- #'+ }, |
||
| 20 | -+ | |||
| 147 | +1x |
- #' @seealso [renv::snapshot()], [renv::restore()].+ run = .renv_snapshot, |
||
| 21 | -+ | |||
| 148 | +1x |
- #'+ lockfile_path = lockfile_path, |
||
| 22 | -+ | |||
| 149 | +1x |
- #' @return `NULL`+ opts = options(), |
||
| 23 | -+ | |||
| 150 | +1x |
- #'+ libpaths = .libPaths(), |
||
| 24 | -+ | |||
| 151 | +1x |
- #' @name module_teal_lockfile+ sysenv = as.list(Sys.getenv()), |
||
| 25 | -- |
- #' @rdname module_teal_lockfile- |
- ||
| 26 | -+ | |||
| 152 | +1x |
- #'+ wd = getwd() |
||
| 27 | +153 |
- #' @keywords internal+ ) |
||
| 28 | -+ | |||
| 154 | +1x |
- NULL+ mirai_obj <<- m |
||
| 29 | -+ | |||
| 155 | +1x |
-
+ m |
||
| 30 | +156 |
- #' @rdname module_teal_lockfile+ }) |
||
| 31 | +157 |
- ui_teal_lockfile <- function(id) {
+
|
||
| 32 | -! | +|||
| 158 | +1x |
- ns <- NS(id)+ shiny::onStop(function() {
|
||
| 33 | -! | +|||
| 159 | +1x |
- shiny::tagList(+ if (mirai::unresolved(mirai_obj)) {
|
||
| 34 | +160 | ! |
- tags$span("", id = ns("lockFileStatus")),
+ logger::log_debug("Terminating a running lockfile process...")
|
|
| 35 | +161 | ! |
- shinyjs::disabled(downloadLink(ns("lockFileLink"), "Download lockfile"))
+ mirai::stop_mirai(mirai_obj) # this doesn't stop running - renv will be created even if session is closed |
|
| 36 | +162 |
- )+ } |
||
| 37 | +163 |
- }+ }) |
||
| 38 | +164 | |||
| 165 | +1x | +
+ suppressWarnings({ # 'package:stats' may not be available when loading
+ |
+ ||
| 166 | +1x | +
+ process$invoke()+ |
+ ||
| 39 | +167 |
- #' @rdname module_teal_lockfile+ }) |
||
| 40 | +168 |
- srv_teal_lockfile <- function(id) {
+
|
||
| 41 | -88x | +169 | +1x |
- moduleServer(id, function(input, output, session) {
+ logger::log_debug("Lockfile creation started based on { getwd() }.")
|
| 42 | -88x | +|||
| 170 | +
- logger::log_debug("Initialize srv_teal_lockfile.")
+
|
|||
| 43 | -88x | +171 | +1x |
- enable_lockfile_download <- function() {
+ process |
| 44 | -! | +|||
| 172 | +
- shinyjs::html("lockFileStatus", "Application lockfile ready.")
+ } |
|||
| 45 | -! | +|||
| 173 | +
- shinyjs::hide("lockFileStatus", anim = TRUE)
+
|
|||
| 46 | -! | +|||
| 174 | +
- shinyjs::enable("lockFileLink")
+ #' @rdname module_teal_lockfile |
|||
| 47 | -! | +|||
| 175 | +
- output$lockFileLink <- shiny::downloadHandler(+ .renv_snapshot <- function(lockfile_path) {
|
|||
| 48 | -! | +|||
| 176 | +1x |
- filename = function() {
+ out <- utils::capture.output( |
||
| 49 | -! | +|||
| 177 | +1x |
- "renv.lock"+ res <- renv::snapshot( |
||
| 50 | -+ | |||
| 178 | +1x |
- },+ lockfile = lockfile_path, |
||
| 51 | -! | +|||
| 179 | +1x |
- content = function(file) {
+ prompt = FALSE, |
||
| 52 | -! | +|||
| 180 | +1x |
- file.copy(lockfile_path, file)+ force = TRUE, |
||
| 53 | -! | +|||
| 181 | +1x |
- file+ type = renv::settings$snapshot.type() # see the section "Different ways of creating lockfile" above here |
||
| 54 | +182 |
- },- |
- ||
| 55 | -! | -
- contentType = "application/json"+ ) |
||
| 56 | +183 |
- )+ ) |
||
| 57 | +184 |
- }+ |
||
| 58 | -88x | -
- disable_lockfile_download <- function() {
- |
- ||
| 59 | -! | -
- warning("Lockfile creation failed.", call. = FALSE)
- |
- ||
| 60 | -! | -
- shinyjs::html("lockFileStatus", "Lockfile creation failed.")
- |
- ||
| 61 | -! | +185 | +1x |
- shinyjs::hide("lockFileLink")
+ list(out = out, res = res) |
| 62 | +186 |
- }+ } |
||
| 63 | +187 | |||
| 64 | -88x | +|||
| 188 | +
- shiny::onStop(function() {
+ #' @rdname module_teal_lockfile |
|||
| 65 | -88x | +|||
| 189 | +
- if (file.exists(lockfile_path) && !shiny::isRunning()) {
+ .is_lockfile_deps_installed <- function() {
|
|||
| 66 | +190 | 1x |
- logger::log_debug("Removing lockfile after shutting down the app")
+ requireNamespace("mirai", quietly = TRUE) && requireNamespace("renv", quietly = TRUE)
|
|
| 67 | -1x | +|||
| 191 | +
- file.remove(lockfile_path)+ } |
|||
| 68 | +192 |
- }+ |
||
| 69 | +193 |
- })+ #' @rdname module_teal_lockfile |
||
| 70 | +194 |
-
+ .is_disabled_lockfile_scenario <- function() {
|
||
| 71 | -88x | +195 | +86x |
- lockfile_path <- "teal_app.lock"+ identical(Sys.getenv("CALLR_IS_RUNNING"), "true") || # inside callr process
|
| 72 | -88x | +196 | +86x |
- mode <- getOption("teal.lockfile.mode", default = "")
+ identical(Sys.getenv("TESTTHAT"), "true") || # inside devtools::test
+ |
+
| 197 | +86x | +
+ !identical(Sys.getenv("QUARTO_PROJECT_ROOT"), "") || # inside Quarto process
|
||
| 73 | +198 |
-
+ ( |
||
| 74 | -88x | +199 | +86x |
- if (!(mode %in% c("auto", "enabled", "disabled"))) {
+ ("CheckExEnv" %in% search()) || any(c("_R_CHECK_TIMINGS_", "_R_CHECK_LICENSE_") %in% names(Sys.getenv()))
|
| 75 | -! | +|||
| 200 | +86x |
- stop("'teal.lockfile.mode' option can only be one of \"auto\", \"disabled\" or \"disabled\". ")
+ ) # inside R CMD CHECK |
||
| 76 | +201 |
- }+ } |
| 77 | +1 |
-
+ #' Send input validation messages to output |
||
| 78 | -88x | +|||
| 2 | +
- if (mode == "disabled") {
+ #' |
|||
| 79 | -1x | +|||
| 3 | +
- logger::log_debug("'teal.lockfile.mode' option is set to 'disabled'. Hiding lockfile download button.")
+ #' Captures messages from `InputValidator` objects and collates them |
|||
| 80 | -1x | +|||
| 4 | +
- shinyjs::hide("lockFileLink")
+ #' into one message passed to `validate`. |
|||
| 81 | -1x | +|||
| 5 | +
- return(NULL)+ #' |
|||
| 82 | +6 |
- }+ #' `shiny::validate` is used to withhold rendering of an output element until |
||
| 83 | +7 |
-
+ #' certain conditions are met and to print a validation message in place |
||
| 84 | -87x | +|||
| 8 | +
- if (file.exists(lockfile_path)) {
+ #' of the output element. |
|||
| 85 | -! | +|||
| 9 | +
- logger::log_debug("Lockfile has already been created for this app - skipping automatic creation.")
+ #' `shinyvalidate::InputValidator` allows to validate input elements |
|||
| 86 | -! | +|||
| 10 | +
- enable_lockfile_download()+ #' and to display specific messages in their respective input widgets. |
|||
| 87 | -! | +|||
| 11 | +
- return(NULL)+ #' `validate_inputs` provides a hybrid solution. |
|||
| 88 | +12 |
- }+ #' Given an `InputValidator` object, messages corresponding to inputs that fail validation |
||
| 89 | +13 |
-
+ #' are extracted and placed in one validation message that is passed to a `validate`/`need` call. |
||
| 90 | -87x | +|||
| 14 | +
- if (mode == "auto" && .is_disabled_lockfile_scenario()) {
+ #' This way the input `validator` messages are repeated in the output. |
|||
| 91 | -86x | +|||
| 15 | +
- logger::log_debug(+ #' |
|||
| 92 | -86x | +|||
| 16 | +
- "Automatic lockfile creation disabled. Execution scenario satisfies teal:::.is_disabled_lockfile_scenario()."+ #' The `...` argument accepts any number of `InputValidator` objects |
|||
| 93 | +17 |
- )+ #' or a nested list of such objects. |
||
| 94 | -86x | +|||
| 18 | +
- shinyjs::hide("lockFileLink")
+ #' If `validators` are passed directly, all their messages are printed together |
|||
| 95 | -86x | +|||
| 19 | +
- return(NULL)+ #' under one (optional) header message specified by `header`. If a list is passed, |
|||
| 96 | +20 |
- }+ #' messages are grouped by `validator`. The list's names are used as headers |
||
| 97 | +21 |
-
+ #' for their respective message groups. |
||
| 98 | -1x | +|||
| 22 | +
- if (!.is_lockfile_deps_installed()) {
+ #' If neither of the nested list elements is named, a header message is taken from `header`. |
|||
| 99 | -! | +|||
| 23 | +
- warning("Automatic lockfile creation disabled. `mirai` and `renv` packages must be installed.")
+ #' |
|||
| 100 | -! | +|||
| 24 | +
- shinyjs::hide("lockFileLink")
+ #' @param ... either any number of `InputValidator` objects |
|||
| 101 | -! | +|||
| 25 | +
- return(NULL)+ #' or an optionally named, possibly nested `list` of `InputValidator` |
|||
| 102 | +26 |
- }+ #' objects, see `Details` |
||
| 103 | +27 |
-
+ #' @param header (`character(1)`) generic validation message; set to NULL to omit |
||
| 104 | +28 |
- # - Will be run only if the lockfile doesn't exist (see the if-s above)+ #' |
||
| 105 | +29 |
- # - We render to the tempfile because the process might last after session is closed and we don't+ #' @return |
||
| 106 | +30 |
- # want to make a "teal_app.renv" then. This is why we copy only during active session.- |
- ||
| 107 | -1x | -
- process <- .teal_lockfile_process_invoke(lockfile_path)+ #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. |
||
| 108 | -1x | +|||
| 31 | +
- observeEvent(process$status(), {
+ #' |
|||
| 109 | -! | +|||
| 32 | +
- if (process$status() %in% c("initial", "running")) {
+ #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`] |
|||
| 110 | -! | +|||
| 33 | +
- shinyjs::html("lockFileStatus", "Creating lockfile...")
+ #' |
|||
| 111 | -! | +|||
| 34 | +
- } else if (process$status() == "success") {
+ #' @examplesIf require("shinyvalidate")
|
|||
| 112 | -! | +|||
| 35 | +
- result <- process$result()+ #' library(shiny) |
|||
| 113 | -! | +|||
| 36 | +
- if (any(grepl("Lockfile written to", result$out))) {
+ #' library(shinyvalidate) |
|||
| 114 | -! | +|||
| 37 | +
- logger::log_debug("Lockfile containing { length(result$res$Packages) } packages created.")
+ #' |
|||
| 115 | -! | +|||
| 38 | +
- if (any(grepl("(WARNING|ERROR):", result$out))) {
+ #' ui <- fluidPage( |
|||
| 116 | -! | +|||
| 39 | +
- warning("Lockfile created with warning(s) or error(s):", call. = FALSE)
+ #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
|
|||
| 117 | -! | +|||
| 40 | +
- for (i in result$out) {
+ #' sidebarLayout( |
|||
| 118 | -! | +|||
| 41 | +
- warning(i, call. = FALSE)+ #' sidebarPanel( |
|||
| 119 | +42 |
- }+ #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
|
||
| 120 | +43 |
- }+ #' selectInput("number", "select a number:", 1:6),
|
||
| 121 | -! | +|||
| 44 | +
- enable_lockfile_download()+ #' tags$br(), |
|||
| 122 | +45 |
- } else {
+ #' selectInput("color", "select a color:",
|
||
| 123 | -! | +|||
| 46 | +
- disable_lockfile_download()+ #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
|
|||
| 124 | +47 |
- }+ #' multiple = TRUE |
||
| 125 | -! | +|||
| 48 | +
- } else if (process$status() == "error") {
+ #' ), |
|||
| 126 | -! | +|||
| 49 | +
- disable_lockfile_download()+ #' sliderInput("size", "select point size:",
|
|||
| 127 | +50 |
- }+ #' min = 0.1, max = 4, value = 0.25 |
||
| 128 | +51 |
- })+ #' ) |
||
| 129 | +52 |
-
+ #' ), |
||
| 130 | -1x | +|||
| 53 | +
- NULL+ #' mainPanel(plotOutput("plot"))
|
|||
| 131 | +54 |
- })+ #' ) |
||
| 132 | +55 |
- }+ #' ) |
||
| 133 | +56 |
-
+ #' |
||
| 134 | +57 |
- utils::globalVariables(c("opts", "sysenv", "libpaths", "wd", "lockfilepath", "run")) # needed for mirai call
+ #' server <- function(input, output) {
|
||
| 135 | +58 |
- #' @rdname module_teal_lockfile+ #' # set up input validation |
||
| 136 | +59 |
- .teal_lockfile_process_invoke <- function(lockfile_path) {
+ #' iv <- InputValidator$new() |
||
| 137 | -1x | +|||
| 60 | +
- mirai_obj <- NULL+ #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
|
|||
| 138 | -1x | +|||
| 61 | +
- process <- shiny::ExtendedTask$new(function() {
+ #' iv$add_rule("number", function(x) {
|
|||
| 139 | -1x | +|||
| 62 | +
- m <- mirai::mirai(+ #' if (as.integer(x) %% 2L == 1L) "choose an even number" |
|||
| 140 | +63 |
- {
+ #' }) |
||
| 141 | -1x | +|||
| 64 | +
- options(opts)+ #' iv$enable() |
|||
| 142 | -1x | +|||
| 65 | +
- do.call(Sys.setenv, sysenv)+ #' # more input validation |
|||
| 143 | -1x | +|||
| 66 | +
- .libPaths(libpaths)+ #' iv_par <- InputValidator$new() |
|||
| 144 | -1x | +|||
| 67 | +
- setwd(wd)+ #' iv_par$add_rule("color", sv_required(message = "choose a color"))
|
|||
| 145 | -1x | +|||
| 68 | +
- run(lockfile_path = lockfile_path)+ #' iv_par$add_rule("color", function(x) {
|
|||
| 146 | +69 |
- },+ #' if (length(x) > 1L) "choose only one color" |
||
| 147 | -1x | +|||
| 70 | +
- run = .renv_snapshot,+ #' }) |
|||
| 148 | -1x | +|||
| 71 | +
- lockfile_path = lockfile_path,+ #' iv_par$add_rule( |
|||
| 149 | -1x | +|||
| 72 | +
- opts = options(),+ #' "size", |
|||
| 150 | -1x | +|||
| 73 | +
- libpaths = .libPaths(),+ #' sv_between( |
|||
| 151 | -1x | +|||
| 74 | +
- sysenv = as.list(Sys.getenv()),+ #' left = 0.5, right = 3, |
|||
| 152 | -1x | +|||
| 75 | +
- wd = getwd()+ #' message_fmt = "choose a value between {left} and {right}"
|
|||
| 153 | +76 |
- )+ #' ) |
||
| 154 | -1x | +|||
| 77 | +
- mirai_obj <<- m+ #' ) |
|||
| 155 | -1x | +|||
| 78 | +
- m+ #' iv_par$enable() |
|||
| 156 | +79 |
- })+ #' |
||
| 157 | +80 |
-
+ #' output$plot <- renderPlot({
|
||
| 158 | -1x | +|||
| 81 | +
- shiny::onStop(function() {
+ #' # validate output |
|||
| 159 | -1x | +|||
| 82 | +
- if (mirai::unresolved(mirai_obj)) {
+ #' switch(input[["method"]], |
|||
| 160 | -! | +|||
| 83 | +
- logger::log_debug("Terminating a running lockfile process...")
+ #' "sequential" = {
|
|||
| 161 | -! | +|||
| 84 | +
- mirai::stop_mirai(mirai_obj) # this doesn't stop running - renv will be created even if session is closed+ #' validate_inputs(iv) |
|||
| 162 | +85 |
- }+ #' validate_inputs(iv_par, header = "Set proper graphical parameters") |
||
| 163 | +86 |
- })+ #' }, |
||
| 164 | +87 |
-
+ #' "combined" = validate_inputs(iv, iv_par), |
||
| 165 | -1x | +|||
| 88 | +
- suppressWarnings({ # 'package:stats' may not be available when loading
+ #' "grouped" = validate_inputs(list( |
|||
| 166 | -1x | +|||
| 89 | +
- process$invoke()+ #' "Some inputs require attention" = iv, |
|||
| 167 | +90 |
- })+ #' "Set proper graphical parameters" = iv_par |
||
| 168 | +91 |
-
+ #' )) |
||
| 169 | -1x | +|||
| 92 | +
- logger::log_debug("Lockfile creation started based on { getwd() }.")
+ #' ) |
|||
| 170 | +93 |
-
+ #' |
||
| 171 | -1x | +|||
| 94 | +
- process+ #' plot(faithful$eruptions ~ faithful$waiting, |
|||
| 172 | +95 |
- }+ #' las = 1, pch = 16, |
||
| 173 | +96 |
-
+ #' col = input[["color"]], cex = input[["size"]] |
||
| 174 | +97 |
- #' @rdname module_teal_lockfile+ #' ) |
||
| 175 | +98 |
- .renv_snapshot <- function(lockfile_path) {
+ #' }) |
||
| 176 | -1x | +|||
| 99 | +
- out <- utils::capture.output(+ #' } |
|||
| 177 | -1x | +|||
| 100 | +
- res <- renv::snapshot(+ #' |
|||
| 178 | -1x | +|||
| 101 | +
- lockfile = lockfile_path,+ #' if (interactive()) {
|
|||
| 179 | -1x | +|||
| 102 | +
- prompt = FALSE,+ #' shinyApp(ui, server) |
|||
| 180 | -1x | +|||
| 103 | +
- force = TRUE,+ #' } |
|||
| 181 | -1x | +|||
| 104 | +
- type = renv::settings$snapshot.type() # see the section "Different ways of creating lockfile" above here+ #' |
|||
| 182 | +105 |
- )+ #' @export |
||
| 183 | +106 |
- )+ #' |
||
| 184 | +107 |
-
+ validate_inputs <- function(..., header = "Some inputs require attention") {
|
||
| 185 | -1x | +108 | +36x |
- list(out = out, res = res)+ dots <- list(...)+ |
+
| 109 | +2x | +
+ if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
|
||
| 186 | +110 |
- }+ + |
+ ||
| 111 | +34x | +
+ messages <- extract_validator(dots, header)+ |
+ ||
| 112 | +34x | +
+ failings <- if (!any_names(dots)) {
+ |
+ ||
| 113 | +29x | +
+ add_header(messages, header) |
||
| 187 | +114 |
-
+ } else {
+ |
+ ||
| 115 | +5x | +
+ unlist(messages) |
||
| 188 | +116 |
- #' @rdname module_teal_lockfile+ } |
||
| 189 | +117 |
- .is_lockfile_deps_installed <- function() {
+
|
||
| 190 | -1x | +118 | +34x |
- requireNamespace("mirai", quietly = TRUE) && requireNamespace("renv", quietly = TRUE)
+ shiny::validate(shiny::need(is.null(failings), failings)) |
| 191 | +119 |
} |
||
| 192 | +120 | |||
| 193 | +121 |
- #' @rdname module_teal_lockfile+ ### internal functions |
||
| 194 | +122 |
- .is_disabled_lockfile_scenario <- function() {
+
|
||
| 195 | -86x | +|||
| 123 | +
- identical(Sys.getenv("CALLR_IS_RUNNING"), "true") || # inside callr process
+ #' @noRd |
|||
| 196 | -86x | +|||
| 124 | +
- identical(Sys.getenv("TESTTHAT"), "true") || # inside devtools::test
+ #' @keywords internal |
|||
| 197 | -86x | +|||
| 125 | +
- !identical(Sys.getenv("QUARTO_PROJECT_ROOT"), "") || # inside Quarto process
+ # recursive object type test |
|||
| 198 | +126 |
- (+ # returns logical of length 1 |
||
| 199 | -86x | +|||
| 127 | +
- ("CheckExEnv" %in% search()) || any(c("_R_CHECK_TIMINGS_", "_R_CHECK_LICENSE_") %in% names(Sys.getenv()))
+ is_validators <- function(x) {
|
|||
| 200 | -86x | +128 | +118x |
- ) # inside R CMD CHECK+ all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator")) |
| 201 | +129 |
} |
| 1 | +130 |
- #' Data Module for teal+ |
||
| 2 | +131 |
- #'+ #' @noRd |
||
| 3 | +132 |
- #' This module manages the `data` argument for `srv_teal`. The `teal` framework uses [teal.data::teal_data()],+ #' @keywords internal |
||
| 4 | +133 |
- #' which can be provided in various ways:+ # test if an InputValidator object is enabled |
||
| 5 | +134 |
- #' 1. Directly as a [teal.data::teal_data()] object. This will automatically convert it into a `reactive` `teal_data`.+ # returns logical of length 1 |
||
| 6 | +135 |
- #' 2. As a `reactive` object that returns a [teal.data::teal_data()] object.+ # official method requested at https://github.com/rstudio/shinyvalidate/issues/64 |
||
| 7 | +136 |
- #'+ validator_enabled <- function(x) {
|
||
| 8 | -+ | |||
| 137 | +49x |
- #' @details+ x$.__enclos_env__$private$enabled |
||
| 9 | +138 |
- #' ## Reactive `teal_data`:+ } |
||
| 10 | +139 |
- #'+ |
||
| 11 | +140 |
- #' The data in the application can be reactively updated, prompting [srv_teal()] to rebuild the+ #' Recursively extract messages from validator list |
||
| 12 | +141 |
- #' content accordingly. There are two methods for creating interactive `teal_data`:+ #' @return A character vector or a list of character vectors, possibly nested and named. |
||
| 13 | +142 |
- #' 1. Using a `reactive` object provided from outside the `teal` application. In this scenario,+ #' @noRd |
||
| 14 | +143 |
- #' reactivity is controlled by an external module, and `srv_teal` responds to changes.+ #' @keywords internal |
||
| 15 | +144 |
- #' 2. Using [teal_data_module()], which is embedded within the `teal` application, allowing data to+ extract_validator <- function(iv, header) {
|
||
| 16 | -+ | |||
| 145 | +113x |
- #' be resubmitted by the user as needed.+ if (inherits(iv, "InputValidator")) {
|
||
| 17 | -+ | |||
| 146 | +49x |
- #'+ add_header(gather_messages(iv), header) |
||
| 18 | +147 |
- #' Since the server of [teal_data_module()] must return a `reactive` `teal_data` object, both+ } else {
|
||
| 19 | -+ | |||
| 148 | +58x |
- #' methods (1 and 2) produce the same reactive behavior within a `teal` application. The distinction+ if (is.null(names(iv))) names(iv) <- rep("", length(iv))
|
||
| 20 | -+ | |||
| 149 | +64x |
- #' lies in data control: the first method involves external control, while the second method+ mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE) |
||
| 21 | +150 |
- #' involves control from a custom module within the app.+ } |
||
| 22 | +151 |
- #'+ } |
||
| 23 | +152 |
- #' For more details, see [`module_teal_data`].+ |
||
| 24 | +153 |
- #'+ #' Collate failing messages from validator. |
||
| 25 | +154 |
- #' @inheritParams init+ #' @return `list` |
||
| 26 | +155 |
- #'+ #' @noRd |
||
| 27 | +156 |
- #' @param data (`teal_data`, `teal_data_module`, or `reactive` returning `teal_data`)+ #' @keywords internal |
||
| 28 | +157 |
- #' The data which application will depend on.+ gather_messages <- function(iv) {
|
||
| 29 | -+ | |||
| 158 | +49x |
- #'+ if (validator_enabled(iv)) {
|
||
| 30 | -+ | |||
| 159 | +46x |
- #' @return A `reactive` object that returns:+ status <- iv$validate() |
||
| 31 | -+ | |||
| 160 | +46x |
- #' Output of the `data`. If `data` fails then returned error is handled (after [tryCatch()]) so that+ failing_inputs <- Filter(Negate(is.null), status) |
||
| 32 | -+ | |||
| 161 | +46x |
- #' rest of the application can respond to this respectively.+ unique(lapply(failing_inputs, function(x) x[["message"]])) |
||
| 33 | +162 |
- #'+ } else {
|
||
| 34 | -+ | |||
| 163 | +3x |
- #' @rdname module_init_data+ warning("Validator is disabled and will be omitted.")
|
||
| 35 | -+ | |||
| 164 | +3x |
- #' @name module_init_data+ list() |
||
| 36 | +165 |
- #' @keywords internal+ } |
||
| 37 | +166 |
- NULL+ } |
||
| 38 | +167 | |||
| 39 | +168 |
- #' @rdname module_init_data+ #' Add optional header to failing messages |
||
| 40 | +169 |
- ui_init_data <- function(id) {
+ #' @noRd |
||
| 41 | -9x | +|||
| 170 | +
- ns <- shiny::NS(id)+ #' @keywords internal |
|||
| 42 | -9x | +|||
| 171 | +
- shiny::div(+ add_header <- function(messages, header = "") {
|
|||
| 43 | -9x | +172 | +78x |
- id = ns("content"),
+ ans <- unlist(messages) |
| 44 | -9x | +173 | +78x |
- style = "display: inline-block; width: 100%;",+ if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
|
| 45 | -9x | +174 | +31x |
- uiOutput(ns("data"))
+ ans <- c(paste0(header, "\n"), ans, "\n") |
| 46 | +175 |
- )+ }+ |
+ ||
| 176 | +78x | +
+ ans |
||
| 47 | +177 |
} |
||
| 48 | +178 | |||
| 49 | +179 |
- #' @rdname module_init_data+ #' Recursively check if the object contains a named list |
||
| 50 | +180 |
- srv_init_data <- function(id, data) {
- |
- ||
| 51 | -88x | -
- checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ #' @noRd |
||
| 52 | -88x | +|||
| 181 | +
- checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
+ #' @keywords internal |
|||
| 53 | +182 |
-
+ any_names <- function(x) {
|
||
| 54 | -88x | +183 | +103x |
- moduleServer(id, function(input, output, session) {
+ any( |
| 55 | -88x | +184 | +103x |
- logger::log_debug("srv_data initializing.")
+ if (is.list(x)) {
|
| 56 | -88x | +185 | +58x |
- data_out <- if (inherits(data, "teal_data_module")) {
+ if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names)) |
| 57 | -10x | +|||
| 186 | +
- output$data <- renderUI(data$ui(id = session$ns("teal_data_module")))
+ } else {
|
|||
| 58 | -10x | +187 | +40x |
- data$server("teal_data_module")
+ FALSE |
| 59 | -88x | +|||
| 188 | +
- } else if (inherits(data, "teal_data")) {
+ } |
|||
| 60 | -48x | +|||
| 189 | +
- reactiveVal(data)+ ) |
|||
| 61 | -88x | +|||
| 190 | +
- } else if (test_reactive(data)) {
+ } |
|||
| 62 | -30x | +
| 1 | +
- data+ #' Execute and validate `teal_data_module` |
||
| 63 | +2 |
- }+ #' |
|
| 64 | +3 |
-
+ #' This is a low level module to handle `teal_data_module` execution and validation. |
|
| 65 | -87x | +||
| 4 | +
- data_handled <- reactive({
+ #' [teal_transform_module()] inherits from [teal_data_module()] so it is handled by this module too. |
||
| 66 | -80x | +||
| 5 | +
- tryCatch(data_out(), error = function(e) e)+ #' [srv_teal()] accepts various `data` objects and eventually they are all transformed to `reactive` |
||
| 67 | +6 |
- })+ #' [teal.data::teal_data()] which is a standard data class in whole `teal` framework. |
|
| 68 | +7 |
-
+ #' |
|
| 69 | +8 |
- # We want to exclude teal_data_module elements from bookmarking as they might have some secrets+ #' @section data validation: |
|
| 70 | -87x | -
- observeEvent(data_handled(), {
+ | |
| 9 | ++ |
+ #' |
|
| 71 | -80x | +||
| 10 | +
- if (inherits(data_handled(), "teal_data")) {
+ #' Executed [teal_data_module()] is validated and output is validated for consistency. |
||
| 72 | -75x | +||
| 11 | +
- app_session <- .subset2(shiny::getDefaultReactiveDomain(), "parent")+ #' Output `data` is invalid if: |
||
| 73 | -75x | +||
| 12 | +
- setBookmarkExclude(+ #' 1. [teal_data_module()] is invalid if server doesn't return `reactive`. **Immediately crashes an app!** |
||
| 74 | -75x | +||
| 13 | +
- session$ns(+ #' 2. `reactive` throws a `shiny.error` - happens when module creating [teal.data::teal_data()] fails. |
||
| 75 | -75x | +||
| 14 | +
- grep(+ #' 3. `reactive` returns `qenv.error` - happens when [teal.data::teal_data()] evaluates a failing code. |
||
| 76 | -75x | +||
| 15 | +
- pattern = "teal_data_module-",+ #' 4. `reactive` object doesn't return [teal.data::teal_data()]. |
||
| 77 | -75x | +||
| 16 | +
- x = names(reactiveValuesToList(input)),+ #' 5. [teal.data::teal_data()] object lacks any `datanames` specified in the `modules` argument. |
||
| 78 | -75x | +||
| 17 | +
- value = TRUE+ #' |
||
| 79 | +18 |
- )+ #' `teal` (observers in `srv_teal`) always waits to render an app until `reactive` `teal_data` is |
|
| 80 | +19 |
- ),+ #' returned. If error 2-4 occurs, relevant error message is displayed to the app user. Once the issue is |
|
| 81 | -75x | +||
| 20 | +
- session = app_session+ #' resolved, the app will continue to run. `teal` guarantees that errors in data don't crash the app |
||
| 82 | +21 |
- )+ #' (except error 1). |
|
| 83 | +22 |
- }+ #' |
|
| 84 | +23 |
- })+ #' @param id (`character(1)`) Module id |
|
| 85 | +24 |
-
+ #' @param data (`reactive teal_data`) |
|
| 86 | -87x | +||
| 25 | +
- data_handled+ #' @param data_module (`teal_data_module`) |
||
| 87 | +26 |
- })+ #' @param modules (`teal_modules` or `teal_module`) For `datanames` validation purpose |
|
| 88 | +27 |
- }+ #' @param validate_shiny_silent_error (`logical`) If `TRUE`, then `shiny.silent.error` is validated and |
|
| 89 | +28 |
-
+ #' @param is_transform_failed (`reactiveValues`) contains `logical` flags named after each transformator. |
|
| 90 | +29 |
- #' Adds signature protection to the `datanames` in the data+ #' Help to determine if any previous transformator failed, so that following transformators can be disabled |
|
| 91 | +30 |
- #' @param data (`teal_data`)+ #' and display a generic failure message. |
|
| 92 | +31 |
- #' @return `teal_data` with additional code that has signature of the `datanames`+ #' |
|
| 93 | +32 |
- #' @keywords internal+ #' @return `reactive` `teal_data` |
|
| 94 | +33 |
- .add_signature_to_data <- function(data) {
+ #' |
|
| 95 | -75x | +||
| 34 | +
- hashes <- .get_hashes_code(data)+ #' @rdname module_teal_data |
||
| 96 | -75x | +||
| 35 | +
- tdata <- do.call(+ #' @name module_teal_data |
||
| 97 | -75x | +||
| 36 | +
- teal.data::teal_data,+ #' @keywords internal |
||
| 98 | -75x | +||
| 37 | +
- c(+ NULL |
||
| 99 | -75x | +||
| 38 | +
- list(code = trimws(c(teal.code::get_code(data), hashes), which = "right")),+ |
||
| 100 | -75x | +||
| 39 | +
- list(join_keys = teal.data::join_keys(data)),+ #' @rdname module_teal_data |
||
| 101 | -75x | +||
| 40 | +
- sapply(+ #' @aliases ui_teal_data |
||
| 102 | -75x | +||
| 41 | +
- names(data),+ #' @note |
||
| 103 | -75x | +||
| 42 | +
- teal.code::get_var,+ #' `ui_teal_data_module` was renamed from `ui_teal_data`. |
||
| 104 | -75x | +||
| 43 | +
- object = data,+ ui_teal_data_module <- function(id, data_module = function(id) NULL) {
|
||
| 105 | -75x | +||
| 44 | +! |
- simplify = FALSE+ checkmate::assert_string(id) |
|
| 106 | -+ | ||
| 45 | +! |
- )+ checkmate::assert_function(data_module, args = "id") |
|
| 107 | -+ | ||
| 46 | +! |
- )+ ns <- NS(id) |
|
| 108 | +47 |
- )+ |
|
| 109 | -+ | ||
| 48 | +! |
-
+ shiny::tagList( |
|
| 110 | -75x | +||
| 49 | +! |
- tdata@verified <- data@verified+ tags$div(id = ns("wrapper"), data_module(id = ns("data"))),
|
|
| 111 | -75x | +||
| 50 | +! |
- tdata+ ui_validate_reactive_teal_data(ns("validate"))
|
|
| 112 | +51 | ++ |
+ )+ |
+
| 52 |
} |
||
| 113 | +53 | ||
| 114 | +54 |
- #' Get code that tests the integrity of the reproducible data+ #' @rdname module_teal_data |
|
| 115 | +55 |
- #'+ #' @aliases srv_teal_data |
|
| 116 | +56 |
- #' @param data (`teal_data`) object holding the data+ #' @note |
|
| 117 | +57 |
- #' @param datanames (`character`) names of `datasets`+ #' `srv_teal_data_module` was renamed from `srv_teal_data`. |
|
| 118 | +58 |
- #'+ srv_teal_data_module <- function(id, |
|
| 119 | +59 |
- #' @return A character vector with the code lines.+ data_module = function(id) NULL, |
|
| 120 | +60 |
- #' @keywords internal+ modules = NULL, |
|
| 121 | +61 |
- #'+ validate_shiny_silent_error = TRUE, |
|
| 122 | +62 |
- .get_hashes_code <- function(data, datanames = names(data)) {
+ is_transform_failed = reactiveValues()) {
|
|
| 123 | -75x | +||
| 63 | +! |
- vapply(+ checkmate::assert_string(id) |
|
| 124 | -75x | +||
| 64 | +! |
- datanames,+ checkmate::assert_function(data_module, args = "id") |
|
| 125 | -75x | +||
| 65 | +! |
- function(dataname, datasets) {
+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
|
|
| 126 | -133x | +||
| 66 | +! |
- x <- data[[dataname]]+ checkmate::assert_class(is_transform_failed, "reactivevalues") |
|
| 127 | +67 | ||
| 128 | -133x | +||
| 68 | +! |
- code <- if (is.function(x) && !is.primitive(x)) {
+ moduleServer(id, function(input, output, session) {
|
|
| 129 | -6x | +||
| 69 | +! |
- x <- deparse1(x)+ logger::log_debug("srv_teal_data_module initializing.")
|
|
| 130 | -6x | +||
| 70 | +! |
- bquote(rlang::hash(deparse1(.(as.name(dataname)))))+ is_transform_failed[[id]] <- FALSE |
|
| 131 | -+ | ||
| 71 | +! |
- } else {
+ module_out <- data_module(id = "data") |
|
| 132 | -127x | +||
| 72 | +! |
- bquote(rlang::hash(.(as.name(dataname))))+ try_module_out <- reactive(tryCatch(module_out(), error = function(e) e)) |
|
| 133 | -+ | ||
| 73 | +! |
- }+ observeEvent(try_module_out(), {
|
|
| 134 | -133x | +||
| 74 | +! |
- sprintf(+ if (!inherits(try_module_out(), "teal_data")) {
|
|
| 135 | -133x | +||
| 75 | +! |
- "stopifnot(%s == %s) # @linksto %s",+ is_transform_failed[[id]] <- TRUE |
|
| 136 | -133x | +||
| 76 | +
- deparse1(code),+ } else {
|
||
| 137 | -133x | +||
| 77 | +! |
- deparse1(rlang::hash(x)),+ is_transform_failed[[id]] <- FALSE |
|
| 138 | -133x | +||
| 78 | +
- dataname+ } |
||
| 139 | +79 |
- )+ }) |
|
| 140 | +80 |
- },+ |
|
| 141 | -75x | +||
| 81 | +! |
- character(1L),+ is_previous_failed <- reactive({
|
|
| 142 | -75x | +||
| 82 | +! |
- USE.NAMES = TRUE+ idx_this <- which(names(is_transform_failed) == id) |
|
| 143 | -+ | ||
| 83 | +! |
- )+ is_transform_failed_list <- reactiveValuesToList(is_transform_failed) |
|
| 144 | -+ | ||
| 84 | +! |
- }+ idx_failures <- which(unlist(is_transform_failed_list)) |
| 1 | -+ | |||
| 85 | +! |
- #' Manage multiple `FilteredData` objects+ any(idx_failures < idx_this) |
||
| 2 | +86 |
- #'+ }) |
||
| 3 | +87 |
- #' @description+ |
||
| 4 | -+ | |||
| 88 | +! |
- #' Oversee filter states across the entire application.+ observeEvent(is_previous_failed(), {
|
||
| 5 | -+ | |||
| 89 | +! |
- #'+ if (is_previous_failed()) {
|
||
| 6 | -+ | |||
| 90 | +! |
- #' @section Slices global:+ shinyjs::disable("wrapper")
|
||
| 7 | +91 |
- #' The key role in maintaining the module-specific filter states is played by the `.slicesGlobal`+ } else {
|
||
| 8 | -+ | |||
| 92 | +! |
- #' object. It is a reference class that holds the following fields:+ shinyjs::enable("wrapper")
|
||
| 9 | +93 |
- #' - `all_slices` (`reactiveVal`) - reactive value containing all filters registered in an app.+ } |
||
| 10 | +94 |
- #' - `module_slices_api` (`reactiveValues`) - reactive field containing references to each modules'+ }) |
||
| 11 | +95 |
- #' `FilteredData` object methods. At this moment it is used only in `srv_filter_manager` to display+ |
||
| 12 | -+ | |||
| 96 | +! |
- #' the filter states in a table combining informations from `all_slices` and from+ srv_validate_reactive_teal_data( |
||
| 13 | -+ | |||
| 97 | +! |
- #' `FilteredData$get_available_teal_slices()`.+ "validate", |
||
| 14 | -+ | |||
| 98 | +! |
- #'+ data = try_module_out, |
||
| 15 | -+ | |||
| 99 | +! |
- #' During a session only new filters are added to `all_slices` unless [`module_snapshot_manager`] is+ modules = modules, |
||
| 16 | -+ | |||
| 100 | +! |
- #' used to restore previous state. Filters from `all_slices` can be activated or deactivated in a+ validate_shiny_silent_error = validate_shiny_silent_error, |
||
| 17 | -+ | |||
| 101 | +! |
- #' module which is linked (both ways) by `attr(, "mapping")` so that:+ hide_validation_error = is_previous_failed |
||
| 18 | +102 |
- #' - If module's filter is added or removed in its `FilteredData` object, this information is passed+ ) |
||
| 19 | +103 |
- #' to `SlicesGlobal` which updates `attr(, "mapping")` accordingly.+ }) |
||
| 20 | +104 |
- #' - When mapping changes in a `SlicesGlobal`, filters are set or removed from module's+ } |
||
| 21 | +105 |
- #' `FilteredData`.+ |
||
| 22 | +106 |
- #'+ #' @rdname module_teal_data |
||
| 23 | +107 |
- #' @section Filter manager:+ ui_validate_reactive_teal_data <- function(id) {
|
||
| 24 | -+ | |||
| 108 | +! |
- #' Filter-manager is split into two parts:+ ns <- NS(id) |
||
| 25 | -+ | |||
| 109 | +! |
- #' 1. `ui/srv_filter_manager_panel` - Called once for the whole app. This module observes changes in+ tagList( |
||
| 26 | -+ | |||
| 110 | +! |
- #' the filters in `slices_global` and displays them in a table utilizing information from `mapping`:+ div( |
||
| 27 | -+ | |||
| 111 | +! |
- #' - (`TRUE`) - filter is active in the module+ id = ns("validate_messages"),
|
||
| 28 | -+ | |||
| 112 | +! |
- #' - (`FALSE`) - filter is inactive in the module+ class = "teal_validated", |
||
| 29 | -+ | |||
| 113 | +! |
- #' - (`NA`) - filter is not available in the module+ ui_validate_error(ns("silent_error")),
|
||
| 30 | -+ | |||
| 114 | +! |
- #' 2. `ui/srv_module_filter_manager` - Called once for each `teal_module`. Handling filter states+ ui_check_class_teal_data(ns("class_teal_data")),
|
||
| 31 | -+ | |||
| 115 | +! |
- #' for of single module and keeping module `FilteredData` consistent with `slices_global`, so that+ ui_check_module_datanames(ns("shiny_warnings"))
|
||
| 32 | +116 |
- #' local filters are always reflected in the `slices_global` and its mapping and vice versa.+ ), |
||
| 33 | -+ | |||
| 117 | +! |
- #'+ div( |
||
| 34 | -+ | |||
| 118 | +! |
- #'+ class = "teal_validated", |
||
| 35 | -+ | |||
| 119 | +! |
- #' @param id (`character(1)`)+ uiOutput(ns("previous_failed"))
|
||
| 36 | +120 |
- #' `shiny` module instance id.+ ) |
||
| 37 | +121 |
- #'+ ) |
||
| 38 | +122 |
- #' @param slices_global (`reactiveVal`)+ } |
||
| 39 | +123 |
- #' containing `teal_slices`.+ |
||
| 40 | +124 |
- #'+ #' @rdname module_teal_data |
||
| 41 | +125 |
- #' @param module_fd (`FilteredData`)+ srv_validate_reactive_teal_data <- function(id, # nolint: object_length |
||
| 42 | +126 |
- #' Object containing the data to be filtered in a single `teal` module.+ data, |
||
| 43 | +127 |
- #'+ modules = NULL, |
||
| 44 | +128 |
- #' @return+ validate_shiny_silent_error = FALSE, |
||
| 45 | +129 |
- #' Module returns a `slices_global` (`reactiveVal`) containing a `teal_slices` object with mapping.+ hide_validation_error = reactive(FALSE)) {
|
||
| 46 | -+ | |||
| 130 | +! |
- #'+ checkmate::assert_string(id) |
||
| 47 | -+ | |||
| 131 | +! |
- #' @encoding UTF-8+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
|
||
| 48 | -+ | |||
| 132 | +! |
- #'+ checkmate::assert_flag(validate_shiny_silent_error) |
||
| 49 | +133 |
- #' @name module_filter_manager+ |
||
| 50 | -+ | |||
| 134 | +! |
- #' @rdname module_filter_manager+ moduleServer(id, function(input, output, session) {
|
||
| 51 | +135 |
- #'+ # there is an empty reactive cycle on `init` and `data` has `shiny.silent.error` class |
||
| 52 | -+ | |||
| 136 | +! |
- NULL+ srv_validate_error("silent_error", data, validate_shiny_silent_error)
|
||
| 53 | -+ | |||
| 137 | +! |
-
+ srv_check_class_teal_data("class_teal_data", data)
|
||
| 54 | -+ | |||
| 138 | +! |
- #' @rdname module_filter_manager+ srv_check_module_datanames("shiny_warnings", data, modules)
|
||
| 55 | -+ | |||
| 139 | +! |
- ui_filter_manager_panel <- function(id) {
+ output$previous_failed <- renderUI({
|
||
| 56 | +140 | ! |
- ns <- NS(id)+ if (hide_validation_error()) {
|
|
| 57 | +141 | ! |
- tags$button(+ shinyjs::hide("validate_messages")
|
|
| 58 | +142 | ! |
- id = ns("show_filter_manager"),
+ tags$div("One of previous transformators failed. Please check its inputs.", class = "teal-output-warning")
|
|
| 59 | -! | +|||
| 143 | +
- class = "btn action-button wunder_bar_button",+ } else {
|
|||
| 60 | +144 | ! |
- title = "View filter mapping",+ shinyjs::show("validate_messages")
|
|
| 61 | +145 | ! |
- suppressMessages(icon("fas fa-grip"))
+ NULL |
|
| 62 | +146 |
- )+ } |
||
| 63 | +147 |
- }+ }) |
||
| 64 | +148 | |||
| 149 | +! | +
+ .trigger_on_success(data)+ |
+ ||
| 65 | +150 |
- #' @rdname module_filter_manager+ }) |
||
| 66 | +151 |
- #' @keywords internal+ } |
||
| 67 | +152 |
- srv_filter_manager_panel <- function(id, slices_global) {
+
|
||
| 68 | -87x | +|||
| 153 | +
- checkmate::assert_string(id)+ #' @keywords internal |
|||
| 69 | -87x | +|||
| 154 | +
- checkmate::assert_class(slices_global, ".slicesGlobal")+ ui_validate_error <- function(id) {
|
|||
| 70 | -87x | +155 | +116x |
- moduleServer(id, function(input, output, session) {
+ ns <- NS(id) |
| 71 | -87x | +156 | +116x |
- setBookmarkExclude(c("show_filter_manager"))
+ uiOutput(ns("message"))
|
| 72 | -87x | +|||
| 157 | +
- observeEvent(input$show_filter_manager, {
+ } |
|||
| 73 | -! | +|||
| 158 | +
- logger::log_debug("srv_filter_manager_panel@1 show_filter_manager button has been clicked.")
+
|
|||
| 74 | -! | +|||
| 159 | +
- showModal(+ #' @keywords internal |
|||
| 75 | -! | +|||
| 160 | +
- modalDialog(+ srv_validate_error <- function(id, data, validate_shiny_silent_error) {
|
|||
| 76 | -! | +|||
| 161 | +113x |
- ui_filter_manager(session$ns("filter_manager")),
+ checkmate::assert_string(id) |
||
| 77 | -! | +|||
| 162 | +113x |
- class = "filter_manager_modal",+ checkmate::assert_flag(validate_shiny_silent_error) |
||
| 78 | -! | +|||
| 163 | +113x |
- size = "l",+ moduleServer(id, function(input, output, session) {
|
||
| 79 | -! | +|||
| 164 | +113x |
- footer = NULL,+ output$message <- renderUI({
|
||
| 80 | -! | +|||
| 165 | +112x |
- easyClose = TRUE+ is_shiny_silent_error <- inherits(data(), "shiny.silent.error") && identical(data()$message, "") |
||
| 81 | -+ | |||
| 166 | +112x |
- )+ if (inherits(data(), "qenv.error")) {
|
||
| 82 | -+ | |||
| 167 | +2x |
- )+ validate( |
||
| 83 | -+ | |||
| 168 | +2x |
- })+ need( |
||
| 84 | -87x | +169 | +2x |
- srv_filter_manager("filter_manager", slices_global = slices_global)
+ FALSE, |
| 85 | -+ | |||
| 170 | +2x |
- })+ paste( |
||
| 86 | -- |
- }- |
- ||
| 87 | -- | - - | -||
| 88 | -- |
- #' @rdname module_filter_manager- |
- ||
| 89 | -- |
- ui_filter_manager <- function(id) {
- |
- ||
| 90 | -! | -
- ns <- NS(id)- |
- ||
| 91 | -! | -
- actionButton(ns("filter_manager"), NULL, icon = icon("fas fa-filter"))
- |
- ||
| 92 | -! | +|||
| 171 | +2x |
- tags$div(+ "Error when executing the `data` module:", |
||
| 93 | -! | +|||
| 172 | +2x |
- class = "filter_manager_content",+ cli::ansi_strip(paste(data()$message, collapse = "\n")), |
||
| 94 | -! | +|||
| 173 | +2x |
- tableOutput(ns("slices_table"))
+ "\nCheck your inputs or contact app developer if error persists.", |
||
| 95 | -+ | |||
| 174 | +2x |
- )+ collapse = "\n" |
||
| 96 | +175 |
- }+ ) |
||
| 97 | +176 |
-
+ ) |
||
| 98 | +177 |
- #' @rdname module_filter_manager+ ) |
||
| 99 | -+ | |||
| 178 | +110x |
- srv_filter_manager <- function(id, slices_global) {
+ } else if (inherits(data(), "error")) {
|
||
| 100 | -87x | +179 | +11x |
- checkmate::assert_string(id)+ if (is_shiny_silent_error && !validate_shiny_silent_error) {
|
| 101 | -87x | +180 | +4x |
- checkmate::assert_class(slices_global, ".slicesGlobal")+ return(NULL) |
| 102 | +181 |
-
+ } |
||
| 103 | -87x | +182 | +7x |
- moduleServer(id, function(input, output, session) {
+ validate( |
| 104 | -87x | -
- logger::log_debug("filter_manager_srv initializing.")
- |
- ||
| 105 | -- | - - | -||
| 106 | -+ | 183 | +7x |
- # Bookmark slices global with mapping.+ need( |
| 107 | -87x | +184 | +7x |
- session$onBookmark(function(state) {
+ FALSE, |
| 108 | -! | +|||
| 185 | +7x |
- logger::log_debug("filter_manager_srv@onBookmark: storing filter state")
+ sprintf( |
||
| 109 | -! | +|||
| 186 | +7x |
- state$values$filter_state_on_bookmark <- as.list(+ "Shiny error when executing the `data` module.\n%s\n%s", |
||
| 110 | -! | +|||
| 187 | +7x |
- slices_global$all_slices(),+ data()$message, |
||
| 111 | -! | +|||
| 188 | +7x |
- recursive = TRUE+ "Check your inputs or contact app developer if error persists." |
||
| 112 | +189 |
- )+ ) |
||
| 113 | +190 |
- })+ ) |
||
| 114 | +191 | - - | -||
| 115 | -87x | -
- bookmarked_slices <- restoreValue(session$ns("filter_state_on_bookmark"), NULL)
+ ) |
||
| 116 | -87x | +|||
| 192 | +
- if (!is.null(bookmarked_slices)) {
+ } |
|||
| 117 | -! | +|||
| 193 | +
- logger::log_debug("filter_manager_srv: restoring filter state from bookmark.")
+ }) |
|||
| 118 | -! | +|||
| 194 | +
- slices_global$slices_set(bookmarked_slices)+ }) |
|||
| 119 | +195 |
- }+ } |
||
| 120 | +196 | |||
| 121 | -87x | -
- mapping_table <- reactive({
- |
- ||
| 122 | +197 |
- # We want this to be reactive on slices_global$all_slices() only as get_available_teal_slices()+ |
||
| 123 | +198 |
- # is dependent on slices_global$all_slices().+ #' @keywords internal |
||
| 124 | -96x | +|||
| 199 | +
- module_labels <- setdiff(+ ui_check_class_teal_data <- function(id) {
|
|||
| 125 | -96x | +200 | +116x |
- names(attr(slices_global$all_slices(), "mapping")),+ ns <- NS(id) |
| 126 | -96x | +201 | +116x |
- "Report previewer"+ uiOutput(ns("message"))
|
| 127 | +202 |
- )+ } |
||
| 128 | -96x | +|||
| 203 | +
- isolate({
+
|
|||
| 129 | -96x | +|||
| 204 | +
- mm <- as.data.frame(+ #' @keywords internal |
|||
| 130 | -96x | +|||
| 205 | +
- sapply(+ srv_check_class_teal_data <- function(id, data) {
|
|||
| 131 | -96x | +206 | +113x |
- module_labels,+ checkmate::assert_string(id) |
| 132 | -96x | +207 | +113x |
- simplify = FALSE,+ moduleServer(id, function(input, output, session) {
|
| 133 | -96x | +208 | +113x |
- function(module_label) {
+ output$message <- renderUI({
|
| 134 | -109x | +209 | +112x |
- available_slices <- slices_global$module_slices_api[[module_label]]$get_available_teal_slices()+ validate( |
| 135 | -101x | +210 | +112x |
- global_ids <- sapply(slices_global$all_slices(), `[[`, "id", simplify = FALSE)+ need( |
| 136 | -101x | +211 | +112x |
- module_ids <- sapply(slices_global$slices_get(module_label), `[[`, "id", simplify = FALSE)+ inherits(data(), c("teal_data", "error")),
|
| 137 | -101x | +212 | +112x |
- allowed_ids <- vapply(available_slices, `[[`, character(1L), "id")+ "Did not receive `teal_data` object. Cannot proceed further." |
| 138 | -101x | +|||
| 213 | +
- active_ids <- global_ids %in% module_ids+ ) |
|||
| 139 | -101x | +|||
| 214 | +
- setNames(nm = global_ids, ifelse(global_ids %in% allowed_ids, active_ids, NA))+ ) |
|||
| 140 | +215 |
- }+ }) |
||
| 141 | +216 |
- ),+ }) |
||
| 142 | -96x | +|||
| 217 | +
- check.names = FALSE+ } |
|||
| 143 | +218 |
- )+ |
||
| 144 | -88x | +|||
| 219 | +
- colnames(mm)[colnames(mm) == "global_filters"] <- "Global filters"+ #' @keywords internal |
|||
| 145 | +220 |
-
+ ui_check_module_datanames <- function(id) {
|
||
| 146 | -88x | +221 | +116x |
- mm+ ns <- NS(id) |
| 147 | -+ | |||
| 222 | +116x |
- })+ uiOutput(NS(id, "message")) |
||
| 148 | +223 |
- })+ } |
||
| 149 | +224 | |||
| 150 | -87x | +|||
| 225 | +
- output$slices_table <- renderTable(+ #' @keywords internal |
|||
| 151 | -87x | +|||
| 226 | +
- expr = {
+ srv_check_module_datanames <- function(id, data, modules) {
|
|||
| 152 | -96x | +227 | +193x |
- logger::log_debug("filter_manager_srv@1 rendering slices_table.")
+ checkmate::assert_string(id) |
| 153 | -96x | -
- mm <- mapping_table()- |
- ||
| 154 | -+ | 228 | +193x |
-
+ moduleServer(id, function(input, output, session) {
|
| 155 | -+ | |||
| 229 | +193x |
- # Display logical values as UTF characters.+ output$message <- renderUI({
|
||
| 156 | -88x | +230 | +196x |
- mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))+ if (inherits(data(), "teal_data")) {
|
| 157 | -88x | +231 | +179x |
- mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))+ is_modules_ok <- check_modules_datanames_html( |
| 158 | -+ | |||
| 232 | +179x |
-
+ modules = modules, datanames = names(data()) |
||
| 159 | +233 |
- # Display placeholder if no filters defined.- |
- ||
| 160 | -88x | -
- if (nrow(mm) == 0L) {
+ ) |
||
| 161 | -64x | +234 | +179x |
- mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)+ if (!isTRUE(is_modules_ok)) {
|
| 162 | -64x | +235 | +19x |
- rownames(mm) <- ""+ tags$div(is_modules_ok, class = "teal-output-warning") |
| 163 | +236 |
} |
||
| 164 | -88x | +|||
| 237 | +
- mm+ } |
|||
| 165 | +238 |
- },+ }) |
||
| 166 | -87x | +|||
| 239 | +
- rownames = TRUE+ }) |
|||
| 167 | +240 |
- )+ } |
||
| 168 | +241 | |||
| 169 | -87x | -
- mapping_table # for testing purpose- |
- ||
| 170 | +242 |
- })+ .trigger_on_success <- function(data) {
|
||
| 171 | -+ | |||
| 243 | +113x |
- }+ out <- reactiveVal(NULL) |
||
| 172 | -+ | |||
| 244 | +113x |
-
+ observeEvent(data(), {
|
||
| 173 | -+ | |||
| 245 | +112x |
- #' @rdname module_filter_manager+ if (inherits(data(), "teal_data")) {
|
||
| 174 | -+ | |||
| 246 | +97x |
- srv_module_filter_manager <- function(id, module_fd, slices_global) {
+ if (!identical(data(), out())) {
|
||
| 175 | -112x | +247 | +97x |
- checkmate::assert_string(id)+ out(data()) |
| 176 | -112x | +|||
| 248 | +
- assert_reactive(module_fd)+ } |
|||
| 177 | -112x | +|||
| 249 | +
- checkmate::assert_class(slices_global, ".slicesGlobal")+ } |
|||
| 178 | +250 |
-
+ }) |
||
| 179 | -112x | +|||
| 251 | +
- moduleServer(id, function(input, output, session) {
+
|
|||
| 180 | -112x | +252 | +113x |
- logger::log_debug("srv_module_filter_manager initializing for module: { id }.")
+ out |
| 181 | +253 |
- # Track filter global and local states.+ } |
||
| 182 | -112x | +
| 1 | +
- slices_global_module <- reactive({
+ # FilteredData ------ |
||
| 183 | -201x | +||
| 2 | +
- slices_global$slices_get(module_label = id)+ |
||
| 184 | +3 |
- })+ #' Drive a `teal` application |
|
| 185 | -112x | +||
| 4 | +
- slices_module <- reactive(req(module_fd())$get_filter_state())+ #' |
||
| 186 | +5 |
-
+ #' Extension of the `shinytest2::AppDriver` class with methods for |
|
| 187 | -112x | +||
| 6 | +
- module_fd_previous <- reactiveVal(NULL)+ #' driving a teal application for performing interactions for `shinytest2` tests. |
||
| 188 | +7 |
-
+ #' |
|
| 189 | +8 |
- # Set (reactively) available filters for the module.+ #' @keywords internal |
|
| 190 | -112x | +||
| 9 | +
- obs1 <- observeEvent(module_fd(), priority = 1, {
+ #' |
||
| 191 | -93x | +||
| 10 | +
- logger::log_debug("srv_module_filter_manager@1 setting initial slices for module: { id }.")
+ TealAppDriver <- R6::R6Class( # nolint: object_name. |
||
| 192 | +11 |
- # Filters relevant for the module in module-specific app.+ "TealAppDriver", |
|
| 193 | -93x | +||
| 12 | +
- slices <- slices_global_module()+ inherit = {
|
||
| 194 | +13 |
-
+ lapply(c("testthat", "shinytest2", "rvest"), function(.x, use_testthat) {
|
|
| 195 | +14 |
- # Clean up previous filter states and refresh cache of previous module_fd with current+ if (!requireNamespace(.x, quietly = TRUE)) {
|
|
| 196 | -3x | +||
| 15 | +
- if (!is.null(module_fd_previous())) module_fd_previous()$finalize()+ if (use_testthat) {
|
||
| 197 | -93x | +||
| 16 | +
- module_fd_previous(module_fd())+ testthat::skip(sprintf("%s is not installed", .x))
|
||
| 198 | +17 |
-
+ } else {
|
|
| 199 | +18 |
- # Setting filter states from slices_global:+ stop("Please install '", .x, "' package to use this class.", call. = FALSE)
|
|
| 200 | +19 |
- # 1. when app initializes slices_global set to initial filters (specified by app developer)+ } |
|
| 201 | +20 |
- # 2. when data reinitializes slices_global reflects latest filter states+ } |
|
| 202 | +21 |
-
+ }, use_testthat = requireNamespace("testthat", quietly = TRUE) && testthat::is_testing())
|
|
| 203 | -93x | +||
| 22 | +
- module_fd()$set_filter_state(slices)+ shinytest2::AppDriver |
||
| 204 | +23 |
-
+ }, |
|
| 205 | +24 |
- # irrelevant filters are discarded in FilteredData$set_available_teal_slices+ # public methods ---- |
|
| 206 | +25 |
- # it means we don't need to subset slices_global$all_slices() from filters refering to irrelevant datasets+ public = list( |
|
| 207 | -93x | +||
| 26 | +
- module_fd()$set_available_teal_slices(slices_global$all_slices)+ #' @description |
||
| 208 | +27 |
-
+ #' Initialize a `TealAppDriver` object for testing a `teal` application. |
|
| 209 | +28 |
- # this needed in filter_manager_srv+ #' |
|
| 210 | -93x | +||
| 29 | +
- slices_global$module_slices_api_set(+ #' @param data,modules,filter,title,header,footer,landing_popup arguments passed to `init` |
||
| 211 | -93x | +||
| 30 | +
- id,+ #' @param timeout (`numeric`) Default number of milliseconds for any timeout or |
||
| 212 | -93x | +||
| 31 | +
- list(+ #' timeout_ parameter in the `TealAppDriver` class. |
||
| 213 | -93x | +||
| 32 | +
- get_available_teal_slices = module_fd()$get_available_teal_slices(),+ #' Defaults to 20s. |
||
| 214 | -93x | +||
| 33 | +
- set_filter_state = module_fd()$set_filter_state, # for testing purpose+ #' |
||
| 215 | -93x | +||
| 34 | +
- get_filter_state = module_fd()$get_filter_state # for testing purpose+ #' See [`shinytest2::AppDriver`] `new` method for more details on how to change it |
||
| 216 | +35 |
- )+ #' via options or environment variables. |
|
| 217 | +36 |
- )+ #' @param load_timeout (`numeric`) How long to wait for the app to load, in ms. |
|
| 218 | +37 |
- })+ #' This includes the time to start R. Defaults to 100s. |
|
| 219 | +38 |
-
+ #' |
|
| 220 | +39 |
- # Update global state and mapping matrix when module filters change.+ #' See [`shinytest2::AppDriver`] `new` method for more details on how to change it |
|
| 221 | -112x | +||
| 40 | +
- obs2 <- observeEvent(slices_module(), priority = 0, {
+ #' via options or environment variables |
||
| 222 | -113x | +||
| 41 | +
- this_slices <- slices_module()+ #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$new` |
||
| 223 | -113x | +||
| 42 | +
- slices_global$slices_append(this_slices) # append new slices to the all_slices list+ #' |
||
| 224 | -113x | +||
| 43 | +
- mapping_elem <- setNames(nm = id, list(vapply(this_slices, `[[`, character(1L), "id")))+ #' |
||
| 225 | -113x | +||
| 44 | +
- slices_global$slices_active(mapping_elem)+ #' @return Object of class `TealAppDriver` |
||
| 226 | +45 |
- })+ initialize = function(data, |
|
| 227 | +46 |
-
+ modules, |
|
| 228 | -112x | +||
| 47 | +
- obs3 <- observeEvent(slices_global_module(), {
+ filter = teal_slices(), |
||
| 229 | -135x | +||
| 48 | +
- global_vs_module <- setdiff_teal_slices(slices_global_module(), slices_module())+ title = build_app_title(), |
||
| 230 | -135x | +||
| 49 | +
- module_vs_global <- setdiff_teal_slices(slices_module(), slices_global_module())+ header = tags$p(), |
||
| 231 | -126x | +||
| 50 | +
- if (length(global_vs_module) || length(module_vs_global)) {
+ footer = tags$p(), |
||
| 232 | +51 |
- # Comment: (Nota Bene) Normally new filters for a module are added through module-filter-panel, and slices+ landing_popup = NULL, |
|
| 233 | +52 |
- # global are updated automatically so slices_module -> slices_global_module are equal.+ timeout = rlang::missing_arg(), |
|
| 234 | +53 |
- # this if is valid only when a change is made on the global level so the change needs to be propagated down+ load_timeout = rlang::missing_arg(), |
|
| 235 | +54 |
- # to the module (for example through snapshot manager). If it happens both slices are different+ ...) {
|
|
| 236 | -13x | +||
| 55 | +! |
- logger::log_debug("srv_module_filter_manager@3 (N.B.) global state has changed for a module:{ id }.")
+ private$data <- data |
|
| 237 | -13x | +||
| 56 | +! |
- module_fd()$clear_filter_states()+ private$modules <- modules |
|
| 238 | -13x | +||
| 57 | +! |
- module_fd()$set_filter_state(slices_global_module())+ private$filter <- filter |
|
| 239 | -+ | ||
| 58 | +! |
- }+ app <- init( |
|
| 240 | -+ | ||
| 59 | +! |
- })+ data = data, |
|
| 241 | -+ | ||
| 60 | +! |
-
+ modules = modules, |
|
| 242 | -112x | +||
| 61 | +! |
- slices_module # returned for testing purpose+ filter = filter, |
|
| 243 | -+ | ||
| 62 | +! |
- })+ title = title, |
|
| 244 | -+ | ||
| 63 | +! |
- }+ header = header, |
|
| 245 | -+ | ||
| 64 | +! |
-
+ footer = footer, |
|
| 246 | -+ | ||
| 65 | +! |
- #' @importFrom shiny reactiveVal reactiveValues+ landing_popup = landing_popup, |
|
| 247 | +66 |
- methods::setOldClass("reactiveVal")
+ ) |
|
| 248 | +67 |
- methods::setOldClass("reactivevalues")
+
|
|
| 249 | +68 |
-
+ # Default timeout is hardcoded to 4s in shinytest2:::resolve_timeout |
|
| 250 | +69 |
- #' @importFrom methods new+ # It must be set as parameter to the AppDriver |
|
| 251 | -+ | ||
| 70 | +! |
- #' @rdname module_filter_manager+ suppressWarnings( |
|
| 252 | -+ | ||
| 71 | +! |
- .slicesGlobal <- methods::setRefClass(".slicesGlobal", # nolint: object_name.
+ super$initialize( |
|
| 253 | -+ | ||
| 72 | +! |
- fields = list(+ app_dir = shinyApp(app$ui, app$server), |
|
| 254 | -+ | ||
| 73 | +! |
- all_slices = "reactiveVal",+ name = "teal", |
|
| 255 | -+ | ||
| 74 | +! |
- module_slices_api = "reactivevalues"+ variant = shinytest2::platform_variant(), |
|
| 256 | -+ | ||
| 75 | +! |
- ),+ timeout = rlang::maybe_missing(timeout, 20 * 1000),+ |
+ |
| 76 | +! | +
+ load_timeout = rlang::maybe_missing(load_timeout, 100 * 1000), |
|
| 257 | +77 |
- methods = list(+ ... |
|
| 258 | +78 |
- initialize = function(slices = teal_slices(), module_labels) {
+ ) |
|
| 259 | -87x | +||
| 79 | +
- shiny::isolate({
+ ) |
||
| 260 | -87x | +||
| 80 | +
- checkmate::assert_class(slices, "teal_slices")+ |
||
| 261 | +81 |
- # needed on init to not mix "global_filters" with module-specific-slots+ # Check for minimum version of Chrome that supports the tests |
|
| 262 | -87x | +||
| 82 | +
- if (isTRUE(attr(slices, "module_specific"))) {
+ # - Element.checkVisibility was added on 105 |
||
| 263 | -11x | +||
| 83 | +! |
- old_mapping <- attr(slices, "mapping")+ chrome_version <- numeric_version( |
|
| 264 | -11x | +||
| 84 | +! |
- new_mapping <- sapply(module_labels, simplify = FALSE, function(module_label) {
+ gsub( |
|
| 265 | -20x | +||
| 85 | +! |
- unique(unlist(old_mapping[c(module_label, "global_filters")]))+ "[[:alnum:]_]+/", # Prefix that ends with forward slash |
|
| 266 | +86 |
- })+ "", |
|
| 267 | -11x | +||
| 87 | +! |
- attr(slices, "mapping") <- new_mapping+ self$get_chromote_session()$Browser$getVersion()$product |
|
| 268 | +88 |
- }- |
- |
| 269 | -87x | -
- .self$all_slices <<- shiny::reactiveVal(slices)- |
- |
| 270 | -87x | -
- .self$module_slices_api <<- shiny::reactiveValues()+ ), |
|
| 271 | -87x | +||
| 89 | +! |
- .self$slices_append(slices)+ strict = FALSE |
|
| 272 | -87x | +||
| 90 | +
- .self$slices_active(attr(slices, "mapping"))+ ) |
||
| 273 | -87x | +||
| 91 | +
- invisible(.self)+ |
||
| 274 | -+ | ||
| 92 | +! |
- })+ required_version <- "121" |
|
| 275 | +93 |
- },+ |
|
| 276 | -+ | ||
| 94 | +! |
- is_module_specific = function() {
+ testthat::skip_if( |
|
| 277 | -296x | +||
| 95 | +! |
- isTRUE(attr(.self$all_slices(), "module_specific"))+ is.na(chrome_version), |
|
| 278 | -+ | ||
| 96 | +! |
- },+ "Problem getting Chrome version, please contact the developers." |
|
| 279 | +97 |
- module_slices_api_set = function(module_label, functions_list) {
+ ) |
|
| 280 | -93x | +||
| 98 | +! |
- shiny::isolate({
+ testthat::skip_if( |
|
| 281 | -93x | +||
| 99 | +! |
- if (!.self$is_module_specific()) {
+ chrome_version < required_version, |
|
| 282 | -77x | +||
| 100 | +! |
- module_label <- "global_filters"+ sprintf( |
|
| 283 | -+ | ||
| 101 | +! |
- }+ "Chrome version '%s' is not supported, please upgrade to '%s' or higher", |
|
| 284 | -93x | +||
| 102 | +! |
- if (!identical(.self$module_slices_api[[module_label]], functions_list)) {
+ chrome_version, |
|
| 285 | -93x | +||
| 103 | +! |
- .self$module_slices_api[[module_label]] <- functions_list+ required_version |
|
| 286 | +104 |
- }- |
- |
| 287 | -93x | -
- invisible(.self)+ ) |
|
| 288 | +105 |
- })+ ) |
|
| 289 | +106 |
- },+ # end od check |
|
| 290 | +107 |
- slices_deactivate_all = function(module_label) {
- |
- |
| 291 | -! | -
- shiny::isolate({
+
|
|
| 292 | +108 | ! |
- new_slices <- .self$all_slices()+ private$set_active_ns() |
| 293 | +109 | ! |
- old_mapping <- attr(new_slices, "mapping")+ self$wait_for_idle() |
| 294 | +110 |
-
+ }, |
|
| 295 | -! | +||
| 111 | +
- new_mapping <- if (.self$is_module_specific()) {
+ #' @description |
||
| 296 | -! | +||
| 112 | +
- new_module_mapping <- setNames(nm = module_label, list(character(0)))+ #' Append parent [`shinytest2::AppDriver`] `click` method with a call to `waif_for_idle()` method. |
||
| 297 | -! | +||
| 113 | +
- modifyList(old_mapping, new_module_mapping)+ #' @param ... arguments passed to parent [`shinytest2::AppDriver`] `click()` method. |
||
| 298 | -! | +||
| 114 | +
- } else if (missing(module_label)) {
+ click = function(...) {
|
||
| 299 | +115 | ! |
- lapply(+ super$click(...) |
| 300 | +116 | ! |
- attr(.self$all_slices(), "mapping"),+ private$wait_for_page_stability() |
| 301 | -! | +||
| 117 | +
- function(x) character(0)+ }, |
||
| 302 | +118 |
- )+ #' @description |
|
| 303 | +119 |
- } else {
+ #' Check if the app has shiny errors. This checks for global shiny errors. |
|
| 304 | -! | +||
| 120 | +
- old_mapping[[module_label]] <- character(0)+ #' Note that any shiny errors dependent on shiny server render will only be captured after the teal module tab |
||
| 305 | -! | +||
| 121 | +
- old_mapping+ #' is visited because shiny will not trigger server computations when the tab is invisible. |
||
| 306 | +122 |
- }+ #' So, navigate to the module tab you want to test before calling this function. |
|
| 307 | +123 |
-
+ #' Although, this catches errors hidden in the other module tabs if they are already rendered. |
|
| 308 | -! | +||
| 124 | +
- if (!identical(new_mapping, old_mapping)) {
+ expect_no_shiny_error = function() {
|
||
| 309 | +125 | ! |
- logger::log_debug(".slicesGlobal@slices_deactivate_all: deactivating all slices.")
+ testthat::expect_null( |
| 310 | +126 | ! |
- attr(new_slices, "mapping") <- new_mapping+ self$get_html(".shiny-output-error:not(.shiny-output-error-validation)"),
|
| 311 | +127 | ! |
- .self$all_slices(new_slices)+ info = "Shiny error is observed" |
| 312 | +128 |
- }+ ) |
|
| 313 | -! | +||
| 129 | +
- invisible(.self)+ }, |
||
| 314 | +130 |
- })+ #' @description |
|
| 315 | +131 |
- },+ #' Check if the app has no validation errors. This checks for global shiny validation errors. |
|
| 316 | +132 |
- slices_active = function(mapping_elem) {
+ expect_no_validation_error = function() {
|
|
| 317 | -203x | +||
| 133 | +! |
- shiny::isolate({
+ testthat::expect_null( |
|
| 318 | -203x | +||
| 134 | +! |
- if (.self$is_module_specific()) {
+ self$get_html(".shiny-output-error-validation"),
|
|
| 319 | -36x | +||
| 135 | +! |
- new_mapping <- modifyList(attr(.self$all_slices(), "mapping"), mapping_elem)+ info = "No validation error is observed" |
|
| 320 | +136 |
- } else {
+ ) |
|
| 321 | -167x | +||
| 137 | +
- new_mapping <- setNames(nm = "global_filters", list(unique(unlist(mapping_elem))))+ }, |
||
| 322 | +138 |
- }+ #' @description |
|
| 323 | +139 |
-
+ #' Check if the app has validation errors. This checks for global shiny validation errors. |
|
| 324 | -203x | +||
| 140 | +
- if (!identical(new_mapping, attr(.self$all_slices(), "mapping"))) {
+ expect_validation_error = function() {
|
||
| 325 | -146x | +||
| 141 | +! |
- mapping_modules <- toString(names(new_mapping))+ testthat::expect_false( |
|
| 326 | -146x | +||
| 142 | +! |
- logger::log_debug(".slicesGlobal@slices_active: changing mapping for module(s): { mapping_modules }.")
+ is.null(self$get_html(".shiny-output-error-validation")),
|
|
| 327 | -146x | +||
| 143 | +! |
- new_slices <- .self$all_slices()+ info = "Validation error is not observed" |
|
| 328 | -146x | +||
| 144 | +
- attr(new_slices, "mapping") <- new_mapping+ ) |
||
| 329 | -146x | +||
| 145 | +
- .self$all_slices(new_slices)+ }, |
||
| 330 | +146 |
- }+ #' @description |
|
| 331 | +147 | - - | -|
| 332 | -203x | -
- invisible(.self)+ #' Set the input in the `teal` app. |
|
| 333 | +148 |
- })+ #' |
|
| 334 | +149 |
- },+ #' @param input_id (character) The shiny input id with it's complete name space. |
|
| 335 | +150 |
- # - only new filters are appended to the $all_slices+ #' @param value The value to set the input to. |
|
| 336 | +151 |
- # - mapping is not updated here+ #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$set_inputs` |
|
| 337 | +152 |
- slices_append = function(slices, activate = FALSE) {
+ #' |
|
| 338 | -203x | +||
| 153 | +
- shiny::isolate({
+ #' @return The `TealAppDriver` object invisibly. |
||
| 339 | -203x | +||
| 154 | +
- if (!is.teal_slices(slices)) {
+ set_input = function(input_id, value, ...) {
|
||
| 340 | +155 | ! |
- slices <- as.teal_slices(slices)+ do.call( |
| 341 | -+ | ||
| 156 | +! |
- }+ self$set_inputs, |
|
| 342 | -+ | ||
| 157 | +! |
-
+ c(setNames(list(value), input_id), list(...)) |
|
| 343 | +158 |
- # to make sure that we don't unnecessary trigger $all_slices <reactiveVal>+ ) |
|
| 344 | -203x | +||
| 159 | +! |
- new_slices <- setdiff_teal_slices(slices, .self$all_slices())+ invisible(self) |
|
| 345 | -203x | +||
| 160 | +
- old_mapping <- attr(.self$all_slices(), "mapping")+ }, |
||
| 346 | -203x | +||
| 161 | +
- if (length(new_slices)) {
+ #' @description |
||
| 347 | -6x | +||
| 162 | +
- new_ids <- vapply(new_slices, `[[`, character(1L), "id")+ #' Navigate the teal tabs in the `teal` app. |
||
| 348 | -6x | +||
| 163 | +
- logger::log_debug(".slicesGlobal@slices_append: appending new slice(s): { new_ids }.")
+ #' |
||
| 349 | -6x | +||
| 164 | +
- slices_ids <- vapply(.self$all_slices(), `[[`, character(1L), "id")+ #' @param tabs (character) Labels of tabs to navigate to. The order of the tabs is important, |
||
| 350 | -6x | +||
| 165 | +
- lapply(new_slices, function(slice) {
+ #' and it should start with the most parent level tab. |
||
| 351 | +166 |
- # In case the new state has the same id as an existing one, add a suffix+ #' Note: In case the teal tab group has duplicate names, the first tab will be selected, |
|
| 352 | -6x | +||
| 167 | +
- if (slice$id %in% slices_ids) {
+ #' If you wish to select the second tab with the same name, use the suffix "_1". |
||
| 353 | -1x | +||
| 168 | +
- slice$id <- utils::tail(make.unique(c(slices_ids, slice$id), sep = "_"), 1)+ #' If you wish to select the third tab with the same name, use the suffix "_2" and so on. |
||
| 354 | +169 |
- }+ #' |
|
| 355 | +170 |
- })+ #' @return The `TealAppDriver` object invisibly. |
|
| 356 | +171 |
-
+ navigate_teal_tab = function(tabs) {
|
|
| 357 | -6x | +||
| 172 | +! |
- new_slices_all <- c(.self$all_slices(), new_slices)+ checkmate::check_character(tabs, min.len = 1) |
|
| 358 | -6x | +||
| 173 | +! |
- attr(new_slices_all, "mapping") <- old_mapping+ for (tab in tabs) {
|
|
| 359 | -6x | +||
| 174 | +! |
- .self$all_slices(new_slices_all)+ self$set_input( |
|
| 360 | -+ | ||
| 175 | +! |
- }+ "teal-teal_modules-active_tab", |
|
| 361 | -+ | ||
| 176 | +! |
-
+ get_unique_labels(tab), |
|
| 362 | -203x | +||
| 177 | +! |
- invisible(.self)+ wait_ = FALSE |
|
| 363 | +178 |
- })+ ) |
|
| 364 | +179 |
- },+ } |
|
| 365 | -+ | ||
| 180 | +! |
- slices_get = function(module_label) {
+ self$wait_for_idle() |
|
| 366 | -302x | +||
| 181 | +! |
- if (missing(module_label)) {
+ private$set_active_ns() |
|
| 367 | +182 | ! |
- .self$all_slices()+ invisible(self) |
| 368 | +183 |
- } else {
- |
- |
| 369 | -302x | -
- module_ids <- unlist(attr(.self$all_slices(), "mapping")[c(module_label, "global_filters")])- |
- |
| 370 | -302x | -
- Filter(+ }, |
|
| 371 | -302x | +||
| 184 | +
- function(slice) slice$id %in% module_ids,+ #' @description |
||
| 372 | -302x | +||
| 185 | +
- .self$all_slices()+ #' Get the active shiny name space for different components of the teal app. |
||
| 373 | +186 |
- )+ #' |
|
| 374 | +187 |
- }+ #' @return (`list`) The list of active shiny name space of the teal components. |
|
| 375 | +188 |
- },+ active_ns = function() {
|
|
| 376 | -+ | ||
| 189 | +! |
- slices_set = function(slices) {
+ if (identical(private$ns$module, character(0))) {
|
|
| 377 | -7x | +||
| 190 | +! |
- shiny::isolate({
+ private$set_active_ns() |
|
| 378 | -7x | +||
| 191 | +
- if (!is.teal_slices(slices)) {
+ } |
||
| 379 | +192 | ! |
- slices <- as.teal_slices(slices)+ private$ns |
| 380 | +193 |
- }+ }, |
|
| 381 | -7x | +||
| 194 | +
- .self$all_slices(slices)+ #' @description |
||
| 382 | -7x | +||
| 195 | +
- invisible(.self)+ #' Get the active shiny name space for interacting with the module content. |
||
| 383 | +196 |
- })+ #' |
|
| 384 | +197 |
- },+ #' @return (`string`) The active shiny name space of the component. |
|
| 385 | +198 |
- show = function() {
+ active_module_ns = function() {
|
|
| 386 | +199 | ! |
- shiny::isolate(print(.self$all_slices()))+ if (identical(private$ns$module, character(0))) {
|
| 387 | +200 | ! |
- invisible(.self)+ private$set_active_ns() |
| 388 | +201 |
- }+ } |
|
| 389 | -+ | ||
| 202 | +! |
- )+ private$ns$module |
|
| 390 | +203 |
- )+ }, |
| 1 | +204 |
- #' An example `teal` module+ #' @description |
|
| 2 | +205 |
- #'+ #' Get the active shiny name space bound with a custom `element` name. |
|
| 3 | +206 |
- #' `r lifecycle::badge("experimental")`
+ #' |
|
| 4 | +207 |
- #'+ #' @param element `character(1)` custom element name. |
|
| 5 | +208 |
- #' This module creates an object called `object` that can be modified with decorators.+ #' |
|
| 6 | +209 |
- #' The `object` is determined by what's selected in `Choose a dataset` input in UI.+ #' @return (`string`) The active shiny name space of the component bound with the input `element`. |
|
| 7 | +210 |
- #' The object can be anything that can be handled by `renderPrint()`.+ active_module_element = function(element) {
|
|
| 8 | -+ | ||
| 211 | +! |
- #' See the `vignette("decorate-modules-output", package = "teal")` or [`teal_transform_module`]
+ checkmate::assert_string(element) |
|
| 9 | -+ | ||
| 212 | +! |
- #' to read more about decorators.+ sprintf("#%s-%s", self$active_module_ns(), element)
|
|
| 10 | +213 |
- #'+ }, |
|
| 11 | +214 |
- #' @inheritParams teal_modules+ #' @description |
|
| 12 | +215 |
- #' @param decorators `r lifecycle::badge("experimental")` (`list` of `teal_transform_module` or `NULL`) optional,
+ #' Get the text of the active shiny name space bound with a custom `element` name. |
|
| 13 | +216 |
- #' if not `NULL`, decorator for tables or plots included in the module.+ #' |
|
| 14 | +217 |
- #'+ #' @param element `character(1)` the text of the custom element name. |
|
| 15 | +218 |
- #' @return A `teal` module which can be included in the `modules` argument to [init()].+ #' |
|
| 16 | +219 |
- #' @examples+ #' @return (`string`) The text of the active shiny name space of the component bound with the input `element`. |
|
| 17 | +220 |
- #' app <- init(+ active_module_element_text = function(element) {
|
|
| 18 | -+ | ||
| 221 | +! |
- #' data = teal_data(IRIS = iris, MTCARS = mtcars),+ checkmate::assert_string(element) |
|
| 19 | -+ | ||
| 222 | +! |
- #' modules = example_module()+ self$get_text(self$active_module_element(element)) |
|
| 20 | +223 |
- #' )+ }, |
|
| 21 | +224 |
- #' if (interactive()) {
+ #' @description |
|
| 22 | +225 |
- #' shinyApp(app$ui, app$server)+ #' Get the active shiny name space for interacting with the filter panel. |
|
| 23 | +226 |
- #' }+ #' |
|
| 24 | +227 |
- #' @export+ #' @return (`string`) The active shiny name space of the component. |
|
| 25 | +228 |
- example_module <- function(label = "example teal module",+ active_filters_ns = function() {
|
|
| 26 | -+ | ||
| 229 | +! |
- datanames = "all",+ if (identical(private$ns$filter_panel, character(0))) {
|
|
| 27 | -+ | ||
| 230 | +! |
- transformators = list(),+ private$set_active_ns() |
|
| 28 | +231 |
- decorators = NULL) {
+ } |
|
| 29 | -43x | -
- checkmate::assert_string(label)- |
- |
| 30 | -43x | +||
| 232 | +! |
- checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)+ private$ns$filter_panel |
|
| 31 | +233 | - - | -|
| 32 | -43x | -
- ans <- module(- |
- |
| 33 | -43x | -
- label,- |
- |
| 34 | -43x | -
- server = function(id, data, decorators) {
+ }, |
|
| 35 | -5x | +||
| 234 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ #' @description |
||
| 36 | -5x | +||
| 235 | +
- moduleServer(id, function(input, output, session) {
+ #' Get the active shiny name space for interacting with the data-summary panel. |
||
| 37 | -5x | +||
| 236 | +
- datanames_rv <- reactive(names(req(data())))+ #' |
||
| 38 | -5x | +||
| 237 | +
- observeEvent(datanames_rv(), {
+ #' @return (`string`) The active shiny name space of the data-summary component. |
||
| 39 | -5x | +||
| 238 | +
- selected <- input$dataname+ active_data_summary_ns = function() {
|
||
| 40 | -5x | +||
| 239 | +! |
- if (identical(selected, "")) {
+ if (identical(private$ns$data_summary, character(0))) {
|
|
| 41 | +240 | ! |
- selected <- restoreInput(session$ns("dataname"), NULL)
+ private$set_active_ns() |
| 42 | -5x | +||
| 241 | +
- } else if (isFALSE(selected %in% datanames_rv())) {
+ } |
||
| 43 | +242 | ! |
- selected <- datanames_rv()[1]+ private$ns$data_summary |
| 44 | +243 |
- }- |
- |
| 45 | -5x | -
- updateSelectInput(+ }, |
|
| 46 | -5x | +||
| 244 | +
- session = session,+ #' @description |
||
| 47 | -5x | +||
| 245 | +
- inputId = "dataname",+ #' Get the active shiny name space bound with a custom `element` name. |
||
| 48 | -5x | +||
| 246 | +
- choices = datanames_rv(),+ #' |
||
| 49 | -5x | +||
| 247 | +
- selected = selected+ #' @param element `character(1)` custom element name. |
||
| 50 | +248 |
- )+ #' |
|
| 51 | +249 |
- })+ #' @return (`string`) The active shiny name space of the component bound with the input `element`. |
|
| 52 | +250 |
-
+ active_data_summary_element = function(element) {
|
|
| 53 | -5x | +||
| 251 | +! |
- table_data <- reactive({
+ checkmate::assert_string(element) |
|
| 54 | -8x | +||
| 252 | +! |
- req(input$dataname)+ sprintf("#%s-%s", self$active_data_summary_ns(), element)
|
|
| 55 | -3x | +||
| 253 | +
- within(data(),+ }, |
||
| 56 | +254 |
- {
+ #' @description |
|
| 57 | -3x | +||
| 255 | +
- object <- dataname+ #' Get the input from the module in the `teal` app. |
||
| 58 | +256 |
- },+ #' This function will only access inputs from the name space of the current active teal module. |
|
| 59 | -3x | +||
| 257 | +
- dataname = as.name(input$dataname)+ #' |
||
| 60 | +258 |
- )+ #' @param input_id (character) The shiny input id to get the value from. |
|
| 61 | +259 |
- })+ #' |
|
| 62 | +260 |
-
+ #' @return The value of the shiny input. |
|
| 63 | -5x | +||
| 261 | +
- table_data_decorated_no_print <- srv_transform_teal_data(+ get_active_module_input = function(input_id) {
|
||
| 64 | -5x | +||
| 262 | +! |
- "decorate",+ checkmate::check_string(input_id) |
|
| 65 | -5x | +||
| 263 | +! |
- data = table_data,+ self$get_value(input = sprintf("%s-%s", self$active_module_ns(), input_id))
|
|
| 66 | -5x | +||
| 264 | +
- transformators = decorators+ }, |
||
| 67 | +265 |
- )+ #' @description |
|
| 68 | -5x | +||
| 266 | +
- table_data_decorated <- reactive(within(req(table_data_decorated_no_print()), expr = object))+ #' Get the output from the module in the `teal` app. |
||
| 69 | +267 |
-
+ #' This function will only access outputs from the name space of the current active teal module. |
|
| 70 | -5x | +||
| 268 | +
- output$text <- renderPrint({
+ #' |
||
| 71 | -9x | +||
| 269 | +
- req(table_data()) # Ensure original errors from module are displayed+ #' @param output_id (character) The shiny output id to get the value from. |
||
| 72 | -4x | +||
| 270 | +
- table_data_decorated()[["object"]]+ #' |
||
| 73 | +271 |
- })+ #' @return The value of the shiny output. |
|
| 74 | +272 |
-
+ get_active_module_output = function(output_id) {
|
|
| 75 | -5x | +||
| 273 | +! |
- teal.widgets::verbatim_popup_srv(+ checkmate::check_string(output_id) |
|
| 76 | -5x | +||
| 274 | +! |
- id = "rcode",+ self$get_value(output = sprintf("%s-%s", self$active_module_ns(), output_id))
|
|
| 77 | -5x | +||
| 275 | +
- verbatim_content = reactive(teal.code::get_code(req(table_data_decorated()))),+ }, |
||
| 78 | -5x | +||
| 276 | +
- title = "Example Code"+ #' @description |
||
| 79 | +277 |
- )+ #' Get the output from the module's `teal.widgets::table_with_settings` or `DT::DTOutput` in the `teal` app. |
|
| 80 | +278 |
-
+ #' This function will only access outputs from the name space of the current active teal module. |
|
| 81 | -5x | +||
| 279 | +
- table_data_decorated+ #' |
||
| 82 | +280 |
- })+ #' @param table_id (`character(1)`) The id of the table in the active teal module's name space. |
|
| 83 | +281 |
- },+ #' @param which (integer) If there is more than one table, which should be extracted. |
|
| 84 | -43x | +||
| 282 | +
- ui = function(id, decorators) {
+ #' By default it will look for a table that is built using `teal.widgets::table_with_settings`. |
||
| 85 | -! | +||
| 283 | +
- ns <- NS(id)+ #' |
||
| 86 | -! | +||
| 284 | +
- teal.widgets::standard_layout(+ #' @return The data.frame with table contents. |
||
| 87 | -! | +||
| 285 | +
- output = verbatimTextOutput(ns("text")),
+ get_active_module_table_output = function(table_id, which = 1) {
|
||
| 88 | +286 | ! |
- encoding = tags$div(+ checkmate::check_number(which, lower = 1) |
| 89 | +287 | ! |
- selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
+ checkmate::check_string(table_id) |
| 90 | +288 | ! |
- ui_transform_teal_data(ns("decorate"), transformators = decorators),
+ table <- rvest::html_table( |
| 91 | +289 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ self$get_html_rvest(self$active_module_element(table_id)), |
| 92 | -+ | ||
| 290 | +! |
- )+ fill = TRUE |
|
| 93 | +291 |
) |
|
| 94 | -- |
- },- |
- |
| 95 | -43x | -
- ui_args = list(decorators = decorators),- |
- |
| 96 | -43x | -
- server_args = list(decorators = decorators),- |
- |
| 97 | -43x | +||
| 292 | +! |
- datanames = datanames,+ if (length(table) == 0) {
|
|
| 98 | -43x | +||
| 293 | +! |
- transformators = transformators+ data.frame() |
|
| 99 | +294 |
- )- |
- |
| 100 | -43x | -
- attr(ans, "teal_bookmarkable") <- TRUE+ } else {
|
|
| 101 | -43x | +||
| 295 | +! |
- ans+ table[[which]] |
|
| 102 | +296 |
- }+ } |
| 1 | +297 |
- setOldClass("teal_data_module")
+ }, |
|
| 2 | +298 |
-
+ #' @description |
|
| 3 | +299 |
- #' Evaluate code on `teal_data_module`+ #' Get the output from the module's `teal.widgets::plot_with_settings` in the `teal` app. |
|
| 4 | +300 |
- #'+ #' This function will only access plots from the name space of the current active teal module. |
|
| 5 | +301 |
- #' @details+ #' |
|
| 6 | +302 |
- #' `eval_code` evaluates given code in the environment of the `teal_data` object created by the `teal_data_module`.+ #' @param plot_id (`character(1)`) The id of the plot in the active teal module's name space. |
|
| 7 | +303 |
- #' The code is added to the `@code` slot of the `teal_data`.+ #' |
|
| 8 | +304 |
- #'+ #' @return The `src` attribute as `character(1)` vector. |
|
| 9 | +305 |
- #' @param object (`teal_data_module`)- |
- |
| 10 | -- |
- #' @inheritParams teal.code::eval_code- |
- |
| 11 | -- |
- #'+ get_active_module_plot_output = function(plot_id) {
|
|
| 12 | -+ | ||
| 306 | +! |
- #' @return+ checkmate::check_string(plot_id) |
|
| 13 | -+ | ||
| 307 | +! |
- #' `eval_code` returns a `teal_data_module` object with a delayed evaluation of `code` when the module is run.+ self$get_attr( |
|
| 14 | -+ | ||
| 308 | +! |
- #'+ self$active_module_element(sprintf("%s-plot_main > img", plot_id)),
|
|
| 15 | -+ | ||
| 309 | +! |
- #' @examples+ "src" |
|
| 16 | +310 |
- #' eval_code(tdm, "dataset1 <- subset(dataset1, Species == 'virginica')")+ ) |
|
| 17 | +311 |
- #'+ }, |
|
| 18 | +312 |
- #' @include teal_data_module.R+ #' @description |
|
| 19 | +313 |
- #' @name eval_code+ #' Set the input in the module in the `teal` app. |
|
| 20 | +314 |
- #' @rdname teal_data_module+ #' This function will only set inputs in the name space of the current active teal module. |
|
| 21 | +315 |
- #' @aliases eval_code,teal_data_module,character-method+ #' |
|
| 22 | +316 |
- #' @aliases eval_code,teal_data_module,language-method+ #' @param input_id (character) The shiny input id to get the value from. |
|
| 23 | +317 |
- #' @aliases eval_code,teal_data_module,expression-method+ #' @param value The value to set the input to. |
|
| 24 | +318 |
- #'+ #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$set_inputs` |
|
| 25 | +319 |
- #' @importFrom methods setMethod+ #' |
|
| 26 | +320 |
- #' @importMethodsFrom teal.code eval_code+ #' @return The `TealAppDriver` object invisibly. |
|
| 27 | +321 |
- #'+ set_active_module_input = function(input_id, value, ...) {
|
|
| 28 | -+ | ||
| 322 | +! |
- setMethod("eval_code", signature = c("teal_data_module", "character"), function(object, code) {
+ checkmate::check_string(input_id) |
|
| 29 | -9x | +||
| 323 | +! |
- teal_data_module(+ checkmate::check_string(value) |
|
| 30 | -9x | +||
| 324 | +! |
- ui = function(id) {
+ self$set_input( |
|
| 31 | -1x | +||
| 325 | +! |
- ns <- NS(id)+ sprintf("%s-%s", self$active_module_ns(), input_id),
|
|
| 32 | -1x | +||
| 326 | +! |
- object$ui(ns("mutate_inner"))
+ value, |
|
| 33 | +327 |
- },+ ... |
|
| 34 | -9x | +||
| 328 | +
- server = function(id) {
+ ) |
||
| 35 | -7x | +||
| 329 | +! |
- moduleServer(id, function(input, output, session) {
+ dots <- rlang::list2(...) |
|
| 36 | -7x | +||
| 330 | +! |
- data <- object$server("mutate_inner")
+ if (!isFALSE(dots[["wait"]])) self$wait_for_idle() # Default behavior is to wait |
|
| 37 | -6x | +||
| 331 | +! |
- td <- eventReactive(data(),+ invisible(self) |
|
| 38 | +332 |
- {
+ }, |
|
| 39 | -6x | +||
| 333 | +
- if (inherits(data(), c("teal_data", "qenv.error"))) {
+ #' @description |
||
| 40 | -4x | +||
| 334 | +
- eval_code(data(), code)+ #' Get the active datasets that can be accessed via the filter panel of the current active teal module. |
||
| 41 | +335 |
- } else {
+ get_active_filter_vars = function() {
|
|
| 42 | -2x | +||
| 336 | +! |
- data()+ displayed_datasets_index <- self$is_visible( |
|
| 43 | -+ | ||
| 337 | +! |
- }+ sprintf("#%s-filters-filter_active_vars_contents > span", self$active_filters_ns())
|
|
| 44 | +338 |
- },- |
- |
| 45 | -6x | -
- ignoreNULL = FALSE+ ) |
|
| 46 | +339 |
- )+ |
|
| 47 | -6x | +||
| 340 | +! |
- td+ available_datasets <- self$get_text( |
|
| 48 | -+ | ||
| 341 | +! |
- })+ sprintf( |
|
| 49 | -+ | ||
| 342 | +! |
- }+ "#%s-filters-filter_active_vars_contents .filter_panel_dataname", |
|
| 50 | -+ | ||
| 343 | +! |
- )+ self$active_filters_ns() |
|
| 51 | +344 |
- })+ ) |
|
| 52 | +345 |
-
+ ) |
|
| 53 | +346 |
- setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
+
|
|
| 54 | -1x | +||
| 347 | +! |
- eval_code(object, code = paste(lang2calls(code), collapse = "\n"))+ available_datasets[displayed_datasets_index] |
|
| 55 | +348 |
- })+ }, |
|
| 56 | +349 |
-
+ #' @description |
|
| 57 | +350 |
- setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
- |
- |
| 58 | -2x | -
- eval_code(object, code = paste(lang2calls(code), collapse = "\n"))+ #' Get the active data summary table |
|
| 59 | +351 |
- })+ #' @return `data.frame` |
| 1 | +352 |
- #' Filter settings for `teal` applications+ get_active_data_summary_table = function() {
|
|
| 2 | -+ | ||
| 353 | +! |
- #'+ summary_table <- rvest::html_table( |
|
| 3 | -+ | ||
| 354 | +! |
- #' Specify initial filter states and filtering settings for a `teal` app.+ self$get_html_rvest(self$active_data_summary_element("table")),
|
|
| 4 | -+ | ||
| 355 | +! |
- #'+ fill = TRUE |
|
| 5 | -+ | ||
| 356 | +! |
- #' Produces a `teal_slices` object.+ )[[1]] |
|
| 6 | +357 |
- #' The `teal_slice` components will specify filter states that will be active when the app starts.+ |
|
| 7 | -+ | ||
| 358 | +! |
- #' Attributes (created with the named arguments) will configure the way the app applies filters.+ col_names <- unlist(summary_table[1, ], use.names = FALSE) |
|
| 8 | -+ | ||
| 359 | +! |
- #' See argument descriptions for details.+ summary_table <- summary_table[-1, ] |
|
| 9 | -+ | ||
| 360 | +! |
- #'+ colnames(summary_table) <- col_names |
|
| 10 | -+ | ||
| 361 | +! |
- #' @inheritParams teal.slice::teal_slices+ if (nrow(summary_table) > 0) {
|
|
| 11 | -+ | ||
| 362 | +! |
- #'+ summary_table |
|
| 12 | +363 |
- #' @param module_specific (`logical(1)`) optional,+ } else {
|
|
| 13 | -+ | ||
| 364 | +! |
- #' - `FALSE` (default) when one filter panel applied to all modules.+ NULL |
|
| 14 | +365 |
- #' All filters will be shared by all modules.+ } |
|
| 15 | +366 |
- #' - `TRUE` when filter panel module-specific.+ }, |
|
| 16 | +367 |
- #' Modules can have different set of filters specified - see `mapping` argument.+ #' @description |
|
| 17 | +368 |
- #' @param mapping `r lifecycle::badge("experimental")`
+ #' Test if `DOM` elements are visible on the page with a JavaScript call. |
|
| 18 | +369 |
- #' _This is a new feature. Do kindly share your opinions on+ #' @param selector (`character(1)`) `CSS` selector to check visibility. |
|
| 19 | +370 |
- #' [`teal`'s GitHub repository](https://github.com/insightsengineering/teal/)._+ #' A `CSS` id will return only one element if the UI is well formed. |
|
| 20 | +371 |
- #'+ #' @param content_visibility_auto,opacity_property,visibility_property (`logical(1)`) See more information |
|
| 21 | +372 |
- #' (named `list`) specifies which filters will be active in which modules on app start.+ #' on <https://developer.mozilla.org/en-US/docs/Web/API/Element/checkVisibility>. |
|
| 22 | +373 |
- #' Elements should contain character vector of `teal_slice` `id`s (see [`teal.slice::teal_slice`]).+ #' |
|
| 23 | +374 |
- #' Names of the list should correspond to `teal_module` `label` set in [module()] function.+ #' @return Logical vector with all occurrences of the selector. |
|
| 24 | +375 |
- #' - `id`s listed under `"global_filters` will be active in all modules.+ is_visible = function(selector, |
|
| 25 | +376 |
- #' - If missing, all filters will be applied to all modules.+ content_visibility_auto = FALSE, |
|
| 26 | +377 |
- #' - If empty list, all filters will be available to all modules but will start inactive.+ opacity_property = FALSE, |
|
| 27 | +378 |
- #' - If `module_specific` is `FALSE`, only `global_filters` will be active on start.+ visibility_property = FALSE) {
|
|
| 28 | -+ | ||
| 379 | +! |
- #' @param app_id (`character(1)`)+ checkmate::assert_string(selector) |
|
| 29 | -+ | ||
| 380 | +! |
- #' For internal use only, do not set manually.+ checkmate::assert_flag(content_visibility_auto) |
|
| 30 | -+ | ||
| 381 | +! |
- #' Added by `init` so that a `teal_slices` can be matched to the app in which it was used.+ checkmate::assert_flag(opacity_property) |
|
| 31 | -+ | ||
| 382 | +! |
- #' Used for verifying snapshots uploaded from file. See `snapshot`.+ checkmate::assert_flag(visibility_property) |
|
| 32 | +383 |
- #'+ |
|
| 33 | -+ | ||
| 384 | +! |
- #' @param x (`list`) of lists to convert to `teal_slices`+ private$wait_for_page_stability() |
|
| 34 | +385 |
- #'+ |
|
| 35 | -+ | ||
| 386 | +! |
- #' @return+ testthat::skip_if_not( |
|
| 36 | -+ | ||
| 387 | +! |
- #' A `teal_slices` object.+ self$get_js("typeof Element.prototype.checkVisibility === 'function'"),
|
|
| 37 | -+ | ||
| 388 | +! |
- #'+ "Element.prototype.checkVisibility is not supported in the current browser." |
|
| 38 | +389 |
- #' @seealso [`teal.slice::teal_slices`], [`teal.slice::teal_slice`], [slices_store()]+ ) |
|
| 39 | +390 |
- #'+ |
|
| 40 | -+ | ||
| 391 | +! |
- #' @examples+ unlist( |
|
| 41 | -+ | ||
| 392 | +! |
- #' filter <- teal_slices(+ self$get_js( |
|
| 42 | -+ | ||
| 393 | +! |
- #' teal_slice(dataname = "iris", varname = "Species", id = "species"),+ sprintf( |
|
| 43 | -+ | ||
| 394 | +! |
- #' teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),+ "Array.from(document.querySelectorAll('%s')).map(el => el.checkVisibility({%s, %s, %s}))",
|
|
| 44 | -+ | ||
| 395 | +! |
- #' teal_slice(+ selector, |
|
| 45 | +396 |
- #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"+ # Extra parameters |
|
| 46 | -+ | ||
| 397 | +! |
- #' ),+ sprintf("contentVisibilityAuto: %s", tolower(content_visibility_auto)),
|
|
| 47 | -+ | ||
| 398 | +! |
- #' teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),+ sprintf("opacityProperty: %s", tolower(opacity_property)),
|
|
| 48 | -+ | ||
| 399 | +! |
- #' mapping = list(+ sprintf("visibilityProperty: %s", tolower(visibility_property))
|
|
| 49 | +400 |
- #' module1 = c("species", "sepal_length"),
+ ) |
|
| 50 | +401 |
- #' module2 = c("mtcars_mpg"),
+ ) |
|
| 51 | +402 |
- #' global_filters = "long_petals"+ ) |
|
| 52 | +403 |
- #' )+ }, |
|
| 53 | +404 |
- #' )+ #' @description |
|
| 54 | +405 |
- #'+ #' Get the active filter variables from a dataset in the `teal` app. |
|
| 55 | +406 |
- #' app <- init(+ #' |
|
| 56 | +407 |
- #' data = teal_data(iris = iris, mtcars = mtcars),+ #' @param dataset_name (character) The name of the dataset to get the filter variables from. |
|
| 57 | +408 |
- #' modules = list(+ #' If `NULL`, the filter variables for all the datasets will be returned in a list. |
|
| 58 | +409 |
- #' module("module1"),
+ get_active_data_filters = function(dataset_name = NULL) {
|
|
| 59 | -+ | ||
| 410 | +! |
- #' module("module2")
+ checkmate::check_string(dataset_name, null.ok = TRUE) |
|
| 60 | -+ | ||
| 411 | +! |
- #' ),+ datasets <- self$get_active_filter_vars() |
|
| 61 | -+ | ||
| 412 | +! |
- #' filter = filter+ checkmate::assert_subset(dataset_name, datasets) |
|
| 62 | -+ | ||
| 413 | +! |
- #' )+ active_filters <- lapply( |
|
| 63 | -+ | ||
| 414 | +! |
- #'+ datasets, |
|
| 64 | -+ | ||
| 415 | +! |
- #' if (interactive()) {
+ function(x) {
|
|
| 65 | -+ | ||
| 416 | +! |
- #' shinyApp(app$ui, app$server)+ var_names <- gsub( |
|
| 66 | -+ | ||
| 417 | +! |
- #' }+ pattern = "\\s", |
|
| 67 | -+ | ||
| 418 | +! |
- #'+ replacement = "", |
|
| 68 | -+ | ||
| 419 | +! |
- #' @export+ self$get_text( |
|
| 69 | -+ | ||
| 420 | +! |
- teal_slices <- function(...,+ sprintf( |
|
| 70 | -+ | ||
| 421 | +! |
- exclude_varnames = NULL,+ "#%s-filters-%s .filter-card-varname", |
|
| 71 | -+ | ||
| 422 | +! |
- include_varnames = NULL,+ self$active_filters_ns(), |
|
| 72 | -+ | ||
| 423 | +! |
- count_type = NULL,+ x |
|
| 73 | +424 |
- allow_add = TRUE,+ ) |
|
| 74 | +425 |
- module_specific = FALSE,+ ) |
|
| 75 | +426 |
- mapping,+ ) |
|
| 76 | -+ | ||
| 427 | +! |
- app_id = NULL) {
+ structure( |
|
| 77 | -170x | +||
| 428 | +! |
- shiny::isolate({
+ lapply(var_names, private$get_active_filter_selection, dataset_name = x), |
|
| 78 | -170x | +||
| 429 | +! |
- checkmate::assert_flag(allow_add)+ names = var_names |
|
| 79 | -170x | +||
| 430 | +
- checkmate::assert_flag(module_specific)+ ) |
||
| 80 | -53x | +||
| 431 | +
- if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
+ } |
||
| 81 | -167x | +||
| 432 | +
- checkmate::assert_string(app_id, null.ok = TRUE)+ ) |
||
| 82 | -+ | ||
| 433 | +! |
-
+ names(active_filters) <- datasets |
|
| 83 | -167x | +||
| 434 | +! |
- slices <- list(...)+ if (is.null(dataset_name)) {
|
|
| 84 | -167x | +||
| 435 | +! |
- all_slice_id <- vapply(slices, `[[`, character(1L), "id")+ return(active_filters) |
|
| 85 | +436 |
-
+ } |
|
| 86 | -167x | +||
| 437 | +! |
- if (missing(mapping)) {
+ active_filters[[dataset_name]] |
|
| 87 | -117x | +||
| 438 | +
- mapping <- if (length(all_slice_id)) {
+ }, |
||
| 88 | -26x | +||
| 439 | +
- list(global_filters = all_slice_id)+ #' @description |
||
| 89 | +440 |
- } else {
+ #' Add a new variable from the dataset to be filtered. |
|
| 90 | -91x | +||
| 441 | +
- list()+ #' |
||
| 91 | +442 |
- }+ #' @param dataset_name (character) The name of the dataset to add the filter variable to. |
|
| 92 | +443 |
- }+ #' @param var_name (character) The name of the variable to add to the filter panel. |
|
| 93 | +444 |
-
+ #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$set_inputs` |
|
| 94 | -167x | +||
| 445 | +
- if (!module_specific) {
+ #' |
||
| 95 | -148x | +||
| 446 | +
- mapping[setdiff(names(mapping), "global_filters")] <- NULL+ #' @return The `TealAppDriver` object invisibly. |
||
| 96 | +447 |
- }+ add_filter_var = function(dataset_name, var_name, ...) {
|
|
| 97 | -+ | ||
| 448 | +! |
-
+ checkmate::check_string(dataset_name) |
|
| 98 | -167x | +||
| 449 | +! |
- failed_slice_id <- setdiff(unlist(mapping), all_slice_id)+ checkmate::check_string(var_name) |
|
| 99 | -167x | +||
| 450 | +! |
- if (length(failed_slice_id)) {
+ private$set_active_ns() |
|
| 100 | -1x | +||
| 451 | +! |
- stop(sprintf(+ self$click( |
|
| 101 | -1x | +||
| 452 | +! |
- "Filters in mapping don't match any available filter.\n %s not in %s",+ selector = sprintf( |
|
| 102 | -1x | +||
| 453 | +! |
- toString(failed_slice_id),+ "#%s-filters-%s-add_filter_icon", |
|
| 103 | -1x | +||
| 454 | +! |
- toString(all_slice_id)+ private$ns$filter_panel, |
|
| 104 | -+ | ||
| 455 | +! |
- ))+ dataset_name |
|
| 105 | +456 |
- }+ ) |
|
| 106 | +457 |
-
+ ) |
|
| 107 | -166x | +||
| 458 | +! |
- tss <- teal.slice::teal_slices(+ self$set_input( |
|
| 108 | -+ | ||
| 459 | +! |
- ...,+ sprintf( |
|
| 109 | -166x | +||
| 460 | +! |
- exclude_varnames = exclude_varnames,+ "%s-filters-%s-%s-filter-var_to_add", |
|
| 110 | -166x | +||
| 461 | +! |
- include_varnames = include_varnames,+ private$ns$filter_panel, |
|
| 111 | -166x | +||
| 462 | +! |
- count_type = count_type,+ dataset_name, |
|
| 112 | -166x | +||
| 463 | +! |
- allow_add = allow_add+ dataset_name |
|
| 113 | +464 |
- )+ ), |
|
| 114 | -166x | +||
| 465 | +! |
- attr(tss, "mapping") <- mapping+ var_name, |
|
| 115 | -166x | +||
| 466 | +
- attr(tss, "module_specific") <- module_specific+ ... |
||
| 116 | -166x | +||
| 467 | +
- attr(tss, "app_id") <- app_id+ ) |
||
| 117 | -166x | +||
| 468 | +! |
- class(tss) <- c("modules_teal_slices", class(tss))
+ invisible(self) |
|
| 118 | -166x | +||
| 469 | +
- tss+ }, |
||
| 119 | +470 |
- })+ #' @description |
|
| 120 | +471 |
- }+ #' Remove an active filter variable of a dataset from the active filter variables panel. |
|
| 121 | +472 |
-
+ #' |
|
| 122 | +473 |
-
+ #' @param dataset_name (character) The name of the dataset to remove the filter variable from. |
|
| 123 | +474 |
- #' @rdname teal_slices+ #' If `NULL`, all the filter variables will be removed. |
|
| 124 | +475 |
- #' @export+ #' @param var_name (character) The name of the variable to remove from the filter panel. |
|
| 125 | +476 |
- #' @keywords internal+ #' If `NULL`, all the filter variables of the dataset will be removed. |
|
| 126 | +477 |
- #'+ #' |
|
| 127 | +478 |
- as.teal_slices <- function(x) { # nolint: object_name.
+ #' @return The `TealAppDriver` object invisibly. |
|
| 128 | -15x | +||
| 479 | +
- checkmate::assert_list(x)+ remove_filter_var = function(dataset_name = NULL, var_name = NULL) {
|
||
| 129 | -15x | +||
| 480 | +! |
- lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")+ checkmate::check_string(dataset_name, null.ok = TRUE) |
|
| 130 | -+ | ||
| 481 | +! |
-
+ checkmate::check_string(var_name, null.ok = TRUE) |
|
| 131 | -15x | +||
| 482 | +! |
- attrs <- attributes(unclass(x))+ if (is.null(dataset_name)) {
|
|
| 132 | -15x | +||
| 483 | +! |
- ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))+ remove_selector <- sprintf( |
|
| 133 | -15x | +||
| 484 | +! |
- do.call(teal_slices, c(ans, attrs))+ "#%s-active-remove_all_filters", |
|
| 134 | -+ | ||
| 485 | +! |
- }+ self$active_filters_ns() |
|
| 135 | +486 |
-
+ ) |
|
| 136 | -+ | ||
| 487 | +! |
-
+ } else if (is.null(var_name)) {
|
|
| 137 | -+ | ||
| 488 | +! |
- #' @rdname teal_slices+ remove_selector <- sprintf( |
|
| 138 | -+ | ||
| 489 | +! |
- #' @export+ "#%s-active-%s-remove_filters", |
|
| 139 | -+ | ||
| 490 | +! |
- #' @keywords internal+ self$active_filters_ns(),+ |
+ |
| 491 | +! | +
+ dataset_name |
|
| 140 | +492 |
- #'+ ) |
|
| 141 | +493 |
- c.teal_slices <- function(...) {
+ } else {
|
|
| 142 | -6x | +||
| 494 | +! |
- x <- list(...)+ remove_selector <- sprintf( |
|
| 143 | -6x | +||
| 495 | +! |
- checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ "#%s-active-%s-filter-%s_%s-remove", |
|
| 144 | -+ | ||
| 496 | +! |
-
+ self$active_filters_ns(), |
|
| 145 | -6x | +||
| 497 | +! |
- all_attributes <- lapply(x, attributes)+ dataset_name, |
|
| 146 | -6x | +||
| 498 | +! |
- all_attributes <- coalesce_r(all_attributes)+ dataset_name, |
|
| 147 | -6x | +||
| 499 | +! |
- all_attributes <- all_attributes[names(all_attributes) != "class"]+ var_name |
|
| 148 | +500 |
-
+ ) |
|
| 149 | -6x | +||
| 501 | +
- do.call(+ } |
||
| 150 | -6x | +||
| 502 | +! |
- teal_slices,+ self$click( |
|
| 151 | -6x | +||
| 503 | +! |
- c(+ selector = remove_selector |
|
| 152 | -6x | +||
| 504 | +
- unique(unlist(x, recursive = FALSE)),+ ) |
||
| 153 | -6x | +||
| 505 | +! |
- all_attributes+ invisible(self) |
|
| 154 | +506 |
- )+ }, |
|
| 155 | +507 |
- )+ #' @description |
|
| 156 | +508 |
- }+ #' Set the active filter values for a variable of a dataset in the active filter variable panel. |
|
| 157 | +509 |
-
+ #' |
|
| 158 | +510 |
-
+ #' @param dataset_name (character) The name of the dataset to set the filter value for. |
|
| 159 | +511 |
- #' Deep copy `teal_slices`+ #' @param var_name (character) The name of the variable to set the filter value for. |
|
| 160 | +512 |
- #'+ #' @param input The value to set the filter to. |
|
| 161 | +513 |
- #' it's important to create a new copy of `teal_slices` when+ #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$set_inputs` |
|
| 162 | +514 |
- #' starting a new `shiny` session. Otherwise, object will be shared+ #' |
|
| 163 | +515 |
- #' by multiple users as it is created in global environment before+ #' @return The `TealAppDriver` object invisibly. |
|
| 164 | +516 |
- #' `shiny` session starts.+ set_active_filter_selection = function(dataset_name, |
|
| 165 | +517 |
- #' @param filter (`teal_slices`)+ var_name, |
|
| 166 | +518 |
- #' @return `teal_slices`+ input, |
|
| 167 | +519 |
- #' @keywords internal+ ...) {
|
|
| 168 | -+ | ||
| 520 | +! |
- deep_copy_filter <- function(filter) {
+ checkmate::check_string(dataset_name) |
|
| 169 | -1x | +||
| 521 | +! |
- checkmate::assert_class(filter, "teal_slices")+ checkmate::check_string(var_name) |
|
| 170 | -1x | +||
| 522 | +! |
- shiny::isolate({
+ checkmate::check_string(input) |
|
| 171 | -1x | +||
| 523 | +
- filter_copy <- lapply(filter, function(slice) {
+
|
||
| 172 | -2x | +||
| 524 | +! |
- teal.slice::as.teal_slice(as.list(slice))+ input_id_prefix <- sprintf( |
|
| 173 | -+ | ||
| 525 | +! |
- })+ "%s-filters-%s-filter-%s_%s-inputs", |
|
| 174 | -1x | +||
| 526 | +! |
- attributes(filter_copy) <- attributes(filter)+ self$active_filters_ns(), |
|
| 175 | -1x | +||
| 527 | +! |
- filter_copy+ dataset_name, |
|
| 176 | -+ | ||
| 528 | +! |
- })+ dataset_name, |
|
| 177 | -+ | ||
| 529 | +! |
- }+ var_name |
| 1 | +530 |
- #' Execute and validate `teal_data_module`+ ) |
|
| 2 | +531 |
- #'+ |
|
| 3 | +532 |
- #' This is a low level module to handle `teal_data_module` execution and validation.+ # Find the type of filter (based on filter panel) |
|
| 4 | -+ | ||
| 533 | +! |
- #' [teal_transform_module()] inherits from [teal_data_module()] so it is handled by this module too.+ supported_suffix <- c("selection", "selection_manual")
|
|
| 5 | -+ | ||
| 534 | +! |
- #' [srv_teal()] accepts various `data` objects and eventually they are all transformed to `reactive`+ slices_suffix <- supported_suffix[ |
|
| 6 | -+ | ||
| 535 | +! |
- #' [teal.data::teal_data()] which is a standard data class in whole `teal` framework.+ match( |
|
| 7 | -+ | ||
| 536 | +! |
- #'+ TRUE, |
|
| 8 | -+ | ||
| 537 | +! |
- #' @section data validation:+ vapply( |
|
| 9 | -+ | ||
| 538 | +! |
- #'+ supported_suffix, |
|
| 10 | -+ | ||
| 539 | +! |
- #' Executed [teal_data_module()] is validated and output is validated for consistency.+ function(suffix) {
|
|
| 11 | -+ | ||
| 540 | +! |
- #' Output `data` is invalid if:+ !is.null(self$get_html(sprintf("#%s-%s", input_id_prefix, suffix)))
|
|
| 12 | +541 |
- #' 1. [teal_data_module()] is invalid if server doesn't return `reactive`. **Immediately crashes an app!**+ }, |
|
| 13 | -+ | ||
| 542 | +! |
- #' 2. `reactive` throws a `shiny.error` - happens when module creating [teal.data::teal_data()] fails.+ logical(1) |
|
| 14 | +543 |
- #' 3. `reactive` returns `qenv.error` - happens when [teal.data::teal_data()] evaluates a failing code.+ ) |
|
| 15 | +544 |
- #' 4. `reactive` object doesn't return [teal.data::teal_data()].+ ) |
|
| 16 | +545 |
- #' 5. [teal.data::teal_data()] object lacks any `datanames` specified in the `modules` argument.+ ] |
|
| 17 | +546 |
- #'+ |
|
| 18 | +547 |
- #' `teal` (observers in `srv_teal`) always waits to render an app until `reactive` `teal_data` is+ # Generate correct namespace |
|
| 19 | -+ | ||
| 548 | +! |
- #' returned. If error 2-4 occurs, relevant error message is displayed to the app user. Once the issue is+ slices_input_id <- sprintf( |
|
| 20 | -+ | ||
| 549 | +! |
- #' resolved, the app will continue to run. `teal` guarantees that errors in data don't crash the app+ "%s-filters-%s-filter-%s_%s-inputs-%s", |
|
| 21 | -+ | ||
| 550 | +! |
- #' (except error 1).+ self$active_filters_ns(), |
|
| 22 | -+ | ||
| 551 | +! |
- #'+ dataset_name, |
|
| 23 | -+ | ||
| 552 | +! |
- #' @param id (`character(1)`) Module id+ dataset_name, |
|
| 24 | -+ | ||
| 553 | +! |
- #' @param data (`reactive teal_data`)+ var_name, |
|
| 25 | -+ | ||
| 554 | +! |
- #' @param data_module (`teal_data_module`)+ slices_suffix |
|
| 26 | +555 |
- #' @param modules (`teal_modules` or `teal_module`) For `datanames` validation purpose+ ) |
|
| 27 | +556 |
- #' @param validate_shiny_silent_error (`logical`) If `TRUE`, then `shiny.silent.error` is validated and+ |
|
| 28 | -+ | ||
| 557 | +! |
- #' @param is_transform_failed (`reactiveValues`) contains `logical` flags named after each transformator.+ if (identical(slices_suffix, "selection_manual")) {
|
|
| 29 | -+ | ||
| 558 | +! |
- #' Help to determine if any previous transformator failed, so that following transformators can be disabled+ checkmate::assert_numeric(input, len = 2) |
|
| 30 | +559 |
- #' and display a generic failure message.+ |
|
| 31 | -+ | ||
| 560 | +! |
- #'+ dots <- rlang::list2(...) |
|
| 32 | -+ | ||
| 561 | +! |
- #' @return `reactive` `teal_data`+ checkmate::assert_choice(dots$priority_, formals(self$set_inputs)[["priority_"]], null.ok = TRUE) |
|
| 33 | -+ | ||
| 562 | +! |
- #'+ checkmate::assert_flag(dots$wait_, null.ok = TRUE) |
|
| 34 | +563 |
- #' @rdname module_teal_data+ |
|
| 35 | -+ | ||
| 564 | +! |
- #' @name module_teal_data+ self$run_js( |
|
| 36 | -+ | ||
| 565 | +! |
- #' @keywords internal+ sprintf( |
|
| 37 | -+ | ||
| 566 | +! |
- NULL+ "Shiny.setInputValue('%s:sw.numericRange', [%f, %f], {priority: '%s'})",
|
|
| 38 | -+ | ||
| 567 | +! |
-
+ slices_input_id, |
|
| 39 | -+ | ||
| 568 | +! |
- #' @rdname module_teal_data+ input[[1]], |
|
| 40 | -+ | ||
| 569 | +! |
- #' @aliases ui_teal_data+ input[[2]],+ |
+ |
| 570 | +! | +
+ priority_ = ifelse(is.null(dots$priority_), "input", dots$priority_) |
|
| 41 | +571 |
- #' @note+ ) |
|
| 42 | +572 |
- #' `ui_teal_data_module` was renamed from `ui_teal_data`.+ ) |
|
| 43 | +573 |
- ui_teal_data_module <- function(id, data_module = function(id) NULL) {
+
|
|
| 44 | +574 | ! |
- checkmate::assert_string(id)+ if (isTRUE(dots$wait_) || is.null(dots$wait_)) {
|
| 45 | +575 | ! |
- checkmate::assert_function(data_module, args = "id")+ self$wait_for_idle( |
| 46 | +576 | ! |
- ns <- NS(id)+ timeout = if (is.null(dots$timeout_)) rlang::missing_arg() else dots$timeout_ |
| 47 | +577 |
-
+ )+ |
+ |
| 578 | ++ |
+ } |
|
| 48 | +579 | ! |
- shiny::tagList(+ } else if (identical(slices_suffix, "selection")) {
|
| 49 | +580 | ! |
- tags$div(id = ns("wrapper"), data_module(id = ns("data"))),
+ self$set_input( |
| 50 | +581 | ! |
- ui_validate_reactive_teal_data(ns("validate"))
+ slices_input_id,+ |
+
| 582 | +! | +
+ input, |
|
| 51 | +583 |
- )+ ... |
|
| 52 | +584 |
- }+ ) |
|
| 53 | +585 |
-
+ } else {
+ |
+ |
| 586 | +! | +
+ stop("Filter selection set not supported for this slice.")
|
|
| 54 | +587 |
- #' @rdname module_teal_data+ } |
|
| 55 | +588 |
- #' @aliases srv_teal_data+ + |
+ |
| 589 | +! | +
+ invisible(self) |
|
| 56 | +590 |
- #' @note+ }, |
|
| 57 | +591 |
- #' `srv_teal_data_module` was renamed from `srv_teal_data`.+ #' @description |
|
| 58 | +592 |
- srv_teal_data_module <- function(id,+ #' Extract `html` attribute (found by a `selector`). |
|
| 59 | +593 |
- data_module = function(id) NULL,+ #' |
|
| 60 | +594 |
- modules = NULL,+ #' @param selector (`character(1)`) specifying the selector to be used to get the content of a specific node. |
|
| 61 | +595 |
- validate_shiny_silent_error = TRUE,+ #' @param attribute (`character(1)`) name of an attribute to retrieve from a node specified by `selector`. |
|
| 62 | +596 |
- is_transform_failed = reactiveValues()) {
+ #' |
|
| 63 | -! | +||
| 597 | +
- checkmate::assert_string(id)+ #' @return The `character` vector.+ |
+ ||
| 598 | ++ |
+ get_attr = function(selector, attribute) {
|
|
| 64 | +599 | ! |
- checkmate::assert_function(data_module, args = "id")+ rvest::html_attr( |
| 65 | +600 | ! |
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
+ rvest::html_nodes(self$get_html_rvest("html"), selector),
|
| 66 | +601 | ! |
- checkmate::assert_class(is_transform_failed, "reactivevalues")+ attribute |
| 67 | +602 | - - | -|
| 68 | -! | -
- moduleServer(id, function(input, output, session) {
+ ) |
|
| 69 | -! | +||
| 603 | +
- logger::log_debug("srv_teal_data_module initializing.")
+ }, |
||
| 70 | -! | +||
| 604 | +
- is_transform_failed[[id]] <- FALSE+ #' @description |
||
| 71 | -! | +||
| 605 | +
- module_out <- data_module(id = "data")+ #' Wrapper around `get_html` that passes the output directly to `rvest::read_html`. |
||
| 72 | -! | +||
| 606 | +
- try_module_out <- reactive(tryCatch(module_out(), error = function(e) e))+ #' |
||
| 73 | -! | +||
| 607 | +
- observeEvent(try_module_out(), {
+ #' @param selector `(character(1))` passed to `get_html`. |
||
| 74 | -! | +||
| 608 | +
- if (!inherits(try_module_out(), "teal_data")) {
+ #' |
||
| 75 | -! | +||
| 609 | +
- is_transform_failed[[id]] <- TRUE+ #' @return An XML document. |
||
| 76 | +610 |
- } else {
+ get_html_rvest = function(selector) {
|
|
| 77 | +611 | ! |
- is_transform_failed[[id]] <- FALSE+ rvest::read_html(self$get_html(selector)) |
| 78 | +612 |
- }+ }, |
|
| 79 | +613 |
- })+ #' Wrapper around `get_url()` method that opens the app in the browser. |
|
| 80 | +614 |
-
+ #' |
|
| 81 | -! | +||
| 615 | +
- is_previous_failed <- reactive({
+ #' @return Nothing. Opens the underlying teal app in the browser. |
||
| 82 | -! | +||
| 616 | +
- idx_this <- which(names(is_transform_failed) == id)+ open_url = function() {
|
||
| 83 | +617 | ! |
- is_transform_failed_list <- reactiveValuesToList(is_transform_failed)+ browseURL(self$get_url()) |
| 84 | -! | +||
| 618 | +
- idx_failures <- which(unlist(is_transform_failed_list))+ }, |
||
| 85 | -! | +||
| 619 | +
- any(idx_failures < idx_this)+ #' @description |
||
| 86 | +620 |
- })+ #' Waits until a specified input, output, or export value. |
|
| 87 | +621 |
-
+ #' This function serves as a wrapper around the `wait_for_value` method, |
|
| 88 | -! | +||
| 622 | +
- observeEvent(is_previous_failed(), {
+ #' providing a more flexible interface for waiting on different types of values within the active module namespace. |
||
| 89 | -! | +||
| 623 | +
- if (is_previous_failed()) {
+ #' @param input,output,export A name of an input, output, or export value. |
||
| 90 | -! | +||
| 624 | +
- shinyjs::disable("wrapper")
+ #' Only one of these parameters may be used. |
||
| 91 | +625 |
- } else {
+ #' @param ... Must be empty. Allows for parameter expansion. |
|
| 92 | -! | +||
| 626 | +
- shinyjs::enable("wrapper")
+ #' Parameter with additional value to passed in `wait_for_value`. |
||
| 93 | +627 |
- }+ wait_for_active_module_value = function(input = rlang::missing_arg(), |
|
| 94 | +628 |
- })+ output = rlang::missing_arg(), |
|
| 95 | +629 |
-
+ export = rlang::missing_arg(), |
|
| 96 | -! | +||
| 630 | +
- srv_validate_reactive_teal_data(+ ...) {
|
||
| 97 | +631 | ! |
- "validate",+ ns <- shiny::NS(self$active_module_ns()) |
| 98 | -! | +||
| 632 | +
- data = try_module_out,+ |
||
| 99 | +633 | ! |
- modules = modules,+ if (!rlang::is_missing(input) && checkmate::test_string(input, min.chars = 1)) input <- ns(input) |
| 100 | +634 | ! |
- validate_shiny_silent_error = validate_shiny_silent_error,+ if (!rlang::is_missing(output) && checkmate::test_string(output, min.chars = 1)) output <- ns(output) |
| 101 | +635 | ! |
- hide_validation_error = is_previous_failed- |
-
| 102 | -- |
- )- |
- |
| 103 | -- |
- })- |
- |
| 104 | -- |
- }+ if (!rlang::is_missing(export) && checkmate::test_string(export, min.chars = 1)) export <- ns(export) |
|
| 105 | +636 | ||
| 106 | -- |
- #' @rdname module_teal_data- |
- |
| 107 | -- |
- ui_validate_reactive_teal_data <- function(id) {
- |
- |
| 108 | +637 | ! |
- ns <- NS(id)+ self$wait_for_value( |
| 109 | +638 | ! |
- tagList(+ input = input, |
| 110 | +639 | ! |
- div(+ output = output, |
| 111 | +640 | ! |
- id = ns("validate_messages"),
+ export = export, |
| 112 | -! | +||
| 641 | +
- class = "teal_validated",+ ... |
||
| 113 | -! | +||
| 642 | +
- ui_validate_error(ns("silent_error")),
+ ) |
||
| 114 | -! | +||
| 643 | +
- ui_check_class_teal_data(ns("class_teal_data")),
+ } |
||
| 115 | -! | +||
| 644 | +
- ui_check_module_datanames(ns("shiny_warnings"))
+ ), |
||
| 116 | +645 |
- ),+ # private members ---- |
|
| 117 | -! | +||
| 646 | +
- div(+ private = list( |
||
| 118 | -! | +||
| 647 | +
- class = "teal_validated",+ # private attributes ---- |
||
| 119 | -! | +||
| 648 | +
- uiOutput(ns("previous_failed"))
+ data = NULL, |
||
| 120 | +649 |
- )+ modules = NULL, |
|
| 121 | +650 |
- )+ filter = teal_slices(), |
|
| 122 | +651 |
- }+ ns = list( |
|
| 123 | +652 |
-
+ module = character(0), |
|
| 124 | +653 |
- #' @rdname module_teal_data+ filter_panel = character(0) |
|
| 125 | +654 |
- srv_validate_reactive_teal_data <- function(id, # nolint: object_length+ ), |
|
| 126 | +655 |
- data,+ # private methods ---- |
|
| 127 | +656 |
- modules = NULL,+ set_active_ns = function() {
|
|
| 128 | -+ | ||
| 657 | +! |
- validate_shiny_silent_error = FALSE,+ all_inputs <- self$get_values()$input+ |
+ |
| 658 | +! | +
+ active_tab_inputs <- all_inputs[grepl("-active_tab$", names(all_inputs))]
|
|
| 129 | +659 |
- hide_validation_error = reactive(FALSE)) {
+
|
|
| 130 | +660 | ! |
- checkmate::assert_string(id)+ tab_ns <- unlist(lapply(names(active_tab_inputs), function(name) {
|
| 131 | +661 | ! |
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"), null.ok = TRUE)
+ gsub( |
| 132 | +662 | ! |
- checkmate::assert_flag(validate_shiny_silent_error)+ pattern = "-active_tab$", |
| 133 | -+ | ||
| 663 | +! |
-
+ replacement = sprintf("-%s", active_tab_inputs[[name]]),
|
|
| 134 | +664 | ! |
- moduleServer(id, function(input, output, session) {
+ name |
| 135 | +665 |
- # there is an empty reactive cycle on `init` and `data` has `shiny.silent.error` class+ )+ |
+ |
| 666 | ++ |
+ })) |
|
| 136 | +667 | ! |
- srv_validate_error("silent_error", data, validate_shiny_silent_error)
+ active_ns <- tab_ns[1] |
| 137 | +668 | ! |
- srv_check_class_teal_data("class_teal_data", data)
+ if (length(tab_ns) > 1) {
|
| 138 | +669 | ! |
- srv_check_module_datanames("shiny_warnings", data, modules)
+ for (i in 2:length(tab_ns)) {
|
| 139 | +670 | ! |
- output$previous_failed <- renderUI({
+ next_ns <- tab_ns[i] |
| 140 | +671 | ! |
- if (hide_validation_error()) {
+ if (grepl(pattern = active_ns, next_ns)) {
|
| 141 | +672 | ! |
- shinyjs::hide("validate_messages")
+ active_ns <- next_ns+ |
+
| 673 | ++ |
+ }+ |
+ |
| 674 | ++ |
+ }+ |
+ |
| 675 | ++ |
+ } |
|
| 142 | +676 | ! |
- tags$div("One of previous transformators failed. Please check its inputs.", class = "teal-output-warning")
+ private$ns$module <- sprintf("%s-%s", active_ns, "module")
|
| 143 | +677 |
- } else {
+
|
|
| 144 | +678 | ! |
- shinyjs::show("validate_messages")
+ components <- c("filter_panel", "data_summary")
|
| 145 | +679 | ! |
- NULL+ for (component in components) {
|
| 146 | +680 |
- }+ if (+ |
+ |
| 681 | +! | +
+ !is.null(self$get_html(sprintf("#%s-%s-panel", active_ns, component))) ||
+ |
+ |
| 682 | +! | +
+ !is.null(self$get_html(sprintf("#%s-%s-table", active_ns, component)))
|
|
| 147 | +683 |
- })+ ) {
+ |
+ |
| 684 | +! | +
+ private$ns[[component]] <- sprintf("%s-%s", active_ns, component)
|
|
| 148 | +685 |
-
+ } else {
|
|
| 149 | +686 | ! |
- .trigger_on_success(data)+ private$ns[[component]] <- sprintf("%s-module_%s", active_ns, component)
|
| 150 | +687 |
- })+ } |
|
| 151 | +688 |
- }+ } |
|
| 152 | +689 |
-
+ }, |
|
| 153 | +690 |
- #' @keywords internal+ # @description |
|
| 154 | +691 |
- ui_validate_error <- function(id) {
+ # Get the active filter values from the active filter selection of dataset from the filter panel. |
|
| 155 | -116x | +||
| 692 | +
- ns <- NS(id)+ # |
||
| 156 | -116x | +||
| 693 | +
- uiOutput(ns("message"))
+ # @param dataset_name (character) The name of the dataset to get the filter values from. |
||
| 157 | +694 |
- }+ # @param var_name (character) The name of the variable to get the filter values from. |
|
| 158 | +695 |
-
+ # |
|
| 159 | +696 |
- #' @keywords internal+ # @return The value of the active filter selection. |
|
| 160 | +697 |
- srv_validate_error <- function(id, data, validate_shiny_silent_error) {
+ get_active_filter_selection = function(dataset_name, var_name) {
|
|
| 161 | -113x | +||
| 698 | +! |
- checkmate::assert_string(id)+ checkmate::check_string(dataset_name) |
|
| 162 | -113x | +||
| 699 | +! |
- checkmate::assert_flag(validate_shiny_silent_error)+ checkmate::check_string(var_name) |
|
| 163 | -113x | +||
| 700 | +! |
- moduleServer(id, function(input, output, session) {
+ input_id_prefix <- sprintf( |
|
| 164 | -113x | +||
| 701 | +! |
- output$message <- renderUI({
+ "%s-filters-%s-filter-%s_%s-inputs", |
|
| 165 | -112x | +||
| 702 | +! |
- is_shiny_silent_error <- inherits(data(), "shiny.silent.error") && identical(data()$message, "")+ self$active_filters_ns(), |
|
| 166 | -112x | +||
| 703 | +! |
- if (inherits(data(), "qenv.error")) {
+ dataset_name, |
|
| 167 | -2x | +||
| 704 | +! |
- validate(+ dataset_name, |
|
| 168 | -2x | +||
| 705 | +! |
- need(+ var_name |
|
| 169 | -2x | +||
| 706 | +
- FALSE,+ ) |
||
| 170 | -2x | +||
| 707 | +
- paste(+ |
||
| 171 | -2x | +||
| 708 | +
- "Error when executing the `data` module:",+ # Find the type of filter (categorical or range) |
||
| 172 | -2x | +||
| 709 | +! |
- cli::ansi_strip(paste(data()$message, collapse = "\n")),+ supported_suffix <- c("selection", "selection_manual")
|
|
| 173 | -2x | +||
| 710 | +! |
- "\nCheck your inputs or contact app developer if error persists.",+ for (suffix in supported_suffix) {
|
|
| 174 | -2x | +||
| 711 | +! |
- collapse = "\n"+ if (!is.null(self$get_html(sprintf("#%s-%s", input_id_prefix, suffix)))) {
|
|
| 175 | -+ | ||
| 712 | +! |
- )+ return(self$get_value(input = sprintf("%s-%s", input_id_prefix, suffix)))
|
|
| 176 | +713 |
- )+ } |
|
| 177 | +714 |
- )- |
- |
| 178 | -110x | -
- } else if (inherits(data(), "error")) {
- |
- |
| 179 | -11x | -
- if (is_shiny_silent_error && !validate_shiny_silent_error) {
- |
- |
| 180 | -4x | -
- return(NULL)+ } |
|
| 181 | +715 |
- }- |
- |
| 182 | -7x | -
- validate(- |
- |
| 183 | -7x | -
- need(- |
- |
| 184 | -7x | -
- FALSE,- |
- |
| 185 | -7x | -
- sprintf(- |
- |
| 186 | -7x | -
- "Shiny error when executing the `data` module.\n%s\n%s",- |
- |
| 187 | -7x | -
- data()$message,+ |
|
| 188 | -7x | +||
| 716 | +! |
- "Check your inputs or contact app developer if error persists."+ NULL # If there are not any supported filters |
|
| 189 | +717 |
- )+ }, |
|
| 190 | +718 |
- )+ # @description |
|
| 191 | +719 |
- )+ # Check if the page is stable without any `DOM` updates in the body of the app. |
|
| 192 | +720 |
- }+ # This is achieved by blocing the R process by sleeping until the page is unchanged till the `stability_period`. |
|
| 193 | +721 |
- })+ # @param stability_period (`numeric(1)`) The time in milliseconds to wait till the page to be stable. |
|
| 194 | +722 |
- })+ # @param check_interval (`numeric(1)`) The time in milliseconds to check for changes in the page. |
|
| 195 | +723 |
- }+ # The stability check is reset when a change is detected in the page after sleeping for check_interval. |
|
| 196 | +724 |
-
+ wait_for_page_stability = function(stability_period = 2000, check_interval = 200) {
|
|
| 197 | -+ | ||
| 725 | +! |
-
+ previous_content <- self$get_html("body")
|
|
| 198 | -+ | ||
| 726 | +! |
- #' @keywords internal+ end_time <- Sys.time() + (stability_period / 1000) |
|
| 199 | +727 |
- ui_check_class_teal_data <- function(id) {
+
|
|
| 200 | -116x | +||
| 728 | +! |
- ns <- NS(id)+ repeat {
|
|
| 201 | -116x | +||
| 729 | +! |
- uiOutput(ns("message"))
+ Sys.sleep(check_interval / 1000) |
|
| 202 | -+ | ||
| 730 | +! |
- }+ current_content <- self$get_html("body")
|
|
| 203 | +731 | ||
| 204 | -- |
- #' @keywords internal- |
- |
| 205 | -- |
- srv_check_class_teal_data <- function(id, data) {
- |
- |
| 206 | -113x | -
- checkmate::assert_string(id)- |
- |
| 207 | -113x | -
- moduleServer(id, function(input, output, session) {
- |
- |
| 208 | -113x | +||
| 732 | +! |
- output$message <- renderUI({
+ if (!identical(previous_content, current_content)) {
|
|
| 209 | -112x | +||
| 733 | +! |
- validate(+ previous_content <- current_content |
|
| 210 | -112x | +||
| 734 | +! |
- need(+ end_time <- Sys.time() + (stability_period / 1000) |
|
| 211 | -112x | +||
| 735 | +! |
- inherits(data(), c("teal_data", "error")),
+ } else if (Sys.time() >= end_time) {
|
|
| 212 | -112x | +||
| 736 | +! |
- "Did not receive `teal_data` object. Cannot proceed further."+ break |
|
| 213 | +737 |
- )+ } |
|
| 214 | +738 |
- )+ } |
|
| 215 | +739 |
- })+ } |
|
| 216 | +740 |
- })+ ) |
|
| 217 | +741 |
- }+ ) |
| 218 | +1 |
-
+ #' Validate that dataset has a minimum number of observations |
|
| 219 | +2 |
- #' @keywords internal+ #' |
|
| 220 | +3 |
- ui_check_module_datanames <- function(id) {
- |
- |
| 221 | -116x | -
- ns <- NS(id)- |
- |
| 222 | -116x | -
- uiOutput(NS(id, "message"))+ #' `r lifecycle::badge("stable")`
|
|
| 223 | +4 |
- }+ #' |
|
| 224 | +5 |
-
+ #' This function is a wrapper for `shiny::validate`. |
|
| 225 | +6 |
- #' @keywords internal+ #' |
|
| 226 | +7 |
- srv_check_module_datanames <- function(id, data, modules) {
- |
- |
| 227 | -193x | -
- checkmate::assert_string(id)- |
- |
| 228 | -193x | -
- moduleServer(id, function(input, output, session) {
- |
- |
| 229 | -193x | -
- output$message <- renderUI({
- |
- |
| 230 | -196x | -
- if (inherits(data(), "teal_data")) {
- |
- |
| 231 | -179x | -
- is_modules_ok <- check_modules_datanames_html(+ #' @param x (`data.frame`) |
|
| 232 | -179x | +||
| 8 | +
- modules = modules, datanames = names(data())+ #' @param min_nrow (`numeric(1)`) Minimum allowed number of rows in `x`. |
||
| 233 | +9 |
- )+ #' @param complete (`logical(1)`) Flag specifying whether to check only complete cases. Defaults to `FALSE`. |
|
| 234 | -179x | +||
| 10 | +
- if (!isTRUE(is_modules_ok)) {
+ #' @param allow_inf (`logical(1)`) Flag specifying whether to allow infinite values. Defaults to `TRUE`. |
||
| 235 | -19x | +||
| 11 | +
- tags$div(is_modules_ok, class = "teal-output-warning")+ #' @param msg (`character(1)`) Additional message to display alongside the default message. |
||
| 236 | +12 |
- }+ #' |
|
| 237 | +13 |
- }+ #' @export |
|
| 238 | +14 |
- })+ #' |
|
| 239 | +15 |
- })+ #' @examples |
|
| 240 | +16 |
- }+ #' library(teal) |
|
| 241 | +17 |
-
+ #' ui <- fluidPage( |
|
| 242 | +18 |
- .trigger_on_success <- function(data) {
+ #' sliderInput("len", "Max Length of Sepal",
|
|
| 243 | -113x | +||
| 19 | +
- out <- reactiveVal(NULL)+ #' min = 4.3, max = 7.9, value = 5 |
||
| 244 | -113x | +||
| 20 | +
- observeEvent(data(), {
+ #' ), |
||
| 245 | -112x | +||
| 21 | +
- if (inherits(data(), "teal_data")) {
+ #' plotOutput("plot")
|
||
| 246 | -97x | +||
| 22 | +
- if (!identical(data(), out())) {
+ #' ) |
||
| 247 | -97x | +||
| 23 | +
- out(data())+ #' |
||
| 248 | +24 |
- }+ #' server <- function(input, output) {
|
|
| 249 | +25 |
- }+ #' output$plot <- renderPlot({
|
|
| 250 | +26 |
- })+ #' iris_df <- iris[iris$Sepal.Length <= input$len, ] |
|
| 251 | +27 |
-
+ #' validate_has_data( |
|
| 252 | -113x | +||
| 28 | +
- out+ #' iris_df, |
||
| 253 | +29 |
- }+ #' min_nrow = 10, |
| 1 | +30 |
- #' App state management.+ #' complete = FALSE, |
|
| 2 | +31 |
- #'+ #' msg = "Please adjust Max Length of Sepal" |
|
| 3 | +32 |
- #' @description+ #' ) |
|
| 4 | +33 |
- #' `r lifecycle::badge("experimental")`
+ #' |
|
| 5 | +34 |
- #'+ #' hist(iris_df$Sepal.Length, breaks = 5) |
|
| 6 | +35 |
- #' Capture and restore the global (app) input state.+ #' }) |
|
| 7 | +36 |
- #'+ #' } |
|
| 8 | +37 |
- #' @details+ #' if (interactive()) {
|
|
| 9 | +38 |
- #' This module introduces bookmarks into `teal` apps: the `shiny` bookmarking mechanism becomes enabled+ #' shinyApp(ui, server) |
|
| 10 | +39 |
- #' and server-side bookmarks can be created.+ #' } |
|
| 11 | +40 |
#' |
|
| 12 | +41 |
- #' The bookmark manager presents a button with the bookmark icon and is placed in the tab-bar.+ validate_has_data <- function(x, |
|
| 13 | +42 |
- #' When clicked, the button creates a bookmark and opens a modal which displays the bookmark URL.+ min_nrow = NULL, |
|
| 14 | +43 |
- #'+ complete = FALSE, |
|
| 15 | +44 |
- #' `teal` does not guarantee that all modules (`teal_module` objects) are bookmarkable.+ allow_inf = TRUE, |
|
| 16 | +45 |
- #' Those that are, have a `teal_bookmarkable` attribute set to `TRUE`. If any modules are not bookmarkable,+ msg = NULL) {
+ |
+ |
| 46 | +17x | +
+ checkmate::assert_string(msg, null.ok = TRUE)+ |
+ |
| 47 | +15x | +
+ checkmate::assert_data_frame(x)+ |
+ |
| 48 | +15x | +
+ if (!is.null(min_nrow)) {
+ |
+ |
| 49 | +15x | +
+ if (complete) {
+ |
+ |
| 50 | +5x | +
+ complete_index <- stats::complete.cases(x)+ |
+ |
| 51 | +5x | +
+ validate(need(+ |
+ |
| 52 | +5x | +
+ sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,+ |
+ |
| 53 | +5x | +
+ paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
|
|
| 17 | +54 |
- #' the bookmark manager modal displays a warning and the bookmark button displays a flag.+ )) |
|
| 18 | +55 |
- #' In order to communicate that a external module is bookmarkable, the module developer+ } else {
+ |
+ |
| 56 | +10x | +
+ validate(need(+ |
+ |
| 57 | +10x | +
+ nrow(x) >= min_nrow,+ |
+ |
| 58 | +10x | +
+ paste(+ |
+ |
| 59 | +10x | +
+ c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
+ |
+ |
| 60 | +10x | +
+ collapse = "\n" |
|
| 19 | +61 |
- #' should set the `teal_bookmarkable` attribute to `TRUE`.+ ) |
|
| 20 | +62 |
- #'+ )) |
|
| 21 | +63 |
- #' @section Server logic:+ } |
|
| 22 | +64 |
- #' A bookmark is a URL that contains the app address with a `/?_state_id_=<bookmark_dir>` suffix.+ + |
+ |
| 65 | +10x | +
+ if (!allow_inf) {
+ |
+ |
| 66 | +6x | +
+ validate(need(+ |
+ |
| 67 | +6x | +
+ all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))),+ |
+ |
| 68 | +6x | +
+ "Dataframe contains Inf values which is not allowed." |
|
| 23 | +69 |
- #' `<bookmark_dir>` is a directory created on the server, where the state of the application is saved.+ )) |
|
| 24 | +70 |
- #' Accessing the bookmark URL opens a new session of the app that starts in the previously saved state.+ } |
|
| 25 | +71 |
- #'+ } |
|
| 26 | +72 |
- #' @section Note:+ } |
|
| 27 | +73 |
- #' To enable bookmarking use either:+ |
|
| 28 | +74 |
- #' - `shiny` app by using `shinyApp(..., enableBookmarking = "server")` (not supported in `shinytest2`)+ #' Validate that dataset has unique rows for key variables |
|
| 29 | +75 |
- #' - set `options(shiny.bookmarkStore = "server")` before running the app+ #' |
|
| 30 | +76 |
- #'+ #' `r lifecycle::badge("stable")`
|
|
| 31 | +77 |
#' |
|
| 32 | +78 |
- #' @inheritParams init+ #' This function is a wrapper for `shiny::validate`. |
|
| 33 | +79 |
#' |
|
| 34 | +80 |
- #' @return Invisible `NULL`.+ #' @param x (`data.frame`) |
|
| 35 | +81 | ++ |
+ #' @param key (`character`) Vector of ID variables from `x` that identify unique records.+ |
+
| 82 |
#' |
||
| 36 | +83 |
- #' @aliases bookmark bookmark_manager bookmark_manager_module+ #' @export |
|
| 37 | +84 |
#' |
|
| 38 | +85 |
- #' @name module_bookmark_manager+ #' @examples |
|
| 39 | +86 |
- #' @rdname module_bookmark_manager+ #' iris$id <- rep(1:50, times = 3) |
|
| 40 | +87 |
- #'+ #' ui <- fluidPage( |
|
| 41 | +88 |
- #' @keywords internal+ #' selectInput( |
|
| 42 | +89 |
- #'+ #' inputId = "species", |
|
| 43 | +90 |
- NULL+ #' label = "Select species", |
|
| 44 | +91 |
-
+ #' choices = c("setosa", "versicolor", "virginica"),
|
|
| 45 | +92 |
- #' @rdname module_bookmark_manager+ #' selected = "setosa", |
|
| 46 | +93 |
- ui_bookmark_panel <- function(id, modules) {
+ #' multiple = TRUE |
|
| 47 | -! | +||
| 94 | +
- ns <- NS(id)+ #' ), |
||
| 48 | +95 |
-
+ #' plotOutput("plot")
|
|
| 49 | -! | +||
| 96 | +
- bookmark_option <- get_bookmarking_option()+ #' ) |
||
| 50 | -! | +||
| 97 | +
- is_unbookmarkable <- need_bookmarking(modules)+ #' server <- function(input, output) {
|
||
| 51 | -! | +||
| 98 | +
- shinyOptions(bookmarkStore = bookmark_option)+ #' output$plot <- renderPlot({
|
||
| 52 | +99 |
-
+ #' iris_f <- iris[iris$Species %in% input$species, ] |
|
| 53 | +100 |
- # Render bookmark warnings count+ #' validate_one_row_per_id(iris_f, key = c("id"))
|
|
| 54 | -! | +||
| 101 | +
- if (!all(is_unbookmarkable) && identical(bookmark_option, "server")) {
+ #' |
||
| 55 | -! | +||
| 102 | +
- tags$button(+ #' hist(iris_f$Sepal.Length, breaks = 5) |
||
| 56 | -! | +||
| 103 | +
- id = ns("do_bookmark"),
+ #' }) |
||
| 57 | -! | +||
| 104 | +
- class = "btn action-button wunder_bar_button bookmark_manager_button",+ #' } |
||
| 58 | -! | +||
| 105 | +
- title = "Add bookmark",+ #' if (interactive()) {
|
||
| 59 | -! | +||
| 106 | +
- tags$span(+ #' shinyApp(ui, server) |
||
| 60 | -! | +||
| 107 | +
- suppressMessages(icon("fas fa-bookmark")),
+ #' } |
||
| 61 | -! | +||
| 108 | +
- if (any(is_unbookmarkable)) {
+ #' |
||
| 62 | -! | +||
| 109 | +
- tags$span(+ validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
|
||
| 63 | +110 | ! |
- sum(is_unbookmarkable),+ validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
|
| 64 | -! | +||
| 111 | +
- class = "badge-warning badge-count text-white bg-danger"+ } |
||
| 65 | +112 |
- )+ |
|
| 66 | +113 |
- }+ #' Validates that vector includes all expected values |
|
| 67 | +114 |
- )+ #' |
|
| 68 | +115 |
- )+ #' `r lifecycle::badge("stable")`
|
|
| 69 | +116 |
- }+ #' |
|
| 70 | +117 |
- }+ #' This function is a wrapper for `shiny::validate`. |
|
| 71 | +118 |
-
+ #' |
|
| 72 | +119 |
- #' @rdname module_bookmark_manager+ #' @param x Vector of values to test. |
|
| 73 | +120 |
- srv_bookmark_panel <- function(id, modules) {
+ #' @param choices Vector to test against. |
|
| 74 | -87x | +||
| 121 | +
- checkmate::assert_character(id)+ #' @param msg (`character(1)`) Error message to display if some elements of `x` are not elements of `choices`. |
||
| 75 | -87x | +||
| 122 | +
- checkmate::assert_class(modules, "teal_modules")+ #' |
||
| 76 | -87x | +||
| 123 | +
- moduleServer(id, function(input, output, session) {
+ #' @export |
||
| 77 | -87x | +||
| 124 | +
- logger::log_debug("bookmark_manager_srv initializing")
+ #' |
||
| 78 | -87x | +||
| 125 | +
- ns <- session$ns+ #' @examples |
||
| 79 | -87x | +||
| 126 | +
- bookmark_option <- get_bookmarking_option()+ #' ui <- fluidPage( |
||
| 80 | -87x | +||
| 127 | +
- is_unbookmarkable <- need_bookmarking(modules)+ #' selectInput( |
||
| 81 | +128 |
-
+ #' "species", |
|
| 82 | +129 |
- # Set up bookmarking callbacks ----+ #' "Select species", |
|
| 83 | +130 |
- # Register bookmark exclusions: do_bookmark button to avoid re-bookmarking+ #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
|
|
| 84 | -87x | +||
| 131 | +
- setBookmarkExclude(c("do_bookmark"))
+ #' selected = "setosa", |
||
| 85 | +132 |
- # This bookmark can only be used on the app session.+ #' multiple = FALSE |
|
| 86 | -87x | +||
| 133 | +
- app_session <- .subset2(session, "parent")+ #' ), |
||
| 87 | -87x | +||
| 134 | +
- app_session$onBookmarked(function(url) {
+ #' verbatimTextOutput("summary")
|
||
| 88 | -! | +||
| 135 | +
- logger::log_debug("bookmark_manager_srv@onBookmarked: bookmark button clicked, registering bookmark")
- |
- ||
| 89 | -! | -
- modal_content <- if (bookmark_option != "server") {
- |
- |
| 90 | -! | -
- msg <- sprintf(- |
- |
| 91 | -! | -
- "Bookmarking has been set to \"%s\".\n%s\n%s",- |
- |
| 92 | -! | -
- bookmark_option,- |
- |
| 93 | -! | -
- "Only server-side bookmarking is supported.",- |
- |
| 94 | -! | -
- "Please contact your app developer."- |
- |
| 95 | -- |
- )- |
- |
| 96 | -! | -
- tags$div(- |
- |
| 97 | -! | -
- tags$p(msg, class = "text-warning")- |
- |
| 98 | -- |
- )- |
- |
| 99 | -- |
- } else {
- |
- |
| 100 | -! | -
- tags$div(- |
- |
| 101 | -! | -
- tags$span(- |
- |
| 102 | -! | -
- tags$pre(url)- |
- |
| 103 | -- |
- ),- |
- |
| 104 | -! | -
- if (any(is_unbookmarkable)) {
- |
- |
| 105 | -! | -
- bkmb_summary <- rapply2(- |
- |
| 106 | -! | -
- modules_bookmarkable(modules),- |
- |
| 107 | -! | -
- function(x) {
- |
- |
| 108 | -! | -
- if (isTRUE(x)) {
- |
- |
| 109 | -! | -
- "\u2705" # check mark- |
- |
| 110 | -! | -
- } else if (isFALSE(x)) {
- |
- |
| 111 | -! | -
- "\u274C" # cross mark- |
- |
| 112 | -- |
- } else {
- |
- |
| 113 | -! | -
- "\u2753" # question mark- |
- |
| 114 | -- |
- }- |
- |
| 115 | -- |
- }- |
- |
| 116 | -- |
- )- |
- |
| 117 | -! | -
- tags$div(- |
- |
| 118 | -! | -
- tags$p(- |
- |
| 119 | -! | -
- icon("fas fa-exclamation-triangle"),
- |
- |
| 120 | -! | -
- "Some modules will not be restored when using this bookmark.",- |
- |
| 121 | -! | -
- tags$br(),- |
- |
| 122 | -! | -
- "Check the list below to see which modules are not bookmarkable.",- |
- |
| 123 | -! | -
- class = "text-warning"- |
- |
| 124 | -- |
- ),- |
- |
| 125 | -! | -
- tags$pre(yaml::as.yaml(bkmb_summary))+ #' ) |
|
| 126 | -- |
- )- |
- |
| 127 | -- |
- }- |
- |
| 128 | -- |
- )- |
- |
| 129 | -- |
- }- |
- |
| 130 | -- | - - | -|
| 131 | -! | -
- showModal(- |
- |
| 132 | -! | -
- modalDialog(- |
- |
| 133 | -! | -
- id = ns("bookmark_modal"),
- |
- |
| 134 | -! | -
- title = "Bookmarked teal app url",- |
- |
| 135 | -! | -
- modal_content,- |
- |
| 136 | -! | +
- easyClose = TRUE+ #' |
|
| 137 |
- )+ #' server <- function(input, output) {
|
||
| 138 |
- )+ #' output$summary <- renderPrint({
|
||
| 139 |
- })+ #' validate_in(input$species, iris$Species, "Species does not exist.") |
||
| 140 |
-
+ #' nrow(iris[iris$Species == input$species, ]) |
||
| 141 |
- # manually trigger bookmarking because of the problems reported on windows with bookmarkButton in teal+ #' }) |
||
| 142 | -87x | +
- observeEvent(input$do_bookmark, {
+ #' } |
|
| 143 | -! | +
- logger::log_debug("bookmark_manager_srv@1 do_bookmark module clicked.")
+ #' if (interactive()) {
|
|
| 144 | -! | +
- session$doBookmark()+ #' shinyApp(ui, server) |
|
| 145 |
- })+ #' } |
||
| 146 |
-
+ #' |
||
| 147 | -87x | +
- invisible(NULL)+ validate_in <- function(x, choices, msg) {
|
|
| 148 | -+ | ! |
- })+ validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg)) |
| 151 |
-
+ #' Validates that vector has length greater than 0 |
||
| 152 |
- #' @rdname module_bookmark_manager+ #' |
||
| 153 |
- get_bookmarking_option <- function() {
+ #' `r lifecycle::badge("stable")`
|
||
| 154 | -87x | +
- bookmark_option <- getShinyOption("bookmarkStore")
+ #' |
|
| 155 | -87x | +
- if (is.null(bookmark_option) && identical(getOption("shiny.bookmarkStore"), "server")) {
+ #' This function is a wrapper for `shiny::validate`. |
|
| 156 | -! | +
- bookmark_option <- getOption("shiny.bookmarkStore")
+ #' |
|
| 157 |
- }+ #' @param x vector |
||
| 158 | -87x | +
- bookmark_option+ #' @param msg message to display |
|
| 159 |
- }+ #' |
||
| 160 |
-
+ #' @export |
||
| 161 |
- #' @rdname module_bookmark_manager+ #' |
||
| 162 |
- need_bookmarking <- function(modules) {
+ #' @examples |
||
| 163 | -87x | +
- unlist(rapply2(+ #' data <- data.frame( |
|
| 164 | -87x | +
- modules_bookmarkable(modules),+ #' id = c(1:10, 11:20, 1:10), |
|
| 165 | -87x | +
- Negate(isTRUE)+ #' strata = rep(c("A", "B"), each = 15)
|
|
| 166 |
- ))+ #' ) |
||
| 167 |
- }+ #' ui <- fluidPage( |
||
| 168 |
-
+ #' selectInput("ref1", "Select strata1 to compare",
|
||
| 169 |
-
+ #' choices = c("A", "B", "C"), selected = "A"
|
||
| 170 |
- # utilities ----+ #' ), |
||
| 171 |
-
+ #' selectInput("ref2", "Select strata2 to compare",
|
||
| 172 |
- #' Restore value from bookmark.+ #' choices = c("A", "B", "C"), selected = "B"
|
||
| 173 |
- #'+ #' ), |
||
| 174 |
- #' Get value from bookmark or return default.+ #' verbatimTextOutput("arm_summary")
|
||
| 175 |
- #'+ #' ) |
||
| 176 |
- #' Bookmarks can store not only inputs but also arbitrary values.+ #' |
||
| 177 |
- #' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks,+ #' server <- function(input, output) {
|
||
| 178 |
- #' and they are placed in the `values` environment in the `session$restoreContext` field.+ #' output$arm_summary <- renderText({
|
||
| 179 |
- #' Using `teal_data_module` makes it impossible to run the callbacks+ #' sample_1 <- data$id[data$strata == input$ref1] |
||
| 180 |
- #' because the app becomes ready before modules execute and callbacks are registered.+ #' sample_2 <- data$id[data$strata == input$ref2] |
||
| 181 |
- #' In those cases the stored values can still be recovered from the `session` object directly.+ #' |
||
| 182 |
- #'+ #' validate_has_elements(sample_1, "No subjects in strata1.") |
||
| 183 |
- #' Note that variable names in the `values` environment are prefixed with module name space names,+ #' validate_has_elements(sample_2, "No subjects in strata2.") |
||
| 184 |
- #' therefore, when using this function in modules, `value` must be run through the name space function.+ #' |
||
| 185 |
- #'+ #' paste0( |
||
| 186 |
- #' @param value (`character(1)`) name of value to restore+ #' "Number of samples in: strata1=", length(sample_1), |
||
| 187 |
- #' @param default fallback value+ #' " comparions strata2=", length(sample_2) |
||
| 188 |
- #'+ #' ) |
||
| 189 |
- #' @return+ #' }) |
||
| 190 |
- #' In an application restored from a server-side bookmark,+ #' } |
||
| 191 |
- #' the variable specified by `value` from the `values` environment.+ #' if (interactive()) {
|
||
| 192 |
- #' Otherwise `default`.+ #' shinyApp(ui, server) |
||
| 193 |
- #'+ #' } |
||
| 194 |
- #' @keywords internal+ validate_has_elements <- function(x, msg) {
|
||
| 195 | -+ | ! |
- #'+ validate(need(length(x) > 0, msg)) |
| 196 |
- restoreValue <- function(value, default) { # nolint: object_name.
+ } |
||
| 197 | -174x | +
- checkmate::assert_character("value")
+
|
|
| 198 | -174x | +
- session_default <- shiny::getDefaultReactiveDomain()+ #' Validates no intersection between two vectors |
|
| 199 | -174x | +
- session_parent <- .subset2(session_default, "parent")+ #' |
|
| 200 | -174x | +
- session <- if (is.null(session_parent)) session_default else session_parent+ #' `r lifecycle::badge("stable")`
|
|
| 201 |
-
+ #' |
||
| 202 | -174x | +
- if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
+ #' This function is a wrapper for `shiny::validate`. |
|
| 203 | -! | +
- session$restoreContext$values[[value]]+ #' |
|
| 204 |
- } else {
+ #' @param x vector |
||
| 205 | -174x | +
- default+ #' @param y vector |
|
| 206 |
- }+ #' @param msg (`character(1)`) message to display if `x` and `y` intersect |
||
| 207 |
- }+ #' |
||
| 208 |
-
+ #' @export |
||
| 209 |
- #' Compare bookmarks.+ #' |
||
| 210 |
- #'+ #' @examples |
||
| 211 |
- #' Test if two bookmarks store identical state.+ #' data <- data.frame( |
||
| 212 |
- #'+ #' id = c(1:10, 11:20, 1:10), |
||
| 213 |
- #' `input` environments are compared one variable at a time and if not identical,+ #' strata = rep(c("A", "B", "C"), each = 10)
|
||
| 214 |
- #' values in both bookmarks are reported. States of `datatable`s are stripped+ #' ) |
||
| 215 |
- #' of the `time` element before comparing because the time stamp is always different.+ #' |
||
| 216 |
- #' The contents themselves are not printed as they are large and the contents are not informative.+ #' ui <- fluidPage( |
||
| 217 |
- #' Elements present in one bookmark and absent in the other are also reported.+ #' selectInput("ref1", "Select strata1 to compare",
|
||
| 218 |
- #' Differences are printed as messages.+ #' choices = c("A", "B", "C"),
|
||
| 219 |
- #'+ #' selected = "A" |
||
| 220 |
- #' `values` environments are compared with `all.equal`.+ #' ), |
||
| 221 |
- #'+ #' selectInput("ref2", "Select strata2 to compare",
|
||
| 222 |
- #' @section How to use:+ #' choices = c("A", "B", "C"),
|
||
| 223 |
- #' Open an application, change relevant inputs (typically, all of them), and create a bookmark.+ #' selected = "B" |
||
| 224 |
- #' Then open that bookmark and immediately create a bookmark of that.+ #' ), |
||
| 225 |
- #' If restoring bookmarks occurred properly, the two bookmarks should store the same state.+ #' verbatimTextOutput("summary")
|
||
| 226 |
- #'+ #' ) |
||
| 228 |
- #' @param book1,book2 bookmark directories stored in `shiny_bookmarks/`;+ #' server <- function(input, output) {
|
||
| 229 |
- #' default to the two most recently modified directories+ #' output$summary <- renderText({
|
||
| 230 |
- #'+ #' sample_1 <- data$id[data$strata == input$ref1] |
||
| 231 |
- #' @return+ #' sample_2 <- data$id[data$strata == input$ref2] |
||
| 232 |
- #' Invisible `NULL` if bookmarks are identical or if there are no bookmarks to test.+ #' |
||
| 233 |
- #' `FALSE` if inconsistencies are detected.+ #' validate_no_intersection( |
||
| 234 |
- #'+ #' sample_1, sample_2, |
||
| 235 |
- #' @keywords internal+ #' "subjects within strata1 and strata2 cannot overlap" |
||
| 236 |
- #'+ #' ) |
||
| 237 |
- bookmarks_identical <- function(book1, book2) {
+ #' paste0( |
||
| 238 | -! | +
- if (!dir.exists("shiny_bookmarks")) {
+ #' "Number of subject in: reference treatment=", length(sample_1), |
|
| 239 | -! | +
- message("no bookmark directory")
+ #' " comparions treatment=", length(sample_2) |
|
| 240 | -! | +
- return(invisible(NULL))+ #' ) |
|
| 241 |
- }+ #' }) |
||
| 242 |
-
+ #' } |
||
| 243 | -! | +
- ans <- TRUE+ #' if (interactive()) {
|
|
| 244 |
-
+ #' shinyApp(ui, server) |
||
| 245 | -! | +
- if (missing(book1) && missing(book2)) {
+ #' } |
|
| 246 | -! | +
- dirs <- list.dirs("shiny_bookmarks", recursive = FALSE)
+ #' |
|
| 247 | -! | +
- bookmarks_sorted <- basename(rev(dirs[order(file.mtime(dirs))]))+ validate_no_intersection <- function(x, y, msg) {
|
|
| 248 | ! |
- if (length(bookmarks_sorted) < 2L) {
+ validate(need(length(intersect(x, y)) == 0, msg)) |
|
| 249 | -! | +
- message("no bookmarks to compare")
+ } |
|
| 250 | -! | +
- return(invisible(NULL))+ |
|
| 251 |
- }+ |
||
| 252 | -! | +
- book1 <- bookmarks_sorted[2L]+ #' Validates that dataset contains specific variable |
|
| 253 | -! | +
- book2 <- bookmarks_sorted[1L]+ #' |
|
| 254 |
- } else {
+ #' `r lifecycle::badge("stable")`
|
||
| 255 | -! | +
- if (!dir.exists(file.path("shiny_bookmarks", book1))) stop(book1, " not found")
+ #' |
|
| 256 | -! | +
- if (!dir.exists(file.path("shiny_bookmarks", book2))) stop(book2, " not found")
+ #' This function is a wrapper for `shiny::validate`. |
|
| 257 |
- }+ #' |
||
| 258 |
-
+ #' @param data (`data.frame`) |
||
| 259 | -! | +
- book1_input <- readRDS(file.path("shiny_bookmarks", book1, "input.rds"))
+ #' @param varname (`character(1)`) name of variable to check for in `data` |
|
| 260 | -! | +
- book2_input <- readRDS(file.path("shiny_bookmarks", book2, "input.rds"))
+ #' @param msg (`character(1)`) message to display if `data` does not include `varname` |
|
| 261 |
-
+ #' |
||
| 262 | -! | +
- elements_common <- intersect(names(book1_input), names(book2_input))+ #' @export |
|
| 263 | -! | +
- dt_states <- grepl("_state$", elements_common)
+ #' |
|
| 264 | -! | +
- if (any(dt_states)) {
+ #' @examples |
|
| 265 | -! | +
- for (el in elements_common[dt_states]) {
+ #' data <- data.frame( |
|
| 266 | -! | +
- book1_input[[el]][["time"]] <- NULL+ #' one = rep("a", length.out = 20),
|
|
| 267 | -! | +
- book2_input[[el]][["time"]] <- NULL+ #' two = rep(c("a", "b"), length.out = 20)
|
|
| 268 |
- }+ #' ) |
||
| 269 |
- }+ #' ui <- fluidPage( |
||
| 270 |
-
+ #' selectInput( |
||
| 271 | -! | +
- identicals <- mapply(identical, book1_input[elements_common], book2_input[elements_common])+ #' "var", |
|
| 272 | -! | +
- non_identicals <- names(identicals[!identicals])+ #' "Select variable", |
|
| 273 | -! | +
- compares <- sprintf("$ %s:\t%s --- %s", non_identicals, book1_input[non_identicals], book2_input[non_identicals])
+ #' choices = c("one", "two", "three", "four"),
|
|
| 274 | -! | +
- if (length(compares) != 0L) {
+ #' selected = "one" |
|
| 275 | -! | +
- message("common elements not identical: \n", paste(compares, collapse = "\n"))
+ #' ), |
|
| 276 | -! | +
- ans <- FALSE+ #' verbatimTextOutput("summary")
|
|
| 277 |
- }+ #' ) |
||
| 278 |
-
+ #' |
||
| 279 | -! | +
- elements_boook1 <- setdiff(names(book1_input), names(book2_input))+ #' server <- function(input, output) {
|
|
| 280 | -! | +
- if (length(elements_boook1) != 0L) {
+ #' output$summary <- renderText({
|
|
| 281 | -! | +
- dt_states <- grepl("_state$", elements_boook1)
+ #' validate_has_variable(data, input$var) |
|
| 282 | -! | +
- if (any(dt_states)) {
+ #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
|
|
| 283 | -! | +
- for (el in elements_boook1[dt_states]) {
+ #' }) |
|
| 284 | -! | +
- if (is.list(book1_input[[el]])) book1_input[[el]] <- "--- data table state ---"+ #' } |
|
| 285 |
- }+ #' if (interactive()) {
|
||
| 286 |
- }+ #' shinyApp(ui, server) |
||
| 287 | -! | +
- excess1 <- sprintf("$ %s:\t%s", elements_boook1, book1_input[elements_boook1])
+ #' } |
|
| 288 | -! | +
- message("elements only in book1: \n", paste(excess1, collapse = "\n"))
+ validate_has_variable <- function(data, varname, msg) {
|
|
| 289 | ! |
- ans <- FALSE+ if (length(varname) != 0) {
|
|
| 290 | -+ | ! |
- }+ has_vars <- varname %in% names(data) |
| 292 | ! |
- elements_boook2 <- setdiff(names(book2_input), names(book1_input))+ if (!all(has_vars)) {
|
|
| 293 | ! |
- if (length(elements_boook2) != 0L) {
+ if (missing(msg)) {
|
|
| 294 | ! |
- dt_states <- grepl("_state$", elements_boook1)
+ msg <- sprintf( |
|
| 295 | ! |
- if (any(dt_states)) {
+ "%s does not have the required variables: %s.", |
|
| 296 | ! |
- for (el in elements_boook1[dt_states]) {
+ deparse(substitute(data)), |
|
| 297 | ! |
- if (is.list(book2_input[[el]])) book2_input[[el]] <- "--- data table state ---"+ toString(varname[!has_vars]) |
|
| 298 |
- }+ ) |
||
| 299 |
- }+ } |
||
| 300 | ! |
- excess2 <- sprintf("$ %s:\t%s", elements_boook2, book2_input[elements_boook2])
+ validate(need(FALSE, msg)) |
|
| 301 | -! | +
- message("elements only in book2: \n", paste(excess2, collapse = "\n"))
+ } |
|
| 302 | -! | +
- ans <- FALSE+ } |
|
| 303 |
- }+ } |
||
| 305 | -! | +
- book1_values <- readRDS(file.path("shiny_bookmarks", book1, "values.rds"))
+ #' Validate that variables has expected number of levels |
|
| 306 | -! | +
- book2_values <- readRDS(file.path("shiny_bookmarks", book2, "values.rds"))
+ #' |
|
| 307 |
-
+ #' `r lifecycle::badge("stable")`
|
||
| 308 | -! | +
- if (!isTRUE(all.equal(book1_values, book2_values))) {
+ #' |
|
| 309 | -! | +
- message("different values detected")
+ #' If the number of levels of `x` is less than `min_levels` |
|
| 310 | -! | +
- message("choices for numeric filters MAY be different, see RangeFilterState$set_choices")
+ #' or greater than `max_levels` the validation will fail. |
|
| 311 | -! | +
- ans <- FALSE+ #' This function is a wrapper for `shiny::validate`. |
|
| 312 |
- }+ #' |
||
| 313 |
-
+ #' @param x variable name. If `x` is not a factor, the unique values |
||
| 314 | -! | +
- if (ans) message("perfect!")
+ #' are treated as levels. |
|
| 315 | -! | +
- invisible(NULL)+ #' @param min_levels cutoff for minimum number of levels of `x` |
|
| 316 |
- }+ #' @param max_levels cutoff for maximum number of levels of `x` |
||
| 317 |
-
+ #' @param var_name name of variable being validated for use in |
||
| 318 |
-
+ #' validation message |
||
| 319 |
- # Replacement for [base::rapply] which doesn't handle NULL values - skips the evaluation+ #' |
||
| 320 |
- # of the function and returns NULL for given element.+ #' @export |
||
| 321 |
- rapply2 <- function(x, f) {
+ #' @examples |
||
| 322 | -199x | +
- if (inherits(x, "list")) {
+ #' data <- data.frame( |
|
| 323 | -87x | +
- lapply(x, rapply2, f = f)+ #' one = rep("a", length.out = 20),
|
|
| 324 |
- } else {
+ #' two = rep(c("a", "b"), length.out = 20),
|
||
| 325 | -112x | +
- f(x)+ #' three = rep(c("a", "b", "c"), length.out = 20),
|
|
| 326 |
- }+ #' four = rep(c("a", "b", "c", "d"), length.out = 20),
|
||
| 327 |
- }+ #' stringsAsFactors = TRUE |
| 1 | +328 |
- #' `teal` main module+ #' ) |
|
| 2 | +329 |
- #'+ #' ui <- fluidPage( |
|
| 3 | +330 |
- #' @description+ #' selectInput( |
|
| 4 | +331 |
- #' `r lifecycle::badge("stable")`
+ #' "var", |
|
| 5 | +332 |
- #' Module to create a `teal` app. This module can be called directly instead of [init()] and+ #' "Select variable", |
|
| 6 | +333 |
- #' included in your custom application. Please note that [init()] adds `reporter_previewer_module`+ #' choices = c("one", "two", "three", "four"),
|
|
| 7 | +334 |
- #' automatically, which is not a case when calling `ui/srv_teal` directly.+ #' selected = "one" |
|
| 8 | +335 |
- #'+ #' ), |
|
| 9 | +336 |
- #' @details+ #' verbatimTextOutput("summary")
|
|
| 10 | +337 |
- #'+ #' ) |
|
| 11 | -- |
- #' Module is responsible for creating the main `shiny` app layout and initializing all the necessary- |
- |
| 12 | -- |
- #' components. This module establishes reactive connection between the input `data` and every other- |
- |
| 13 | +338 |
- #' component in the app. Reactive change of the `data` passed as an argument, reloads the app and+ #' |
|
| 14 | +339 |
- #' possibly keeps all input settings the same so the user can continue where one left off.+ #' server <- function(input, output) {
|
|
| 15 | +340 |
- #'+ #' output$summary <- renderText({
|
|
| 16 | +341 |
- #' ## data flow in `teal` application+ #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var) |
|
| 17 | +342 |
- #'+ #' paste0( |
|
| 18 | +343 |
- #' This module supports multiple data inputs but eventually, they are all converted to `reactive`+ #' "Levels of selected treatment variable: ", |
|
| 19 | +344 |
- #' returning `teal_data` in this module. On this `reactive teal_data` object several actions are+ #' paste(levels(data[[input$var]]), |
|
| 20 | +345 |
- #' performed:+ #' collapse = ", " |
|
| 21 | +346 |
- #' - data loading in [`module_init_data`]+ #' ) |
|
| 22 | +347 |
- #' - data filtering in [`module_filter_data`]+ #' ) |
|
| 23 | +348 |
- #' - data transformation in [`module_transform_data`]+ #' }) |
|
| 24 | +349 |
- #'+ #' } |
|
| 25 | +350 |
- #' ## Fallback on failure+ #' if (interactive()) {
|
|
| 26 | +351 |
- #'+ #' shinyApp(ui, server) |
|
| 27 | +352 |
- #' `teal` is designed in such way that app will never crash if the error is introduced in any+ #' } |
|
| 28 | +353 |
- #' custom `shiny` module provided by app developer (e.g. [teal_data_module()], [teal_transform_module()]).+ validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
|
|
| 29 | -+ | ||
| 354 | +! |
- #' If any module returns a failing object, the app will halt the evaluation and display a warning message.+ x_levels <- if (is.factor(x)) {
|
|
| 30 | -+ | ||
| 355 | +! |
- #' App user should always have a chance to fix the improper input and continue without restarting the session.+ levels(x) |
|
| 31 | +356 |
- #'+ } else {
|
|
| 32 | -+ | ||
| 357 | +! |
- #' @rdname module_teal+ unique(x) |
|
| 33 | +358 |
- #' @name module_teal+ } |
|
| 34 | +359 |
- #'+ |
|
| 35 | -+ | ||
| 360 | +! |
- #' @inheritParams module_init_data+ if (!is.null(min_levels) && !(is.null(max_levels))) {
|
|
| 36 | -+ | ||
| 361 | +! |
- #' @inheritParams init+ validate(need( |
|
| 37 | -+ | ||
| 362 | +! |
- #'+ length(x_levels) >= min_levels && length(x_levels) <= max_levels, |
|
| 38 | -+ | ||
| 363 | +! |
- #' @return `NULL` invisibly+ sprintf( |
|
| 39 | -+ | ||
| 364 | +! |
- NULL+ "%s variable needs minimum %s level(s) and maximum %s level(s).", |
|
| 40 | -+ | ||
| 365 | +! |
-
+ var_name, min_levels, max_levels |
|
| 41 | +366 |
- #' @rdname module_teal+ ) |
|
| 42 | +367 |
- #' @export+ )) |
|
| 43 | -+ | ||
| 368 | +! |
- ui_teal <- function(id,+ } else if (!is.null(min_levels)) {
|
|
| 44 | -+ | ||
| 369 | +! |
- modules,+ validate(need( |
|
| 45 | -+ | ||
| 370 | +! |
- title = build_app_title(),+ length(x_levels) >= min_levels, |
|
| 46 | -+ | ||
| 371 | +! |
- header = tags$p(),+ sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
|
|
| 47 | +372 |
- footer = tags$p()) {
+ )) |
|
| 48 | +373 | ! |
- checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ } else if (!is.null(max_levels)) {
|
| 49 | +374 | ! |
- checkmate::assert(+ validate(need( |
| 50 | +375 | ! |
- .var.name = "title",+ length(x_levels) <= max_levels, |
| 51 | +376 | ! |
- checkmate::check_string(title),+ sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
|
| 52 | -! | +||
| 377 | +
- checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
+ )) |
||
| 53 | +378 |
- )+ } |
|
| 54 | -! | +||
| 379 | +
- checkmate::assert(+ } |
||
| 55 | -! | +
| 1 | +
- .var.name = "header",+ # This is the main function from teal to be used by the end-users. Although it delegates |
|||
| 56 | -! | +|||
| 2 | +
- checkmate::check_string(header),+ # directly to `module_teal_with_splash.R`, we keep it in a separate file because its documentation is quite large |
|||
| 57 | -! | +|||
| 3 | +
- checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
+ # and it is very end-user oriented. It may also perform more argument checking with more informative |
|||
| 58 | +4 |
- )+ # error messages. |
||
| 59 | -! | +|||
| 5 | +
- checkmate::assert(+ |
|||
| 60 | -! | +|||
| 6 | +
- .var.name = "footer",+ #' Create the server and UI function for the `shiny` app |
|||
| 61 | -! | +|||
| 7 | +
- checkmate::check_string(footer),+ #' |
|||
| 62 | -! | +|||
| 8 | +
- checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 63 | +9 |
- )+ #' |
||
| 64 | +10 |
-
+ #' End-users: This is the most important function for you to start a |
||
| 65 | -! | +|||
| 11 | +
- if (is.character(title)) {
+ #' `teal` app that is composed of `teal` modules. |
|||
| 66 | -! | +|||
| 12 | +
- title <- build_app_title(title)+ #' |
|||
| 67 | +13 |
- } else {
+ #' @param data (`teal_data` or `teal_data_module`) |
||
| 68 | -! | +|||
| 14 | +
- validate_app_title_tag(title)+ #' For constructing the data object, refer to [teal.data::teal_data()] and [teal_data_module()]. |
|||
| 69 | +15 |
- }+ #' If `datanames` are not set for the `teal_data` object, defaults from the `teal_data` environment will be used. |
||
| 70 | +16 |
-
+ #' @param modules (`list` or `teal_modules` or `teal_module`) |
||
| 71 | -! | +|||
| 17 | +
- if (checkmate::test_string(header)) {
+ #' Nested list of `teal_modules` or `teal_module` objects or a single |
|||
| 72 | -! | +|||
| 18 | +
- header <- tags$p(header)+ #' `teal_modules` or `teal_module` object. These are the specific output modules which |
|||
| 73 | +19 |
- }+ #' will be displayed in the `teal` application. See [modules()] and [module()] for |
||
| 74 | +20 |
-
+ #' more details. |
||
| 75 | -! | +|||
| 21 | +
- if (checkmate::test_string(footer)) {
+ #' @param filter (`teal_slices`) Optionally, |
|||
| 76 | -! | +|||
| 22 | +
- footer <- tags$p(footer)+ #' specifies the initial filter using [teal_slices()]. |
|||
| 77 | +23 |
- }+ #' @param title (`shiny.tag` or `character(1)`) Optionally, |
||
| 78 | +24 |
-
+ #' the browser window title. Defaults to a title "teal app" with the icon of NEST. |
||
| 79 | -! | +|||
| 25 | +
- ns <- NS(id)+ #' Can be created using the `build_app_title()` or |
|||
| 80 | +26 |
-
+ #' by passing a valid `shiny.tag` which is a head tag with title and link tag. |
||
| 81 | +27 |
- # show busy icon when `shiny` session is busy computing stuff+ #' @param header (`shiny.tag` or `character(1)`) Optionally, |
||
| 82 | +28 |
- # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint: line_length.+ #' the header of the app. |
||
| 83 | -! | +|||
| 29 | +
- shiny_busy_message_panel <- conditionalPanel(+ #' @param footer (`shiny.tag` or `character(1)`) Optionally, |
|||
| 84 | -! | +|||
| 30 | +
- condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint: line_length.
+ #' the footer of the app. |
|||
| 85 | -! | +|||
| 31 | +
- tags$div(+ #' @param id (`character`) Optionally, |
|||
| 86 | -! | +|||
| 32 | +
- icon("arrows-rotate", class = "fa-spin", prefer_type = "solid"),
+ #' a string specifying the `shiny` module id in cases it is used as a `shiny` module |
|||
| 87 | -! | +|||
| 33 | +
- "Computing ...",+ #' rather than a standalone `shiny` app. This is a legacy feature. |
|||
| 88 | +34 |
- # CSS defined in `custom.css`+ #' @param landing_popup (`teal_module_landing`) Optionally, |
||
| 89 | -! | +|||
| 35 | +
- class = "shinybusymessage"+ #' a `landing_popup_module` to show up as soon as the teal app is initialized. |
|||
| 90 | +36 |
- )+ #' |
||
| 91 | +37 |
- )+ #' @return Named list containing server and UI functions. |
||
| 92 | +38 |
-
+ #' |
||
| 93 | -! | +|||
| 39 | +
- fluidPage(+ #' @export |
|||
| 94 | -! | +|||
| 40 | +
- id = id,+ #' |
|||
| 95 | -! | +|||
| 41 | +
- title = title,+ #' @include modules.R |
|||
| 96 | -! | -
- theme = get_teal_bs_theme(),- |
- ||
| 97 | -! | +|||
| 42 | +
- include_teal_css_js(),+ #' |
|||
| 98 | -! | +|||
| 43 | +
- tags$header(header),+ #' @examples |
|||
| 99 | -! | +|||
| 44 | +
- tags$hr(class = "my-2"),+ #' app <- init( |
|||
| 100 | -! | +|||
| 45 | +
- shiny_busy_message_panel,+ #' data = within( |
|||
| 101 | -! | +|||
| 46 | +
- tags$div(+ #' teal_data(), |
|||
| 102 | -! | +|||
| 47 | +
- id = ns("tabpanel_wrapper"),
+ #' {
|
|||
| 103 | -! | +|||
| 48 | +
- class = "teal-body",+ #' new_iris <- transform(iris, id = seq_len(nrow(iris))) |
|||
| 104 | -! | +|||
| 49 | +
- ui_teal_module(id = ns("teal_modules"), modules = modules)
+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars))) |
|||
| 105 | +50 |
- ),+ #' } |
||
| 106 | -! | +|||
| 51 | +
- tags$div(+ #' ), |
|||
| 107 | -! | +|||
| 52 | +
- id = ns("options_buttons"),
+ #' modules = modules( |
|||
| 108 | -! | +|||
| 53 | +
- style = "position: absolute; right: 10px;",+ #' module( |
|||
| 109 | -! | +|||
| 54 | +
- ui_bookmark_panel(ns("bookmark_manager"), modules),
+ #' label = "data source", |
|||
| 110 | -! | +|||
| 55 | +
- tags$button(+ #' server = function(input, output, session, data) {},
|
|||
| 111 | -! | +|||
| 56 | +
- class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger+ #' ui = function(id, ...) tags$div(p("information about data source")),
|
|||
| 112 | -! | +|||
| 57 | +
- href = "javascript:void(0)",+ #' datanames = "all" |
|||
| 113 | -! | +|||
| 58 | +
- onclick = sprintf("toggleFilterPanel('%s');", ns("tabpanel_wrapper")),
+ #' ), |
|||
| 114 | -! | +|||
| 59 | +
- title = "Toggle filter panel",+ #' example_module(label = "example teal module"), |
|||
| 115 | -! | +|||
| 60 | +
- icon("fas fa-bars")
+ #' module( |
|||
| 116 | +61 |
- ),+ #' "Iris Sepal.Length histogram", |
||
| 117 | -! | +|||
| 62 | +
- ui_snapshot_manager_panel(ns("snapshot_manager_panel")),
+ #' server = function(input, output, session, data) {
|
|||
| 118 | -! | +|||
| 63 | +
- ui_filter_manager_panel(ns("filter_manager_panel"))
+ #' output$hist <- renderPlot( |
|||
| 119 | +64 |
- ),+ #' hist(data()[["new_iris"]]$Sepal.Length) |
||
| 120 | -! | +|||
| 65 | +
- tags$script(+ #' ) |
|||
| 121 | -! | +|||
| 66 | +
- HTML(+ #' }, |
|||
| 122 | -! | +|||
| 67 | +
- sprintf(+ #' ui = function(id, ...) {
|
|||
| 123 | +68 |
- "+ #' ns <- NS(id) |
||
| 124 | -! | +|||
| 69 | +
- $(document).ready(function() {
+ #' plotOutput(ns("hist"))
|
|||
| 125 | -! | +|||
| 70 | +
- $('#%s').appendTo('#%s');
+ #' }, |
|||
| 126 | +71 |
- });+ #' datanames = "new_iris" |
||
| 127 | +72 |
- ",+ #' ) |
||
| 128 | -! | +|||
| 73 | +
- ns("options_buttons"),
+ #' ), |
|||
| 129 | -! | +|||
| 74 | +
- ns("teal_modules-active_tab")
+ #' filter = teal_slices( |
|||
| 130 | +75 |
- )+ #' teal_slice(dataname = "new_iris", varname = "Species"), |
||
| 131 | +76 |
- )+ #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"), |
||
| 132 | +77 |
- ),+ #' teal_slice(dataname = "new_mtcars", varname = "cyl"), |
||
| 133 | -! | +|||
| 78 | +
- tags$hr(),+ #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
|
|||
| 134 | -! | +|||
| 79 | +
- tags$footer(+ #' module_specific = TRUE, |
|||
| 135 | -! | +|||
| 80 | +
- tags$div(+ #' mapping = list( |
|||
| 136 | -! | +|||
| 81 | +
- footer,+ #' `example teal module` = "new_iris Species", |
|||
| 137 | -! | +|||
| 82 | +
- teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
+ #' `Iris Sepal.Length histogram` = "new_iris Species", |
|||
| 138 | -! | +|||
| 83 | +
- br(),+ #' global_filters = "new_mtcars cyl" |
|||
| 139 | -! | +|||
| 84 | +
- ui_teal_lockfile(ns("lockfile")),
+ #' ) |
|||
| 140 | -! | +|||
| 85 | +
- textOutput(ns("identifier"))
+ #' ), |
|||
| 141 | +86 |
- )+ #' title = "App title", |
||
| 142 | +87 |
- )+ #' header = tags$h1("Sample App"),
|
||
| 143 | +88 |
- )+ #' footer = tags$p("Sample footer")
|
||
| 144 | +89 |
- }+ #' ) |
||
| 145 | +90 |
-
+ #' if (interactive()) {
|
||
| 146 | +91 |
- #' @rdname module_teal+ #' shinyApp(app$ui, app$server) |
||
| 147 | +92 |
- #' @export+ #' } |
||
| 148 | +93 |
- srv_teal <- function(id, data, modules, filter = teal_slices()) {
+ #' |
||
| 149 | -89x | +|||
| 94 | +
- checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ init <- function(data, |
|||
| 150 | -89x | +|||
| 95 | +
- checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
+ modules, |
|||
| 151 | -88x | +|||
| 96 | +
- checkmate::assert_class(modules, "teal_modules")+ filter = teal_slices(), |
|||
| 152 | -88x | +|||
| 97 | +
- checkmate::assert_class(filter, "teal_slices")+ title = build_app_title(), |
|||
| 153 | +98 |
-
+ header = tags$p(), |
||
| 154 | -88x | +|||
| 99 | +
- moduleServer(id, function(input, output, session) {
+ footer = tags$p(), |
|||
| 155 | -88x | +|||
| 100 | +
- logger::log_debug("srv_teal initializing.")
+ id = character(0), |
|||
| 156 | +101 |
-
+ landing_popup = NULL) {
|
||
| 157 | -88x | -
- if (getOption("teal.show_js_log", default = FALSE)) {
- |
- ||
| 158 | -! | +102 | +14x |
- shinyjs::showLog()+ logger::log_debug("init initializing teal app with: data ('{ class(data) }').")
|
| 159 | +103 |
- }+ |
||
| 160 | +104 | - - | -||
| 161 | -88x | -
- srv_teal_lockfile("lockfile")
+ # argument checking (independent) |
||
| 162 | +105 |
-
+ ## `data` |
||
| 163 | -88x | +106 | +14x |
- output$identifier <- renderText(+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
|
| 164 | -88x | +107 | +14x |
- paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
+ checkmate::assert_class(landing_popup, "teal_module_landing", null.ok = TRUE) |
| 165 | +108 |
- )+ |
||
| 166 | +109 |
-
+ ## `modules` |
||
| 167 | -88x | +110 | +14x |
- teal.widgets::verbatim_popup_srv(+ checkmate::assert( |
| 168 | -88x | +111 | +14x |
- "sessionInfo",+ .var.name = "modules", |
| 169 | -88x | +112 | +14x |
- verbatim_content = utils::capture.output(utils::sessionInfo()),+ checkmate::check_multi_class(modules, c("teal_modules", "teal_module")),
|
| 170 | -88x | -
- title = "SessionInfo"- |
- ||
| 171 | -+ | 113 | +14x |
- )+ checkmate::check_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
|
| 172 | +114 |
-
+ ) |
||
| 173 | -+ | |||
| 115 | +14x |
- # `JavaScript` code+ if (inherits(modules, "teal_module")) {
|
||
| 174 | -88x | +116 | +1x |
- run_js_files(files = "init.js")+ modules <- list(modules) |
| 175 | +117 | - - | -||
| 176 | -- |
- # set timezone in shiny app- |
- ||
| 177 | -- |
- # timezone is set in the early beginning so it will be available also- |
- ||
| 178 | -- |
- # for `DDL` and all shiny modules- |
- ||
| 179 | -88x | -
- get_client_timezone(session$ns)- |
- ||
| 180 | -88x | -
- observeEvent(- |
- ||
| 181 | -88x | -
- eventExpr = input$timezone,+ } |
||
| 182 | -88x | +118 | +14x |
- once = TRUE,+ if (checkmate::test_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))) {
|
| 183 | -88x | -
- handlerExpr = {
- |
- ||
| 184 | -! | -
- session$userData$timezone <- input$timezone- |
- ||
| 185 | -! | +119 | +8x |
- logger::log_debug("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
+ modules <- do.call(teal::modules, modules) |
| 186 | +120 |
- }+ } |
||
| 187 | +121 |
- )+ |
||
| 188 | +122 |
-
+ ## `filter` |
||
| 189 | -88x | +123 | +14x |
- data_handled <- srv_init_data("data", data = data)
+ checkmate::assert_class(filter, "teal_slices") |
| 190 | +124 | |||
| 191 | -87x | -
- validate_ui <- tags$div(- |
- ||
| 192 | -87x | +|||
| 125 | +
- id = session$ns("validate_messages"),
+ ## all other arguments |
|||
| 193 | -87x | +126 | +13x |
- class = "teal_validated",+ checkmate::assert( |
| 194 | -87x | +127 | +13x |
- ui_check_class_teal_data(session$ns("class_teal_data")),
+ .var.name = "title", |
| 195 | -87x | +128 | +13x |
- ui_validate_error(session$ns("silent_error")),
+ checkmate::check_string(title), |
| 196 | -87x | +129 | +13x |
- ui_check_module_datanames(session$ns("datanames_warning"))
+ checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
|
| 197 | +130 |
- )+ ) |
||
| 198 | -87x | +131 | +13x |
- srv_check_class_teal_data("class_teal_data", data_handled)
+ checkmate::assert( |
| 199 | -87x | +132 | +13x |
- srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
+ .var.name = "header", |
| 200 | -87x | -
- srv_check_module_datanames("datanames_warning", data_handled, modules)
- |
- ||
| 201 | -+ | 133 | +13x |
-
+ checkmate::check_string(header), |
| 202 | -87x | +134 | +13x |
- data_validated <- .trigger_on_success(data_handled)+ checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
|
| 203 | +135 | - - | -||
| 204 | -87x | -
- data_signatured <- reactive({
+ ) |
||
| 205 | -152x | +136 | +13x |
- req(inherits(data_validated(), "teal_data"))+ checkmate::assert( |
| 206 | -75x | +137 | +13x |
- is_filter_ok <- check_filter_datanames(filter, names(data_validated()))+ .var.name = "footer", |
| 207 | -75x | +138 | +13x |
- if (!isTRUE(is_filter_ok)) {
+ checkmate::check_string(footer), |
| 208 | -2x | +139 | +13x |
- showNotification(+ checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
|
| 209 | -2x | +|||
| 140 | +
- "Some filters were not applied because of incompatibility with data. Contact app developer.",+ ) |
|||
| 210 | -2x | +141 | +13x |
- type = "warning",+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
| 211 | -2x | +|||
| 142 | +
- duration = 10+ |
|||
| 212 | +143 |
- )+ # log |
||
| 213 | -2x | +144 | +13x |
- warning(is_filter_ok)+ teal.logger::log_system_info() |
| 214 | +145 |
- }- |
- ||
| 215 | -75x | -
- .add_signature_to_data(data_validated())+ |
||
| 216 | +146 |
- })+ # argument transformations |
||
| 217 | +147 |
-
+ ## `modules` - landing module |
||
| 218 | -87x | +148 | +13x |
- data_load_status <- reactive({
+ landing <- extract_module(modules, "teal_module_landing") |
| 219 | -80x | +149 | +13x |
- if (inherits(data_handled(), "teal_data")) {
+ if (length(landing) == 1L) {
|
| 220 | -75x | +|||
| 150 | +! |
- "ok"+ landing_popup <- landing[[1L]] |
||
| 221 | -5x | +|||
| 151 | +! |
- } else if (inherits(data, "teal_data_module")) {
+ modules <- drop_module(modules, "teal_module_landing") |
||
| 222 | -5x | +|||
| 152 | +! |
- "teal_data_module failed"+ lifecycle::deprecate_soft( |
||
| 223 | -+ | |||
| 153 | +! |
- } else {
+ when = "0.15.3", |
||
| 224 | +154 | ! |
- "external failed"+ what = "landing_popup_module()", |
|
| 225 | -+ | |||
| 155 | +! |
- }+ details = paste( |
||
| 226 | -+ | |||
| 156 | +! |
- })+ "Pass `landing_popup_module` to the `landing_popup` argument of the `init` ", |
||
| 227 | -+ | |||
| 157 | +! |
-
+ "instead of wrapping it into `modules()` and passing to the `modules` argument" |
||
| 228 | -87x | +|||
| 158 | +
- datasets_rv <- if (!isTRUE(attr(filter, "module_specific"))) {
+ ) |
|||
| 229 | -76x | +|||
| 159 | +
- eventReactive(data_signatured(), {
+ ) |
|||
| 230 | -66x | +160 | +13x |
- req(inherits(data_signatured(), "teal_data"))+ } else if (length(landing) > 1L) {
|
| 231 | -66x | +|||
| 161 | +! |
- logger::log_debug("srv_teal@1 initializing FilteredData")
+ stop("Only one `landing_popup_module` can be used.")
|
||
| 232 | -66x | +|||
| 162 | +
- teal_data_to_filtered_data(data_signatured())+ } |
|||
| 233 | +163 |
- })+ |
||
| 234 | +164 |
- }+ ## `filter` - set app_id attribute unless present (when restoring bookmark) |
||
| 235 | -+ | |||
| 165 | +13x |
-
+ if (is.null(attr(filter, "app_id", exact = TRUE))) attr(filter, "app_id") <- create_app_id(data, modules) |
||
| 236 | +166 | |||
| 237 | +167 |
-
+ ## `filter` - convert teal.slice::teal_slices to teal::teal_slices |
||
| 238 | -87x | +168 | +13x |
- if (inherits(data, "teal_data_module")) {
+ filter <- as.teal_slices(as.list(filter)) |
| 239 | -9x | +|||
| 169 | +
- setBookmarkExclude(c("teal_modules-active_tab"))
+
|
|||
| 240 | -9x | +|||
| 170 | +
- shiny::insertTab(+ # argument checking (interdependent) |
|||
| 241 | -9x | +|||
| 171 | +
- inputId = "teal_modules-active_tab",+ ## `filter` - `modules` |
|||
| 242 | -9x | +172 | +13x |
- position = "before",+ if (isTRUE(attr(filter, "module_specific"))) {
|
| 243 | -9x | +|||
| 173 | +! |
- select = TRUE,+ module_names <- unlist(c(module_labels(modules), "global_filters")) |
||
| 244 | -9x | +|||
| 174 | +! |
- tabPanel(+ failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names) |
||
| 245 | -9x | +|||
| 175 | +! |
- title = icon("fas fa-database"),
+ if (length(failed_mod_names)) {
|
||
| 246 | -9x | +|||
| 176 | +! |
- value = "teal_data_module",+ stop( |
||
| 247 | -9x | +|||
| 177 | +! |
- tags$div(+ sprintf( |
||
| 248 | -9x | +|||
| 178 | +! |
- ui_init_data(session$ns("data")),
+ "Some module names in the mapping arguments don't match module labels.\n %s not in %s", |
||
| 249 | -9x | +|||
| 179 | +! |
- validate_ui+ toString(failed_mod_names), |
||
| 250 | -+ | |||
| 180 | +! |
- )+ toString(unique(module_names)) |
||
| 251 | +181 |
) |
||
| 252 | +182 |
) |
||
| 253 | +183 |
-
+ } |
||
| 254 | -9x | +|||
| 184 | +
- if (attr(data, "once")) {
+
|
|||
| 255 | -9x | +|||
| 185 | +! |
- observeEvent(data_signatured(), once = TRUE, {
+ if (anyDuplicated(module_names)) {
|
||
| 256 | -4x | +|||
| 186 | +
- logger::log_debug("srv_teal@2 removing data tab.")
+ # In teal we are able to set nested modules with duplicated label. |
|||
| 257 | +187 |
- # when once = TRUE we pull data once and then remove data tab+ # Because mapping argument bases on the relationship between module-label and filter-id, |
||
| 258 | -4x | +|||
| 188 | +
- removeTab("teal_modules-active_tab", target = "teal_data_module")
+ # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)+ |
+ |||
| 189 | +! | +
+ stop(+ |
+ ||
| 190 | +! | +
+ sprintf(+ |
+ ||
| 191 | +! | +
+ "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",+ |
+ ||
| 192 | +! | +
+ toString(module_names[duplicated(module_names)]) |
||
| 259 | +193 |
- })+ ) |
||
| 260 | +194 |
- }+ ) |
||
| 261 | +195 |
- } else {
+ } |
||
| 262 | +196 |
- # when no teal_data_module then we want to display messages above tabsetPanel (because there is no data-tab)+ } |
||
| 263 | -78x | +|||
| 197 | +
- insertUI(+ |
|||
| 264 | -78x | +|||
| 198 | +
- selector = sprintf("#%s", session$ns("tabpanel_wrapper")),
+ ## `data` - `modules` |
|||
| 265 | -78x | +199 | +13x |
- where = "beforeBegin",+ if (inherits(data, "teal_data")) {
|
| 266 | -78x | +200 | +12x |
- ui = tags$div(validate_ui, tags$br())+ if (length(data) == 0) {
|
| 267 | -+ | |||
| 201 | +1x |
- )+ stop("The environment of `data` is empty.")
|
||
| 268 | +202 |
} |
||
| 269 | +203 | |||
| 270 | -87x | +204 | +11x |
- module_labels <- unlist(module_labels(modules), use.names = FALSE)+ is_modules_ok <- check_modules_datanames(modules, names(data)) |
| 271 | -87x | +205 | +11x |
- slices_global <- methods::new(".slicesGlobal", filter, module_labels)
+ if (!isTRUE(is_modules_ok) && length(unlist(extract_transformators(modules))) == 0) {
|
| 272 | -87x | +206 | +4x |
- modules_output <- srv_teal_module(+ warning(is_modules_ok, call. = FALSE) |
| 273 | -87x | +|||
| 207 | +
- id = "teal_modules",+ }+ |
+ |||
| 208 | ++ | + | ||
| 274 | -87x | +209 | +11x |
- data = data_signatured,+ is_filter_ok <- check_filter_datanames(filter, names(data)) |
| 275 | -87x | +210 | +11x |
- datasets = datasets_rv,+ if (!isTRUE(is_filter_ok)) {
|
| 276 | -87x | +211 | +1x |
- modules = modules,+ warning(is_filter_ok)+ |
+
| 212 | ++ |
+ # we allow app to continue if applied filters are outside+ |
+ ||
| 213 | ++ |
+ # of possible data range+ |
+ ||
| 214 | ++ |
+ }+ |
+ ||
| 215 | ++ |
+ }+ |
+ ||
| 216 | ++ | + | ||
| 277 | -87x | +217 | +12x |
- slices_global = slices_global,+ reporter <- teal.reporter::Reporter$new()$set_id(attr(filter, "app_id")) |
| 278 | -87x | +218 | +12x |
- data_load_status = data_load_status+ if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
+ |
+
| 219 | +! | +
+ modules <- append_module(+ |
+ ||
| 220 | +! | +
+ modules,+ |
+ ||
| 221 | +! | +
+ reporter_previewer_module(server_args = list(previewer_buttons = c("download", "reset")))
|
||
| 279 | +222 |
) |
||
| 223 | ++ |
+ }+ |
+ ||
| 224 | ++ | + + | +||
| 280 | -87x | +225 | +12x |
- mapping_table <- srv_filter_manager_panel("filter_manager_panel", slices_global = slices_global)
+ ns <- NS(id)+ |
+
| 226 | ++ |
+ # Note: UI must be a function to support bookmarking. |
||
| 281 | -87x | +227 | +12x |
- snapshots <- srv_snapshot_manager_panel("snapshot_manager_panel", slices_global = slices_global)
+ res <- list( |
| 282 | -87x | +228 | +12x |
- srv_bookmark_panel("bookmark_manager", modules)
+ ui = function(request) {
+ |
+
| 229 | +! | +
+ ui_teal(+ |
+ ||
| 230 | +! | +
+ id = ns("teal"),
+ |
+ ||
| 231 | +! | +
+ modules = modules,+ |
+ ||
| 232 | +! | +
+ title = title,+ |
+ ||
| 233 | +! | +
+ header = header,+ |
+ ||
| 234 | +! | +
+ footer = footer |
||
| 283 | +235 |
- })+ ) |
||
| 284 | +236 | ++ |
+ },+ |
+ |
| 237 | +12x | +
+ server = function(input, output, session) {
+ |
+ ||
| 238 | +! | +
+ if (!is.null(landing_popup)) {
+ |
+ ||
| 239 | +! | +
+ do.call(landing_popup$server, c(list(id = "landing_module_shiny_id"), landing_popup$server_args))+ |
+ ||
| 240 | ++ |
+ }+ |
+ ||
| 241 | +! | +
+ srv_teal(id = ns("teal"), data = data, modules = modules, filter = deep_copy_filter(filter))
+ |
+ ||
| 242 | ++ |
+ }+ |
+ ||
| 243 | ++ |
+ )+ |
+ ||
| 244 | ||||
| 285 | -87x | +245 | +12x |
- invisible(NULL)+ logger::log_debug("init teal app has been initialized.")
|
| 286 | +246 | ++ | + + | +|
| 247 | +12x | +
+ res+ |
+ ||
| 248 |
}@@ -27671,448 +27105,448 @@ teal coverage - 60.02% |
| 1 |
- # FilteredData ------+ #' Manage multiple `FilteredData` objects |
||
| 2 |
-
+ #' |
||
| 3 |
- #' Drive a `teal` application+ #' @description |
||
| 4 |
- #'+ #' Oversee filter states across the entire application. |
||
| 5 |
- #' Extension of the `shinytest2::AppDriver` class with methods for+ #' |
||
| 6 |
- #' driving a teal application for performing interactions for `shinytest2` tests.+ #' @section Slices global: |
||
| 7 |
- #'+ #' The key role in maintaining the module-specific filter states is played by the `.slicesGlobal` |
||
| 8 |
- #' @keywords internal+ #' object. It is a reference class that holds the following fields: |
||
| 9 |
- #'+ #' - `all_slices` (`reactiveVal`) - reactive value containing all filters registered in an app. |
||
| 10 |
- TealAppDriver <- R6::R6Class( # nolint: object_name.+ #' - `module_slices_api` (`reactiveValues`) - reactive field containing references to each modules' |
||
| 11 |
- "TealAppDriver",+ #' `FilteredData` object methods. At this moment it is used only in `srv_filter_manager` to display |
||
| 12 |
- inherit = {
+ #' the filter states in a table combining informations from `all_slices` and from |
||
| 13 |
- if (!requireNamespace("shinytest2", quietly = TRUE)) {
+ #' `FilteredData$get_available_teal_slices()`. |
||
| 14 |
- stop("Please install 'shinytest2' package to use this class.")
+ #' |
||
| 15 |
- }+ #' During a session only new filters are added to `all_slices` unless [`module_snapshot_manager`] is |
||
| 16 |
- if (!requireNamespace("rvest", quietly = TRUE)) {
+ #' used to restore previous state. Filters from `all_slices` can be activated or deactivated in a |
||
| 17 |
- stop("Please install 'rvest' package to use this class.")
+ #' module which is linked (both ways) by `attr(, "mapping")` so that: |
||
| 18 |
- }+ #' - If module's filter is added or removed in its `FilteredData` object, this information is passed |
||
| 19 |
- shinytest2::AppDriver+ #' to `SlicesGlobal` which updates `attr(, "mapping")` accordingly. |
||
| 20 |
- },+ #' - When mapping changes in a `SlicesGlobal`, filters are set or removed from module's |
||
| 21 |
- # public methods ----+ #' `FilteredData`. |
||
| 22 |
- public = list(+ #' |
||
| 23 |
- #' @description+ #' @section Filter manager: |
||
| 24 |
- #' Initialize a `TealAppDriver` object for testing a `teal` application.+ #' Filter-manager is split into two parts: |
||
| 25 |
- #'+ #' 1. `ui/srv_filter_manager_panel` - Called once for the whole app. This module observes changes in |
||
| 26 |
- #' @param data,modules,filter,title,header,footer,landing_popup arguments passed to `init`+ #' the filters in `slices_global` and displays them in a table utilizing information from `mapping`: |
||
| 27 |
- #' @param timeout (`numeric`) Default number of milliseconds for any timeout or+ #' - (`TRUE`) - filter is active in the module |
||
| 28 |
- #' timeout_ parameter in the `TealAppDriver` class.+ #' - (`FALSE`) - filter is inactive in the module |
||
| 29 |
- #' Defaults to 20s.+ #' - (`NA`) - filter is not available in the module |
||
| 30 |
- #'+ #' 2. `ui/srv_module_filter_manager` - Called once for each `teal_module`. Handling filter states |
||
| 31 |
- #' See [`shinytest2::AppDriver`] `new` method for more details on how to change it+ #' for of single module and keeping module `FilteredData` consistent with `slices_global`, so that |
||
| 32 |
- #' via options or environment variables.+ #' local filters are always reflected in the `slices_global` and its mapping and vice versa. |
||
| 33 |
- #' @param load_timeout (`numeric`) How long to wait for the app to load, in ms.+ #' |
||
| 34 |
- #' This includes the time to start R. Defaults to 100s.+ #' |
||
| 35 |
- #'+ #' @param id (`character(1)`) |
||
| 36 |
- #' See [`shinytest2::AppDriver`] `new` method for more details on how to change it+ #' `shiny` module instance id. |
||
| 37 |
- #' via options or environment variables+ #' |
||
| 38 |
- #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$new`+ #' @param slices_global (`reactiveVal`) |
||
| 39 |
- #'+ #' containing `teal_slices`. |
||
| 40 |
- #'+ #' |
||
| 41 |
- #' @return Object of class `TealAppDriver`+ #' @param module_fd (`FilteredData`) |
||
| 42 |
- initialize = function(data,+ #' Object containing the data to be filtered in a single `teal` module. |
||
| 43 |
- modules,+ #' |
||
| 44 |
- filter = teal_slices(),+ #' @return |
||
| 45 |
- title = build_app_title(),+ #' Module returns a `slices_global` (`reactiveVal`) containing a `teal_slices` object with mapping. |
||
| 46 |
- header = tags$p(),+ #' |
||
| 47 |
- footer = tags$p(),+ #' @encoding UTF-8 |
||
| 48 |
- landing_popup = NULL,+ #' |
||
| 49 |
- timeout = rlang::missing_arg(),+ #' @name module_filter_manager |
||
| 50 |
- load_timeout = rlang::missing_arg(),+ #' @rdname module_filter_manager |
||
| 51 |
- ...) {
+ #' |
||
| 52 | -! | +
- private$data <- data+ NULL |
|
| 53 | -! | +
- private$modules <- modules+ |
|
| 54 | -! | +
- private$filter <- filter+ #' @rdname module_filter_manager |
|
| 55 | -! | +
- app <- init(+ ui_filter_manager_panel <- function(id) {
|
|
| 56 | ! |
- data = data,+ ns <- NS(id) |
|
| 57 | ! |
- modules = modules,+ tags$button( |
|
| 58 | ! |
- filter = filter,+ id = ns("show_filter_manager"),
|
|
| 59 | ! |
- title = title,+ class = "btn action-button wunder_bar_button", |
|
| 60 | ! |
- header = header,+ title = "View filter mapping", |
|
| 61 | ! |
- footer = footer,+ suppressMessages(icon("fas fa-grip"))
|
|
| 62 | -! | +
- landing_popup = landing_popup,+ ) |
|
| 63 |
- )+ } |
||
| 65 |
- # Default timeout is hardcoded to 4s in shinytest2:::resolve_timeout+ #' @rdname module_filter_manager |
||
| 66 |
- # It must be set as parameter to the AppDriver+ #' @keywords internal |
||
| 67 | -! | +
- suppressWarnings(+ srv_filter_manager_panel <- function(id, slices_global) {
|
|
| 68 | -! | +87x |
- super$initialize(+ checkmate::assert_string(id) |
| 69 | -! | +87x |
- app_dir = shinyApp(app$ui, app$server),+ checkmate::assert_class(slices_global, ".slicesGlobal") |
| 70 | -! | +87x |
- name = "teal",+ moduleServer(id, function(input, output, session) {
|
| 71 | -! | +87x |
- variant = shinytest2::platform_variant(),+ setBookmarkExclude(c("show_filter_manager"))
|
| 72 | -! | +87x |
- timeout = rlang::maybe_missing(timeout, 20 * 1000),+ observeEvent(input$show_filter_manager, {
|
| 73 | ! |
- load_timeout = rlang::maybe_missing(load_timeout, 100 * 1000),+ logger::log_debug("srv_filter_manager_panel@1 show_filter_manager button has been clicked.")
|
|
| 74 | -+ | ! |
- ...+ showModal( |
| 75 | -+ | ! |
- )+ modalDialog( |
| 76 | -+ | ! |
- )+ ui_filter_manager(session$ns("filter_manager")),
|
| 77 | -+ | ! |
-
+ class = "filter_manager_modal", |
| 78 | -+ | ! |
- # Check for minimum version of Chrome that supports the tests+ size = "l", |
| 79 | -+ | ! |
- # - Element.checkVisibility was added on 105+ footer = NULL, |
| 80 | ! |
- chrome_version <- numeric_version(+ easyClose = TRUE |
|
| 81 | -! | +
- gsub(+ ) |
|
| 82 | -! | +
- "[[:alnum:]_]+/", # Prefix that ends with forward slash+ ) |
|
| 83 |
- "",+ }) |
||
| 84 | -! | +87x |
- self$get_chromote_session()$Browser$getVersion()$product+ srv_filter_manager("filter_manager", slices_global = slices_global)
|
| 85 |
- ),+ }) |
||
| 86 | -! | +
- strict = FALSE+ } |
|
| 87 |
- )+ |
||
| 88 |
-
+ #' @rdname module_filter_manager |
||
| 89 | -! | +
- required_version <- "121"+ ui_filter_manager <- function(id) {
|
|
| 90 | -+ | ! |
-
+ ns <- NS(id) |
| 91 | ! |
- testthat::skip_if(+ actionButton(ns("filter_manager"), NULL, icon = icon("fas fa-filter"))
|
|
| 92 | ! |
- is.na(chrome_version),+ tags$div( |
|
| 93 | ! |
- "Problem getting Chrome version, please contact the developers."+ class = "filter_manager_content", |
|
| 94 | -+ | ! |
- )+ tableOutput(ns("slices_table"))
|
| 95 | -! | +
- testthat::skip_if(+ ) |
|
| 96 | -! | +
- chrome_version < required_version,+ } |
|
| 97 | -! | +
- sprintf(+ |
|
| 98 | -! | +
- "Chrome version '%s' is not supported, please upgrade to '%s' or higher",+ #' @rdname module_filter_manager |
|
| 99 | -! | +
- chrome_version,+ srv_filter_manager <- function(id, slices_global) {
|
|
| 100 | -! | +87x |
- required_version+ checkmate::assert_string(id) |
| 101 | -+ | 87x |
- )+ checkmate::assert_class(slices_global, ".slicesGlobal") |
| 102 |
- )+ |
||
| 103 | -+ | 87x |
- # end od check+ moduleServer(id, function(input, output, session) {
|
| 104 | -+ | 87x |
-
+ logger::log_debug("filter_manager_srv initializing.")
|
| 105 | -! | +
- private$set_active_ns()+ |
|
| 106 | -! | +
- self$wait_for_idle()+ # Bookmark slices global with mapping. |
|
| 107 | -+ | 87x |
- },+ session$onBookmark(function(state) {
|
| 108 | -+ | ! |
- #' @description+ logger::log_debug("filter_manager_srv@onBookmark: storing filter state")
|
| 109 | -+ | ! |
- #' Append parent [`shinytest2::AppDriver`] `click` method with a call to `waif_for_idle()` method.+ state$values$filter_state_on_bookmark <- as.list( |
| 110 | -+ | ! |
- #' @param ... arguments passed to parent [`shinytest2::AppDriver`] `click()` method.+ slices_global$all_slices(), |
| 111 | -+ | ! |
- click = function(...) {
+ recursive = TRUE |
| 112 | -! | +
- super$click(...)+ ) |
|
| 113 | -! | +
- private$wait_for_page_stability()+ }) |
|
| 114 |
- },+ |
||
| 115 | -+ | 87x |
- #' @description+ bookmarked_slices <- restoreValue(session$ns("filter_state_on_bookmark"), NULL)
|
| 116 | -+ | 87x |
- #' Check if the app has shiny errors. This checks for global shiny errors.+ if (!is.null(bookmarked_slices)) {
|
| 117 | -+ | ! |
- #' Note that any shiny errors dependent on shiny server render will only be captured after the teal module tab+ logger::log_debug("filter_manager_srv: restoring filter state from bookmark.")
|
| 118 | -+ | ! |
- #' is visited because shiny will not trigger server computations when the tab is invisible.+ slices_global$slices_set(bookmarked_slices) |
| 119 |
- #' So, navigate to the module tab you want to test before calling this function.+ } |
||
| 120 |
- #' Although, this catches errors hidden in the other module tabs if they are already rendered.+ |
||
| 121 | -+ | 87x |
- expect_no_shiny_error = function() {
+ mapping_table <- reactive({
|
| 122 | -! | +
- testthat::expect_null(+ # We want this to be reactive on slices_global$all_slices() only as get_available_teal_slices() |
|
| 123 | -! | +
- self$get_html(".shiny-output-error:not(.shiny-output-error-validation)"),
+ # is dependent on slices_global$all_slices(). |
|
| 124 | -! | +96x |
- info = "Shiny error is observed"+ module_labels <- setdiff( |
| 125 | -+ | 96x |
- )+ names(attr(slices_global$all_slices(), "mapping")), |
| 126 | -+ | 96x |
- },+ "Report previewer" |
| 127 |
- #' @description+ ) |
||
| 128 | -+ | 96x |
- #' Check if the app has no validation errors. This checks for global shiny validation errors.+ isolate({
|
| 129 | -+ | 96x |
- expect_no_validation_error = function() {
+ mm <- as.data.frame( |
| 130 | -! | +96x |
- testthat::expect_null(+ sapply( |
| 131 | -! | +96x |
- self$get_html(".shiny-output-error-validation"),
+ module_labels, |
| 132 | -! | +96x |
- info = "No validation error is observed"+ simplify = FALSE, |
| 133 | -+ | 96x |
- )+ function(module_label) {
|
| 134 | -+ | 109x |
- },+ available_slices <- slices_global$module_slices_api[[module_label]]$get_available_teal_slices() |
| 135 | -+ | 101x |
- #' @description+ global_ids <- sapply(slices_global$all_slices(), `[[`, "id", simplify = FALSE) |
| 136 | -+ | 101x |
- #' Check if the app has validation errors. This checks for global shiny validation errors.+ module_ids <- sapply(slices_global$slices_get(module_label), `[[`, "id", simplify = FALSE) |
| 137 | -+ | 101x |
- expect_validation_error = function() {
+ allowed_ids <- vapply(available_slices, `[[`, character(1L), "id") |
| 138 | -! | +101x |
- testthat::expect_false(+ active_ids <- global_ids %in% module_ids |
| 139 | -! | +101x |
- is.null(self$get_html(".shiny-output-error-validation")),
+ setNames(nm = global_ids, ifelse(global_ids %in% allowed_ids, active_ids, NA)) |
| 140 | -! | +
- info = "Validation error is not observed"+ } |
|
| 141 |
- )+ ), |
||
| 142 | -+ | 96x |
- },+ check.names = FALSE |
| 143 |
- #' @description+ ) |
||
| 144 | -+ | 88x |
- #' Set the input in the `teal` app.+ colnames(mm)[colnames(mm) == "global_filters"] <- "Global filters" |
| 145 |
- #'+ |
||
| 146 | -+ | 88x |
- #' @param input_id (character) The shiny input id with it's complete name space.+ mm |
| 147 |
- #' @param value The value to set the input to.+ }) |
||
| 148 |
- #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$set_inputs`+ }) |
||
| 149 |
- #'+ |
||
| 150 | -+ | 87x |
- #' @return The `TealAppDriver` object invisibly.+ output$slices_table <- renderTable( |
| 151 | -+ | 87x |
- set_input = function(input_id, value, ...) {
+ expr = {
|
| 152 | -! | +96x |
- do.call(+ logger::log_debug("filter_manager_srv@1 rendering slices_table.")
|
| 153 | -! | +96x |
- self$set_inputs,+ mm <- mapping_table() |
| 154 | -! | +
- c(setNames(list(value), input_id), list(...))+ |
|
| 155 |
- )+ # Display logical values as UTF characters. |
||
| 156 | -! | +88x |
- invisible(self)+ mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060)) |
| 157 | -+ | 88x |
- },+ mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x)) |
| 158 |
- #' @description+ |
||
| 159 |
- #' Navigate the teal tabs in the `teal` app.+ # Display placeholder if no filters defined. |
||
| 160 | -+ | 88x |
- #'+ if (nrow(mm) == 0L) {
|
| 161 | -+ | 64x |
- #' @param tabs (character) Labels of tabs to navigate to. The order of the tabs is important,+ mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE) |
| 162 | -+ | 64x |
- #' and it should start with the most parent level tab.+ rownames(mm) <- "" |
| 163 |
- #' Note: In case the teal tab group has duplicate names, the first tab will be selected,+ } |
||
| 164 | -+ | 88x |
- #' If you wish to select the second tab with the same name, use the suffix "_1".+ mm |
| 165 |
- #' If you wish to select the third tab with the same name, use the suffix "_2" and so on.+ }, |
||
| 166 | -+ | 87x |
- #'+ rownames = TRUE |
| 167 |
- #' @return The `TealAppDriver` object invisibly.+ ) |
||
| 168 |
- navigate_teal_tab = function(tabs) {
+
|
||
| 169 | -! | +87x |
- checkmate::check_character(tabs, min.len = 1)+ mapping_table # for testing purpose |
| 170 | -! | +
- for (tab in tabs) {
+ }) |
|
| 171 | -! | +
- self$set_input(+ } |
|
| 172 | -! | +
- "teal-teal_modules-active_tab",+ |
|
| 173 | -! | +
- get_unique_labels(tab),+ #' @rdname module_filter_manager |
|
| 174 | -! | +
- wait_ = FALSE+ srv_module_filter_manager <- function(id, module_fd, slices_global) {
|
|
| 175 | -+ | 112x |
- )+ checkmate::assert_string(id) |
| 176 | -+ | 112x |
- }+ assert_reactive(module_fd) |
| 177 | -! | +112x |
- self$wait_for_idle()+ checkmate::assert_class(slices_global, ".slicesGlobal") |
| 178 | -! | +
- private$set_active_ns()+ |
|
| 179 | -! | +112x |
- invisible(self)+ moduleServer(id, function(input, output, session) {
|
| 180 | -+ | 112x |
- },+ logger::log_debug("srv_module_filter_manager initializing for module: { id }.")
|
| 181 |
- #' @description+ # Track filter global and local states. |
||
| 182 | -+ | 112x |
- #' Get the active shiny name space for different components of the teal app.+ slices_global_module <- reactive({
|
| 183 | -+ | 201x |
- #'+ slices_global$slices_get(module_label = id) |
| 184 |
- #' @return (`list`) The list of active shiny name space of the teal components.+ }) |
||
| 185 | -+ | 112x |
- active_ns = function() {
+ slices_module <- reactive(req(module_fd())$get_filter_state()) |
| 186 | -! | +
- if (identical(private$ns$module, character(0))) {
+
|
|
| 187 | -! | +112x |
- private$set_active_ns()+ module_fd_previous <- reactiveVal(NULL) |
| 188 |
- }+ |
||
| 189 | -! | +
- private$ns+ # Set (reactively) available filters for the module. |
|
| 190 | -+ | 112x |
- },+ obs1 <- observeEvent(module_fd(), priority = 1, {
|
| 191 | -+ | 93x |
- #' @description+ logger::log_debug("srv_module_filter_manager@1 setting initial slices for module: { id }.")
|
| 192 |
- #' Get the active shiny name space for interacting with the module content.+ # Filters relevant for the module in module-specific app. |
||
| 193 | -+ | 93x |
- #'+ slices <- slices_global_module() |
| 194 |
- #' @return (`string`) The active shiny name space of the component.+ |
||
| 195 |
- active_module_ns = function() {
+ # Clean up previous filter states and refresh cache of previous module_fd with current |
||
| 196 | -! | +3x |
- if (identical(private$ns$module, character(0))) {
+ if (!is.null(module_fd_previous())) module_fd_previous()$finalize() |
| 197 | -! | +93x |
- private$set_active_ns()+ module_fd_previous(module_fd()) |
| 198 |
- }+ |
||
| 199 | -! | +
- private$ns$module+ # Setting filter states from slices_global: |
|
| 200 |
- },+ # 1. when app initializes slices_global set to initial filters (specified by app developer) |
||
| 201 |
- #' @description+ # 2. when data reinitializes slices_global reflects latest filter states |
||
| 202 |
- #' Get the active shiny name space bound with a custom `element` name.+ |
||
| 203 | -+ | 93x |
- #'+ module_fd()$set_filter_state(slices) |
| 204 |
- #' @param element `character(1)` custom element name.+ |
||
| 205 |
- #'+ # irrelevant filters are discarded in FilteredData$set_available_teal_slices |
||
| 206 |
- #' @return (`string`) The active shiny name space of the component bound with the input `element`.+ # it means we don't need to subset slices_global$all_slices() from filters refering to irrelevant datasets |
||
| 207 | -+ | 93x |
- active_module_element = function(element) {
+ module_fd()$set_available_teal_slices(slices_global$all_slices) |
| 208 | -! | +
- checkmate::assert_string(element)+ |
|
| 209 | -! | +
- sprintf("#%s-%s", self$active_module_ns(), element)
+ # this needed in filter_manager_srv |
|
| 210 | -+ | 93x |
- },+ slices_global$module_slices_api_set( |
| 211 | -+ | 93x |
- #' @description+ id, |
| 212 | -+ | 93x |
- #' Get the text of the active shiny name space bound with a custom `element` name.+ list( |
| 213 | -+ | 93x |
- #'+ get_available_teal_slices = module_fd()$get_available_teal_slices(), |
| 214 | -+ | 93x |
- #' @param element `character(1)` the text of the custom element name.+ set_filter_state = module_fd()$set_filter_state, # for testing purpose |
| 215 | -+ | 93x |
- #'+ get_filter_state = module_fd()$get_filter_state # for testing purpose |
| 216 |
- #' @return (`string`) The text of the active shiny name space of the component bound with the input `element`.+ ) |
||
| 217 |
- active_module_element_text = function(element) {
+ ) |
||
| 218 | -! | +
- checkmate::assert_string(element)+ }) |
|
| 219 | -! | +
- self$get_text(self$active_module_element(element))+ |
|
| 220 |
- },+ # Update global state and mapping matrix when module filters change. |
||
| 221 | -+ | 112x |
- #' @description+ obs2 <- observeEvent(slices_module(), priority = 0, {
|
| 222 | -+ | 113x |
- #' Get the active shiny name space for interacting with the filter panel.+ this_slices <- slices_module() |
| 223 | -+ | 113x |
- #'+ slices_global$slices_append(this_slices) # append new slices to the all_slices list |
| 224 | -+ | 113x |
- #' @return (`string`) The active shiny name space of the component.+ mapping_elem <- setNames(nm = id, list(vapply(this_slices, `[[`, character(1L), "id"))) |
| 225 | -+ | 113x |
- active_filters_ns = function() {
+ slices_global$slices_active(mapping_elem) |
| 226 | -! | +
- if (identical(private$ns$filter_panel, character(0))) {
+ }) |
|
| 227 | -! | +
- private$set_active_ns()+ |
|
| 228 | -+ | 112x |
- }+ obs3 <- observeEvent(slices_global_module(), {
|
| 229 | -! | +135x |
- private$ns$filter_panel+ global_vs_module <- setdiff_teal_slices(slices_global_module(), slices_module()) |
| 230 | -+ | 135x |
- },+ module_vs_global <- setdiff_teal_slices(slices_module(), slices_global_module()) |
| 231 | -+ | 126x |
- #' @description+ if (length(global_vs_module) || length(module_vs_global)) {
|
| 232 |
- #' Get the active shiny name space for interacting with the data-summary panel.+ # Comment: (Nota Bene) Normally new filters for a module are added through module-filter-panel, and slices |
||
| 233 |
- #'+ # global are updated automatically so slices_module -> slices_global_module are equal. |
||
| 234 |
- #' @return (`string`) The active shiny name space of the data-summary component.+ # this if is valid only when a change is made on the global level so the change needs to be propagated down |
||
| 235 |
- active_data_summary_ns = function() {
+ # to the module (for example through snapshot manager). If it happens both slices are different |
||
| 236 | -! | +13x |
- if (identical(private$ns$data_summary, character(0))) {
+ logger::log_debug("srv_module_filter_manager@3 (N.B.) global state has changed for a module:{ id }.")
|
| 237 | -! | +13x |
- private$set_active_ns()+ module_fd()$clear_filter_states() |
| 238 | -+ | 13x |
- }+ module_fd()$set_filter_state(slices_global_module()) |
| 239 | -! | +
- private$ns$data_summary+ } |
|
| 240 |
- },+ }) |
||
| 241 |
- #' @description+ |
||
| 242 | -+ | 112x |
- #' Get the active shiny name space bound with a custom `element` name.+ slices_module # returned for testing purpose |
| 243 |
- #'+ }) |
||
| 244 |
- #' @param element `character(1)` custom element name.+ } |
||
| 245 |
- #'+ |
||
| 246 |
- #' @return (`string`) The active shiny name space of the component bound with the input `element`.+ #' @importFrom shiny reactiveVal reactiveValues |
||
| 247 |
- active_data_summary_element = function(element) {
+ methods::setOldClass("reactiveVal")
|
||
| 248 | -! | +
- checkmate::assert_string(element)+ methods::setOldClass("reactivevalues")
|
|
| 249 | -! | +
- sprintf("#%s-%s", self$active_data_summary_ns(), element)
+
|
|
| 250 |
- },+ #' @importFrom methods new |
||
| 251 |
- #' @description+ #' @rdname module_filter_manager |
||
| 252 |
- #' Get the input from the module in the `teal` app.+ .slicesGlobal <- methods::setRefClass(".slicesGlobal", # nolint: object_name.
|
||
| 253 |
- #' This function will only access inputs from the name space of the current active teal module.+ fields = list( |
||
| 254 |
- #'+ all_slices = "reactiveVal", |
||
| 255 |
- #' @param input_id (character) The shiny input id to get the value from.+ module_slices_api = "reactivevalues" |
||
| 256 |
- #'+ ), |
||
| 257 |
- #' @return The value of the shiny input.+ methods = list( |
||
| 258 |
- get_active_module_input = function(input_id) {
+ initialize = function(slices = teal_slices(), module_labels) {
|
||
| 259 | -! | +87x |
- checkmate::check_string(input_id)+ shiny::isolate({
|
| 260 | -! | +87x |
- self$get_value(input = sprintf("%s-%s", self$active_module_ns(), input_id))
+ checkmate::assert_class(slices, "teal_slices") |
| 261 |
- },+ # needed on init to not mix "global_filters" with module-specific-slots |
||
| 262 | -+ | 87x |
- #' @description+ if (isTRUE(attr(slices, "module_specific"))) {
|
| 263 | -+ | 11x |
- #' Get the output from the module in the `teal` app.+ old_mapping <- attr(slices, "mapping") |
| 264 | -+ | 11x |
- #' This function will only access outputs from the name space of the current active teal module.+ new_mapping <- sapply(module_labels, simplify = FALSE, function(module_label) {
|
| 265 | -+ | 20x |
- #'+ unique(unlist(old_mapping[c(module_label, "global_filters")])) |
| 266 |
- #' @param output_id (character) The shiny output id to get the value from.+ }) |
||
| 267 | -+ | 11x |
- #'+ attr(slices, "mapping") <- new_mapping |
| 268 |
- #' @return The value of the shiny output.+ } |
||
| 269 | -+ | 87x |
- get_active_module_output = function(output_id) {
+ .self$all_slices <<- shiny::reactiveVal(slices) |
| 270 | -! | +87x |
- checkmate::check_string(output_id)+ .self$module_slices_api <<- shiny::reactiveValues() |
| 271 | -! | +87x |
- self$get_value(output = sprintf("%s-%s", self$active_module_ns(), output_id))
+ .self$slices_append(slices) |
| 272 | -+ | 87x |
- },+ .self$slices_active(attr(slices, "mapping")) |
| 273 | -+ | 87x |
- #' @description+ invisible(.self) |
| 274 |
- #' Get the output from the module's `teal.widgets::table_with_settings` or `DT::DTOutput` in the `teal` app.+ }) |
||
| 275 |
- #' This function will only access outputs from the name space of the current active teal module.+ }, |
||
| 276 |
- #'+ is_module_specific = function() {
|
||
| 277 | -+ | 296x |
- #' @param table_id (`character(1)`) The id of the table in the active teal module's name space.+ isTRUE(attr(.self$all_slices(), "module_specific")) |
| 278 |
- #' @param which (integer) If there is more than one table, which should be extracted.+ }, |
||
| 279 |
- #' By default it will look for a table that is built using `teal.widgets::table_with_settings`.+ module_slices_api_set = function(module_label, functions_list) {
|
||
| 280 | -+ | 93x |
- #'+ shiny::isolate({
|
| 281 | -+ | 93x |
- #' @return The data.frame with table contents.+ if (!.self$is_module_specific()) {
|
| 282 | -+ | 77x |
- get_active_module_table_output = function(table_id, which = 1) {
+ module_label <- "global_filters" |
| 283 | -! | +
- checkmate::check_number(which, lower = 1)+ } |
|
| 284 | -! | +93x |
- checkmate::check_string(table_id)+ if (!identical(.self$module_slices_api[[module_label]], functions_list)) {
|
| 285 | -! | +93x |
- table <- rvest::html_table(+ .self$module_slices_api[[module_label]] <- functions_list |
| 286 | -! | +
- self$get_html_rvest(self$active_module_element(table_id)),+ } |
|
| 287 | -! | +93x |
- fill = TRUE+ invisible(.self) |
| 288 |
- )+ }) |
||
| 289 | -! | +
- if (length(table) == 0) {
+ }, |
|
| 290 | -! | +
- data.frame()+ slices_deactivate_all = function(module_label) {
|
|
| 291 | -+ | ! |
- } else {
+ shiny::isolate({
|
| 292 | ! |
- table[[which]]+ new_slices <- .self$all_slices() |
|
| 293 | -+ | ! |
- }+ old_mapping <- attr(new_slices, "mapping") |
| 294 |
- },+ |
||
| 295 | -+ | ! |
- #' @description+ new_mapping <- if (.self$is_module_specific()) {
|
| 296 | -+ | ! |
- #' Get the output from the module's `teal.widgets::plot_with_settings` in the `teal` app.+ new_module_mapping <- setNames(nm = module_label, list(character(0))) |
| 297 | -+ | ! |
- #' This function will only access plots from the name space of the current active teal module.+ modifyList(old_mapping, new_module_mapping) |
| 298 | -+ | ! |
- #'+ } else if (missing(module_label)) {
|
| 299 | -+ | ! |
- #' @param plot_id (`character(1)`) The id of the plot in the active teal module's name space.+ lapply( |
| 300 | -+ | ! |
- #'+ attr(.self$all_slices(), "mapping"), |
| 301 | -+ | ! |
- #' @return The `src` attribute as `character(1)` vector.+ function(x) character(0) |
| 302 |
- get_active_module_plot_output = function(plot_id) {
+ ) |
||
| 303 | -! | +
- checkmate::check_string(plot_id)+ } else {
|
|
| 304 | ! |
- self$get_attr(+ old_mapping[[module_label]] <- character(0) |
|
| 305 | ! |
- self$active_module_element(sprintf("%s-plot_main > img", plot_id)),
+ old_mapping |
|
| 306 | -! | +
- "src"+ } |
|
| 307 |
- )+ |
||
| 308 | -+ | ! |
- },+ if (!identical(new_mapping, old_mapping)) {
|
| 309 | -+ | ! |
- #' @description+ logger::log_debug(".slicesGlobal@slices_deactivate_all: deactivating all slices.")
|
| 310 | -+ | ! |
- #' Set the input in the module in the `teal` app.+ attr(new_slices, "mapping") <- new_mapping |
| 311 | -+ | ! |
- #' This function will only set inputs in the name space of the current active teal module.+ .self$all_slices(new_slices) |
| 312 |
- #'+ } |
||
| 313 | -+ | ! |
- #' @param input_id (character) The shiny input id to get the value from.+ invisible(.self) |
| 314 |
- #' @param value The value to set the input to.+ }) |
||
| 315 |
- #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$set_inputs`+ }, |
||
| 316 |
- #'+ slices_active = function(mapping_elem) {
|
||
| 317 | -+ | 203x |
- #' @return The `TealAppDriver` object invisibly.+ shiny::isolate({
|
| 318 | -+ | 203x |
- set_active_module_input = function(input_id, value, ...) {
+ if (.self$is_module_specific()) {
|
| 319 | -! | +36x |
- checkmate::check_string(input_id)+ new_mapping <- modifyList(attr(.self$all_slices(), "mapping"), mapping_elem) |
| 320 | -! | +
- checkmate::check_string(value)+ } else {
|
|
| 321 | -! | +167x |
- self$set_input(+ new_mapping <- setNames(nm = "global_filters", list(unique(unlist(mapping_elem)))) |
| 322 | -! | +
- sprintf("%s-%s", self$active_module_ns(), input_id),
+ } |
|
| 323 | -! | +
- value,+ |
|
| 324 | -+ | 203x |
- ...+ if (!identical(new_mapping, attr(.self$all_slices(), "mapping"))) {
|
| 325 | -+ | 146x |
- )+ mapping_modules <- toString(names(new_mapping)) |
| 326 | -! | +146x |
- dots <- rlang::list2(...)+ logger::log_debug(".slicesGlobal@slices_active: changing mapping for module(s): { mapping_modules }.")
|
| 327 | -! | +146x |
- if (!isFALSE(dots[["wait"]])) self$wait_for_idle() # Default behavior is to wait+ new_slices <- .self$all_slices() |
| 328 | -! | +146x |
- invisible(self)+ attr(new_slices, "mapping") <- new_mapping |
| 329 | -+ | 146x |
- },+ .self$all_slices(new_slices) |
| 330 |
- #' @description+ } |
||
| 331 |
- #' Get the active datasets that can be accessed via the filter panel of the current active teal module.+ |
||
| 332 | -+ | 203x |
- get_active_filter_vars = function() {
+ invisible(.self) |
| 333 | -! | +
- displayed_datasets_index <- self$is_visible(+ }) |
|
| 334 | -! | +
- sprintf("#%s-filters-filter_active_vars_contents > span", self$active_filters_ns())
+ }, |
|
| 335 |
- )+ # - only new filters are appended to the $all_slices |
||
| 336 |
-
+ # - mapping is not updated here |
||
| 337 | -! | +
- available_datasets <- self$get_text(+ slices_append = function(slices, activate = FALSE) {
|
|
| 338 | -! | +203x |
- sprintf(+ shiny::isolate({
|
| 339 | -! | +203x |
- "#%s-filters-filter_active_vars_contents .filter_panel_dataname",+ if (!is.teal_slices(slices)) {
|
| 340 | ! |
- self$active_filters_ns()+ slices <- as.teal_slices(slices) |
|
| 341 |
- )+ } |
||
| 342 |
- )+ |
||
| 343 |
-
+ # to make sure that we don't unnecessary trigger $all_slices <reactiveVal> |
||
| 344 | -! | +203x |
- available_datasets[displayed_datasets_index]+ new_slices <- setdiff_teal_slices(slices, .self$all_slices()) |
| 345 | -+ | 203x |
- },+ old_mapping <- attr(.self$all_slices(), "mapping") |
| 346 | -+ | 203x |
- #' @description+ if (length(new_slices)) {
|
| 347 | -+ | 6x |
- #' Get the active data summary table+ new_ids <- vapply(new_slices, `[[`, character(1L), "id") |
| 348 | -+ | 6x |
- #' @return `data.frame`+ logger::log_debug(".slicesGlobal@slices_append: appending new slice(s): { new_ids }.")
|
| 349 | -+ | 6x |
- get_active_data_summary_table = function() {
+ slices_ids <- vapply(.self$all_slices(), `[[`, character(1L), "id") |
| 350 | -! | +6x |
- summary_table <- rvest::html_table(+ lapply(new_slices, function(slice) {
|
| 351 | -! | +
- self$get_html_rvest(self$active_data_summary_element("table")),
+ # In case the new state has the same id as an existing one, add a suffix |
|
| 352 | -! | +6x |
- fill = TRUE+ if (slice$id %in% slices_ids) {
|
| 353 | -! | +1x |
- )[[1]]+ slice$id <- utils::tail(make.unique(c(slices_ids, slice$id), sep = "_"), 1) |
| 354 |
-
+ } |
||
| 355 | -! | +
- col_names <- unlist(summary_table[1, ], use.names = FALSE)+ }) |
|
| 356 | -! | +
- summary_table <- summary_table[-1, ]+ |
|
| 357 | -! | +6x |
- colnames(summary_table) <- col_names+ new_slices_all <- c(.self$all_slices(), new_slices) |
| 358 | -! | +6x |
- if (nrow(summary_table) > 0) {
+ attr(new_slices_all, "mapping") <- old_mapping |
| 359 | -! | +6x |
- summary_table+ .self$all_slices(new_slices_all) |
| 360 |
- } else {
+ } |
||
| 361 | -! | +
- NULL+ |
|
| 362 | -+ | 203x |
- }+ invisible(.self) |
| 363 |
- },+ }) |
||
| 364 |
- #' @description+ }, |
||
| 365 |
- #' Test if `DOM` elements are visible on the page with a JavaScript call.+ slices_get = function(module_label) {
|
||
| 366 | -+ | 302x |
- #' @param selector (`character(1)`) `CSS` selector to check visibility.+ if (missing(module_label)) {
|
| 367 | -+ | ! |
- #' A `CSS` id will return only one element if the UI is well formed.+ .self$all_slices() |
| 368 |
- #' @param content_visibility_auto,opacity_property,visibility_property (`logical(1)`) See more information+ } else {
|
||
| 369 | -+ | 302x |
- #' on <https://developer.mozilla.org/en-US/docs/Web/API/Element/checkVisibility>.+ module_ids <- unlist(attr(.self$all_slices(), "mapping")[c(module_label, "global_filters")]) |
| 370 | -+ | 302x |
- #'+ Filter( |
| 371 | -+ | 302x |
- #' @return Logical vector with all occurrences of the selector.+ function(slice) slice$id %in% module_ids, |
| 372 | -+ | 302x |
- is_visible = function(selector,+ .self$all_slices() |
| 373 |
- content_visibility_auto = FALSE,+ ) |
||
| 374 |
- opacity_property = FALSE,+ } |
||
| 375 |
- visibility_property = FALSE) {
+ }, |
||
| 376 | -! | +
- checkmate::assert_string(selector)+ slices_set = function(slices) {
|
|
| 377 | -! | +7x |
- checkmate::assert_flag(content_visibility_auto)+ shiny::isolate({
|
| 378 | -! | +7x |
- checkmate::assert_flag(opacity_property)+ if (!is.teal_slices(slices)) {
|
| 379 | ! |
- checkmate::assert_flag(visibility_property)+ slices <- as.teal_slices(slices) |
|
| 380 |
-
+ } |
||
| 381 | -! | +7x |
- private$wait_for_page_stability()+ .self$all_slices(slices) |
| 382 | -+ | 7x |
-
+ invisible(.self) |
| 383 | -! | +
- testthat::skip_if_not(+ }) |
|
| 384 | -! | +
- self$get_js("typeof Element.prototype.checkVisibility === 'function'"),
+ }, |
|
| 385 | -! | +
- "Element.prototype.checkVisibility is not supported in the current browser."+ show = function() {
|
|
| 386 | -+ | ! |
- )+ shiny::isolate(print(.self$all_slices())) |
| 387 | -+ | ! |
-
+ invisible(.self) |
| 388 | -! | +
- unlist(+ } |
|
| 389 | -! | +
- self$get_js(+ ) |
|
| 390 | -! | -
- sprintf(- |
- |
| 391 | -! | +
- "Array.from(document.querySelectorAll('%s')).map(el => el.checkVisibility({%s, %s, %s}))",
+ ) |
|
| 392 | -! | +
| 1 | +
- selector,+ #' An example `teal` module |
||
| 393 | +2 |
- # Extra parameters+ #' |
|
| 394 | -! | +||
| 3 | +
- sprintf("contentVisibilityAuto: %s", tolower(content_visibility_auto)),
+ #' `r lifecycle::badge("experimental")`
|
||
| 395 | -! | +||
| 4 | +
- sprintf("opacityProperty: %s", tolower(opacity_property)),
+ #' |
||
| 396 | -! | +||
| 5 | +
- sprintf("visibilityProperty: %s", tolower(visibility_property))
+ #' This module creates an object called `object` that can be modified with decorators. |
||
| 397 | +6 |
- )+ #' The `object` is determined by what's selected in `Choose a dataset` input in UI. |
|
| 398 | +7 |
- )+ #' The object can be anything that can be handled by `renderPrint()`. |
|
| 399 | +8 |
- )+ #' See the `vignette("decorate-modules-output", package = "teal")` or [`teal_transform_module`]
|
|
| 400 | +9 |
- },+ #' to read more about decorators. |
|
| 401 | +10 |
- #' @description+ #' |
|
| 402 | +11 |
- #' Get the active filter variables from a dataset in the `teal` app.+ #' @inheritParams teal_modules |
|
| 403 | +12 |
- #'+ #' @param decorators `r lifecycle::badge("experimental")` (`list` of `teal_transform_module` or `NULL`) optional,
|
|
| 404 | +13 |
- #' @param dataset_name (character) The name of the dataset to get the filter variables from.+ #' if not `NULL`, decorator for tables or plots included in the module. |
|
| 405 | +14 |
- #' If `NULL`, the filter variables for all the datasets will be returned in a list.+ #' |
|
| 406 | +15 |
- get_active_data_filters = function(dataset_name = NULL) {
+ #' @return A `teal` module which can be included in the `modules` argument to [init()]. |
|
| 407 | -! | +||
| 16 | +
- checkmate::check_string(dataset_name, null.ok = TRUE)+ #' @examples |
||
| 408 | -! | +||
| 17 | +
- datasets <- self$get_active_filter_vars()+ #' app <- init( |
||
| 409 | -! | +||
| 18 | +
- checkmate::assert_subset(dataset_name, datasets)+ #' data = teal_data(IRIS = iris, MTCARS = mtcars), |
||
| 410 | -! | +||
| 19 | +
- active_filters <- lapply(+ #' modules = example_module() |
||
| 411 | -! | +||
| 20 | +
- datasets,+ #' ) |
||
| 412 | -! | +||
| 21 | +
- function(x) {
+ #' if (interactive()) {
|
||
| 413 | -! | +||
| 22 | +
- var_names <- gsub(+ #' shinyApp(app$ui, app$server) |
||
| 414 | -! | +||
| 23 | +
- pattern = "\\s",+ #' } |
||
| 415 | -! | +||
| 24 | +
- replacement = "",+ #' @export |
||
| 416 | -! | +||
| 25 | +
- self$get_text(+ example_module <- function(label = "example teal module", |
||
| 417 | -! | +||
| 26 | +
- sprintf(+ datanames = "all", |
||
| 418 | -! | +||
| 27 | +
- "#%s-filters-%s .filter-card-varname",+ transformators = list(), |
||
| 419 | -! | +||
| 28 | +
- self$active_filters_ns(),+ decorators = NULL) {
|
||
| 420 | -! | +||
| 29 | +43x |
- x+ checkmate::assert_string(label) |
|
| 421 | -+ | ||
| 30 | +43x |
- )+ checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE) |
|
| 422 | +31 |
- )+ |
|
| 423 | -+ | ||
| 32 | +43x |
- )+ ans <- module( |
|
| 424 | -! | +||
| 33 | +43x |
- structure(+ label, |
|
| 425 | -! | +||
| 34 | +43x |
- lapply(var_names, private$get_active_filter_selection, dataset_name = x),+ server = function(id, data, decorators) {
|
|
| 426 | -! | +||
| 35 | +5x |
- names = var_names+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 427 | -+ | ||
| 36 | +5x |
- )+ moduleServer(id, function(input, output, session) {
|
|
| 428 | -+ | ||
| 37 | +5x |
- }+ datanames_rv <- reactive(names(req(data()))) |
|
| 429 | -+ | ||
| 38 | +5x |
- )+ observeEvent(datanames_rv(), {
|
|
| 430 | -! | +||
| 39 | +5x |
- names(active_filters) <- datasets+ selected <- input$dataname |
|
| 431 | -! | +||
| 40 | +5x |
- if (is.null(dataset_name)) {
+ if (identical(selected, "")) {
|
|
| 432 | +41 | ! |
- return(active_filters)+ selected <- restoreInput(session$ns("dataname"), NULL)
|
| 433 | -+ | ||
| 42 | +5x |
- }+ } else if (isFALSE(selected %in% datanames_rv())) {
|
|
| 434 | +43 | ! |
- active_filters[[dataset_name]]- |
-
| 435 | -- |
- },+ selected <- datanames_rv()[1] |
|
| 436 | +44 |
- #' @description+ } |
|
| 437 | -+ | ||
| 45 | +5x |
- #' Add a new variable from the dataset to be filtered.+ updateSelectInput( |
|
| 438 | -+ | ||
| 46 | +5x |
- #'+ session = session, |
|
| 439 | -+ | ||
| 47 | +5x |
- #' @param dataset_name (character) The name of the dataset to add the filter variable to.+ inputId = "dataname", |
|
| 440 | -+ | ||
| 48 | +5x |
- #' @param var_name (character) The name of the variable to add to the filter panel.+ choices = datanames_rv(), |
|
| 441 | -+ | ||
| 49 | +5x |
- #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$set_inputs`+ selected = selected |
|
| 442 | +50 |
- #'+ ) |
|
| 443 | +51 |
- #' @return The `TealAppDriver` object invisibly.+ }) |
|
| 444 | +52 |
- add_filter_var = function(dataset_name, var_name, ...) {
+
|
|
| 445 | -! | +||
| 53 | +5x |
- checkmate::check_string(dataset_name)+ table_data <- reactive({
|
|
| 446 | -! | +||
| 54 | +8x |
- checkmate::check_string(var_name)+ req(input$dataname) |
|
| 447 | -! | +||
| 55 | +3x |
- private$set_active_ns()+ within(data(), |
|
| 448 | -! | +||
| 56 | +
- self$click(+ {
|
||
| 449 | -! | +||
| 57 | +3x |
- selector = sprintf(+ object <- dataname |
|
| 450 | -! | +||
| 58 | +
- "#%s-filters-%s-add_filter_icon",+ }, |
||
| 451 | -! | +||
| 59 | +3x |
- private$ns$filter_panel,+ dataname = as.name(input$dataname) |
|
| 452 | -! | +||
| 60 | +
- dataset_name+ ) |
||
| 453 | +61 |
- )+ }) |
|
| 454 | +62 |
- )+ |
|
| 455 | -! | +||
| 63 | +5x |
- self$set_input(+ table_data_decorated_no_print <- srv_transform_teal_data( |
|
| 456 | -! | +||
| 64 | +5x |
- sprintf(+ "decorate", |
|
| 457 | -! | +||
| 65 | +5x |
- "%s-filters-%s-%s-filter-var_to_add",+ data = table_data, |
|
| 458 | -! | +||
| 66 | +5x |
- private$ns$filter_panel,+ transformators = decorators |
|
| 459 | -! | +||
| 67 | +
- dataset_name,+ ) |
||
| 460 | -! | +||
| 68 | +5x |
- dataset_name+ table_data_decorated <- reactive(within(req(table_data_decorated_no_print()), expr = object)) |
|
| 461 | +69 |
- ),+ |
|
| 462 | -! | +||
| 70 | +5x |
- var_name,+ output$text <- renderPrint({
|
|
| 463 | -+ | ||
| 71 | +9x |
- ...+ req(table_data()) # Ensure original errors from module are displayed |
|
| 464 | -+ | ||
| 72 | +4x |
- )+ table_data_decorated()[["object"]] |
|
| 465 | -! | +||
| 73 | +
- invisible(self)+ }) |
||
| 466 | +74 |
- },+ |
|
| 467 | -+ | ||
| 75 | +5x |
- #' @description+ teal.widgets::verbatim_popup_srv( |
|
| 468 | -+ | ||
| 76 | +5x |
- #' Remove an active filter variable of a dataset from the active filter variables panel.+ id = "rcode", |
|
| 469 | -+ | ||
| 77 | +5x |
- #'+ verbatim_content = reactive(teal.code::get_code(req(table_data_decorated()))), |
|
| 470 | -+ | ||
| 78 | +5x |
- #' @param dataset_name (character) The name of the dataset to remove the filter variable from.+ title = "Example Code" |
|
| 471 | +79 |
- #' If `NULL`, all the filter variables will be removed.+ ) |
|
| 472 | +80 |
- #' @param var_name (character) The name of the variable to remove from the filter panel.+ |
|
| 473 | -+ | ||
| 81 | +5x |
- #' If `NULL`, all the filter variables of the dataset will be removed.+ table_data_decorated |
|
| 474 | +82 |
- #'+ }) |
|
| 475 | +83 |
- #' @return The `TealAppDriver` object invisibly.+ }, |
|
| 476 | -+ | ||
| 84 | +43x |
- remove_filter_var = function(dataset_name = NULL, var_name = NULL) {
+ ui = function(id, decorators) {
|
|
| 477 | +85 | ! |
- checkmate::check_string(dataset_name, null.ok = TRUE)+ ns <- NS(id) |
| 478 | +86 | ! |
- checkmate::check_string(var_name, null.ok = TRUE)+ teal.widgets::standard_layout( |
| 479 | +87 | ! |
- if (is.null(dataset_name)) {
+ output = verbatimTextOutput(ns("text")),
|
| 480 | +88 | ! |
- remove_selector <- sprintf(+ encoding = tags$div( |
| 481 | +89 | ! |
- "#%s-active-remove_all_filters",+ selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
|
| 482 | +90 | ! |
- self$active_filters_ns()+ ui_transform_teal_data(ns("decorate"), transformators = decorators),
+ |
+
| 91 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 483 | +92 |
) |
|
| 484 | -! | +||
| 93 | +
- } else if (is.null(var_name)) {
+ ) |
||
| 485 | -! | +||
| 94 | +
- remove_selector <- sprintf(+ }, |
||
| 486 | -! | +||
| 95 | +43x |
- "#%s-active-%s-remove_filters",+ ui_args = list(decorators = decorators), |
|
| 487 | -! | +||
| 96 | +43x |
- self$active_filters_ns(),+ server_args = list(decorators = decorators), |
|
| 488 | -! | +||
| 97 | +43x |
- dataset_name+ datanames = datanames, |
|
| 489 | -+ | ||
| 98 | +43x |
- )+ transformators = transformators |
|
| 490 | +99 |
- } else {
+ ) |
|
| 491 | -! | +||
| 100 | +43x |
- remove_selector <- sprintf(+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 492 | -! | +||
| 101 | +43x |
- "#%s-active-%s-filter-%s_%s-remove",+ ans |
|
| 493 | -! | +||
| 102 | +
- self$active_filters_ns(),+ } |
||
| 494 | -! | +
| 1 | +
- dataset_name,+ setOldClass("teal_module")
|
||
| 495 | -! | +||
| 2 | +
- dataset_name,+ setOldClass("teal_modules")
|
||
| 496 | -! | +||
| 3 | +
- var_name+ |
||
| 497 | +4 |
- )+ #' Create `teal_module` and `teal_modules` objects |
|
| 498 | +5 |
- }+ #' |
|
| 499 | -! | +||
| 6 | +
- self$click(+ #' @description |
||
| 500 | -! | +||
| 7 | +
- selector = remove_selector+ #' `r lifecycle::badge("stable")`
|
||
| 501 | +8 |
- )+ #' Create a nested tab structure to embed modules in a `teal` application. |
|
| 502 | -! | +||
| 9 | +
- invisible(self)+ #' |
||
| 503 | +10 |
- },+ #' @details |
|
| 504 | +11 |
- #' @description+ #' `module()` creates an instance of a `teal_module` that can be placed in a `teal` application. |
|
| 505 | +12 |
- #' Set the active filter values for a variable of a dataset in the active filter variable panel.+ #' `modules()` shapes the structure of a the application by organizing `teal_module` within the navigation panel. |
|
| 506 | +13 |
- #'+ #' It wraps `teal_module` and `teal_modules` objects in a `teal_modules` object, |
|
| 507 | +14 |
- #' @param dataset_name (character) The name of the dataset to set the filter value for.+ #' which results in a nested structure corresponding to the nested tabs in the final application. |
|
| 508 | +15 |
- #' @param var_name (character) The name of the variable to set the filter value for.+ #' |
|
| 509 | +16 |
- #' @param input The value to set the filter to.+ #' Note that for `modules()` `label` comes after `...`, so it must be passed as a named argument, |
|
| 510 | +17 |
- #' @param ... Additional arguments to be passed to `shinytest2::AppDriver$set_inputs`+ #' otherwise it will be captured by `...`. |
|
| 511 | +18 |
- #'+ #' |
|
| 512 | +19 |
- #' @return The `TealAppDriver` object invisibly.+ #' The labels `"global_filters"` and `"Report previewer"` are reserved |
|
| 513 | +20 |
- set_active_filter_selection = function(dataset_name,+ #' because they are used by the `mapping` argument of [teal_slices()] |
|
| 514 | +21 |
- var_name,+ #' and the report previewer module [reporter_previewer_module()], respectively. |
|
| 515 | +22 |
- input,+ #' |
|
| 516 | +23 |
- ...) {
+ #' # Restricting datasets used by `teal_module`: |
|
| 517 | -! | +||
| 24 | +
- checkmate::check_string(dataset_name)+ #' The `datanames` argument controls which datasets are used by the module’s server. These datasets, |
||
| 518 | -! | +||
| 25 | +
- checkmate::check_string(var_name)+ #' passed via server's `data` argument, are the only ones shown in the module's tab. |
||
| 519 | -! | +||
| 26 | +
- checkmate::check_string(input)+ #' |
||
| 520 | +27 |
-
+ #' When `datanames` is set to `"all"`, all datasets in the data object are treated as relevant. |
|
| 521 | -! | +||
| 28 | +
- input_id_prefix <- sprintf(+ #' However, this may include unnecessary datasets, such as: |
||
| 522 | -! | +||
| 29 | +
- "%s-filters-%s-filter-%s_%s-inputs",+ #' - Proxy variables for column modifications |
||
| 523 | -! | +||
| 30 | +
- self$active_filters_ns(),+ #' - Temporary datasets used to create final versions |
||
| 524 | -! | +||
| 31 | +
- dataset_name,+ #' - Connection objects |
||
| 525 | -! | +||
| 32 | +
- dataset_name,+ #' |
||
| 526 | -! | +||
| 33 | +
- var_name+ #' To exclude irrelevant datasets, use the [set_datanames()] function to change `datanames` from |
||
| 527 | +34 |
- )+ #' `"all"` to specific names. Trying to modify non-`"all"` values with [set_datanames()] will result |
|
| 528 | +35 |
-
+ #' in a warning. Datasets with names starting with . are ignored globally unless explicitly listed |
|
| 529 | +36 |
- # Find the type of filter (based on filter panel)+ #' in `datanames`. |
|
| 530 | -! | +||
| 37 | +
- supported_suffix <- c("selection", "selection_manual")
+ #' |
||
| 531 | -! | +||
| 38 | +
- slices_suffix <- supported_suffix[+ #' # `datanames` with `transformators` |
||
| 532 | -! | +||
| 39 | +
- match(+ #' When transformators are specified, their `datanames` are added to the module’s `datanames`, which |
||
| 533 | -! | +||
| 40 | +
- TRUE,+ #' changes the behavior as follows: |
||
| 534 | -! | +||
| 41 | +
- vapply(+ #' - If `module(datanames)` is `NULL` and the `transformators` have defined `datanames`, the sidebar |
||
| 535 | -! | +||
| 42 | +
- supported_suffix,+ #' will appear showing the `transformators`' datasets, instead of being hidden. |
||
| 536 | -! | +||
| 43 | +
- function(suffix) {
+ #' - If `module(datanames)` is set to specific values and any `transformator` has `datanames = "all"`, |
||
| 537 | -! | +||
| 44 | +
- !is.null(self$get_html(sprintf("#%s-%s", input_id_prefix, suffix)))
+ #' the module may receive extra datasets that could be unnecessary |
||
| 538 | +45 |
- },+ #' |
|
| 539 | -! | +||
| 46 | +
- logical(1)+ #' @param label (`character(1)`) Label shown in the navigation item for the module or module group. |
||
| 540 | +47 |
- )+ #' For `modules()` defaults to `"root"`. See `Details`. |
|
| 541 | +48 |
- )+ #' @param server (`function`) `shiny` module with following arguments: |
|
| 542 | +49 |
- ]+ #' - `id` - `teal` will set proper `shiny` namespace for this module (see [shiny::moduleServer()]). |
|
| 543 | +50 |
-
+ #' - `input`, `output`, `session` - (optional; not recommended) When provided, then [shiny::callModule()] |
|
| 544 | +51 |
- # Generate correct namespace+ #' will be used to call a module. From `shiny` 1.5.0, the recommended way is to use |
|
| 545 | -! | +||
| 52 | +
- slices_input_id <- sprintf(+ #' [shiny::moduleServer()] instead which doesn't require these arguments. |
||
| 546 | -! | +||
| 53 | +
- "%s-filters-%s-filter-%s_%s-inputs-%s",+ #' - `data` (optional) When provided, the module will be called with `teal_data` object (i.e. a list of |
||
| 547 | -! | +||
| 54 | +
- self$active_filters_ns(),+ #' reactive (filtered) data specified in the `filters` argument) as the value of this argument. |
||
| 548 | -! | +||
| 55 | +
- dataset_name,+ #' - `datasets` (optional) When provided, the module will be called with `FilteredData` object as the |
||
| 549 | -! | +||
| 56 | +
- dataset_name,+ #' value of this argument. (See [`teal.slice::FilteredData`]). |
||
| 550 | -! | +||
| 57 | +
- var_name,+ #' - `reporter` (optional) When provided, the module will be called with `Reporter` object as the value |
||
| 551 | -! | +||
| 58 | +
- slices_suffix+ #' of this argument. (See [`teal.reporter::Reporter`]). |
||
| 552 | +59 |
- )+ #' - `filter_panel_api` (optional) When provided, the module will be called with `FilterPanelAPI` object |
|
| 553 | +60 |
-
+ #' as the value of this argument. (See [`teal.slice::FilterPanelAPI`]). |
|
| 554 | -! | +||
| 61 | +
- if (identical(slices_suffix, "selection_manual")) {
+ #' - `...` (optional) When provided, `server_args` elements will be passed to the module named argument |
||
| 555 | -! | +||
| 62 | +
- checkmate::assert_numeric(input, len = 2)+ #' or to the `...`. |
||
| 556 | +63 |
-
+ #' @param ui (`function`) `shiny` UI module function with following arguments: |
|
| 557 | -! | +||
| 64 | +
- dots <- rlang::list2(...)+ #' - `id` - `teal` will set proper `shiny` namespace for this module. |
||
| 558 | -! | +||
| 65 | +
- checkmate::assert_choice(dots$priority_, formals(self$set_inputs)[["priority_"]], null.ok = TRUE)+ #' - `...` (optional) When provided, `ui_args` elements will be passed to the module named argument |
||
| 559 | -! | +||
| 66 | +
- checkmate::assert_flag(dots$wait_, null.ok = TRUE)+ #' or to the `...`. |
||
| 560 | +67 |
-
+ #' @param filters (`character`) Deprecated. Use `datanames` instead. |
|
| 561 | -! | +||
| 68 | +
- self$run_js(+ #' @param datanames (`character`) Names of the datasets relevant to the item. |
||
| 562 | -! | +||
| 69 | +
- sprintf(+ #' There are 2 reserved values that have specific behaviors: |
||
| 563 | -! | +||
| 70 | +
- "Shiny.setInputValue('%s:sw.numericRange', [%f, %f], {priority: '%s'})",
+ #' - The keyword `"all"` includes all datasets available in the data passed to the teal application. |
||
| 564 | -! | +||
| 71 | +
- slices_input_id,+ #' - `NULL` hides the sidebar panel completely. |
||
| 565 | -! | +||
| 72 | +
- input[[1]],+ #' - If `transformators` are specified, their `datanames` are automatically added to this `datanames` |
||
| 566 | -! | +||
| 73 | +
- input[[2]],+ #' argument. |
||
| 567 | -! | +||
| 74 | +
- priority_ = ifelse(is.null(dots$priority_), "input", dots$priority_)+ #' @param server_args (named `list`) with additional arguments passed on to the server function. |
||
| 568 | +75 |
- )+ #' @param ui_args (named `list`) with additional arguments passed on to the UI function. |
|
| 569 | +76 |
- )+ #' @param x (`teal_module` or `teal_modules`) Object to format/print. |
|
| 570 | +77 |
-
+ #' @param transformators (`list` of `teal_transform_module`) that will be applied to transformator module's data input. |
|
| 571 | -! | +||
| 78 | +
- if (isTRUE(dots$wait_) || is.null(dots$wait_)) {
+ #' |
||
| 572 | -! | +||
| 79 | +
- self$wait_for_idle(+ #' |
||
| 573 | -! | +||
| 80 | +
- timeout = if (is.null(dots$timeout_)) rlang::missing_arg() else dots$timeout_+ #' @param ... |
||
| 574 | +81 |
- )+ #' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab. |
|
| 575 | +82 |
- }+ #' - For `format()` and `print()`: Arguments passed to other methods. |
|
| 576 | -! | +||
| 83 | +
- } else if (identical(slices_suffix, "selection")) {
+ #' |
||
| 577 | -! | +||
| 84 | +
- self$set_input(+ #' @return |
||
| 578 | -! | +||
| 85 | +
- slices_input_id,+ #' `module()` returns an object of class `teal_module`. |
||
| 579 | -! | +||
| 86 | +
- input,+ #' |
||
| 580 | +87 |
- ...+ #' `modules()` returns a `teal_modules` object which contains following fields: |
|
| 581 | +88 |
- )+ #' - `label`: taken from the `label` argument. |
|
| 582 | +89 |
- } else {
+ #' - `children`: a list containing objects passed in `...`. List elements are named after |
|
| 583 | -! | +||
| 90 | +
- stop("Filter selection set not supported for this slice.")
+ #' their `label` attribute converted to a valid `shiny` id. |
||
| 584 | +91 |
- }+ #' |
|
| 585 | +92 |
-
+ #' @name teal_modules |
|
| 586 | -! | +||
| 93 | +
- invisible(self)+ #' @aliases teal_module |
||
| 587 | +94 |
- },+ #' |
|
| 588 | +95 |
- #' @description+ #' @examples |
|
| 589 | +96 |
- #' Extract `html` attribute (found by a `selector`).+ #' library(shiny) |
|
| 590 | +97 |
- #'+ #' |
|
| 591 | +98 |
- #' @param selector (`character(1)`) specifying the selector to be used to get the content of a specific node.+ #' module_1 <- module( |
|
| 592 | +99 |
- #' @param attribute (`character(1)`) name of an attribute to retrieve from a node specified by `selector`.+ #' label = "a module", |
|
| 593 | +100 |
- #'+ #' server = function(id, data) {
|
|
| 594 | +101 |
- #' @return The `character` vector.+ #' moduleServer( |
|
| 595 | +102 |
- get_attr = function(selector, attribute) {
+ #' id, |
|
| 596 | -! | +||
| 103 | +
- rvest::html_attr(+ #' module = function(input, output, session) {
|
||
| 597 | -! | +||
| 104 | +
- rvest::html_nodes(self$get_html_rvest("html"), selector),
+ #' output$data <- renderDataTable(data()[["iris"]]) |
||
| 598 | -! | +||
| 105 | +
- attribute+ #' } |
||
| 599 | +106 |
- )+ #' ) |
|
| 600 | +107 |
- },+ #' }, |
|
| 601 | +108 |
- #' @description+ #' ui = function(id) {
|
|
| 602 | +109 |
- #' Wrapper around `get_html` that passes the output directly to `rvest::read_html`.+ #' ns <- NS(id) |
|
| 603 | +110 |
- #'+ #' tagList(dataTableOutput(ns("data")))
|
|
| 604 | +111 |
- #' @param selector `(character(1))` passed to `get_html`.+ #' }, |
|
| 605 | +112 |
- #'+ #' datanames = "all" |
|
| 606 | +113 |
- #' @return An XML document.+ #' ) |
|
| 607 | +114 |
- get_html_rvest = function(selector) {
+ #' |
|
| 608 | -! | +||
| 115 | +
- rvest::read_html(self$get_html(selector))+ #' module_2 <- module( |
||
| 609 | +116 |
- },+ #' label = "another module", |
|
| 610 | +117 |
- #' Wrapper around `get_url()` method that opens the app in the browser.+ #' server = function(id) {
|
|
| 611 | +118 |
- #'+ #' moduleServer( |
|
| 612 | +119 |
- #' @return Nothing. Opens the underlying teal app in the browser.+ #' id, |
|
| 613 | +120 |
- open_url = function() {
+ #' module = function(input, output, session) {
|
|
| 614 | -! | +||
| 121 | +
- browseURL(self$get_url())+ #' output$text <- renderText("Another Module")
|
||
| 615 | +122 |
- },+ #' } |
|
| 616 | +123 |
- #' @description+ #' ) |
|
| 617 | +124 |
- #' Waits until a specified input, output, or export value.+ #' }, |
|
| 618 | +125 |
- #' This function serves as a wrapper around the `wait_for_value` method,+ #' ui = function(id) {
|
|
| 619 | +126 |
- #' providing a more flexible interface for waiting on different types of values within the active module namespace.+ #' ns <- NS(id) |
|
| 620 | +127 |
- #' @param input,output,export A name of an input, output, or export value.+ #' tagList(textOutput(ns("text")))
|
|
| 621 | +128 |
- #' Only one of these parameters may be used.+ #' }, |
|
| 622 | +129 |
- #' @param ... Must be empty. Allows for parameter expansion.+ #' datanames = NULL |
|
| 623 | +130 |
- #' Parameter with additional value to passed in `wait_for_value`.+ #' ) |
|
| 624 | +131 |
- wait_for_active_module_value = function(input = rlang::missing_arg(),+ #' |
|
| 625 | +132 |
- output = rlang::missing_arg(),+ #' modules <- modules( |
|
| 626 | +133 |
- export = rlang::missing_arg(),+ #' label = "modules", |
|
| 627 | +134 |
- ...) {
+ #' modules( |
|
| 628 | -! | +||
| 135 | +
- ns <- shiny::NS(self$active_module_ns())+ #' label = "nested modules", |
||
| 629 | +136 |
-
+ #' module_1 |
|
| 630 | -! | +||
| 137 | +
- if (!rlang::is_missing(input) && checkmate::test_string(input, min.chars = 1)) input <- ns(input)+ #' ), |
||
| 631 | -! | +||
| 138 | +
- if (!rlang::is_missing(output) && checkmate::test_string(output, min.chars = 1)) output <- ns(output)+ #' module_2 |
||
| 632 | -! | +||
| 139 | +
- if (!rlang::is_missing(export) && checkmate::test_string(export, min.chars = 1)) export <- ns(export)+ #' ) |
||
| 633 | +140 |
-
+ #' |
|
| 634 | -! | +||
| 141 | +
- self$wait_for_value(- |
- ||
| 635 | -! | -
- input = input,- |
- |
| 636 | -! | -
- output = output,+ #' app <- init( |
|
| 637 | -! | +||
| 142 | +
- export = export,+ #' data = teal_data(iris = iris), |
||
| 638 | +143 |
- ...+ #' modules = modules |
|
| 639 | +144 |
- )+ #' ) |
|
| 640 | +145 |
- }+ #' |
|
| 641 | +146 |
- ),+ #' if (interactive()) {
|
|
| 642 | +147 |
- # private members ----+ #' shinyApp(app$ui, app$server) |
|
| 643 | +148 |
- private = list(+ #' } |
|
| 644 | +149 |
- # private attributes ----+ #' @rdname teal_modules |
|
| 645 | +150 |
- data = NULL,+ #' @export |
|
| 646 | +151 |
- modules = NULL,+ #' |
|
| 647 | +152 |
- filter = teal_slices(),+ module <- function(label = "module", |
|
| 648 | +153 |
- ns = list(+ server = function(id, data, ...) moduleServer(id, function(input, output, session) NULL), |
|
| 649 | +154 |
- module = character(0),+ ui = function(id, ...) tags$p(paste0("This module has no UI (id: ", id, " )")),
|
|
| 650 | +155 |
- filter_panel = character(0)+ filters, |
|
| 651 | +156 |
- ),+ datanames = "all", |
|
| 652 | +157 |
- # private methods ----+ server_args = NULL, |
|
| 653 | +158 |
- set_active_ns = function() {
+ ui_args = NULL, |
|
| 654 | -! | +||
| 159 | +
- all_inputs <- self$get_values()$input+ transformators = list()) {
|
||
| 655 | -! | +||
| 160 | +
- active_tab_inputs <- all_inputs[grepl("-active_tab$", names(all_inputs))]
+ # argument checking (independent) |
||
| 656 | +161 |
-
+ ## `label` |
|
| 657 | -! | +||
| 162 | +220x |
- tab_ns <- unlist(lapply(names(active_tab_inputs), function(name) {
+ checkmate::assert_string(label) |
|
| 658 | -! | +||
| 163 | +217x |
- gsub(+ if (label == "global_filters") {
|
|
| 659 | -! | +||
| 164 | +1x |
- pattern = "-active_tab$",+ stop( |
|
| 660 | -! | +||
| 165 | +1x |
- replacement = sprintf("-%s", active_tab_inputs[[name]]),
+ sprintf("module(label = \"%s\", ...\n ", label),
|
|
| 661 | -! | +||
| 166 | +1x |
- name+ "Label 'global_filters' is reserved in teal. Please change to something else.", |
|
| 662 | -+ | ||
| 167 | +1x |
- )+ call. = FALSE |
|
| 663 | +168 |
- }))+ ) |
|
| 664 | -! | +||
| 169 | +
- active_ns <- tab_ns[1]+ } |
||
| 665 | -! | +||
| 170 | +216x |
- if (length(tab_ns) > 1) {
+ if (label == "Report previewer") {
|
|
| 666 | +171 | ! |
- for (i in 2:length(tab_ns)) {
+ stop( |
| 667 | +172 | ! |
- next_ns <- tab_ns[i]+ sprintf("module(label = \"%s\", ...\n ", label),
|
| 668 | +173 | ! |
- if (grepl(pattern = active_ns, next_ns)) {
+ "Label 'Report previewer' is reserved in teal. Please change to something else.", |
| 669 | +174 | ! |
- active_ns <- next_ns+ call. = FALSE |
| 670 | +175 |
- }+ ) |
|
| 671 | +176 |
- }+ } |
|
| 672 | +177 |
- }- |
- |
| 673 | -! | -
- private$ns$module <- sprintf("%s-%s", active_ns, "module")
+
|
|
| 674 | +178 |
-
+ ## server |
|
| 675 | -! | +||
| 179 | +216x |
- components <- c("filter_panel", "data_summary")
+ checkmate::assert_function(server) |
|
| 676 | -! | +||
| 180 | +216x |
- for (component in components) {
+ server_formals <- names(formals(server)) |
|
| 677 | -+ | ||
| 181 | +216x |
- if (+ if (!( |
|
| 678 | -! | +||
| 182 | +216x |
- !is.null(self$get_html(sprintf("#%s-%s-panel", active_ns, component))) ||
+ "id" %in% server_formals || |
|
| 679 | -! | +||
| 183 | +216x |
- !is.null(self$get_html(sprintf("#%s-%s-table", active_ns, component)))
+ all(c("input", "output", "session") %in% server_formals)
|
|
| 680 | +184 |
- ) {
- |
- |
| 681 | -! | -
- private$ns[[component]] <- sprintf("%s-%s", active_ns, component)
+ )) {
|
|
| 682 | -+ | ||
| 185 | +2x |
- } else {
+ stop( |
|
| 683 | -! | +||
| 186 | +2x |
- private$ns[[component]] <- sprintf("%s-module_%s", active_ns, component)
+ "\nmodule() `server` argument requires a function with following arguments:", |
|
| 684 | -+ | ||
| 187 | +2x |
- }+ "\n - id - `teal` will set proper `shiny` namespace for this module.", |
|
| 685 | -+ | ||
| 188 | +2x |
- }+ "\n - input, output, session (not recommended) - then `shiny::callModule` will be used to call a module.", |
|
| 686 | -+ | ||
| 189 | +2x |
- },+ "\n\nFollowing arguments can be used optionaly:", |
|
| 687 | -+ | ||
| 190 | +2x |
- # @description+ "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument", |
|
| 688 | -+ | ||
| 191 | +2x |
- # Get the active filter values from the active filter selection of dataset from the filter panel.+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`", |
|
| 689 | -+ | ||
| 192 | +2x |
- #+ "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`", |
|
| 690 | -+ | ||
| 193 | +2x |
- # @param dataset_name (character) The name of the dataset to get the filter values from.+ "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).", |
|
| 691 | -+ | ||
| 194 | +2x |
- # @param var_name (character) The name of the variable to get the filter values from.+ "\n - `...` server_args elements will be passed to the module named argument or to the `...`" |
|
| 692 | +195 |
- #+ ) |
|
| 693 | +196 |
- # @return The value of the active filter selection.+ } |
|
| 694 | +197 |
- get_active_filter_selection = function(dataset_name, var_name) {
- |
- |
| 695 | -! | -
- checkmate::check_string(dataset_name)+ |
|
| 696 | -! | +||
| 198 | +214x |
- checkmate::check_string(var_name)+ if ("datasets" %in% server_formals) {
|
|
| 697 | -! | +||
| 199 | +2x |
- input_id_prefix <- sprintf(+ warning( |
|
| 698 | -! | +||
| 200 | +2x |
- "%s-filters-%s-filter-%s_%s-inputs",+ sprintf("Called from module(label = \"%s\", ...)\n ", label),
|
|
| 699 | -! | +||
| 201 | +2x |
- self$active_filters_ns(),+ "`datasets` argument in the server is deprecated and will be removed in the next release. ", |
|
| 700 | -! | +||
| 202 | +2x |
- dataset_name,+ "Please use `data` instead.", |
|
| 701 | -! | +||
| 203 | +2x |
- dataset_name,+ call. = FALSE |
|
| 702 | -! | +||
| 204 | +
- var_name+ ) |
||
| 703 | +205 |
- )+ } |
|
| 704 | +206 | ||
| 705 | +207 |
- # Find the type of filter (categorical or range)+ ## UI |
|
| 706 | -! | +||
| 208 | +214x |
- supported_suffix <- c("selection", "selection_manual")
+ checkmate::assert_function(ui) |
|
| 707 | -! | +||
| 209 | +214x |
- for (suffix in supported_suffix) {
+ ui_formals <- names(formals(ui)) |
|
| 708 | -! | +||
| 210 | +214x |
- if (!is.null(self$get_html(sprintf("#%s-%s", input_id_prefix, suffix)))) {
+ if (!"id" %in% ui_formals) {
|
|
| 709 | -! | +||
| 211 | +1x |
- return(self$get_value(input = sprintf("%s-%s", input_id_prefix, suffix)))
+ stop( |
|
| 710 | -+ | ||
| 212 | +1x |
- }+ "\nmodule() `ui` argument requires a function with following arguments:", |
|
| 711 | -+ | ||
| 213 | +1x |
- }+ "\n - id - `teal` will set proper `shiny` namespace for this module.", |
|
| 712 | -+ | ||
| 214 | +1x |
-
+ "\n\nFollowing arguments can be used optionally:", |
|
| 713 | -! | +||
| 215 | +1x |
- NULL # If there are not any supported filters+ "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`" |
|
| 714 | +216 |
- },+ ) |
|
| 715 | +217 |
- # @description+ } |
|
| 716 | +218 |
- # Check if the page is stable without any `DOM` updates in the body of the app.+ |
|
| 717 | -+ | ||
| 219 | +213x |
- # This is achieved by blocing the R process by sleeping until the page is unchanged till the `stability_period`.- |
- |
| 718 | -- |
- # @param stability_period (`numeric(1)`) The time in milliseconds to wait till the page to be stable.+ if (any(c("data", "datasets") %in% ui_formals)) {
|
|
| 719 | -+ | ||
| 220 | +2x |
- # @param check_interval (`numeric(1)`) The time in milliseconds to check for changes in the page.+ stop( |
|
| 720 | -+ | ||
| 221 | +2x |
- # The stability check is reset when a change is detected in the page after sleeping for check_interval.+ sprintf("Called from module(label = \"%s\", ...)\n ", label),
|
|
| 721 | -+ | ||
| 222 | +2x |
- wait_for_page_stability = function(stability_period = 2000, check_interval = 200) {
+ "UI with `data` or `datasets` argument is no longer accepted.\n ", |
|
| 722 | -! | +||
| 223 | +2x |
- previous_content <- self$get_html("body")
+ "If some UI inputs depend on data, please move the logic to your server instead.\n ", |
|
| 723 | -! | +||
| 224 | +2x |
- end_time <- Sys.time() + (stability_period / 1000)+ "Possible solutions are renderUI() or updateXyzInput() functions." |
|
| 724 | +225 | - - | -|
| 725 | -! | -
- repeat {
+ ) |
|
| 726 | -! | +||
| 226 | +
- Sys.sleep(check_interval / 1000)+ } |
||
| 727 | -! | +||
| 227 | +
- current_content <- self$get_html("body")
+
|
||
| 728 | +228 |
-
+ ## `filters` |
|
| 729 | -! | +||
| 229 | +211x |
- if (!identical(previous_content, current_content)) {
+ if (!missing(filters)) {
|
|
| 730 | +230 | ! |
- previous_content <- current_content+ datanames <- filters |
| 731 | +231 | ! |
- end_time <- Sys.time() + (stability_period / 1000)+ msg <- |
| 732 | +232 | ! |
- } else if (Sys.time() >= end_time) {
+ "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead." |
| 733 | +233 | ! |
- break- |
-
| 734 | -- |
- }+ warning(msg) |
|
| 735 | +234 |
- }+ } |
|
| 736 | +235 |
- }+ |
|
| 737 | +236 |
- )+ ## `datanames` (also including deprecated `filters`) |
|
| 738 | +237 |
- )+ # please note a race condition between datanames set when filters is not missing and data arg in server function |
| 1 | -+ | |||
| 238 | +211x |
- #' Create a `teal` module for previewing a report+ if (!is.element("data", server_formals) && !is.null(datanames)) {
|
||
| 2 | -+ | |||
| 239 | +12x |
- #'+ message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
|
||
| 3 | -+ | |||
| 240 | +12x |
- #' @description `r lifecycle::badge("experimental")`
+ datanames <- NULL |
||
| 4 | +241 |
- #'+ } |
||
| 5 | -+ | |||
| 242 | +211x |
- #' This function wraps [teal.reporter::reporter_previewer_ui()] and+ checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
||
| 6 | +243 |
- #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be+ |
||
| 7 | +244 |
- #' used in `teal` applications.+ ## `server_args` |
||
| 8 | -+ | |||
| 245 | +210x |
- #'+ checkmate::assert_list(server_args, null.ok = TRUE, names = "named") |
||
| 9 | -+ | |||
| 246 | +208x |
- #' If you are creating a `teal` application using [init()] then this+ srv_extra_args <- setdiff(names(server_args), server_formals) |
||
| 10 | -+ | |||
| 247 | +208x |
- #' module will be added to your application automatically if any of your `teal_modules`+ if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
|
||
| 11 | -+ | |||
| 248 | +1x |
- #' support report generation.+ stop( |
||
| 12 | -+ | |||
| 249 | +1x |
- #'+ "\nFollowing `server_args` elements have no equivalent in the formals of the server:\n", |
||
| 13 | -+ | |||
| 250 | +1x |
- #' @inheritParams teal_modules+ paste(paste(" -", srv_extra_args), collapse = "\n"),
|
||
| 14 | -+ | |||
| 251 | +1x |
- #' @param server_args (named `list`)+ "\n\nUpdate the server arguments by including above or add `...`" |
||
| 15 | +252 |
- #' Arguments passed to [teal.reporter::reporter_previewer_srv()].+ ) |
||
| 16 | +253 |
- #'+ } |
||
| 17 | +254 |
- #' @return+ |
||
| 18 | +255 |
- #' `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer functionality.+ ## `ui_args` |
||
| 19 | -+ | |||
| 256 | +207x |
- #'+ checkmate::assert_list(ui_args, null.ok = TRUE, names = "named") |
||
| 20 | -+ | |||
| 257 | +205x |
- #' @export+ ui_extra_args <- setdiff(names(ui_args), ui_formals) |
||
| 21 | -+ | |||
| 258 | +205x |
- #'+ if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
|
||
| 22 | -+ | |||
| 259 | +1x |
- reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
+ stop( |
||
| 23 | -7x | +260 | +1x |
- checkmate::assert_string(label)+ "\nFollowing `ui_args` elements have no equivalent in the formals of UI:\n", |
| 24 | -5x | +261 | +1x |
- checkmate::assert_list(server_args, names = "named")+ paste(paste(" -", ui_extra_args), collapse = "\n"),
|
| 25 | -5x | +262 | +1x |
- checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))+ "\n\nUpdate the UI arguments by including above or add `...`" |
| 26 | +263 | - - | -||
| 27 | -3x | -
- message("Initializing reporter_previewer_module")
+ ) |
||
| 28 | +264 | - - | -||
| 29 | -3x | -
- srv <- function(id, reporter, ...) {
- |
- ||
| 30 | -! | -
- teal.reporter::reporter_previewer_srv(id, reporter, ...)+ } |
||
| 31 | +265 |
- }+ |
||
| 32 | +266 |
-
+ ## `transformators` |
||
| 33 | -3x | +267 | +204x |
- ui <- function(id, ...) {
+ if (inherits(transformators, "teal_transform_module")) {
|
| 34 | -! | +|||
| 268 | +1x |
- teal.reporter::reporter_previewer_ui(id, ...)+ transformators <- list(transformators) |
||
| 35 | +269 |
} |
||
| 36 | -- | - - | -||
| 37 | -3x | +270 | +204x |
- module <- module(+ checkmate::assert_list(transformators, types = "teal_transform_module") |
| 38 | -3x | +271 | +204x |
- label = "temporary label",+ transform_datanames <- unlist(lapply(transformators, attr, "datanames")) |
| 39 | -3x | +272 | +204x |
- server = srv, ui = ui,+ combined_datanames <- if (identical(datanames, "all")) {
|
| 40 | -3x | +273 | +151x |
- server_args = server_args, ui_args = list(), datanames = NULL+ "all" |
| 41 | +274 |
- )+ } else {
+ |
+ ||
| 275 | +53x | +
+ union(datanames, transform_datanames) |
||
| 42 | +276 |
- # Module is created with a placeholder label and the label is changed later.+ } |
||
| 43 | +277 |
- # This is to prevent another module being labeled "Report previewer".+ |
||
| 44 | -3x | +278 | +204x |
- class(module) <- c(class(module), "teal_module_previewer")+ structure( |
| 45 | -3x | +279 | +204x |
- module$label <- label+ list( |
| 46 | -3x | +280 | +204x |
- attr(module, "teal_bookmarkable") <- TRUE+ label = label, |
| 47 | -3x | +281 | +204x |
- module+ server = server, |
| 48 | -+ | |||
| 282 | +204x |
- }+ ui = ui, |
| 1 | -+ | |||
| 283 | +204x |
- # This is the main function from teal to be used by the end-users. Although it delegates+ datanames = combined_datanames, |
||
| 2 | -+ | |||
| 284 | +204x |
- # directly to `module_teal_with_splash.R`, we keep it in a separate file because its documentation is quite large+ server_args = server_args, |
||
| 3 | -+ | |||
| 285 | +204x |
- # and it is very end-user oriented. It may also perform more argument checking with more informative+ ui_args = ui_args, |
||
| 4 | -+ | |||
| 286 | +204x |
- # error messages.+ transformators = transformators |
||
| 5 | +287 |
-
+ ), |
||
| 6 | -+ | |||
| 288 | +204x |
- #' Create the server and UI function for the `shiny` app+ class = "teal_module" |
||
| 7 | +289 |
- #'+ ) |
||
| 8 | +290 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 9 | +291 |
- #'+ |
||
| 10 | +292 |
- #' End-users: This is the most important function for you to start a+ #' @rdname teal_modules |
||
| 11 | +293 |
- #' `teal` app that is composed of `teal` modules.+ #' @export |
||
| 12 | +294 |
#' |
||
| 13 | +295 |
- #' @param data (`teal_data` or `teal_data_module`)+ modules <- function(..., label = "root") {
|
||
| 14 | -- |
- #' For constructing the data object, refer to [teal.data::teal_data()] and [teal_data_module()].- |
- ||
| 15 | -+ | |||
| 296 | +144x |
- #' If `datanames` are not set for the `teal_data` object, defaults from the `teal_data` environment will be used.+ checkmate::assert_string(label) |
||
| 16 | -+ | |||
| 297 | +142x |
- #' @param modules (`list` or `teal_modules` or `teal_module`)+ submodules <- list(...) |
||
| 17 | -+ | |||
| 298 | +142x |
- #' Nested list of `teal_modules` or `teal_module` objects or a single+ if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
|
||
| 18 | -+ | |||
| 299 | +2x |
- #' `teal_modules` or `teal_module` object. These are the specific output modules which+ stop( |
||
| 19 | -+ | |||
| 300 | +2x |
- #' will be displayed in the `teal` application. See [modules()] and [module()] for+ "The only character argument to modules() must be 'label' and it must be named, ", |
||
| 20 | -+ | |||
| 301 | +2x |
- #' more details.+ "change modules('lab', ...) to modules(label = 'lab', ...)"
|
||
| 21 | +302 |
- #' @param filter (`teal_slices`) Optionally,+ ) |
||
| 22 | +303 |
- #' specifies the initial filter using [teal_slices()].+ } |
||
| 23 | +304 |
- #' @param title (`shiny.tag` or `character(1)`) Optionally,+ |
||
| 24 | -+ | |||
| 305 | +140x |
- #' the browser window title. Defaults to a title "teal app" with the icon of NEST.+ checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
|
||
| 25 | +306 |
- #' Can be created using the `build_app_title()` or+ # name them so we can more easily access the children |
||
| 26 | +307 |
- #' by passing a valid `shiny.tag` which is a head tag with title and link tag.+ # beware however that the label of the submodules should not be changed as it must be kept synced |
||
| 27 | -+ | |||
| 308 | +137x |
- #' @param header (`shiny.tag` or `character(1)`) Optionally,+ labels <- vapply(submodules, function(submodule) submodule$label, character(1)) |
||
| 28 | -+ | |||
| 309 | +137x |
- #' the header of the app.+ names(submodules) <- get_unique_labels(labels) |
||
| 29 | -+ | |||
| 310 | +137x |
- #' @param footer (`shiny.tag` or `character(1)`) Optionally,+ structure( |
||
| 30 | -+ | |||
| 311 | +137x |
- #' the footer of the app.+ list( |
||
| 31 | -+ | |||
| 312 | +137x |
- #' @param id (`character`) Optionally,+ label = label, |
||
| 32 | -+ | |||
| 313 | +137x |
- #' a string specifying the `shiny` module id in cases it is used as a `shiny` module+ children = submodules |
||
| 33 | +314 |
- #' rather than a standalone `shiny` app. This is a legacy feature.+ ), |
||
| 34 | -+ | |||
| 315 | +137x |
- #' @param landing_popup (`teal_module_landing`) Optionally,+ class = "teal_modules" |
||
| 35 | +316 |
- #' a `landing_popup_module` to show up as soon as the teal app is initialized.+ ) |
||
| 36 | +317 |
- #'+ } |
||
| 37 | +318 |
- #' @return Named list containing server and UI functions.+ |
||
| 38 | +319 |
- #'+ # printing methods ---- |
||
| 39 | +320 |
- #' @export+ |
||
| 40 | +321 |
- #'+ #' @rdname teal_modules |
||
| 41 | +322 |
- #' @include modules.R+ #' @param is_last (`logical(1)`) Whether this is the last item in its parent's children list. |
||
| 42 | +323 |
- #'+ #' Affects the tree branch character used (L- vs |-) |
||
| 43 | +324 |
- #' @examples+ #' @param parent_prefix (`character(1)`) The prefix inherited from parent nodes, |
||
| 44 | +325 |
- #' app <- init(+ #' used to maintain the tree structure in nested levels |
||
| 45 | +326 |
- #' data = within(+ #' @param is_root (`logical(1)`) Whether this is the root node of the tree. Only used in |
||
| 46 | +327 |
- #' teal_data(),+ #' format.teal_modules(). Determines whether to show "TEAL ROOT" header |
||
| 47 | +328 |
- #' {
+ #' @param what (`character`) Specifies which metadata to display. |
||
| 48 | +329 |
- #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ #' Possible values: "datasets", "properties", "ui_args", "server_args", "transformators" |
||
| 49 | +330 |
- #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ #' @examples |
||
| 50 | +331 |
- #' }+ #' mod <- module( |
||
| 51 | +332 |
- #' ),+ #' label = "My Custom Module", |
||
| 52 | +333 |
- #' modules = modules(+ #' server = function(id, data, ...) {},
|
||
| 53 | +334 |
- #' module(+ #' ui = function(id, ...) {},
|
||
| 54 | +335 |
- #' label = "data source",+ #' datanames = c("ADSL", "ADTTE"),
|
||
| 55 | +336 |
- #' server = function(input, output, session, data) {},
+ #' transformators = list(), |
||
| 56 | +337 |
- #' ui = function(id, ...) tags$div(p("information about data source")),
+ #' ui_args = list(a = 1, b = "b"), |
||
| 57 | +338 |
- #' datanames = "all"+ #' server_args = list(x = 5, y = list(p = 1)) |
||
| 58 | +339 |
- #' ),+ #' ) |
||
| 59 | +340 |
- #' example_module(label = "example teal module"),+ #' cat(format(mod)) |
||
| 60 | +341 |
- #' module(+ #' @export |
||
| 61 | +342 |
- #' "Iris Sepal.Length histogram",+ format.teal_module <- function(x, |
||
| 62 | +343 |
- #' server = function(input, output, session, data) {
+ is_last = FALSE, |
||
| 63 | +344 |
- #' output$hist <- renderPlot(+ parent_prefix = "", |
||
| 64 | +345 |
- #' hist(data()[["new_iris"]]$Sepal.Length)+ what = c("datasets", "properties", "ui_args", "server_args", "transformators"),
|
||
| 65 | +346 |
- #' )+ ...) {
|
||
| 66 | -+ | |||
| 347 | +3x |
- #' },+ empty_text <- "" |
||
| 67 | -+ | |||
| 348 | +3x |
- #' ui = function(id, ...) {
+ branch <- if (is_last) "L-" else "|-" |
||
| 68 | -+ | |||
| 349 | +3x |
- #' ns <- NS(id)+ current_prefix <- paste0(parent_prefix, branch, " ") |
||
| 69 | -+ | |||
| 350 | +3x |
- #' plotOutput(ns("hist"))
+ content_prefix <- paste0(parent_prefix, if (is_last) " " else "| ") |
||
| 70 | +351 |
- #' },+ |
||
| 71 | -+ | |||
| 352 | +3x |
- #' datanames = "new_iris"+ format_list <- function(lst, empty = empty_text, label_width = 0) {
|
||
| 72 | -+ | |||
| 353 | +6x |
- #' )+ if (is.null(lst) || length(lst) == 0) {
|
||
| 73 | -+ | |||
| 354 | +6x |
- #' ),+ empty |
||
| 74 | +355 |
- #' filter = teal_slices(+ } else {
|
||
| 75 | -+ | |||
| 356 | +! |
- #' teal_slice(dataname = "new_iris", varname = "Species"),+ colon_space <- paste(rep(" ", label_width), collapse = "")
|
||
| 76 | +357 |
- #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),+ |
||
| 77 | -+ | |||
| 358 | +! |
- #' teal_slice(dataname = "new_mtcars", varname = "cyl"),+ first_item <- sprintf("%s (%s)", names(lst)[1], cli::col_silver(class(lst[[1]])[1]))
|
||
| 78 | -+ | |||
| 359 | +! |
- #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
+ rest_items <- if (length(lst) > 1) {
|
||
| 79 | -+ | |||
| 360 | +! |
- #' module_specific = TRUE,+ paste( |
||
| 80 | -+ | |||
| 361 | +! |
- #' mapping = list(+ vapply( |
||
| 81 | -+ | |||
| 362 | +! |
- #' `example teal module` = "new_iris Species",+ names(lst)[-1], |
||
| 82 | -+ | |||
| 363 | +! |
- #' `Iris Sepal.Length histogram` = "new_iris Species",+ function(name) {
|
||
| 83 | -+ | |||
| 364 | +! |
- #' global_filters = "new_mtcars cyl"+ sprintf( |
||
| 84 | -+ | |||
| 365 | +! |
- #' )+ "%s%s (%s)", |
||
| 85 | -+ | |||
| 366 | +! |
- #' ),+ paste0(content_prefix, "| ", colon_space), |
||
| 86 | -+ | |||
| 367 | +! |
- #' title = "App title",+ name, |
||
| 87 | -+ | |||
| 368 | +! |
- #' header = tags$h1("Sample App"),
+ cli::col_silver(class(lst[[name]])[1]) |
||
| 88 | +369 |
- #' footer = tags$p("Sample footer")
+ ) |
||
| 89 | +370 |
- #' )+ }, |
||
| 90 | -+ | |||
| 371 | +! |
- #' if (interactive()) {
+ character(1) |
||
| 91 | +372 |
- #' shinyApp(app$ui, app$server)+ ), |
||
| 92 | -+ | |||
| 373 | +! |
- #' }+ collapse = "\n" |
||
| 93 | +374 |
- #'+ ) |
||
| 94 | +375 |
- init <- function(data,+ } |
||
| 95 | -+ | |||
| 376 | +! |
- modules,+ if (length(lst) > 1) paste0(first_item, "\n", rest_items) else first_item |
||
| 96 | +377 |
- filter = teal_slices(),+ } |
||
| 97 | +378 |
- title = build_app_title(),+ } |
||
| 98 | +379 |
- header = tags$p(),+ |
||
| 99 | -+ | |||
| 380 | +3x |
- footer = tags$p(),+ bookmarkable <- isTRUE(attr(x, "teal_bookmarkable")) |
||
| 100 | -+ | |||
| 381 | +3x |
- id = character(0),+ reportable <- "reporter" %in% names(formals(x$server)) |
||
| 101 | +382 |
- landing_popup = NULL) {
+
|
||
| 102 | -14x | +383 | +3x |
- logger::log_debug("init initializing teal app with: data ('{ class(data) }').")
+ transformators <- if (length(x$transformators) > 0) {
|
| 103 | -+ | |||
| 384 | +! |
-
+ paste(sapply(x$transformators, function(t) attr(t, "label")), collapse = ", ") |
||
| 104 | +385 |
- # argument checking (independent)+ } else {
+ |
+ ||
| 386 | +3x | +
+ empty_text |
||
| 105 | +387 |
- ## `data`+ } |
||
| 106 | -14x | +|||
| 388 | +
- checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
+
|
|||
| 107 | -14x | +389 | +3x |
- checkmate::assert_class(landing_popup, "teal_module_landing", null.ok = TRUE)+ output <- pasten(current_prefix, cli::bg_white(cli::col_black(x$label))) |
| 108 | +390 | |||
| 109 | -+ | |||
| 391 | +3x |
- ## `modules`+ if ("datasets" %in% what) {
|
||
| 110 | -14x | +392 | +3x |
- checkmate::assert(+ output <- paste0( |
| 111 | -14x | +393 | +3x |
- .var.name = "modules",+ output, |
| 112 | -14x | +394 | +3x |
- checkmate::check_multi_class(modules, c("teal_modules", "teal_module")),
+ content_prefix, "|- ", cli::col_yellow("Datasets : "), paste(x$datanames, collapse = ", "), "\n"
|
| 113 | -14x | +|||
| 395 | +
- checkmate::check_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+ ) |
|||
| 114 | +396 |
- )+ } |
||
| 115 | -14x | +397 | +3x |
- if (inherits(modules, "teal_module")) {
+ if ("properties" %in% what) {
|
| 116 | -1x | +398 | +3x |
- modules <- list(modules)+ output <- paste0( |
| 117 | -+ | |||
| 399 | +3x |
- }+ output, |
||
| 118 | -14x | +400 | +3x |
- if (checkmate::test_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))) {
+ content_prefix, "|- ", cli::col_blue("Properties:"), "\n",
|
| 119 | -8x | +401 | +3x |
- modules <- do.call(teal::modules, modules)+ content_prefix, "| |- ", cli::col_cyan("Bookmarkable : "), bookmarkable, "\n",
|
| 120 | -+ | |||
| 402 | +3x |
- }+ content_prefix, "| L- ", cli::col_cyan("Reportable : "), reportable, "\n"
|
||
| 121 | +403 |
-
+ ) |
||
| 122 | +404 |
- ## `filter`+ } |
||
| 123 | -14x | -
- checkmate::assert_class(filter, "teal_slices")- |
- ||
| 124 | -+ | 405 | +3x |
-
+ if ("ui_args" %in% what) {
|
| 125 | -+ | |||
| 406 | +3x |
- ## all other arguments+ ui_args_formatted <- format_list(x$ui_args, label_width = 19) |
||
| 126 | -13x | +407 | +3x |
- checkmate::assert(+ output <- paste0( |
| 127 | -13x | +408 | +3x |
- .var.name = "title",+ output, |
| 128 | -13x | +409 | +3x |
- checkmate::check_string(title),+ content_prefix, "|- ", cli::col_green("UI Arguments : "), ui_args_formatted, "\n"
|
| 129 | -13x | +|||
| 410 | +
- checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
+ ) |
|||
| 130 | +411 |
- )+ } |
||
| 131 | -13x | +412 | +3x |
- checkmate::assert(+ if ("server_args" %in% what) {
|
| 132 | -13x | +413 | +3x |
- .var.name = "header",+ server_args_formatted <- format_list(x$server_args, label_width = 19) |
| 133 | -13x | +414 | +3x |
- checkmate::check_string(header),+ output <- paste0( |
| 134 | -13x | +415 | +3x |
- checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
+ output,+ |
+
| 416 | +3x | +
+ content_prefix, "|- ", cli::col_green("Server Arguments : "), server_args_formatted, "\n"
|
||
| 135 | +417 |
- )+ ) |
||
| 136 | -13x | +|||
| 418 | +
- checkmate::assert(+ } |
|||
| 137 | -13x | +419 | +3x |
- .var.name = "footer",+ if ("transformators" %in% what) {
|
| 138 | -13x | +420 | +3x |
- checkmate::check_string(footer),+ output <- paste0( |
| 139 | -13x | +421 | +3x |
- checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
+ output, |
| 140 | -+ | |||
| 422 | +3x |
- )+ content_prefix, "L- ", cli::col_magenta("Transformators : "), transformators, "\n"
|
||
| 141 | -13x | +|||
| 423 | +
- checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ ) |
|||
| 142 | +424 |
-
+ } |
||
| 143 | +425 |
- # log+ |
||
| 144 | -13x | +426 | +3x |
- teal.logger::log_system_info()+ output |
| 145 | +427 |
-
+ } |
||
| 146 | +428 |
- # argument transformations+ |
||
| 147 | +429 |
- ## `modules` - landing module+ #' @rdname teal_modules |
||
| 148 | -13x | +|||
| 430 | +
- landing <- extract_module(modules, "teal_module_landing")+ #' @examples |
|||
| 149 | -13x | +|||
| 431 | +
- if (length(landing) == 1L) {
+ #' custom_module <- function( |
|||
| 150 | -! | +|||
| 432 | +
- landing_popup <- landing[[1L]]+ #' label = "label", ui_args = NULL, server_args = NULL, |
|||
| 151 | -! | +|||
| 433 | +
- modules <- drop_module(modules, "teal_module_landing")+ #' datanames = "all", transformators = list(), bk = FALSE) {
|
|||
| 152 | -! | +|||
| 434 | +
- lifecycle::deprecate_soft(+ #' ans <- module( |
|||
| 153 | -! | +|||
| 435 | +
- when = "0.15.3",+ #' label, |
|||
| 154 | -! | +|||
| 436 | +
- what = "landing_popup_module()",+ #' server = function(id, data, ...) {},
|
|||
| 155 | -! | +|||
| 437 | +
- details = paste(+ #' ui = function(id, ...) {
|
|||
| 156 | -! | +|||
| 438 | +
- "Pass `landing_popup_module` to the `landing_popup` argument of the `init` ",+ #' }, |
|||
| 157 | -! | +|||
| 439 | +
- "instead of wrapping it into `modules()` and passing to the `modules` argument"+ #' datanames = datanames, |
|||
| 158 | +440 |
- )+ #' transformators = transformators, |
||
| 159 | +441 |
- )+ #' ui_args = ui_args, |
||
| 160 | -13x | +|||
| 442 | +
- } else if (length(landing) > 1L) {
+ #' server_args = server_args |
|||
| 161 | -! | +|||
| 443 | +
- stop("Only one `landing_popup_module` can be used.")
+ #' ) |
|||
| 162 | +444 |
- }+ #' attr(ans, "teal_bookmarkable") <- bk |
||
| 163 | +445 |
-
+ #' ans |
||
| 164 | +446 |
- ## `filter` - set app_id attribute unless present (when restoring bookmark)+ #' } |
||
| 165 | -13x | +|||
| 447 | +
- if (is.null(attr(filter, "app_id", exact = TRUE))) attr(filter, "app_id") <- create_app_id(data, modules)+ #' |
|||
| 166 | +448 |
-
+ #' dummy_transformator <- teal_transform_module( |
||
| 167 | +449 |
- ## `filter` - convert teal.slice::teal_slices to teal::teal_slices+ #' label = "Dummy Transform", |
||
| 168 | -13x | +|||
| 450 | +
- filter <- as.teal_slices(as.list(filter))+ #' ui = function(id) div("(does nothing)"),
|
|||
| 169 | +451 |
-
+ #' server = function(id, data) {
|
||
| 170 | +452 |
- # argument checking (interdependent)+ #' moduleServer(id, function(input, output, session) data) |
||
| 171 | +453 |
- ## `filter` - `modules`+ #' } |
||
| 172 | -13x | +|||
| 454 | +
- if (isTRUE(attr(filter, "module_specific"))) {
+ #' ) |
|||
| 173 | -! | +|||
| 455 | +
- module_names <- unlist(c(module_labels(modules), "global_filters"))+ #' |
|||
| 174 | -! | +|||
| 456 | +
- failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)+ #' plot_transformator <- teal_transform_module( |
|||
| 175 | -! | +|||
| 457 | +
- if (length(failed_mod_names)) {
+ #' label = "Plot Settings", |
|||
| 176 | -! | +|||
| 458 | +
- stop(+ #' ui = function(id) div("(does nothing)"),
|
|||
| 177 | -! | +|||
| 459 | +
- sprintf(+ #' server = function(id, data) {
|
|||
| 178 | -! | +|||
| 460 | +
- "Some module names in the mapping arguments don't match module labels.\n %s not in %s",+ #' moduleServer(id, function(input, output, session) data) |
|||
| 179 | -! | +|||
| 461 | +
- toString(failed_mod_names),+ #' } |
|||
| 180 | -! | +|||
| 462 | +
- toString(unique(module_names))+ #' ) |
|||
| 181 | +463 |
- )+ #' |
||
| 182 | +464 |
- )+ #' complete_modules <- modules( |
||
| 183 | +465 |
- }+ #' custom_module( |
||
| 184 | +466 | - - | -||
| 185 | -! | -
- if (anyDuplicated(module_names)) {
+ #' label = "Data Overview", |
||
| 186 | +467 |
- # In teal we are able to set nested modules with duplicated label.+ #' datanames = c("ADSL", "ADAE", "ADVS"),
|
||
| 187 | +468 |
- # Because mapping argument bases on the relationship between module-label and filter-id,+ #' ui_args = list( |
||
| 188 | +469 |
- # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)- |
- ||
| 189 | -! | -
- stop(- |
- ||
| 190 | -! | -
- sprintf(- |
- ||
| 191 | -! | -
- "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",- |
- ||
| 192 | -! | -
- toString(module_names[duplicated(module_names)])+ #' view_type = "table", |
||
| 193 | +470 |
- )+ #' page_size = 10, |
||
| 194 | +471 |
- )+ #' filters = c("ARM", "SEX", "RACE")
|
||
| 195 | +472 |
- }+ #' ), |
||
| 196 | +473 |
- }+ #' server_args = list( |
||
| 197 | +474 |
-
+ #' cache = TRUE, |
||
| 198 | +475 |
- ## `data` - `modules`- |
- ||
| 199 | -13x | -
- if (inherits(data, "teal_data")) {
- |
- ||
| 200 | -12x | -
- if (length(data) == 0) {
- |
- ||
| 201 | -1x | -
- stop("The environment of `data` is empty.")
+ #' debounce = 1000 |
||
| 202 | +476 |
- }+ #' ), |
||
| 203 | +477 | - - | -||
| 204 | -11x | -
- is_modules_ok <- check_modules_datanames(modules, names(data))- |
- ||
| 205 | -11x | -
- if (!isTRUE(is_modules_ok) && length(unlist(extract_transformators(modules))) == 0) {
- |
- ||
| 206 | -4x | -
- warning(is_modules_ok, call. = FALSE)+ #' transformators = list(dummy_transformator), |
||
| 207 | +478 |
- }+ #' bk = TRUE |
||
| 208 | +479 | - - | -||
| 209 | -11x | -
- is_filter_ok <- check_filter_datanames(filter, names(data))- |
- ||
| 210 | -11x | -
- if (!isTRUE(is_filter_ok)) {
- |
- ||
| 211 | -1x | -
- warning(is_filter_ok)+ #' ), |
||
| 212 | +480 |
- # we allow app to continue if applied filters are outside+ #' modules( |
||
| 213 | +481 |
- # of possible data range+ #' label = "Nested 1", |
||
| 214 | +482 |
- }+ #' custom_module( |
||
| 215 | +483 |
- }+ #' label = "Interactive Plots", |
||
| 216 | +484 | - - | -||
| 217 | -12x | -
- reporter <- teal.reporter::Reporter$new()$set_id(attr(filter, "app_id"))- |
- ||
| 218 | -12x | -
- if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
- |
- ||
| 219 | -! | -
- modules <- append_module(- |
- ||
| 220 | -! | -
- modules,- |
- ||
| 221 | -! | -
- reporter_previewer_module(server_args = list(previewer_buttons = c("download", "reset")))
+ #' datanames = c("ADSL", "ADVS"),
|
||
| 222 | +485 |
- )+ #' ui_args = list( |
||
| 223 | +486 |
- }+ #' plot_type = c("scatter", "box", "line"),
|
||
| 224 | +487 | - - | -||
| 225 | -12x | -
- ns <- NS(id)+ #' height = 600, |
||
| 226 | +488 |
- # Note: UI must be a function to support bookmarking.- |
- ||
| 227 | -12x | -
- res <- list(- |
- ||
| 228 | -12x | -
- ui = function(request) {
- |
- ||
| 229 | -! | -
- ui_teal(- |
- ||
| 230 | -! | -
- id = ns("teal"),
- |
- ||
| 231 | -! | -
- modules = modules,- |
- ||
| 232 | -! | -
- title = title,- |
- ||
| 233 | -! | -
- header = header,- |
- ||
| 234 | -! | -
- footer = footer+ #' width = 800, |
||
| 235 | +489 |
- )+ #' color_scheme = "viridis" |
||
| 236 | +490 |
- },- |
- ||
| 237 | -12x | -
- server = function(input, output, session) {
- |
- ||
| 238 | -! | -
- if (!is.null(landing_popup)) {
- |
- ||
| 239 | -! | -
- do.call(landing_popup$server, c(list(id = "landing_module_shiny_id"), landing_popup$server_args))+ #' ), |
||
| 240 | +491 |
- }- |
- ||
| 241 | -! | -
- srv_teal(id = ns("teal"), data = data, modules = modules, filter = deep_copy_filter(filter))
+ #' server_args = list( |
||
| 242 | +492 |
- }+ #' render_type = "svg", |
||
| 243 | +493 |
- )+ #' cache_plots = TRUE |
||
| 244 | +494 | - - | -||
| 245 | -12x | -
- logger::log_debug("init teal app has been initialized.")
+ #' ), |
||
| 246 | +495 | - - | -||
| 247 | -12x | -
- res+ #' transformators = list(dummy_transformator, plot_transformator), |
||
| 248 | +496 |
- }+ #' bk = TRUE |
| 1 | +497 |
- #' Calls all `modules`+ #' ), |
||
| 2 | +498 |
- #'+ #' modules( |
||
| 3 | +499 |
- #' On the UI side each `teal_modules` is translated to a `tabsetPanel` and each `teal_module` is a+ #' label = "Nested 2", |
||
| 4 | +500 |
- #' `tabPanel`. Both, UI and server are called recursively so that each tab is a separate module and+ #' custom_module( |
||
| 5 | +501 |
- #' reflect nested structure of `modules` argument.+ #' label = "Summary Statistics", |
||
| 6 | +502 |
- #'+ #' datanames = "ADSL", |
||
| 7 | +503 |
- #' @name module_teal_module+ #' ui_args = list( |
||
| 8 | +504 |
- #'+ #' stats = c("mean", "median", "sd", "range"),
|
||
| 9 | +505 |
- #' @inheritParams module_teal+ #' grouping = c("ARM", "SEX")
|
||
| 10 | +506 |
- #'+ #' ) |
||
| 11 | +507 |
- #' @param data (`reactive` returning `teal_data`)+ #' ), |
||
| 12 | +508 |
- #'+ #' modules( |
||
| 13 | +509 |
- #' @param slices_global (`reactiveVal` returning `modules_teal_slices`)+ #' label = "Labeled nested modules", |
||
| 14 | +510 |
- #' see [`module_filter_manager`]+ #' custom_module( |
||
| 15 | +511 |
- #'+ #' label = "Subgroup Analysis", |
||
| 16 | +512 |
- #' @param depth (`integer(1)`)+ #' datanames = c("ADSL", "ADAE"),
|
||
| 17 | +513 |
- #' number which helps to determine depth of the modules nesting.+ #' ui_args = list( |
||
| 18 | +514 |
- #'+ #' subgroups = c("AGE", "SEX", "RACE"),
|
||
| 19 | +515 |
- #' @param datasets (`reactive` returning `FilteredData` or `NULL`)+ #' analysis_type = "stratified" |
||
| 20 | +516 |
- #' When `datasets` is passed from the parent module (`srv_teal`) then `dataset` is a singleton+ #' ), |
||
| 21 | +517 |
- #' which implies in filter-panel to be "global". When `NULL` then filter-panel is "module-specific".+ #' bk = TRUE |
||
| 22 | +518 |
- #'+ #' ) |
||
| 23 | +519 |
- #' @param data_load_status (`reactive` returning `character`)+ #' ), |
||
| 24 | +520 |
- #' Determines action dependent on a data loading status:+ #' modules(custom_module(label = "Subgroup Analysis in non-labled modules")) |
||
| 25 | +521 |
- #' - `"ok"` when `teal_data` is returned from the data loading.+ #' ) |
||
| 26 | +522 |
- #' - `"teal_data_module failed"` when [teal_data_module()] didn't return `teal_data`. Disables tabs buttons.+ #' ), |
||
| 27 | +523 |
- #' - `"external failed"` when a `reactive` passed to `srv_teal(data)` didn't return `teal_data`. Hides the whole tab+ #' custom_module("Non-nested module")
|
||
| 28 | +524 |
- #' panel.+ #' ) |
||
| 29 | +525 |
#' |
||
| 30 | +526 |
- #' @return+ #' cat(format(complete_modules)) |
||
| 31 | +527 |
- #' output of currently active module.+ #' cat(format(complete_modules, what = c("ui_args", "server_args", "transformators")))
|
||
| 32 | +528 |
- #' - `srv_teal_module.teal_module` returns `reactiveVal` containing output of the called module.+ #' @export |
||
| 33 | +529 |
- #' - `srv_teal_module.teal_modules` returns output of module selected by `input$active_tab`.+ format.teal_modules <- function(x, is_root = TRUE, is_last = FALSE, parent_prefix = "", ...) {
|
||
| 34 | -+ | |||
| 530 | +1x |
- #'+ if (is_root) {
|
||
| 35 | -- |
- #' @keywords internal- |
- ||
| 36 | -- |
- NULL- |
- ||
| 37 | -+ | |||
| 531 | +1x |
-
+ header <- pasten(cli::style_bold("TEAL ROOT"))
|
||
| 38 | -+ | |||
| 532 | +1x |
- #' @rdname module_teal_module+ new_parent_prefix <- " " #' Initial indent for root level |
||
| 39 | +533 |
- ui_teal_module <- function(id, modules, depth = 0L) {
+ } else {
|
||
| 40 | +534 | ! |
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module", "shiny.tag"))
+ if (!is.null(x$label)) {
|
|
| 41 | +535 | ! |
- checkmate::assert_count(depth)+ branch <- if (is_last) "L-" else "|-" |
|
| 42 | +536 | ! |
- UseMethod("ui_teal_module", modules)
- |
- |
| 43 | -- |
- }- |
- ||
| 44 | -- | - - | -||
| 45 | -- |
- #' @rdname module_teal_module+ header <- pasten(parent_prefix, branch, " ", cli::style_bold(x$label)) |
||
| 46 | -+ | |||
| 537 | +! |
- #' @export+ new_parent_prefix <- paste0(parent_prefix, if (is_last) " " else "| ") |
||
| 47 | +538 |
- ui_teal_module.default <- function(id, modules, depth = 0L) {
+ } else {
|
||
| 48 | +539 | ! |
- stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ header <- "" |
|
| 49 | -+ | |||
| 540 | +! |
- }+ new_parent_prefix <- parent_prefix |
||
| 50 | +541 |
-
+ } |
||
| 51 | +542 |
- #' @rdname module_teal_module+ } |
||
| 52 | +543 |
- #' @export+ |
||
| 53 | -+ | |||
| 544 | +1x |
- ui_teal_module.teal_modules <- function(id, modules, depth = 0L) {
+ if (length(x$children) > 0) {
|
||
| 54 | -! | +|||
| 545 | +1x |
- ns <- NS(id)+ children_output <- character(0) |
||
| 55 | -! | +|||
| 546 | +1x |
- tags$div(+ n_children <- length(x$children) |
||
| 56 | -! | +|||
| 547 | +
- id = ns("wrapper"),
+
|
|||
| 57 | -! | +|||
| 548 | +1x |
- do.call(+ for (i in seq_along(x$children)) {
|
||
| 58 | -! | +|||
| 549 | +3x |
- tabsetPanel,+ child <- x$children[[i]] |
||
| 59 | -! | +|||
| 550 | +3x |
- c(+ is_last_child <- (i == n_children) |
||
| 60 | +551 |
- # by giving an id, we can reactively respond to tab changes+ |
||
| 61 | -! | +|||
| 552 | +3x |
- list(+ if (inherits(child, "teal_modules")) {
|
||
| 62 | +553 | ! |
- id = ns("active_tab"),
+ children_output <- c( |
|
| 63 | +554 | ! |
- type = if (modules$label == "root") "pills" else "tabs"- |
- |
| 64 | -- |
- ),+ children_output, |
||
| 65 | +555 | ! |
- lapply(+ format(child, |
|
| 66 | +556 | ! |
- names(modules$children),+ is_root = FALSE, |
|
| 67 | +557 | ! |
- function(module_id) {
+ is_last = is_last_child, |
|
| 68 | +558 | ! |
- module_label <- modules$children[[module_id]]$label+ parent_prefix = new_parent_prefix, |
|
| 69 | -! | +|||
| 559 | +
- if (is.null(module_label)) {
+ ... |
|||
| 70 | -! | +|||
| 560 | +
- module_label <- icon("fas fa-database")
+ ) |
|||
| 71 | +561 |
- }+ ) |
||
| 72 | -! | +|||
| 562 | +
- tabPanel(+ } else {
|
|||
| 73 | -! | +|||
| 563 | +3x |
- title = module_label,+ children_output <- c( |
||
| 74 | -! | +|||
| 564 | +3x |
- value = module_id, # when clicked this tab value changes input$<tabset panel id>+ children_output, |
||
| 75 | -! | +|||
| 565 | +3x |
- ui_teal_module(+ format(child, |
||
| 76 | -! | +|||
| 566 | +3x |
- id = ns(module_id),+ is_last = is_last_child, |
||
| 77 | -! | +|||
| 567 | +3x |
- modules = modules$children[[module_id]],+ parent_prefix = new_parent_prefix, |
||
| 78 | -! | +|||
| 568 | +
- depth = depth + 1L+ ... |
|||
| 79 | +569 |
- )+ ) |
||
| 80 | +570 |
- )+ ) |
||
| 81 | +571 |
- }+ } |
||
| 82 | +572 |
- )+ } |
||
| 83 | +573 |
- )+ + |
+ ||
| 574 | +1x | +
+ paste0(header, paste(children_output, collapse = "")) |
||
| 84 | +575 |
- )+ } else {
+ |
+ ||
| 576 | +! | +
+ header |
||
| 85 | +577 |
- )+ } |
||
| 86 | +578 |
} |
||
| 87 | +579 | |||
| 88 | +580 |
- #' @rdname module_teal_module+ #' @rdname teal_modules |
||
| 89 | +581 |
#' @export |
||
| 90 | +582 |
- ui_teal_module.teal_module <- function(id, modules, depth = 0L) {
+ print.teal_module <- function(x, ...) {
|
||
| 91 | +583 | ! |
- ns <- NS(id)+ cat(format(x, ...)) |
|
| 92 | +584 | ! |
- args <- c(list(id = ns("module")), modules$ui_args)
+ invisible(x) |
|
| 93 | +585 |
-
+ } |
||
| 94 | -! | +|||
| 586 | +
- ui_teal <- tagList(+ |
|||
| 95 | -! | +|||
| 587 | +
- shinyjs::hidden(+ #' @rdname teal_modules |
|||
| 96 | -! | +|||
| 588 | +
- tags$div(+ #' @export |
|||
| 97 | -! | +|||
| 589 | +
- id = ns("transform_failure_info"),
+ print.teal_modules <- function(x, ...) {
|
|||
| 98 | +590 | ! |
- class = "teal_validated",+ cat(format(x, ...)) |
|
| 99 | +591 | ! |
- div(+ invisible(x) |
|
| 100 | -! | +|||
| 592 | +
- class = "teal-output-warning",+ } |
|||
| 101 | -! | +|||
| 593 | +
- "One of transformators failed. Please check its inputs."+ |
|||
| 102 | +594 |
- )+ #' @param modules (`teal_module` or `teal_modules`) |
||
| 103 | +595 |
- )+ #' @rdname teal_modules |
||
| 104 | +596 |
- ),+ #' @examples |
||
| 105 | -! | +|||
| 597 | +
- tags$div(+ #' # change the module's datanames |
|||
| 106 | -! | +|||
| 598 | +
- id = ns("teal_module_ui"),
+ #' set_datanames(module(datanames = "all"), "a") |
|||
| 107 | -! | +|||
| 599 | +
- tags$div(+ #' |
|||
| 108 | -! | +|||
| 600 | +
- class = "teal_validated",+ #' # change modules' datanames |
|||
| 109 | -! | +|||
| 601 | +
- ui_check_module_datanames(ns("validate_datanames"))
+ #' set_datanames( |
|||
| 110 | +602 |
- ),+ #' modules( |
||
| 111 | -! | +|||
| 603 | +
- do.call(modules$ui, args)+ #' module(datanames = "all"), |
|||
| 112 | +604 |
- )+ #' module(datanames = "a") |
||
| 113 | +605 |
- )+ #' ), |
||
| 114 | +606 |
-
+ #' "b" |
||
| 115 | -! | +|||
| 607 | +
- div(+ #' ) |
|||
| 116 | -! | +|||
| 608 | +
- id = id,+ #' @export |
|||
| 117 | -! | +|||
| 609 | +
- class = "teal_module",+ set_datanames <- function(modules, datanames) {
|
|||
| 118 | +610 | ! |
- uiOutput(ns("data_reactive"), inline = TRUE),
+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
|
| 119 | +611 | ! |
- tagList(+ if (inherits(modules, "teal_modules")) {
|
|
| 120 | +612 | ! |
- if (depth >= 2L) tags$div(style = "mt-6"),+ modules$children <- lapply(modules$children, set_datanames, datanames) |
|
| 121 | -! | -
- if (!is.null(modules$datanames)) {
- |
- ||
| 122 | -! | +|||
| 613 | +
- fluidRow(+ } else {
|
|||
| 123 | +614 | ! |
- column(width = 9, ui_teal, class = "teal_primary_col"),+ if (identical(modules$datanames, "all")) {
|
|
| 124 | +615 | ! |
- column(+ modules$datanames <- datanames |
|
| 125 | -! | +|||
| 616 | +
- width = 3,+ } else {
|
|||
| 126 | +617 | ! |
- ui_data_summary(ns("data_summary")),
+ warning( |
|
| 127 | +618 | ! |
- ui_filter_data(ns("filter_panel")),
+ "Not possible to modify datanames of the module ", modules$label, |
|
| 128 | +619 | ! |
- ui_transform_teal_data(ns("data_transform"), transformators = modules$transformators, class = "well"),
+ ". set_datanames() can only change datanames if it was set to \"all\".", |
|
| 129 | +620 | ! |
- class = "teal_secondary_col"+ call. = FALSE |
|
| 130 | +621 |
- )+ ) |
||
| 131 | +622 |
- )+ } |
||
| 132 | +623 |
- } else {
+ } |
||
| 133 | +624 | ! |
- ui_teal- |
- |
| 134 | -- |
- }- |
- ||
| 135 | -- |
- )- |
- ||
| 136 | -- |
- )+ modules |
||
| 137 | +625 |
} |
||
| 138 | +626 | |||
| 139 | +627 |
- #' @rdname module_teal_module+ # utilities ---- |
||
| 140 | +628 |
- srv_teal_module <- function(id,+ ## subset or modify modules ---- |
||
| 141 | +629 |
- data,+ |
||
| 142 | +630 |
- modules,+ #' Append a `teal_module` to `children` of a `teal_modules` object |
||
| 143 | +631 |
- datasets = NULL,+ #' @keywords internal |
||
| 144 | +632 |
- slices_global,+ #' @param modules (`teal_modules`) |
||
| 145 | +633 |
- reporter = teal.reporter::Reporter$new(),+ #' @param module (`teal_module`) object to be appended onto the children of `modules` |
||
| 146 | +634 |
- data_load_status = reactive("ok"),
+ #' @return A `teal_modules` object with `module` appended. |
||
| 147 | +635 |
- is_active = reactive(TRUE)) {
+ append_module <- function(modules, module) {
|
||
| 148 | -199x | +636 | +8x |
- checkmate::assert_string(id)+ checkmate::assert_class(modules, "teal_modules") |
| 149 | -199x | +637 | +6x |
- assert_reactive(data)+ checkmate::assert_class(module, "teal_module") |
| 150 | -199x | +638 | +4x |
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ modules$children <- c(modules$children, list(module)) |
| 151 | -199x | +639 | +4x |
- assert_reactive(datasets, null.ok = TRUE)+ labels <- vapply(modules$children, function(submodule) submodule$label, character(1)) |
| 152 | -199x | +640 | +4x |
- checkmate::assert_class(slices_global, ".slicesGlobal")+ names(modules$children) <- get_unique_labels(labels) |
| 153 | -199x | +641 | +4x |
- checkmate::assert_class(reporter, "Reporter")+ modules |
| 154 | -199x | +|||
| 642 | +
- assert_reactive(data_load_status)+ } |
|||
| 155 | -199x | +|||
| 643 | +
- UseMethod("srv_teal_module", modules)
+
|
|||
| 156 | +644 |
- }+ #' Extract/Remove module(s) of specific class |
||
| 157 | +645 |
-
+ #' |
||
| 158 | +646 |
- #' @rdname module_teal_module+ #' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`. |
||
| 159 | +647 |
- #' @export+ #' |
||
| 160 | +648 |
- srv_teal_module.default <- function(id,+ #' @param modules (`teal_modules`) |
||
| 161 | +649 |
- data,+ #' @param class The class name of `teal_module` to be extracted or dropped. |
||
| 162 | +650 |
- modules,+ #' @keywords internal |
||
| 163 | +651 |
- datasets = NULL,+ #' @return |
||
| 164 | +652 |
- slices_global,+ #' - For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`. |
||
| 165 | +653 |
- reporter = teal.reporter::Reporter$new(),+ #' - For `drop_module`, the opposite, which is all `teal_modules` of class other than `class`. |
||
| 166 | +654 |
- data_load_status = reactive("ok"),
+ #' @rdname module_management |
||
| 167 | +655 |
- is_active = reactive(TRUE)) {
+ extract_module <- function(modules, class) {
|
||
| 168 | -! | +|||
| 656 | +28x |
- stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ if (inherits(modules, class)) {
|
||
| 169 | -+ | |||
| 657 | +! |
- }+ modules |
||
| 170 | -+ | |||
| 658 | +28x |
-
+ } else if (inherits(modules, "teal_module")) {
|
||
| 171 | -+ | |||
| 659 | +15x |
- #' @rdname module_teal_module+ NULL |
||
| 172 | -+ | |||
| 660 | +13x |
- #' @export+ } else if (inherits(modules, "teal_modules")) {
|
||
| 173 | -+ | |||
| 661 | +13x |
- srv_teal_module.teal_modules <- function(id,+ Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class)) |
||
| 174 | +662 |
- data,+ } |
||
| 175 | +663 |
- modules,+ } |
||
| 176 | +664 |
- datasets = NULL,+ |
||
| 177 | +665 |
- slices_global,+ #' @keywords internal |
||
| 178 | +666 |
- reporter = teal.reporter::Reporter$new(),+ #' @return `teal_modules` |
||
| 179 | +667 |
- data_load_status = reactive("ok"),
+ #' @rdname module_management |
||
| 180 | +668 |
- is_active = reactive(TRUE)) {
+ drop_module <- function(modules, class) {
|
||
| 181 | -87x | +|||
| 669 | +! |
- moduleServer(id = id, module = function(input, output, session) {
+ if (inherits(modules, class)) {
|
||
| 182 | -87x | +|||
| 670 | +! |
- logger::log_debug("srv_teal_module.teal_modules initializing the module { deparse1(modules$label) }.")
+ NULL |
||
| 183 | -+ | |||
| 671 | +! |
-
+ } else if (inherits(modules, "teal_module")) {
|
||
| 184 | -87x | +|||
| 672 | +! |
- observeEvent(data_load_status(), {
+ modules |
||
| 185 | -80x | +|||
| 673 | +! |
- tabs_selector <- sprintf("#%s li a", session$ns("active_tab"))
+ } else if (inherits(modules, "teal_modules")) {
|
||
| 186 | -80x | +|||
| 674 | +! |
- if (identical(data_load_status(), "ok")) {
+ do.call( |
||
| 187 | -75x | +|||
| 675 | +! |
- logger::log_debug("srv_teal_module@1 enabling modules tabs.")
+ "modules", |
||
| 188 | -75x | +|||
| 676 | +! |
- shinyjs::show("wrapper")
+ c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label) |
||
| 189 | -75x | +|||
| 677 | +
- shinyjs::enable(selector = tabs_selector)+ ) |
|||
| 190 | -5x | +|||
| 678 | +
- } else if (identical(data_load_status(), "teal_data_module failed")) {
+ } |
|||
| 191 | -5x | +|||
| 679 | +
- logger::log_debug("srv_teal_module@1 disabling modules tabs.")
+ } |
|||
| 192 | -5x | +|||
| 680 | +
- shinyjs::disable(selector = tabs_selector)+ |
|||
| 193 | -! | +|||
| 681 | +
- } else if (identical(data_load_status(), "external failed")) {
+ ## read modules ---- |
|||
| 194 | -! | +|||
| 682 | +
- logger::log_debug("srv_teal_module@1 hiding modules tabs.")
+
|
|||
| 195 | -! | +|||
| 683 | +
- shinyjs::hide("wrapper")
+ #' Does the object make use of the `arg` |
|||
| 196 | +684 |
- }+ #' |
||
| 197 | +685 |
- })+ #' @param modules (`teal_module` or `teal_modules`) object |
||
| 198 | +686 |
-
+ #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules. |
||
| 199 | -87x | +|||
| 687 | +
- modules_output <- sapply(+ #' @return `logical` whether the object makes use of `arg`. |
|||
| 200 | -87x | +|||
| 688 | +
- names(modules$children),+ #' @rdname is_arg_used |
|||
| 201 | -87x | +|||
| 689 | +
- function(module_id) {
+ #' @keywords internal |
|||
| 202 | -112x | +|||
| 690 | +
- srv_teal_module(+ is_arg_used <- function(modules, arg) {
|
|||
| 203 | -112x | +691 | +519x |
- id = module_id,+ checkmate::assert_string(arg) |
| 204 | -112x | +692 | +516x |
- data = data,+ if (inherits(modules, "teal_modules")) {
|
| 205 | -112x | +693 | +20x |
- modules = modules$children[[module_id]],+ any(unlist(lapply(modules$children, is_arg_used, arg))) |
| 206 | -112x | +694 | +496x |
- datasets = datasets,+ } else if (inherits(modules, "teal_module")) {
|
| 207 | -112x | +695 | +32x |
- slices_global = slices_global,+ is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg) |
| 208 | -112x | +696 | +464x |
- reporter = reporter,+ } else if (is.function(modules)) {
|
| 209 | -112x | +697 | +462x |
- is_active = reactive(+ isTRUE(arg %in% names(formals(modules))) |
| 210 | -112x | +|||
| 698 | +
- is_active() &&+ } else {
|
|||
| 211 | -112x | +699 | +2x |
- input$active_tab == module_id &&+ stop("is_arg_used function not implemented for this object")
|
| 212 | -112x | +|||
| 700 | +
- identical(data_load_status(), "ok")+ } |
|||
| 213 | +701 |
- )+ } |
||
| 214 | +702 |
- )+ |
||
| 215 | +703 |
- },+ |
||
| 216 | -87x | +|||
| 704 | +
- simplify = FALSE+ #' Get module depth |
|||
| 217 | +705 |
- )+ #' |
||
| 218 | +706 |
-
+ #' Depth starts at 0, so a single `teal.module` has depth 0. |
||
| 219 | -87x | +|||
| 707 | +
- modules_output+ #' Nesting it increases overall depth by 1. |
|||
| 220 | +708 |
- })+ #' |
||
| 221 | +709 |
- }+ #' @inheritParams init |
||
| 222 | +710 |
-
+ #' @param depth optional integer determining current depth level |
||
| 223 | +711 |
- #' @rdname module_teal_module+ #' |
||
| 224 | +712 |
- #' @export+ #' @return Depth level for given module. |
||
| 225 | +713 |
- srv_teal_module.teal_module <- function(id,+ #' @keywords internal |
||
| 226 | +714 |
- data,+ modules_depth <- function(modules, depth = 0L) {
|
||
| 227 | -+ | |||
| 715 | +12x |
- modules,+ checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
|
||
| 228 | -+ | |||
| 716 | +12x |
- datasets = NULL,+ checkmate::assert_int(depth, lower = 0) |
||
| 229 | -+ | |||
| 717 | +11x |
- slices_global,+ if (inherits(modules, "teal_modules")) {
+ |
+ ||
| 718 | +4x | +
+ max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L)) |
||
| 230 | +719 |
- reporter = teal.reporter::Reporter$new(),+ } else {
+ |
+ ||
| 720 | +7x | +
+ depth |
||
| 231 | +721 |
- data_load_status = reactive("ok"),
+ } |
||
| 232 | +722 |
- is_active = reactive(TRUE)) {
+ } |
||
| 233 | -112x | +|||
| 723 | +
- logger::log_debug("srv_teal_module.teal_module initializing the module: { deparse1(modules$label) }.")
+
|
|||
| 234 | -112x | +|||
| 724 | +
- moduleServer(id = id, module = function(input, output, session) {
+ #' Retrieve labels from `teal_modules` |
|||
| 235 | -112x | +|||
| 725 | +
- module_out <- reactiveVal()+ #' |
|||
| 236 | +726 |
-
+ #' @param modules (`teal_modules`) |
||
| 237 | -112x | +|||
| 727 | +
- active_datanames <- reactive({
+ #' @return A `list` containing the labels of the modules. If the modules are nested, |
|||
| 238 | -89x | +|||
| 728 | +
- .resolve_module_datanames(data = data(), modules = modules)+ #' the function returns a nested `list` of labels. |
|||
| 239 | +729 |
- })+ #' @keywords internal |
||
| 240 | -112x | +|||
| 730 | +
- if (is.null(datasets)) {
+ module_labels <- function(modules) {
|
|||
| 241 | -20x | +731 | +199x |
- datasets <- eventReactive(data(), {
+ if (inherits(modules, "teal_modules")) {
|
| 242 | -16x | +732 | +87x |
- req(inherits(data(), "teal_data"))+ lapply(modules$children, module_labels) |
| 243 | -16x | +|||
| 733 | +
- logger::log_debug("srv_teal_module@1 initializing module-specific FilteredData")
+ } else {
|
|||
| 244 | -16x | +734 | +112x |
- teal_data_to_filtered_data(data(), datanames = active_datanames())+ modules$label |
| 245 | +735 |
- })+ } |
||
| 246 | +736 |
- }+ } |
||
| 247 | +737 | |||
| 248 | +738 |
- # manage module filters on the module level+ #' Retrieve `teal_bookmarkable` attribute from `teal_modules` |
||
| 249 | +739 |
- # important:+ #' |
||
| 250 | +740 |
- # filter_manager_module_srv needs to be called before filter_panel_srv+ #' @param modules (`teal_modules` or `teal_module`) object |
||
| 251 | +741 |
- # Because available_teal_slices is used in FilteredData$srv_available_slices (via srv_filter_panel)+ #' @return named list of the same structure as `modules` with `TRUE` or `FALSE` values indicating |
||
| 252 | +742 |
- # and if it is not set, then it won't be available in the srv_filter_panel- |
- ||
| 253 | -112x | -
- srv_module_filter_manager(modules$label, module_fd = datasets, slices_global = slices_global)+ #' whether the module is bookmarkable. |
||
| 254 | +743 |
-
+ #' @keywords internal |
||
| 255 | -112x | +|||
| 744 | +
- call_once_when(is_active(), {
+ modules_bookmarkable <- function(modules) {
|
|||
| 256 | -86x | +745 | +199x |
- filtered_teal_data <- srv_filter_data(+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
| 257 | -86x | +746 | +199x |
- "filter_panel",+ if (inherits(modules, "teal_modules")) {
|
| 258 | -86x | +747 | +87x |
- datasets = datasets,+ setNames( |
| 259 | -86x | +748 | +87x |
- active_datanames = active_datanames,+ lapply(modules$children, modules_bookmarkable), |
| 260 | -86x | +749 | +87x |
- data = data,+ vapply(modules$children, `[[`, "label", FUN.VALUE = character(1)) |
| 261 | -86x | +|||
| 750 | +
- is_active = is_active+ ) |
|||
| 262 | +751 |
- )+ } else {
|
||
| 263 | -86x | +752 | +112x |
- is_transform_failed <- reactiveValues()+ attr(modules, "teal_bookmarkable", exact = TRUE) |
| 264 | -86x | +|||
| 753 | +
- transformed_teal_data <- srv_transform_teal_data(+ } |
|||
| 265 | -86x | +|||
| 754 | +
- "data_transform",+ } |
|||
| 266 | -86x | +
| 1 | +
- data = filtered_teal_data,+ #' App state management. |
|||
| 267 | -86x | +|||
| 2 | +
- transformators = modules$transformators,+ #' |
|||
| 268 | -86x | +|||
| 3 | +
- modules = modules,+ #' @description |
|||
| 269 | -86x | +|||
| 4 | +
- is_transform_failed = is_transform_failed+ #' `r lifecycle::badge("experimental")`
|
|||
| 270 | +5 |
- )+ #' |
||
| 271 | -86x | +|||
| 6 | +
- any_transform_failed <- reactive({
+ #' Capture and restore the global (app) input state. |
|||
| 272 | -86x | +|||
| 7 | +
- any(unlist(reactiveValuesToList(is_transform_failed)))+ #' |
|||
| 273 | +8 |
- })+ #' @details |
||
| 274 | +9 |
-
+ #' This module introduces bookmarks into `teal` apps: the `shiny` bookmarking mechanism becomes enabled |
||
| 275 | -86x | +|||
| 10 | +
- observeEvent(any_transform_failed(), {
+ #' and server-side bookmarks can be created. |
|||
| 276 | -86x | +|||
| 11 | +
- if (isTRUE(any_transform_failed())) {
+ #' |
|||
| 277 | -6x | +|||
| 12 | +
- shinyjs::hide("teal_module_ui")
+ #' The bookmark manager presents a button with the bookmark icon and is placed in the tab-bar. |
|||
| 278 | -6x | +|||
| 13 | +
- shinyjs::show("transform_failure_info")
+ #' When clicked, the button creates a bookmark and opens a modal which displays the bookmark URL. |
|||
| 279 | +14 |
- } else {
+ #' |
||
| 280 | -80x | +|||
| 15 | +
- shinyjs::show("teal_module_ui")
+ #' `teal` does not guarantee that all modules (`teal_module` objects) are bookmarkable. |
|||
| 281 | -80x | +|||
| 16 | +
- shinyjs::hide("transform_failure_info")
+ #' Those that are, have a `teal_bookmarkable` attribute set to `TRUE`. If any modules are not bookmarkable, |
|||
| 282 | +17 |
- }+ #' the bookmark manager modal displays a warning and the bookmark button displays a flag. |
||
| 283 | +18 |
- })+ #' In order to communicate that a external module is bookmarkable, the module developer |
||
| 284 | +19 |
-
+ #' should set the `teal_bookmarkable` attribute to `TRUE`. |
||
| 285 | -86x | +|||
| 20 | +
- module_teal_data <- reactive({
+ #' |
|||
| 286 | -94x | +|||
| 21 | +
- req(inherits(transformed_teal_data(), "teal_data"))+ #' @section Server logic: |
|||
| 287 | -88x | +|||
| 22 | +
- all_teal_data <- transformed_teal_data()+ #' A bookmark is a URL that contains the app address with a `/?_state_id_=<bookmark_dir>` suffix. |
|||
| 288 | -88x | +|||
| 23 | +
- module_datanames <- .resolve_module_datanames(data = all_teal_data, modules = modules)+ #' `<bookmark_dir>` is a directory created on the server, where the state of the application is saved. |
|||
| 289 | -88x | +|||
| 24 | +
- all_teal_data[c(module_datanames, ".raw_data")]+ #' Accessing the bookmark URL opens a new session of the app that starts in the previously saved state. |
|||
| 290 | +25 |
- })+ #' |
||
| 291 | +26 |
-
+ #' @section Note: |
||
| 292 | -86x | +|||
| 27 | +
- srv_check_module_datanames(+ #' To enable bookmarking use either: |
|||
| 293 | -86x | +|||
| 28 | +
- "validate_datanames",+ #' - `shiny` app by using `shinyApp(..., enableBookmarking = "server")` (not supported in `shinytest2`) |
|||
| 294 | -86x | +|||
| 29 | +
- data = module_teal_data,+ #' - set `options(shiny.bookmarkStore = "server")` before running the app |
|||
| 295 | -86x | +|||
| 30 | +
- modules = modules+ #' |
|||
| 296 | +31 |
- )+ #' |
||
| 297 | +32 |
-
+ #' @inheritParams init |
||
| 298 | -86x | +|||
| 33 | +
- summary_table <- srv_data_summary("data_summary", module_teal_data)
+ #' |
|||
| 299 | +34 |
-
+ #' @return Invisible `NULL`. |
||
| 300 | +35 |
- # Call modules.+ #' |
||
| 301 | -86x | +|||
| 36 | +
- if (!inherits(modules, "teal_module_previewer")) {
+ #' @aliases bookmark bookmark_manager bookmark_manager_module |
|||
| 302 | -86x | +|||
| 37 | +
- obs_module <- call_once_when(+ #' |
|||
| 303 | -86x | +|||
| 38 | +
- !is.null(module_teal_data()),+ #' @name module_bookmark_manager |
|||
| 304 | -86x | +|||
| 39 | +
- ignoreNULL = TRUE,+ #' @rdname module_bookmark_manager |
|||
| 305 | -86x | +|||
| 40 | +
- handlerExpr = {
+ #' |
|||
| 306 | -80x | +|||
| 41 | +
- module_out(.call_teal_module(modules, datasets, module_teal_data, reporter))+ #' @keywords internal |
|||
| 307 | +42 |
- }+ #' |
||
| 308 | +43 |
- )+ NULL |
||
| 309 | +44 |
- } else {
+
|
||
| 310 | +45 |
- # Report previewer must be initiated on app start for report cards to be included in bookmarks.+ #' @rdname module_bookmark_manager |
||
| 311 | +46 |
- # When previewer is delayed, cards are bookmarked only if previewer has been initiated (visited).+ ui_bookmark_panel <- function(id, modules) {
|
||
| 312 | +47 | ! |
- module_out(.call_teal_module(modules, datasets, module_teal_data, reporter))+ ns <- NS(id) |
|
| 313 | +48 |
- }+ + |
+ ||
| 49 | +! | +
+ bookmark_option <- get_bookmarking_option()+ |
+ ||
| 50 | +! | +
+ is_unbookmarkable <- need_bookmarking(modules)+ |
+ ||
| 51 | +! | +
+ shinyOptions(bookmarkStore = bookmark_option) |
||
| 314 | +52 |
- })+ |
||
| 315 | +53 |
-
+ # Render bookmark warnings count |
||
| 316 | -112x | +|||
| 54 | +! |
- module_out+ if (!all(is_unbookmarkable) && identical(bookmark_option, "server")) {
+ |
+ ||
| 55 | +! | +
+ tags$button(+ |
+ ||
| 56 | +! | +
+ id = ns("do_bookmark"),
+ |
+ ||
| 57 | +! | +
+ class = "btn action-button wunder_bar_button bookmark_manager_button",+ |
+ ||
| 58 | +! | +
+ title = "Add bookmark",+ |
+ ||
| 59 | +! | +
+ tags$span(+ |
+ ||
| 60 | +! | +
+ suppressMessages(icon("fas fa-bookmark")),
+ |
+ ||
| 61 | +! | +
+ if (any(is_unbookmarkable)) {
+ |
+ ||
| 62 | +! | +
+ tags$span(+ |
+ ||
| 63 | +! | +
+ sum(is_unbookmarkable),+ |
+ ||
| 64 | +! | +
+ class = "badge-warning badge-count text-white bg-danger" |
||
| 317 | +65 |
- })+ ) |
||
| 318 | +66 |
- }+ } |
||
| 319 | +67 |
-
+ ) |
||
| 320 | +68 |
- # This function calls a module server function.+ ) |
||
| 321 | +69 |
- .call_teal_module <- function(modules, datasets, data, reporter) {
+ } |
||
| 322 | -80x | +|||
| 70 | +
- assert_reactive(data)+ } |
|||
| 323 | +71 | |||
| 324 | +72 |
- # collect arguments to run teal_module+ #' @rdname module_bookmark_manager+ |
+ ||
| 73 | ++ |
+ srv_bookmark_panel <- function(id, modules) {
|
||
| 325 | -80x | +74 | +87x |
- args <- c(list(id = "module"), modules$server_args)+ checkmate::assert_character(id) |
| 326 | -80x | +75 | +87x |
- if (is_arg_used(modules$server, "reporter")) {
+ checkmate::assert_class(modules, "teal_modules") |
| 327 | -1x | +76 | +87x |
- args <- c(args, list(reporter = reporter))+ moduleServer(id, function(input, output, session) {
+ |
+
| 77 | +87x | +
+ logger::log_debug("bookmark_manager_srv initializing")
+ |
+ ||
| 78 | +87x | +
+ ns <- session$ns+ |
+ ||
| 79 | +87x | +
+ bookmark_option <- get_bookmarking_option()+ |
+ ||
| 80 | +87x | +
+ is_unbookmarkable <- need_bookmarking(modules) |
||
| 328 | +81 |
- }+ |
||
| 329 | +82 |
-
+ # Set up bookmarking callbacks ----+ |
+ ||
| 83 | ++ |
+ # Register bookmark exclusions: do_bookmark button to avoid re-bookmarking |
||
| 330 | -80x | +84 | +87x |
- if (is_arg_used(modules$server, "datasets")) {
+ setBookmarkExclude(c("do_bookmark"))
+ |
+
| 85 | ++ |
+ # This bookmark can only be used on the app session. |
||
| 331 | -1x | +86 | +87x |
- args <- c(args, datasets = datasets())+ app_session <- .subset2(session, "parent") |
| 332 | -1x | +87 | +87x |
- warning("datasets argument is not reactive and therefore it won't be updated when data is refreshed.")
+ app_session$onBookmarked(function(url) {
+ |
+
| 88 | +! | +
+ logger::log_debug("bookmark_manager_srv@onBookmarked: bookmark button clicked, registering bookmark")
+ |
+ ||
| 89 | +! | +
+ modal_content <- if (bookmark_option != "server") {
+ |
+ ||
| 90 | +! | +
+ msg <- sprintf(+ |
+ ||
| 91 | +! | +
+ "Bookmarking has been set to \"%s\".\n%s\n%s",+ |
+ ||
| 92 | +! | +
+ bookmark_option,+ |
+ ||
| 93 | +! | +
+ "Only server-side bookmarking is supported.",+ |
+ ||
| 94 | +! | +
+ "Please contact your app developer." |
||
| 333 | +95 | ++ |
+ )+ |
+ |
| 96 | +! | +
+ tags$div(+ |
+ ||
| 97 | +! | +
+ tags$p(msg, class = "text-warning")+ |
+ ||
| 98 | ++ |
+ )+ |
+ ||
| 99 | ++ |
+ } else {
+ |
+ ||
| 100 | +! | +
+ tags$div(+ |
+ ||
| 101 | +! | +
+ tags$span(+ |
+ ||
| 102 | +! | +
+ tags$pre(url)+ |
+ ||
| 103 | ++ |
+ ),+ |
+ ||
| 104 | +! | +
+ if (any(is_unbookmarkable)) {
+ |
+ ||
| 105 | +! | +
+ bkmb_summary <- rapply2(+ |
+ ||
| 106 | +! | +
+ modules_bookmarkable(modules),+ |
+ ||
| 107 | +! | +
+ function(x) {
+ |
+ ||
| 108 | +! | +
+ if (isTRUE(x)) {
+ |
+ ||
| 109 | +! | +
+ "\u2705" # check mark+ |
+ ||
| 110 | +! | +
+ } else if (isFALSE(x)) {
+ |
+ ||
| 111 | +! | +
+ "\u274C" # cross mark+ |
+ ||
| 112 | ++ |
+ } else {
+ |
+ ||
| 113 | +! | +
+ "\u2753" # question mark+ |
+ ||
| 114 | ++ |
+ }+ |
+ ||
| 115 | ++ |
+ }+ |
+ ||
| 116 |
- }+ )+ |
+ |||
| 117 | +! | +
+ tags$div(+ |
+ ||
| 118 | +! | +
+ tags$p(+ |
+ ||
| 119 | +! | +
+ icon("fas fa-exclamation-triangle"),
+ |
+ ||
| 120 | +! | +
+ "Some modules will not be restored when using this bookmark.",+ |
+ ||
| 121 | +! | +
+ tags$br(),+ |
+ ||
| 122 | +! | +
+ "Check the list below to see which modules are not bookmarkable.",+ |
+ ||
| 123 | +! | +
+ class = "text-warning"+ |
+ ||
| 124 | ++ |
+ ),+ |
+ ||
| 125 | +! | +
+ tags$pre(yaml::as.yaml(bkmb_summary))+ |
+ ||
| 126 | ++ |
+ )+ |
+ ||
| 127 | ++ |
+ }+ |
+ ||
| 128 | ++ |
+ )+ |
+ ||
| 129 | ++ |
+ }+ |
+ ||
| 130 | ++ | + + | +||
| 131 | +! | +
+ showModal(+ |
+ ||
| 132 | +! | +
+ modalDialog(+ |
+ ||
| 133 | +! | +
+ id = ns("bookmark_modal"),
+ |
+ ||
| 134 | +! | +
+ title = "Bookmarked teal app url",+ |
+ ||
| 135 | +! | +
+ modal_content,+ |
+ ||
| 136 | +! | +
+ easyClose = TRUE |
||
| 334 | +137 |
-
+ ) |
||
| 335 | -80x | +|||
| 138 | +
- if (is_arg_used(modules$server, "data")) {
+ ) |
|||
| 336 | -76x | +|||
| 139 | +
- args <- c(args, data = list(data))+ }) |
|||
| 337 | +140 |
- }+ |
||
| 338 | +141 |
-
+ # manually trigger bookmarking because of the problems reported on windows with bookmarkButton in teal |
||
| 339 | -80x | +142 | +87x |
- if (is_arg_used(modules$server, "filter_panel_api")) {
+ observeEvent(input$do_bookmark, {
|
| 340 | -1x | +|||
| 143 | +! |
- args <- c(args, filter_panel_api = teal.slice::FilterPanelAPI$new(datasets()))+ logger::log_debug("bookmark_manager_srv@1 do_bookmark module clicked.")
|
||
| 341 | -+ | |||
| 144 | +! |
- }+ session$doBookmark() |
||
| 342 | +145 |
-
+ }) |
||
| 343 | -80x | +|||
| 146 | +
- if (is_arg_used(modules$server, "id")) {
+
|
|||
| 344 | -80x | +147 | +87x |
- do.call(modules$server, args)+ invisible(NULL) |
| 345 | +148 |
- } else {
+ }) |
||
| 346 | -! | +|||
| 149 | +
- do.call(callModule, c(args, list(module = modules$server)))+ } |
|||
| 347 | +150 |
- }+ |
||
| 348 | +151 |
- }+ |
||
| 349 | +152 |
-
+ #' @rdname module_bookmark_manager |
||
| 350 | +153 |
- .resolve_module_datanames <- function(data, modules) {
+ get_bookmarking_option <- function() {
|
||
| 351 | -177x | +154 | +87x |
- stopifnot("data must be teal_data object." = inherits(data, "teal_data"))
+ bookmark_option <- getShinyOption("bookmarkStore")
|
| 352 | -177x | +155 | +87x |
- if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
+ if (is.null(bookmark_option) && identical(getOption("shiny.bookmarkStore"), "server")) {
|
| 353 | -145x | +|||
| 156 | +! |
- names(data)+ bookmark_option <- getOption("shiny.bookmarkStore")
|
||
| 354 | +157 |
- } else {
- |
- ||
| 355 | -32x | -
- intersect(+ } |
||
| 356 | -32x | +158 | +87x |
- names(data), # Keep topological order from teal.data::names()+ bookmark_option |
| 357 | -32x | +|||
| 159 | +
- .include_parent_datanames(modules$datanames, teal.data::join_keys(data))+ } |
|||
| 358 | +160 |
- )+ |
||
| 359 | +161 |
- }+ #' @rdname module_bookmark_manager |
||
| 360 | +162 |
- }+ need_bookmarking <- function(modules) {
|
||
| 361 | -+ | |||
| 163 | +87x |
-
+ unlist(rapply2( |
||
| 362 | -+ | |||
| 164 | +87x |
- #' Calls expression when condition is met+ modules_bookmarkable(modules), |
||
| 363 | -+ | |||
| 165 | +87x |
- #'+ Negate(isTRUE) |
||
| 364 | +166 |
- #' Function postpones `handlerExpr` to the moment when `eventExpr` (condition) returns `TRUE`,+ )) |
||
| 365 | +167 |
- #' otherwise nothing happens.+ } |
||
| 366 | +168 |
- #' @param eventExpr A (quoted or unquoted) logical expression that represents the event;+ |
||
| 367 | +169 |
- #' this can be a simple reactive value like input$click, a call to a reactive expression+ |
||
| 368 | +170 |
- #' like dataset(), or even a complex expression inside curly braces.+ # utilities ---- |
||
| 369 | +171 |
- #' @param ... additional arguments passed to `observeEvent` with the exception of `eventExpr` that is not allowed.+ |
||
| 370 | +172 |
- #' @inheritParams shiny::observeEvent+ #' Restore value from bookmark. |
||
| 371 | +173 |
#' |
||
| 372 | +174 |
- #' @return An observer.+ #' Get value from bookmark or return default. |
||
| 373 | +175 |
#' |
||
| 374 | +176 |
- #' @keywords internal+ #' Bookmarks can store not only inputs but also arbitrary values. |
||
| 375 | +177 |
- call_once_when <- function(eventExpr, # nolint: object_name.+ #' These values are stored by `onBookmark` callbacks and restored by `onBookmarked` callbacks, |
||
| 376 | +178 |
- handlerExpr, # nolint: object_name.+ #' and they are placed in the `values` environment in the `session$restoreContext` field. |
||
| 377 | +179 |
- event.env = parent.frame(), # nolint: object_name.+ #' Using `teal_data_module` makes it impossible to run the callbacks |
||
| 378 | +180 |
- handler.env = parent.frame(), # nolint: object_name.+ #' because the app becomes ready before modules execute and callbacks are registered. |
||
| 379 | +181 |
- ...) {
- |
- ||
| 380 | -198x | -
- event_quo <- rlang::new_quosure(substitute(eventExpr), env = event.env)- |
- ||
| 381 | -198x | -
- handler_quo <- rlang::new_quosure(substitute(handlerExpr), env = handler.env)+ #' In those cases the stored values can still be recovered from the `session` object directly. |
||
| 382 | +182 |
-
+ #' |
||
| 383 | +183 |
- # When `condExpr` is TRUE, then `handlerExpr` is evaluated once.- |
- ||
| 384 | -198x | -
- activator <- reactive({
- |
- ||
| 385 | -198x | -
- if (isTRUE(rlang::eval_tidy(event_quo))) {
- |
- ||
| 386 | -166x | -
- TRUE+ #' Note that variable names in the `values` environment are prefixed with module name space names, |
||
| 387 | +184 |
- }+ #' therefore, when using this function in modules, `value` must be run through the name space function. |
||
| 388 | +185 |
- })+ #' |
||
| 389 | +186 | - - | -||
| 390 | -198x | -
- observeEvent(- |
- ||
| 391 | -198x | -
- eventExpr = activator(),- |
- ||
| 392 | -198x | -
- once = TRUE,- |
- ||
| 393 | -198x | -
- handlerExpr = rlang::eval_tidy(handler_quo),+ #' @param value (`character(1)`) name of value to restore |
||
| 394 | +187 |
- ...+ #' @param default fallback value |
||
| 395 | +188 |
- )+ #' |
||
| 396 | +189 |
- }+ #' @return |
| 1 | +190 |
- #' Validate that dataset has a minimum number of observations+ #' In an application restored from a server-side bookmark, |
|
| 2 | +191 |
- #'+ #' the variable specified by `value` from the `values` environment. |
|
| 3 | +192 |
- #' `r lifecycle::badge("stable")`
+ #' Otherwise `default`. |
|
| 4 | +193 |
#' |
|
| 5 | +194 |
- #' This function is a wrapper for `shiny::validate`.+ #' @keywords internal |
|
| 6 | +195 |
#' |
|
| 7 | +196 |
- #' @param x (`data.frame`)+ restoreValue <- function(value, default) { # nolint: object_name.
|
|
| 8 | -+ | ||
| 197 | +174x |
- #' @param min_nrow (`numeric(1)`) Minimum allowed number of rows in `x`.+ checkmate::assert_character("value")
|
|
| 9 | -+ | ||
| 198 | +174x |
- #' @param complete (`logical(1)`) Flag specifying whether to check only complete cases. Defaults to `FALSE`.+ session_default <- shiny::getDefaultReactiveDomain() |
|
| 10 | -+ | ||
| 199 | +174x |
- #' @param allow_inf (`logical(1)`) Flag specifying whether to allow infinite values. Defaults to `TRUE`.+ session_parent <- .subset2(session_default, "parent") |
|
| 11 | -+ | ||
| 200 | +174x |
- #' @param msg (`character(1)`) Additional message to display alongside the default message.+ session <- if (is.null(session_parent)) session_default else session_parent |
|
| 12 | +201 |
- #'+ |
|
| 13 | -+ | ||
| 202 | +174x |
- #' @export+ if (isTRUE(session$restoreContext$active) && exists(value, session$restoreContext$values, inherits = FALSE)) {
|
|
| 14 | -+ | ||
| 203 | +! |
- #'+ session$restoreContext$values[[value]] |
|
| 15 | +204 |
- #' @examples+ } else {
+ |
+ |
| 205 | +174x | +
+ default |
|
| 16 | +206 |
- #' library(teal)+ } |
|
| 17 | +207 |
- #' ui <- fluidPage(+ } |
|
| 18 | +208 |
- #' sliderInput("len", "Max Length of Sepal",
+
|
|
| 19 | +209 |
- #' min = 4.3, max = 7.9, value = 5+ #' Compare bookmarks. |
|
| 20 | +210 |
- #' ),+ #' |
|
| 21 | +211 |
- #' plotOutput("plot")
+ #' Test if two bookmarks store identical state. |
|
| 22 | +212 |
- #' )+ #' |
|
| 23 | +213 |
- #'+ #' `input` environments are compared one variable at a time and if not identical, |
|
| 24 | +214 |
- #' server <- function(input, output) {
+ #' values in both bookmarks are reported. States of `datatable`s are stripped |
|
| 25 | +215 |
- #' output$plot <- renderPlot({
+ #' of the `time` element before comparing because the time stamp is always different. |
|
| 26 | +216 |
- #' iris_df <- iris[iris$Sepal.Length <= input$len, ]+ #' The contents themselves are not printed as they are large and the contents are not informative. |
|
| 27 | +217 |
- #' validate_has_data(+ #' Elements present in one bookmark and absent in the other are also reported. |
|
| 28 | +218 |
- #' iris_df,+ #' Differences are printed as messages. |
|
| 29 | +219 |
- #' min_nrow = 10,+ #' |
|
| 30 | +220 |
- #' complete = FALSE,+ #' `values` environments are compared with `all.equal`. |
|
| 31 | +221 |
- #' msg = "Please adjust Max Length of Sepal"+ #' |
|
| 32 | +222 |
- #' )+ #' @section How to use: |
|
| 33 | +223 |
- #'+ #' Open an application, change relevant inputs (typically, all of them), and create a bookmark. |
|
| 34 | +224 |
- #' hist(iris_df$Sepal.Length, breaks = 5)+ #' Then open that bookmark and immediately create a bookmark of that. |
|
| 35 | +225 |
- #' })+ #' If restoring bookmarks occurred properly, the two bookmarks should store the same state. |
|
| 36 | +226 |
- #' }+ #' |
|
| 37 | +227 |
- #' if (interactive()) {
+ #' |
|
| 38 | +228 |
- #' shinyApp(ui, server)+ #' @param book1,book2 bookmark directories stored in `shiny_bookmarks/`; |
|
| 39 | +229 |
- #' }+ #' default to the two most recently modified directories |
|
| 40 | +230 |
#' |
|
| 41 | +231 |
- validate_has_data <- function(x,+ #' @return |
|
| 42 | +232 |
- min_nrow = NULL,+ #' Invisible `NULL` if bookmarks are identical or if there are no bookmarks to test. |
|
| 43 | +233 |
- complete = FALSE,+ #' `FALSE` if inconsistencies are detected. |
|
| 44 | +234 |
- allow_inf = TRUE,+ #' |
|
| 45 | +235 |
- msg = NULL) {
+ #' @keywords internal |
|
| 46 | -17x | +||
| 236 | +
- checkmate::assert_string(msg, null.ok = TRUE)+ #' |
||
| 47 | -15x | +||
| 237 | +
- checkmate::assert_data_frame(x)+ bookmarks_identical <- function(book1, book2) {
|
||
| 48 | -15x | +||
| 238 | +! |
- if (!is.null(min_nrow)) {
+ if (!dir.exists("shiny_bookmarks")) {
|
|
| 49 | -15x | +||
| 239 | +! |
- if (complete) {
+ message("no bookmark directory")
|
|
| 50 | -5x | +||
| 240 | +! |
- complete_index <- stats::complete.cases(x)+ return(invisible(NULL)) |
|
| 51 | -5x | +||
| 241 | +
- validate(need(+ } |
||
| 52 | -5x | +||
| 242 | +
- sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,+ |
||
| 53 | -5x | +||
| 243 | +! |
- paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
+ ans <- TRUE |
|
| 54 | +244 |
- ))+ |
|
| 55 | -+ | ||
| 245 | +! |
- } else {
+ if (missing(book1) && missing(book2)) {
|
|
| 56 | -10x | +||
| 246 | +! |
- validate(need(+ dirs <- list.dirs("shiny_bookmarks", recursive = FALSE)
|
|
| 57 | -10x | +||
| 247 | +! |
- nrow(x) >= min_nrow,+ bookmarks_sorted <- basename(rev(dirs[order(file.mtime(dirs))])) |
|
| 58 | -10x | +||
| 248 | +! |
- paste(+ if (length(bookmarks_sorted) < 2L) {
|
|
| 59 | -10x | +||
| 249 | +! |
- c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
+ message("no bookmarks to compare")
|
|
| 60 | -10x | +||
| 250 | +! |
- collapse = "\n"+ return(invisible(NULL)) |
|
| 61 | +251 |
- )+ } |
|
| 62 | -+ | ||
| 252 | +! |
- ))+ book1 <- bookmarks_sorted[2L] |
|
| 63 | -+ | ||
| 253 | +! |
- }+ book2 <- bookmarks_sorted[1L] |
|
| 64 | +254 |
-
+ } else {
|
|
| 65 | -10x | +||
| 255 | +! |
- if (!allow_inf) {
+ if (!dir.exists(file.path("shiny_bookmarks", book1))) stop(book1, " not found")
|
|
| 66 | -6x | +||
| 256 | +! |
- validate(need(+ if (!dir.exists(file.path("shiny_bookmarks", book2))) stop(book2, " not found")
|
|
| 67 | -6x | +||
| 257 | +
- all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))),+ } |
||
| 68 | -6x | +||
| 258 | +
- "Dataframe contains Inf values which is not allowed."+ |
||
| 69 | -+ | ||
| 259 | +! |
- ))+ book1_input <- readRDS(file.path("shiny_bookmarks", book1, "input.rds"))
|
|
| 70 | -+ | ||
| 260 | +! |
- }+ book2_input <- readRDS(file.path("shiny_bookmarks", book2, "input.rds"))
|
|
| 71 | +261 |
- }+ |
|
| 72 | -+ | ||
| 262 | +! |
- }+ elements_common <- intersect(names(book1_input), names(book2_input)) |
|
| 73 | -+ | ||
| 263 | +! |
-
+ dt_states <- grepl("_state$", elements_common)
|
|
| 74 | -+ | ||
| 264 | +! |
- #' Validate that dataset has unique rows for key variables+ if (any(dt_states)) {
|
|
| 75 | -+ | ||
| 265 | +! |
- #'+ for (el in elements_common[dt_states]) {
|
|
| 76 | -+ | ||
| 266 | +! |
- #' `r lifecycle::badge("stable")`
+ book1_input[[el]][["time"]] <- NULL |
|
| 77 | -+ | ||
| 267 | +! |
- #'+ book2_input[[el]][["time"]] <- NULL |
|
| 78 | +268 |
- #' This function is a wrapper for `shiny::validate`.+ } |
|
| 79 | +269 |
- #'+ } |
|
| 80 | +270 |
- #' @param x (`data.frame`)+ |
|
| 81 | -+ | ||
| 271 | +! |
- #' @param key (`character`) Vector of ID variables from `x` that identify unique records.+ identicals <- mapply(identical, book1_input[elements_common], book2_input[elements_common]) |
|
| 82 | -+ | ||
| 272 | +! |
- #'+ non_identicals <- names(identicals[!identicals]) |
|
| 83 | -+ | ||
| 273 | +! |
- #' @export+ compares <- sprintf("$ %s:\t%s --- %s", non_identicals, book1_input[non_identicals], book2_input[non_identicals])
|
|
| 84 | -+ | ||
| 274 | +! |
- #'+ if (length(compares) != 0L) {
|
|
| 85 | -+ | ||
| 275 | +! |
- #' @examples+ message("common elements not identical: \n", paste(compares, collapse = "\n"))
|
|
| 86 | -+ | ||
| 276 | +! |
- #' iris$id <- rep(1:50, times = 3)+ ans <- FALSE |
|
| 87 | +277 |
- #' ui <- fluidPage(+ } |
|
| 88 | +278 |
- #' selectInput(+ |
|
| 89 | -+ | ||
| 279 | +! |
- #' inputId = "species",+ elements_boook1 <- setdiff(names(book1_input), names(book2_input)) |
|
| 90 | -+ | ||
| 280 | +! |
- #' label = "Select species",+ if (length(elements_boook1) != 0L) {
|
|
| 91 | -+ | ||
| 281 | +! |
- #' choices = c("setosa", "versicolor", "virginica"),
+ dt_states <- grepl("_state$", elements_boook1)
|
|
| 92 | -+ | ||
| 282 | +! |
- #' selected = "setosa",+ if (any(dt_states)) {
|
|
| 93 | -+ | ||
| 283 | +! |
- #' multiple = TRUE+ for (el in elements_boook1[dt_states]) {
|
|
| 94 | -+ | ||
| 284 | +! |
- #' ),+ if (is.list(book1_input[[el]])) book1_input[[el]] <- "--- data table state ---" |
|
| 95 | +285 |
- #' plotOutput("plot")
+ } |
|
| 96 | +286 |
- #' )+ } |
|
| 97 | -+ | ||
| 287 | +! |
- #' server <- function(input, output) {
+ excess1 <- sprintf("$ %s:\t%s", elements_boook1, book1_input[elements_boook1])
|
|
| 98 | -+ | ||
| 288 | +! |
- #' output$plot <- renderPlot({
+ message("elements only in book1: \n", paste(excess1, collapse = "\n"))
|
|
| 99 | -+ | ||
| 289 | +! |
- #' iris_f <- iris[iris$Species %in% input$species, ]+ ans <- FALSE |
|
| 100 | +290 |
- #' validate_one_row_per_id(iris_f, key = c("id"))
+ } |
|
| 101 | +291 |
- #'+ |
|
| 102 | -+ | ||
| 292 | +! |
- #' hist(iris_f$Sepal.Length, breaks = 5)+ elements_boook2 <- setdiff(names(book2_input), names(book1_input)) |
|
| 103 | -+ | ||
| 293 | +! |
- #' })+ if (length(elements_boook2) != 0L) {
|
|
| 104 | -+ | ||
| 294 | +! |
- #' }+ dt_states <- grepl("_state$", elements_boook1)
|
|
| 105 | -+ | ||
| 295 | +! |
- #' if (interactive()) {
+ if (any(dt_states)) {
|
|
| 106 | -+ | ||
| 296 | +! |
- #' shinyApp(ui, server)+ for (el in elements_boook1[dt_states]) {
|
|
| 107 | -+ | ||
| 297 | +! |
- #' }+ if (is.list(book2_input[[el]])) book2_input[[el]] <- "--- data table state ---" |
|
| 108 | +298 |
- #'+ } |
|
| 109 | +299 |
- validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
+ } |
|
| 110 | +300 | ! |
- validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
+ excess2 <- sprintf("$ %s:\t%s", elements_boook2, book2_input[elements_boook2])
+ |
+
| 301 | +! | +
+ message("elements only in book2: \n", paste(excess2, collapse = "\n"))
+ |
+ |
| 302 | +! | +
+ ans <- FALSE |
|
| 111 | +303 |
- }+ } |
|
| 112 | +304 | - + + | +|
| 305 | +! | +
+ book1_values <- readRDS(file.path("shiny_bookmarks", book1, "values.rds"))
|
|
| 113 | -+ | ||
| 306 | +! |
- #' Validates that vector includes all expected values+ book2_values <- readRDS(file.path("shiny_bookmarks", book2, "values.rds"))
|
|
| 114 | +307 |
- #'+ |
|
| 115 | -+ | ||
| 308 | +! |
- #' `r lifecycle::badge("stable")`
+ if (!isTRUE(all.equal(book1_values, book2_values))) {
|
|
| 116 | -+ | ||
| 309 | +! |
- #'+ message("different values detected")
|
|
| 117 | -+ | ||
| 310 | +! |
- #' This function is a wrapper for `shiny::validate`.+ message("choices for numeric filters MAY be different, see RangeFilterState$set_choices")
|
|
| 118 | -+ | ||
| 311 | +! |
- #'+ ans <- FALSE |
|
| 119 | +312 |
- #' @param x Vector of values to test.+ } |
|
| 120 | +313 |
- #' @param choices Vector to test against.+ |
|
| 121 | -+ | ||
| 314 | +! |
- #' @param msg (`character(1)`) Error message to display if some elements of `x` are not elements of `choices`.+ if (ans) message("perfect!")
|
|
| 122 | -+ | ||
| 315 | +! |
- #'+ invisible(NULL) |
|
| 123 | +316 |
- #' @export+ } |
|
| 124 | +317 |
- #'+ |
|
| 125 | +318 |
- #' @examples+ |
|
| 126 | +319 |
- #' ui <- fluidPage(+ # Replacement for [base::rapply] which doesn't handle NULL values - skips the evaluation |
|
| 127 | +320 |
- #' selectInput(+ # of the function and returns NULL for given element. |
|
| 128 | +321 |
- #' "species",+ rapply2 <- function(x, f) {
|
|
| 129 | -+ | ||
| 322 | +199x |
- #' "Select species",+ if (inherits(x, "list")) {
|
|
| 130 | -+ | ||
| 323 | +87x |
- #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
+ lapply(x, rapply2, f = f) |
|
| 131 | +324 |
- #' selected = "setosa",+ } else {
|
|
| 132 | -+ | ||
| 325 | +112x |
- #' multiple = FALSE+ f(x) |
|
| 133 | +326 |
- #' ),+ } |
|
| 134 | +327 |
- #' verbatimTextOutput("summary")
+ } |
| 135 | +1 |
- #' )+ #' Get client timezone |
|
| 136 | +2 |
#' |
|
| 137 | +3 |
- #' server <- function(input, output) {
+ #' User timezone in the browser may be different to the one on the server. |
|
| 138 | +4 |
- #' output$summary <- renderPrint({
+ #' This script can be run to register a `shiny` input which contains information about the timezone in the browser. |
|
| 139 | +5 |
- #' validate_in(input$species, iris$Species, "Species does not exist.")+ #' |
|
| 140 | +6 |
- #' nrow(iris[iris$Species == input$species, ])+ #' @param ns (`function`) namespace function passed from the `session` object in the `shiny` server. |
|
| 141 | +7 |
- #' })+ #' For `shiny` modules this will allow for proper name spacing of the registered input. |
|
| 142 | +8 |
- #' }+ #' |
|
| 143 | +9 |
- #' if (interactive()) {
+ #' @return `NULL`, invisibly. |
|
| 144 | +10 |
- #' shinyApp(ui, server)+ #' |
|
| 145 | +11 |
- #' }+ #' @keywords internal |
|
| 146 | +12 |
#' |
|
| 147 | +13 |
- validate_in <- function(x, choices, msg) {
+ get_client_timezone <- function(ns) {
|
|
| 148 | -! | +||
| 14 | +88x |
- validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg))+ script <- sprintf( |
|
| 149 | -+ | ||
| 15 | +88x |
- }+ "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)", |
|
| 150 | -+ | ||
| 16 | +88x |
-
+ ns("timezone")
|
|
| 151 | +17 |
- #' Validates that vector has length greater than 0+ ) |
|
| 152 | -+ | ||
| 18 | +88x |
- #'+ shinyjs::runjs(script) # function does not return anything |
|
| 153 | -+ | ||
| 19 | +88x |
- #' `r lifecycle::badge("stable")`
+ invisible(NULL) |
|
| 154 | +20 |
- #'+ } |
|
| 155 | +21 |
- #' This function is a wrapper for `shiny::validate`.+ |
|
| 156 | +22 |
- #'+ #' Resolve the expected bootstrap theme |
|
| 157 | +23 |
- #' @param x vector+ #' @noRd |
|
| 158 | +24 |
- #' @param msg message to display+ #' @keywords internal |
|
| 159 | +25 |
- #'+ get_teal_bs_theme <- function() {
|
|
| 160 | -+ | ||
| 26 | +4x |
- #' @export+ bs_theme <- getOption("teal.bs_theme")
|
|
| 161 | +27 |
- #'+ |
|
| 162 | -+ | ||
| 28 | +4x |
- #' @examples+ if (is.null(bs_theme)) {
|
|
| 163 | -+ | ||
| 29 | +1x |
- #' data <- data.frame(+ return(NULL) |
|
| 164 | +30 |
- #' id = c(1:10, 11:20, 1:10),+ } |
|
| 165 | +31 |
- #' strata = rep(c("A", "B"), each = 15)
+
|
|
| 166 | -+ | ||
| 32 | +3x |
- #' )+ if (!checkmate::test_class(bs_theme, "bs_theme")) {
|
|
| 167 | -+ | ||
| 33 | +2x |
- #' ui <- fluidPage(+ warning( |
|
| 168 | -+ | ||
| 34 | +2x |
- #' selectInput("ref1", "Select strata1 to compare",
+ "Assertion on 'teal.bs_theme' option value failed: ", |
|
| 169 | -+ | ||
| 35 | +2x |
- #' choices = c("A", "B", "C"), selected = "A"
+ checkmate::check_class(bs_theme, "bs_theme"), |
|
| 170 | -+ | ||
| 36 | +2x |
- #' ),+ ". The default Shiny Bootstrap theme will be used." |
|
| 171 | +37 |
- #' selectInput("ref2", "Select strata2 to compare",
+ ) |
|
| 172 | -+ | ||
| 38 | +2x |
- #' choices = c("A", "B", "C"), selected = "B"
+ return(NULL) |
|
| 173 | +39 |
- #' ),+ } |
|
| 174 | +40 |
- #' verbatimTextOutput("arm_summary")
+
|
|
| 175 | -+ | ||
| 41 | +1x |
- #' )+ bs_theme |
|
| 176 | +42 |
- #'+ } |
|
| 177 | +43 |
- #' server <- function(input, output) {
+
|
|
| 178 | +44 |
- #' output$arm_summary <- renderText({
+ #' Return parentnames along with datanames. |
|
| 179 | +45 |
- #' sample_1 <- data$id[data$strata == input$ref1]+ #' @noRd |
|
| 180 | +46 |
- #' sample_2 <- data$id[data$strata == input$ref2]+ #' @keywords internal |
|
| 181 | +47 |
- #'+ .include_parent_datanames <- function(datanames, join_keys) {
|
|
| 182 | -+ | ||
| 48 | +32x |
- #' validate_has_elements(sample_1, "No subjects in strata1.")+ ordered_datanames <- datanames |
|
| 183 | -+ | ||
| 49 | +32x |
- #' validate_has_elements(sample_2, "No subjects in strata2.")+ for (current in datanames) {
|
|
| 184 | -+ | ||
| 50 | +62x |
- #'+ parents <- character(0L) |
|
| 185 | -+ | ||
| 51 | +62x |
- #' paste0(+ while (length(current) > 0) {
|
|
| 186 | -+ | ||
| 52 | +64x |
- #' "Number of samples in: strata1=", length(sample_1),+ current <- teal.data::parent(join_keys, current) |
|
| 187 | -+ | ||
| 53 | +64x |
- #' " comparions strata2=", length(sample_2)+ parents <- c(current, parents) |
|
| 188 | +54 |
- #' )+ } |
|
| 189 | -+ | ||
| 55 | +62x |
- #' })+ ordered_datanames <- c(parents, ordered_datanames) |
|
| 190 | +56 |
- #' }+ } |
|
| 191 | +57 |
- #' if (interactive()) {
+
|
|
| 192 | -+ | ||
| 58 | +32x |
- #' shinyApp(ui, server)+ unique(ordered_datanames) |
|
| 193 | +59 |
- #' }+ } |
|
| 194 | +60 |
- validate_has_elements <- function(x, msg) {
- |
- |
| 195 | -! | -
- validate(need(length(x) > 0, msg))+ |
|
| 196 | +61 |
- }+ #' Create a `FilteredData` |
|
| 197 | +62 |
-
+ #' |
|
| 198 | +63 |
- #' Validates no intersection between two vectors+ #' Create a `FilteredData` object from a `teal_data` object. |
|
| 199 | +64 |
#' |
|
| 200 | +65 |
- #' `r lifecycle::badge("stable")`
+ #' @param x (`teal_data`) object |
|
| 201 | +66 |
- #'+ #' @param datanames (`character`) vector of data set names to include; must be subset of `names(x)` |
|
| 202 | +67 |
- #' This function is a wrapper for `shiny::validate`.+ #' @return A `FilteredData` object. |
|
| 203 | +68 |
- #'+ #' @keywords internal |
|
| 204 | +69 |
- #' @param x vector+ teal_data_to_filtered_data <- function(x, datanames = names(x)) {
+ |
+ |
| 70 | +83x | +
+ checkmate::assert_class(x, "teal_data") |
|
| 205 | -+ | ||
| 71 | +83x |
- #' @param y vector+ checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE) |
|
| 206 | +72 |
- #' @param msg (`character(1)`) message to display if `x` and `y` intersect+ # Otherwise, FilteredData will be created in the modules' scope later |
|
| 207 | -+ | ||
| 73 | +83x |
- #'+ teal.slice::init_filtered_data( |
|
| 208 | -+ | ||
| 74 | +83x |
- #' @export+ x = Filter(length, sapply(datanames, function(dn) x[[dn]], simplify = FALSE)), |
|
| 209 | -+ | ||
| 75 | +83x |
- #'+ join_keys = teal.data::join_keys(x) |
|
| 210 | +76 |
- #' @examples+ ) |
|
| 211 | +77 |
- #' data <- data.frame(+ } |
|
| 212 | +78 |
- #' id = c(1:10, 11:20, 1:10),+ |
|
| 213 | +79 |
- #' strata = rep(c("A", "B", "C"), each = 10)
+
|
|
| 214 | +80 |
- #' )+ #' Template function for `TealReportCard` creation and customization |
|
| 215 | +81 |
#' |
|
| 216 | +82 |
- #' ui <- fluidPage(+ #' This function generates a report card with a title, |
|
| 217 | +83 |
- #' selectInput("ref1", "Select strata1 to compare",
+ #' an optional description, and the option to append the filter state list. |
|
| 218 | +84 |
- #' choices = c("A", "B", "C"),
+ #' |
|
| 219 | +85 |
- #' selected = "A"+ #' @param title (`character(1)`) title of the card (unless overwritten by label) |
|
| 220 | +86 |
- #' ),+ #' @param label (`character(1)`) label provided by the user when adding the card |
|
| 221 | +87 |
- #' selectInput("ref2", "Select strata2 to compare",
+ #' @param description (`character(1)`) optional, additional description |
|
| 222 | +88 |
- #' choices = c("A", "B", "C"),
+ #' @param with_filter (`logical(1)`) flag indicating to add filter state |
|
| 223 | +89 |
- #' selected = "B"+ #' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation |
|
| 224 | +90 |
- #' ),+ #' of the filter state in the report |
|
| 225 | +91 |
- #' verbatimTextOutput("summary")
+ #' |
|
| 226 | +92 |
- #' )+ #' @return (`TealReportCard`) populated with a title, description and filter state. |
|
| 227 | +93 |
#' |
|
| 228 | +94 |
- #' server <- function(input, output) {
+ #' @export |
|
| 229 | +95 |
- #' output$summary <- renderText({
+ report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
|
|
| 230 | -+ | ||
| 96 | +2x |
- #' sample_1 <- data$id[data$strata == input$ref1]+ checkmate::assert_string(title) |
|
| 231 | -+ | ||
| 97 | +2x |
- #' sample_2 <- data$id[data$strata == input$ref2]+ checkmate::assert_string(label) |
|
| 232 | -+ | ||
| 98 | +2x |
- #'+ checkmate::assert_string(description, null.ok = TRUE) |
|
| 233 | -+ | ||
| 99 | +2x |
- #' validate_no_intersection(+ checkmate::assert_flag(with_filter) |
|
| 234 | -+ | ||
| 100 | +2x |
- #' sample_1, sample_2,+ checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI") |
|
| 235 | +101 |
- #' "subjects within strata1 and strata2 cannot overlap"+ |
|
| 236 | -+ | ||
| 102 | +2x |
- #' )+ card <- teal::TealReportCard$new() |
|
| 237 | -+ | ||
| 103 | +2x |
- #' paste0(+ title <- if (label == "") title else label |
|
| 238 | -+ | ||
| 104 | +2x |
- #' "Number of subject in: reference treatment=", length(sample_1),+ card$set_name(title) |
|
| 239 | -+ | ||
| 105 | +2x |
- #' " comparions treatment=", length(sample_2)+ card$append_text(title, "header2") |
|
| 240 | -+ | ||
| 106 | +1x |
- #' )+ if (!is.null(description)) card$append_text(description, "header3") |
|
| 241 | -+ | ||
| 107 | +1x |
- #' })+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ |
+ |
| 108 | +2x | +
+ card |
|
| 242 | +109 |
- #' }+ } |
|
| 243 | +110 |
- #' if (interactive()) {
+
|
|
| 244 | +111 |
- #' shinyApp(ui, server)+ |
|
| 245 | +112 |
- #' }+ #' Check `datanames` in modules |
|
| 246 | +113 |
#' |
|
| 247 | +114 |
- validate_no_intersection <- function(x, y, msg) {
+ #' These functions check if specified `datanames` in modules match those in the data object, |
|
| 248 | -! | +||
| 115 | +
- validate(need(length(intersect(x, y)) == 0, msg))+ #' returning error messages or `TRUE` for successful validation. Two functions return error message |
||
| 249 | +116 |
- }+ #' in different forms: |
|
| 250 | +117 |
-
+ #' - `check_modules_datanames` returns `character(1)` for basic assertion usage |
|
| 251 | +118 |
-
+ #' - `check_modules_datanames_html` returns `shiny.tag.list` to display it in the app. |
|
| 252 | +119 |
- #' Validates that dataset contains specific variable+ #' |
|
| 253 | +120 |
- #'+ #' @param modules (`teal_modules`) object |
|
| 254 | +121 |
- #' `r lifecycle::badge("stable")`
+ #' @param datanames (`character`) names of datasets available in the `data` object |
|
| 255 | +122 |
#' |
|
| 256 | +123 |
- #' This function is a wrapper for `shiny::validate`.+ #' @return `TRUE` if validation passes, otherwise `character(1)` or `shiny.tag.list` |
|
| 257 | +124 |
- #'+ #' @keywords internal |
|
| 258 | +125 |
- #' @param data (`data.frame`)+ check_modules_datanames <- function(modules, datanames) {
|
|
| 259 | -+ | ||
| 126 | +11x |
- #' @param varname (`character(1)`) name of variable to check for in `data`+ out <- check_modules_datanames_html(modules, datanames) |
|
| 260 | -+ | ||
| 127 | +11x |
- #' @param msg (`character(1)`) message to display if `data` does not include `varname`+ if (inherits(out, "shiny.tag.list")) {
|
|
| 261 | -+ | ||
| 128 | +5x |
- #'+ out_with_ticks <- gsub("<code>|</code>", "`", toString(out))
|
|
| 262 | -+ | ||
| 129 | +5x |
- #' @export+ out_text <- gsub("<[^<>]+>", "", toString(out_with_ticks))
|
|
| 263 | -+ | ||
| 130 | +5x |
- #'+ trimws(gsub("[[:space:]]+", " ", out_text))
|
|
| 264 | +131 |
- #' @examples+ } else {
|
|
| 265 | -+ | ||
| 132 | +6x |
- #' data <- data.frame(+ out |
|
| 266 | +133 |
- #' one = rep("a", length.out = 20),
+ } |
|
| 267 | +134 |
- #' two = rep(c("a", "b"), length.out = 20)
+ } |
|
| 268 | +135 |
- #' )+ |
|
| 269 | +136 |
- #' ui <- fluidPage(+ #' @rdname check_modules_datanames |
|
| 270 | +137 |
- #' selectInput(+ check_reserved_datanames <- function(datanames) {
|
|
| 271 | -+ | ||
| 138 | +190x |
- #' "var",+ reserved_datanames <- datanames[datanames %in% c("all", ".raw_data")]
|
|
| 272 | -+ | ||
| 139 | +190x |
- #' "Select variable",+ if (length(reserved_datanames) == 0L) {
|
|
| 273 | -+ | ||
| 140 | +184x |
- #' choices = c("one", "two", "three", "four"),
+ return(NULL) |
|
| 274 | +141 |
- #' selected = "one"+ } |
|
| 275 | +142 |
- #' ),+ |
|
| 276 | -+ | ||
| 143 | +6x |
- #' verbatimTextOutput("summary")
+ tags$span( |
|
| 277 | -+ | ||
| 144 | +6x |
- #' )+ to_html_code_list(reserved_datanames), |
|
| 278 | -+ | ||
| 145 | +6x |
- #'+ sprintf( |
|
| 279 | -+ | ||
| 146 | +6x |
- #' server <- function(input, output) {
+ "%s reserved for internal use. Please avoid using %s as %s.", |
|
| 280 | -+ | ||
| 147 | +6x |
- #' output$summary <- renderText({
+ pluralize(reserved_datanames, "is", "are"), |
|
| 281 | -+ | ||
| 148 | +6x |
- #' validate_has_variable(data, input$var)+ pluralize(reserved_datanames, "it", "them"), |
|
| 282 | -+ | ||
| 149 | +6x |
- #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
+ pluralize(reserved_datanames, "a dataset name", "dataset names") |
|
| 283 | +150 |
- #' })+ ) |
|
| 284 | +151 |
- #' }+ ) |
|
| 285 | +152 |
- #' if (interactive()) {
+ } |
|
| 286 | +153 |
- #' shinyApp(ui, server)+ |
|
| 287 | +154 |
- #' }+ #' @rdname check_modules_datanames |
|
| 288 | +155 |
- validate_has_variable <- function(data, varname, msg) {
+ check_modules_datanames_html <- function(modules, datanames) {
|
|
| 289 | -! | +||
| 156 | +190x |
- if (length(varname) != 0) {
+ check_datanames <- check_modules_datanames_recursive(modules, datanames) |
|
| 290 | -! | +||
| 157 | +190x |
- has_vars <- varname %in% names(data)+ show_module_info <- inherits(modules, "teal_modules") # used in two contexts - module and app |
|
| 291 | +158 | ||
| 292 | -! | -
- if (!all(has_vars)) {
- |
- |
| 293 | -! | -
- if (missing(msg)) {
- |
- |
| 294 | -! | +||
| 159 | +190x |
- msg <- sprintf(+ reserved_datanames <- check_reserved_datanames(datanames) |
|
| 295 | -! | +||
| 160 | +
- "%s does not have the required variables: %s.",+ |
||
| 296 | -! | +||
| 161 | +190x |
- deparse(substitute(data)),+ if (!length(check_datanames)) {
|
|
| 297 | -! | +||
| 162 | +172x |
- toString(varname[!has_vars])+ out <- if (is.null(reserved_datanames)) {
|
|
| 298 | -+ | ||
| 163 | +166x |
- )+ TRUE |
|
| 299 | +164 |
- }+ } else {
|
|
| 300 | -! | +||
| 165 | +6x |
- validate(need(FALSE, msg))+ shiny::tagList(reserved_datanames) |
|
| 301 | +166 |
} |
|
| 302 | -+ | ||
| 167 | +172x |
- }+ return(out) |
|
| 303 | +168 |
- }+ } |
|
| 304 | -+ | ||
| 169 | +18x |
-
+ shiny::tagList( |
|
| 305 | -+ | ||
| 170 | +18x |
- #' Validate that variables has expected number of levels+ reserved_datanames, |
|
| 306 | -+ | ||
| 171 | +18x |
- #'+ lapply( |
|
| 307 | -+ | ||
| 172 | +18x |
- #' `r lifecycle::badge("stable")`
+ check_datanames, |
|
| 308 | -+ | ||
| 173 | +18x |
- #'+ function(mod) {
|
|
| 309 | -+ | ||
| 174 | +18x |
- #' If the number of levels of `x` is less than `min_levels`+ tagList( |
|
| 310 | -+ | ||
| 175 | +18x |
- #' or greater than `max_levels` the validation will fail.+ tags$span( |
|
| 311 | -+ | ||
| 176 | +18x |
- #' This function is a wrapper for `shiny::validate`.+ tags$span(pluralize(mod$missing_datanames, "Dataset")), |
|
| 312 | -+ | ||
| 177 | +18x |
- #'+ to_html_code_list(mod$missing_datanames), |
|
| 313 | -+ | ||
| 178 | +18x |
- #' @param x variable name. If `x` is not a factor, the unique values+ tags$span( |
|
| 314 | -+ | ||
| 179 | +18x |
- #' are treated as levels.+ sprintf( |
|
| 315 | -+ | ||
| 180 | +18x |
- #' @param min_levels cutoff for minimum number of levels of `x`+ "%s missing%s.", |
|
| 316 | -+ | ||
| 181 | +18x |
- #' @param max_levels cutoff for maximum number of levels of `x`+ pluralize(mod$missing_datanames, "is", "are"), |
|
| 317 | -+ | ||
| 182 | +18x |
- #' @param var_name name of variable being validated for use in+ if (show_module_info) sprintf(" for module '%s'", mod$label) else ""
|
|
| 318 | +183 |
- #' validation message+ ) |
|
| 319 | +184 |
- #'+ ) |
|
| 320 | +185 |
- #' @export+ ), |
|
| 321 | -+ | ||
| 186 | +18x |
- #' @examples+ if (length(datanames) >= 1) {
|
|
| 322 | -+ | ||
| 187 | +16x |
- #' data <- data.frame(+ tagList( |
|
| 323 | -+ | ||
| 188 | +16x |
- #' one = rep("a", length.out = 20),
+ tags$span(pluralize(datanames, "Dataset")), |
|
| 324 | -+ | ||
| 189 | +16x |
- #' two = rep(c("a", "b"), length.out = 20),
+ tags$span("available in data:"),
|
|
| 325 | -+ | ||
| 190 | +16x |
- #' three = rep(c("a", "b", "c"), length.out = 20),
+ tagList( |
|
| 326 | -+ | ||
| 191 | +16x |
- #' four = rep(c("a", "b", "c", "d"), length.out = 20),
+ tags$span( |
|
| 327 | -+ | ||
| 192 | +16x |
- #' stringsAsFactors = TRUE+ to_html_code_list(datanames), |
|
| 328 | -+ | ||
| 193 | +16x |
- #' )+ tags$span(".", .noWS = "outside"),
|
|
| 329 | -+ | ||
| 194 | +16x |
- #' ui <- fluidPage(+ .noWS = c("outside")
|
|
| 330 | +195 |
- #' selectInput(+ ) |
|
| 331 | +196 |
- #' "var",+ ) |
|
| 332 | +197 |
- #' "Select variable",+ ) |
|
| 333 | +198 |
- #' choices = c("one", "two", "three", "four"),
+ } else {
|
|
| 334 | -+ | ||
| 199 | +2x |
- #' selected = "one"+ tags$span("No datasets are available in data.")
|
|
| 335 | +200 |
- #' ),+ }, |
|
| 336 | -+ | ||
| 201 | +18x |
- #' verbatimTextOutput("summary")
+ tags$br(.noWS = "before") |
|
| 337 | +202 |
- #' )+ ) |
|
| 338 | +203 |
- #'+ } |
|
| 339 | +204 |
- #' server <- function(input, output) {
+ ) |
|
| 340 | +205 |
- #' output$summary <- renderText({
+ ) |
|
| 341 | +206 |
- #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var)+ } |
|
| 342 | +207 |
- #' paste0(+ |
|
| 343 | +208 |
- #' "Levels of selected treatment variable: ",+ #' Recursively checks modules and returns list for every datanames mismatch between module and data |
|
| 344 | +209 |
- #' paste(levels(data[[input$var]]),+ #' @noRd |
|
| 345 | +210 |
- #' collapse = ", "+ check_modules_datanames_recursive <- function(modules, datanames) { # nolint: object_name_length
|
|
| 346 | -+ | ||
| 211 | +296x |
- #' )+ checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
|
|
| 347 | -+ | ||
| 212 | +296x |
- #' )+ checkmate::assert_character(datanames) |
|
| 348 | -+ | ||
| 213 | +296x |
- #' })+ if (inherits(modules, "teal_modules")) {
|
|
| 349 | -+ | ||
| 214 | +86x |
- #' }+ unlist( |
|
| 350 | -+ | ||
| 215 | +86x |
- #' if (interactive()) {
+ lapply(modules$children, check_modules_datanames_recursive, datanames = datanames), |
|
| 351 | -+ | ||
| 216 | +86x |
- #' shinyApp(ui, server)+ recursive = FALSE |
|
| 352 | +217 |
- #' }+ ) |
|
| 353 | +218 |
- validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
+ } else {
|
|
| 354 | -! | +||
| 219 | +210x |
- x_levels <- if (is.factor(x)) {
+ missing_datanames <- setdiff(modules$datanames, c("all", datanames))
|
|
| 355 | -! | +||
| 220 | +210x |
- levels(x)+ if (length(missing_datanames)) {
|
|
| 356 | -+ | ||
| 221 | +18x |
- } else {
+ list(list( |
|
| 357 | -! | +||
| 222 | +18x |
- unique(x)+ label = modules$label, |
|
| 358 | -+ | ||
| 223 | +18x |
- }+ missing_datanames = missing_datanames |
|
| 359 | +224 | - - | -|
| 360 | -! | -
- if (!is.null(min_levels) && !(is.null(max_levels))) {
+ )) |
|
| 361 | -! | +||
| 225 | +
- validate(need(+ } |
||
| 362 | -! | +||
| 226 | +
- length(x_levels) >= min_levels && length(x_levels) <= max_levels,+ } |
||
| 363 | -! | +||
| 227 | +
- sprintf(+ } |
||
| 364 | -! | +||
| 228 | +
- "%s variable needs minimum %s level(s) and maximum %s level(s).",+ |
||
| 365 | -! | +||
| 229 | +
- var_name, min_levels, max_levels+ #' Convert character vector to html code separated with commas and "and" |
||
| 366 | +230 |
- )+ #' @noRd |
|
| 367 | +231 |
- ))+ to_html_code_list <- function(x) {
|
|
| 368 | -! | +||
| 232 | +40x |
- } else if (!is.null(min_levels)) {
+ checkmate::assert_character(x) |
|
| 369 | -! | +||
| 233 | +40x |
- validate(need(+ do.call( |
|
| 370 | -! | +||
| 234 | +40x |
- length(x_levels) >= min_levels,+ tagList, |
|
| 371 | -! | +||
| 235 | +40x |
- sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
+ lapply(seq_along(x), function(.ix) {
|
- |
| 372 | -+ | ||
| 236 | +56x |
- ))+ tagList( |
|
| 373 | -! | +||
| 237 | +56x |
- } else if (!is.null(max_levels)) {
+ tags$code(x[.ix]), |
|
| 374 | -! | +||
| 238 | +56x |
- validate(need(+ if (.ix != length(x)) {
|
|
| 375 | -! | +||
| 239 | +1x |
- length(x_levels) <= max_levels,+ if (.ix == length(x) - 1) tags$span(" and ") else tags$span(", ", .noWS = "before")
|
|
| 376 | -! | +||
| 240 | +
- sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
+ } |
||
| 377 | +241 |
- ))+ ) |
|
| 378 | +242 |
- }+ }) |
|
| 379 | +243 |
- }+ ) |
| 1 | +244 |
- #' Data module for `teal` transformations and output customization+ } |
||
| 2 | +245 |
- #'+ |
||
| 3 | +246 |
- #' @description+ |
||
| 4 | +247 |
- #' `r lifecycle::badge("experimental")`
+ #' Check `datanames` in filters |
||
| 5 | +248 |
#' |
||
| 6 | +249 |
- #' `teal_transform_module` provides a `shiny` module that enables data transformations within a `teal` application+ #' This function checks whether `datanames` in filters correspond to those in `data`, |
||
| 7 | +250 |
- #' and allows for customization of outputs generated by modules.+ #' returning character vector with error messages or `TRUE` if all checks pass. |
||
| 8 | +251 |
#' |
||
| 9 | +252 |
- #' # Transforming Module Inputs in `teal`+ #' @param filters (`teal_slices`) object |
||
| 10 | +253 |
- #'+ #' @param datanames (`character`) names of datasets available in the `data` object |
||
| 11 | +254 |
- #' Data transformations occur after data has been filtered in `teal`.+ #' |
||
| 12 | +255 |
- #' The transformed data is then passed to the `server` of [`teal_module()`] and managed by `teal`'s internal processes.+ #' @return A `character(1)` containing error message or TRUE if validation passes. |
||
| 13 | +256 |
- #' The primary advantage of `teal_transform_module` over custom modules is in its error handling, where all warnings and+ #' @keywords internal |
||
| 14 | +257 |
- #' errors are managed by `teal`, allowing developers to focus on transformation logic.+ check_filter_datanames <- function(filters, datanames) {
|
||
| 15 | -+ | |||
| 258 | +86x |
- #'+ checkmate::assert_class(filters, "teal_slices") |
||
| 16 | -+ | |||
| 259 | +86x |
- #' For more details, see the vignette: `vignette("data-transform-as-shiny-module", package = "teal")`.
+ checkmate::assert_character(datanames) |
||
| 17 | +260 |
- #'+ |
||
| 18 | +261 |
- #' # Customizing Module Outputs+ # check teal_slices against datanames |
||
| 19 | -+ | |||
| 262 | +86x |
- #'+ out <- unlist(sapply( |
||
| 20 | -+ | |||
| 263 | +86x |
- #' `teal_transform_module` also allows developers to modify any object created within [`teal.data::teal_data`].+ filters, function(filter) {
|
||
| 21 | -+ | |||
| 264 | +24x |
- #' This means you can use it to customize not only datasets but also tables, listings, and graphs.+ dataname <- shiny::isolate(filter$dataname) |
||
| 22 | -+ | |||
| 265 | +24x |
- #' Some [`teal_modules`] permit developers to inject custom `shiny` modules to enhance displayed outputs.+ if (!dataname %in% datanames) {
|
||
| 23 | -+ | |||
| 266 | +3x |
- #' To manage these `decorators` within your module, use [`ui_transform_teal_data()`] and [`srv_transform_teal_data()`].+ sprintf( |
||
| 24 | -+ | |||
| 267 | +3x |
- #' (For further guidance on managing decorators, refer to `ui_args` and `srv_args` in the vignette documentation.)+ "- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)", |
||
| 25 | -+ | |||
| 268 | +3x |
- #'+ shiny::isolate(filter$id), |
||
| 26 | -+ | |||
| 269 | +3x |
- #' See the vignette `vignette("decorate-modules-output", package = "teal")` for additional examples.
+ dQuote(dataname, q = FALSE), |
||
| 27 | -+ | |||
| 270 | +3x |
- #'+ toString(dQuote(datanames, q = FALSE)) |
||
| 28 | +271 |
- #' # `server` as a language+ ) |
||
| 29 | +272 |
- #'+ } |
||
| 30 | +273 |
- #' The `server` function in `teal_transform_module` must return a reactive [`teal.data::teal_data`] object.+ } |
||
| 31 | +274 |
- #' For simple transformations without complex reactivity, the `server` function might look like this:s+ )) |
||
| 32 | +275 |
- #'+ |
||
| 33 | +276 |
- #' ```+ |
||
| 34 | -+ | |||
| 277 | +86x |
- #' function(id, data) {
+ if (length(out)) {
|
||
| 35 | -+ | |||
| 278 | +3x |
- #' moduleServer(id, function(input, output, session) {
+ paste(out, collapse = "\n") |
||
| 36 | +279 |
- #' reactive({
+ } else {
|
||
| 37 | -+ | |||
| 280 | +83x |
- #' within(+ TRUE |
||
| 38 | +281 |
- #' data(),+ } |
||
| 39 | +282 |
- #' expr = x <- subset(x, col == level),+ } |
||
| 40 | +283 |
- #' level = input$level+ |
||
| 41 | +284 |
- #' )+ #' Function for validating the title parameter of `teal::init` |
||
| 42 | +285 |
- #' })+ #' |
||
| 43 | +286 |
- #' })+ #' Checks if the input of the title from `teal::init` will create a valid title and favicon tag. |
||
| 44 | +287 |
- #' }+ #' @param shiny_tag (`shiny.tag`) Object to validate for a valid title. |
||
| 45 | +288 |
- #' ```+ #' @keywords internal |
||
| 46 | +289 |
- #'+ validate_app_title_tag <- function(shiny_tag) {
|
||
| 47 | -+ | |||
| 290 | +7x |
- #' The example above can be simplified using `make_teal_transform_server`, where `level` is automatically matched to the+ checkmate::assert_class(shiny_tag, "shiny.tag") |
||
| 48 | -+ | |||
| 291 | +7x |
- #' corresponding `input` parameter:+ checkmate::assert_true(shiny_tag$name == "head") |
||
| 49 | -+ | |||
| 292 | +6x |
- #'+ child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name") |
||
| 50 | -+ | |||
| 293 | +6x |
- #' ```+ checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags")
|
||
| 51 | -+ | |||
| 294 | +4x |
- #' make_teal_transform_server(expr = expression(x <- subset(x, col == level)))+ rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel |
||
| 52 | -+ | |||
| 295 | +4x |
- #' ```+ checkmate::assert_subset(+ |
+ ||
| 296 | +4x | +
+ rel_attr,+ |
+ ||
| 297 | +4x | +
+ c("icon", "shortcut icon"),
+ |
+ ||
| 298 | +4x | +
+ .var.name = "Link tag's rel attribute",+ |
+ ||
| 299 | +4x | +
+ empty.ok = FALSE |
||
| 53 | +300 |
- #' @inheritParams teal_data_module+ ) |
||
| 54 | +301 |
- #' @param server (`function(id, data)` or `expression`)+ } |
||
| 55 | +302 |
- #' A `shiny` module server function that takes `id` and `data` as arguments, where `id` is the module id and `data`+ |
||
| 56 | +303 |
- #' is the reactive `teal_data` input. The `server` function must return a reactive expression containing a `teal_data`+ #' Build app title with favicon |
||
| 57 | +304 |
- #' object. For simplified syntax, use [`make_teal_transform_server()`].+ #' |
||
| 58 | +305 |
- #' @param datanames (`character`)+ #' A helper function to create the browser title along with a logo. |
||
| 59 | +306 |
- #' Specifies the names of datasets relevant to the module. Only filters for the specified `datanames` will be displayed+ #' |
||
| 60 | +307 |
- #' in the filter panel. The keyword `"all"` can be used to display filters for all datasets. `datanames` are+ #' @param title (`character`) The browser title for the `teal` app. |
||
| 61 | +308 |
- #' automatically appended to the [`modules()`] `datanames`.+ #' @param favicon (`character`) The path for the icon for the title. |
||
| 62 | +309 |
- #'+ #' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/` |
||
| 63 | +310 |
#' |
||
| 64 | +311 |
- #' @examples+ #' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app. |
||
| 65 | +312 |
- #' data_transformators <- list(+ #' @export |
||
| 66 | +313 |
- #' teal_transform_module(+ build_app_title <- function( |
||
| 67 | +314 |
- #' label = "Static transformator for iris",+ title = "teal app", |
||
| 68 | +315 |
- #' datanames = "iris",+ favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
|
||
| 69 | -+ | |||
| 316 | +15x |
- #' server = function(id, data) {
+ checkmate::assert_string(title, null.ok = TRUE) |
||
| 70 | -+ | |||
| 317 | +15x |
- #' moduleServer(id, function(input, output, session) {
+ checkmate::assert_string(favicon, null.ok = TRUE)+ |
+ ||
| 318 | +15x | +
+ tags$head(+ |
+ ||
| 319 | +15x | +
+ tags$title(title),+ |
+ ||
| 320 | +15x | +
+ tags$link(+ |
+ ||
| 321 | +15x | +
+ rel = "icon",+ |
+ ||
| 322 | +15x | +
+ href = favicon,+ |
+ ||
| 323 | +15x | +
+ sizes = "any" |
||
| 71 | +324 |
- #' reactive({
+ ) |
||
| 72 | +325 |
- #' within(data(), {
+ ) |
||
| 73 | +326 |
- #' iris <- head(iris, 5)+ } |
||
| 74 | +327 |
- #' })+ |
||
| 75 | +328 |
- #' })+ #' Application ID |
||
| 76 | +329 |
- #' })+ #' |
||
| 77 | +330 |
- #' }+ #' Creates App ID used to match filter snapshots to application. |
||
| 78 | +331 |
- #' ),+ #' |
||
| 79 | +332 |
- #' teal_transform_module(+ #' Calculate app ID that will be used to stamp filter state snapshots. |
||
| 80 | +333 |
- #' label = "Interactive transformator for iris",+ #' App ID is a hash of the app's data and modules. |
||
| 81 | +334 |
- #' datanames = "iris",+ #' See "transferring snapshots" section in ?snapshot. |
||
| 82 | +335 |
- #' ui = function(id) {
+ #' |
||
| 83 | +336 |
- #' ns <- NS(id)+ #' @param data (`teal_data` or `teal_data_module`) as accepted by `init` |
||
| 84 | +337 |
- #' tags$div(+ #' @param modules (`teal_modules`) object as accepted by `init` |
||
| 85 | +338 |
- #' numericInput(ns("n_cols"), "Show n columns", value = 5, min = 1, max = 5, step = 1)
+ #' |
||
| 86 | +339 |
- #' )+ #' @return A single character string. |
||
| 87 | +340 |
- #' },+ #' |
||
| 88 | +341 |
- #' server = function(id, data) {
+ #' @keywords internal |
||
| 89 | +342 |
- #' moduleServer(id, function(input, output, session) {
+ create_app_id <- function(data, modules) {
|
||
| 90 | -+ | |||
| 343 | +23x |
- #' reactive({
+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
|
||
| 91 | -+ | |||
| 344 | +22x |
- #' within(data(),+ checkmate::assert_class(modules, "teal_modules") |
||
| 92 | +345 |
- #' {
+
|
||
| 93 | -+ | |||
| 346 | +21x |
- #' iris <- iris[, 1:n_cols]+ data <- if (inherits(data, "teal_data")) {
|
||
| 94 | -+ | |||
| 347 | +19x |
- #' },+ as.list(data) |
||
| 95 | -+ | |||
| 348 | +21x |
- #' n_cols = input$n_cols+ } else if (inherits(data, "teal_data_module")) {
|
||
| 96 | -+ | |||
| 349 | +2x |
- #' )+ deparse1(body(data$server)) |
||
| 97 | +350 |
- #' })+ } |
||
| 98 | -+ | |||
| 351 | +21x |
- #' })+ modules <- lapply(modules, defunction) |
||
| 99 | +352 |
- #' }+ |
||
| 100 | -+ | |||
| 353 | +21x |
- #' )+ rlang::hash(list(data = data, modules = modules)) |
||
| 101 | +354 |
- #' )+ } |
||
| 102 | +355 |
- #'+ |
||
| 103 | +356 |
- #' output_decorator <- teal_transform_module(+ #' Go through list and extract bodies of encountered functions as string, recursively. |
||
| 104 | +357 |
- #' server = make_teal_transform_server(+ #' @keywords internal |
||
| 105 | +358 |
- #' expression(+ #' @noRd |
||
| 106 | +359 |
- #' object <- rev(object)+ defunction <- function(x) {
|
||
| 107 | -+ | |||
| 360 | +297x |
- #' )+ if (is.list(x)) {
|
||
| 108 | -+ | |||
| 361 | +121x |
- #' )+ lapply(x, defunction) |
||
| 109 | -+ | |||
| 362 | +176x |
- #' )+ } else if (is.function(x)) {
|
||
| 110 | -+ | |||
| 363 | +54x |
- #'+ deparse1(body(x)) |
||
| 111 | +364 |
- #' app <- init(+ } else {
|
||
| 112 | -+ | |||
| 365 | +122x |
- #' data = teal_data(iris = iris),+ x |
||
| 113 | +366 |
- #' modules = example_module(+ } |
||
| 114 | +367 |
- #' transformators = data_transformators,+ } |
||
| 115 | +368 |
- #' decorators = list(output_decorator)+ |
||
| 116 | +369 |
- #' )+ #' Get unique labels |
||
| 117 | +370 |
- #' )+ #' |
||
| 118 | +371 |
- #' if (interactive()) {
+ #' Get unique labels for the modules to avoid namespace conflicts. |
||
| 119 | +372 |
- #' shinyApp(app$ui, app$server)+ #' |
||
| 120 | +373 |
- #' }+ #' @param labels (`character`) vector of labels |
||
| 121 | +374 |
#' |
||
| 122 | +375 |
- #' @name teal_transform_module+ #' @return (`character`) vector of unique labels |
||
| 123 | +376 |
#' |
||
| 124 | +377 |
- #' @export+ #' @keywords internal |
||
| 125 | +378 |
- teal_transform_module <- function(ui = NULL,+ get_unique_labels <- function(labels) {
+ |
+ ||
| 379 | +141x | +
+ make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
|
||
| 126 | +380 |
- server = function(id, data) data,+ } |
||
| 127 | +381 |
- label = "transform module",+ |
||
| 128 | +382 |
- datanames = "all") {
+ #' @keywords internal |
||
| 129 | -25x | +|||
| 383 | +
- structure(+ #' @noRd |
|||
| 130 | -25x | +384 | +4x |
- list(+ pasten <- function(...) paste0(..., "\n") |
| 131 | -25x | +|||
| 385 | +
- ui = ui,+ |
|||
| 132 | -25x | +|||
| 386 | +
- server = function(id, data) {
+ #' Convert character list to human readable html with commas and "and" |
|||
| 133 | -26x | +|||
| 387 | +
- data_out <- server(id, data)+ #' @noRd |
|||
| 134 | +388 |
-
+ paste_datanames_character <- function(x, |
||
| 135 | -26x | +|||
| 389 | +
- if (inherits(data_out, "reactive.event")) {
+ tags = list(span = shiny::tags$span, code = shiny::tags$code), |
|||
| 136 | +390 |
- # This warning message partially detects when `eventReactive` is used in `data_module`.+ tagList = shiny::tagList) { # nolint: object_name.
|
||
| 137 | -1x | +|||
| 391 | +! |
- warning(+ checkmate::assert_character(x) |
||
| 138 | -1x | +|||
| 392 | +! |
- "teal_transform_module() ",+ do.call( |
||
| 139 | -1x | +|||
| 393 | +! |
- "Using eventReactive in teal_transform module server code should be avoided as it ",+ tagList, |
||
| 140 | -1x | +|||
| 394 | +! |
- "may lead to unexpected behavior. See the vignettes for more information ",+ lapply(seq_along(x), function(.ix) {
|
||
| 141 | -1x | +|||
| 395 | +! |
- "(`vignette(\"data-transform-as-shiny-module\", package = \"teal\")`).",+ tagList( |
||
| 142 | -1x | +|||
| 396 | +! |
- call. = FALSE+ tags$code(x[.ix]), |
||
| 143 | -+ | |||
| 397 | +! |
- )+ if (.ix != length(x)) {
+ |
+ ||
| 398 | +! | +
+ tags$span(if (.ix == length(x) - 1) " and " else ", ") |
||
| 144 | +399 |
} |
||
| 145 | +400 |
-
+ ) |
||
| 146 | +401 |
-
+ }) |
||
| 147 | -26x | +|||
| 402 | +
- decorate_err_msg(+ ) |
|||
| 148 | -26x | +|||
| 403 | +
- assert_reactive(data_out),+ } |
|||
| 149 | -26x | +|||
| 404 | +
- pre = sprintf("From: 'teal_transform_module()':\nA 'teal_transform_module' with \"%s\" label:", label),
+
|
|||
| 150 | -26x | +|||
| 405 | +
- post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.+ #' Build datanames error string for error message |
|||
| 151 | +406 |
- )+ #' |
||
| 152 | +407 |
- }+ #' tags and tagList are overwritten in arguments allowing to create strings for |
||
| 153 | +408 |
- ),+ #' logging purposes |
||
| 154 | -25x | +|||
| 409 | +
- label = label,+ #' @noRd |
|||
| 155 | -25x | +|||
| 410 | +
- datanames = datanames,+ build_datanames_error_message <- function(label = NULL, |
|||
| 156 | -25x | +|||
| 411 | +
- class = c("teal_transform_module", "teal_data_module")
+ datanames, |
|||
| 157 | +412 |
- )+ extra_datanames, |
||
| 158 | +413 |
- }+ tags = list(span = shiny::tags$span, code = shiny::tags$code), |
||
| 159 | +414 |
-
+ tagList = shiny::tagList) { # nolint: object_name.
|
||
| 160 | -+ | |||
| 415 | +! |
- #' Make teal_transform_module's server+ tags$span( |
||
| 161 | -+ | |||
| 416 | +! |
- #'+ tags$span(pluralize(extra_datanames, "Dataset")), |
||
| 162 | -+ | |||
| 417 | +! |
- #' A factory function to simplify creation of a [`teal_transform_module`]'s server. Specified `expr`+ paste_datanames_character(extra_datanames, tags, tagList), |
||
| 163 | -+ | |||
| 418 | +! |
- #' is wrapped in a shiny module function and output can be passed to the `server` argument in+ tags$span( |
||
| 164 | -+ | |||
| 419 | +! | +
+ sprintf(+ |
+ ||
| 420 | +! |
- #' [teal_transform_module()] call. Such a server function can be linked with ui and values from the+ "%s missing%s", |
||
| 165 | -+ | |||
| 421 | +! |
- #' inputs can be used in the expression. Object names specified in the expression will be substituted+ pluralize(extra_datanames, "is", "are"), |
||
| 166 | -+ | |||
| 422 | +! |
- #' with the value of the respective input (matched by the name) - for example in+ if (is.null(label)) "" else sprintf(" for tab '%s'", label)
|
||
| 167 | +423 |
- #' `expression(graph <- graph + ggtitle(title))` object `title` will be replaced with the value of+ ) |
||
| 168 | +424 |
- #' `input$title`.+ ), |
||
| 169 | -+ | |||
| 425 | +! |
- #' @param expr (`language`)+ if (length(datanames) >= 1) {
|
||
| 170 | -+ | |||
| 426 | +! |
- #' An R call which will be evaluated within [`teal.data::teal_data`] environment.+ tagList( |
||
| 171 | -+ | |||
| 427 | +! |
- #' @return `function(id, data)` returning `shiny` module+ tags$span(pluralize(datanames, "Dataset")), |
||
| 172 | -+ | |||
| 428 | +! |
- #' @examples+ tags$span("available in data:"),
|
||
| 173 | -+ | |||
| 429 | +! |
- #'+ tagList( |
||
| 174 | -+ | |||
| 430 | +! |
- #' trim_iris <- teal_transform_module(+ tags$span( |
||
| 175 | -+ | |||
| 431 | +! |
- #' label = "Simplified interactive transformator for iris",+ paste_datanames_character(datanames, tags, tagList), |
||
| 176 | -+ | |||
| 432 | +! |
- #' datanames = "iris",+ tags$span(".", .noWS = "outside"),
|
||
| 177 | -+ | |||
| 433 | +! |
- #' ui = function(id) {
+ .noWS = c("outside")
|
||
| 178 | +434 |
- #' ns <- NS(id)+ ) |
||
| 179 | +435 |
- #' numericInput(ns("n_rows"), "Subset n rows", value = 6, min = 1, max = 150, step = 1)
+ ) |
||
| 180 | +436 |
- #' },+ ) |
||
| 181 | +437 |
- #' server = make_teal_transform_server(expression(iris <- head(iris, n_rows)))+ } else {
|
||
| 182 | -+ | |||
| 438 | +! |
- #' )+ tags$span("No datasets are available in data.")
|
||
| 183 | +439 |
- #'+ } |
||
| 184 | +440 |
- #' app <- init(+ ) |
||
| 185 | +441 |
- #' data = teal_data(iris = iris),+ } |
||
| 186 | +442 |
- #' modules = example_module(transformators = trim_iris)+ |
||
| 187 | +443 |
- #' )+ #' Smart `rbind` |
||
| 188 | +444 |
- #' if (interactive()) {
+ #' |
||
| 189 | +445 |
- #' shinyApp(app$ui, app$server)+ #' Combine `data.frame` objects which have different columns |
||
| 190 | +446 |
- #' }+ #' |
||
| 191 | +447 |
- #'+ #' @param ... (`data.frame`) |
||
| 192 | +448 |
- #' @export+ #' @keywords internal |
||
| 193 | +449 |
- make_teal_transform_server <- function(expr) {
+ .smart_rbind <- function(...) {
|
||
| 194 | -3x | +450 | +89x |
- if (is.call(expr)) {
+ dots <- list(...) |
| 195 | -1x | +451 | +89x |
- expr <- as.expression(expr)+ checkmate::assert_list(dots, "data.frame", .var.name = "...") |
| 196 | -+ | |||
| 452 | +89x |
- }+ Reduce( |
||
| 197 | -3x | +453 | +89x |
- checkmate::assert_multi_class(expr, c("call", "expression"))
+ x = dots, |
| 198 | -+ | |||
| 454 | +89x |
-
+ function(x, y) {
|
||
| 199 | -3x | +455 | +72x |
- function(id, data) {
+ all_columns <- union(colnames(x), colnames(y)) |
| 200 | -3x | +456 | +72x |
- moduleServer(id, function(input, output, session) {
+ x[setdiff(all_columns, colnames(x))] <- NA |
| 201 | -3x | +457 | +72x |
- list_env <- reactive(+ y[setdiff(all_columns, colnames(y))] <- NA |
| 202 | -3x | +458 | +72x |
- lapply(rlang::set_names(names(input)), function(x) input[[x]])+ rbind(x, y) |
| 203 | +459 |
- )+ } |
||
| 204 | +460 |
-
+ ) |
||
| 205 | -3x | +|||
| 461 | +
- reactive({
+ } |
|||
| 206 | -4x | +|||
| 462 | +
- call_with_inputs <- lapply(expr, function(x) {
+
|
|||
| 207 | -4x | +|||
| 463 | +
- do.call(what = substitute, args = list(expr = x, env = list_env()))+ #' Pluralize a word depending on the size of the input |
|||
| 208 | +464 |
- })+ #' |
||
| 209 | -4x | +|||
| 465 | +
- eval_code(object = data(), code = as.expression(call_with_inputs))+ #' @param x (`object`) to check length for plural. |
|||
| 210 | +466 |
- })+ #' @param singular (`character`) singular form of the word. |
||
| 211 | +467 |
- })+ #' @param plural (optional `character`) plural form of the word. If not given an "s" |
||
| 212 | +468 |
- }+ #' is added to the singular form. |
||
| 213 | +469 |
- }+ #' |
||
| 214 | +470 |
-
+ #' @return A `character` that correctly represents the size of the `x` argument. |
||
| 215 | +471 |
- #' Extract all `transformators` from `modules`.+ #' @keywords internal |
||
| 216 | +472 |
- #'+ pluralize <- function(x, singular, plural = NULL) {
|
||
| 217 | -+ | |||
| 473 | +70x |
- #' @param modules `teal_modules` or `teal_module`+ checkmate::assert_string(singular) |
||
| 218 | -+ | |||
| 474 | +70x |
- #' @return A list of `teal_transform_module` nested in the same way as input `modules`.+ checkmate::assert_string(plural, null.ok = TRUE) |
||
| 219 | -+ | |||
| 475 | +70x |
- #' @keywords internal+ if (length(x) == 1L) { # Zero length object should use plural form.
+ |
+ ||
| 476 | +42x | +
+ singular |
||
| 220 | +477 |
- extract_transformators <- function(modules) {
+ } else {
|
||
| 221 | -10x | +478 | +28x |
- if (inherits(modules, "teal_module")) {
+ if (is.null(plural)) {
|
| 222 | -5x | +479 | +12x |
- modules$transformators+ sprintf("%ss", singular)
|
| 223 | -5x | +|||
| 480 | +
- } else if (inherits(modules, "teal_modules")) {
+ } else {
|
|||
| 224 | -5x | +481 | +16x |
- lapply(modules$children, extract_transformators)+ plural |
| 225 | +482 | ++ |
+ }+ |
+ |
| 483 |
} |
|||
| 226 | +484 |
}@@ -41952,735 +41534,735 @@ teal coverage - 60.02% |
| 1 |
- #' @title `TealReportCard`+ #' Module to transform `reactive` `teal_data` |
|||
| 2 |
- #' @description `r lifecycle::badge("experimental")`
+ #' |
|||
| 3 |
- #' Child class of [`teal.reporter::ReportCard`] that is used for `teal` specific applications.+ #' Module calls [teal_transform_module()] in sequence so that `reactive teal_data` output |
|||
| 4 |
- #' In addition to the parent methods, it supports rendering `teal` specific elements such as+ #' from one module is handed over to the following module's input. |
|||
| 5 |
- #' the source code, the encodings panel content and the filter panel content as part of the+ #' |
|||
| 6 |
- #' meta data.+ #' @inheritParams module_teal_data |
|||
| 7 |
- #' @export+ #' @inheritParams teal_modules |
|||
| 8 |
- #'+ #' @param class (character(1)) CSS class to be added in the `div` wrapper tag. |
|||
| 9 |
- TealReportCard <- R6::R6Class( # nolint: object_name.+ |
|||
| 10 |
- classname = "TealReportCard",+ #' @return `reactive` `teal_data` |
|||
| 11 |
- inherit = teal.reporter::ReportCard,+ #' |
|||
| 12 |
- public = list(+ #' @name module_transform_data |
|||
| 13 |
- #' @description Appends the source code to the `content` meta data of this `TealReportCard`.+ NULL |
|||
| 14 |
- #'+ |
|||
| 15 |
- #' @param src (`character(1)`) code as text.+ #' @export |
|||
| 16 |
- #' @param ... any `rmarkdown` `R` chunk parameter and its value.+ #' @rdname module_transform_data |
|||
| 17 |
- #' But `eval` parameter is always set to `FALSE`.+ ui_transform_teal_data <- function(id, transformators, class = "well") {
|
|||
| 18 | -+ | 1x |
- #' @return Object of class `TealReportCard`, invisibly.+ checkmate::assert_string(id) |
|
| 19 | -+ | 1x |
- #' @examples+ if (length(transformators) == 0L) {
|
|
| 20 | -+ | ! |
- #' card <- TealReportCard$new()$append_src(+ return(NULL) |
|
| 21 |
- #' "plot(iris)"+ } |
|||
| 22 | -+ | 1x |
- #' )+ if (inherits(transformators, "teal_transform_module")) {
|
|
| 23 | -+ | 1x |
- #' card$get_content()[[1]]$get_content()+ transformators <- list(transformators) |
|
| 24 |
- append_src = function(src, ...) {
+ } |
|||
| 25 | -4x | +1x |
- checkmate::assert_character(src, min.len = 0, max.len = 1)+ checkmate::assert_list(transformators, "teal_transform_module") |
|
| 26 | -4x | +1x |
- params <- list(...)+ names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))
|
|
| 27 | -4x | +
- params$eval <- FALSE+ |
||
| 28 | -4x | +1x |
- rblock <- RcodeBlock$new(src)+ lapply( |
|
| 29 | -4x | +1x |
- rblock$set_params(params)+ names(transformators), |
|
| 30 | -4x | +1x |
- self$append_content(rblock)+ function(name) {
|
|
| 31 | -4x | +1x |
- self$append_metadata("SRC", src)
+ child_id <- NS(id, name) |
|
| 32 | -4x | +1x |
- invisible(self)+ ns <- NS(child_id) |
|
| 33 | -+ | 1x |
- },+ data_mod <- transformators[[name]] |
|
| 34 | -+ | 1x |
- #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.+ transform_wrapper_id <- ns(sprintf("wrapper_%s", name))
|
|
| 35 |
- #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses+ |
|||
| 36 | -+ | 1x |
- #' the default `yaml::as.yaml` to format the list.+ display_fun <- if (is.null(data_mod$ui)) shinyjs::hidden else function(x) x |
|
| 37 |
- #' If the filter state list is empty, nothing is appended to the `content`.+ |
|||
| 38 | -+ | 1x |
- #'+ display_fun( |
|
| 39 | -+ | 1x |
- #' @param fs (`teal_slices`) object returned from [teal_slices()] function.+ div( |
|
| 40 |
- #' @return `self`, invisibly.+ # class .teal_validated changes the color of the boarder on error in ui_validate_reactive_teal_data |
|||
| 41 |
- append_fs = function(fs) {
+ # For details see tealValidate.js file. |
|||
| 42 | -5x | +1x |
- checkmate::assert_class(fs, "teal_slices")+ id = ns("wrapper"),
|
|
| 43 | -4x | +1x |
- self$append_text("Filter State", "header3")
+ class = c(class, "teal_validated"), |
|
| 44 | -4x | +1x |
- if (length(fs)) {
+ title = attr(data_mod, "label"), |
|
| 45 | -3x | +1x |
- self$append_content(TealSlicesBlock$new(fs))+ tags$span( |
|
| 46 | -+ | 1x |
- } else {
+ class = "text-primary mb-4", |
|
| 47 | 1x |
- self$append_text("No filters specified.")
+ icon("fas fa-square-pen"),
|
||
| 48 | -+ | 1x |
- }+ attr(data_mod, "label") |
|
| 49 | -4x | +
- invisible(self)+ ), |
||
| 50 | -+ | 1x |
- },+ tags$i( |
|
| 51 | -+ | 1x |
- #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.+ class = "remove pull-right fa fa-angle-down", |
|
| 52 | -+ | 1x |
- #'+ style = "cursor: pointer;", |
|
| 53 | -+ | 1x |
- #' @param encodings (`list`) list of encodings selections of the `teal` app.+ title = "fold/expand transformator panel", |
|
| 54 | -+ | 1x |
- #' @return `self`, invisibly.+ onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", transform_wrapper_id)
|
|
| 55 |
- #' @examples+ ), |
|||
| 56 | -+ | 1x |
- #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))+ tags$div( |
|
| 57 | -+ | 1x |
- #' card$get_content()[[1]]$get_content()+ id = transform_wrapper_id, |
|
| 58 | -+ | 1x |
- #'+ if (is.null(data_mod$ui)) {
|
|
| 59 | -+ | ! |
- append_encodings = function(encodings) {
+ return(NULL) |
|
| 60 | -4x | +
- checkmate::assert_list(encodings)+ } else {
|
||
| 61 | -4x | +1x |
- self$append_text("Selected Options", "header3")
+ data_mod$ui(id = ns("transform"))
|
|
| 62 | -4x | +
- if (requireNamespace("yaml", quietly = TRUE)) {
+ }, |
||
| 63 | -4x | +1x |
- self$append_text(yaml::as.yaml(encodings, handlers = list(+ div( |
|
| 64 | -4x | +1x |
- POSIXct = function(x) format(x, "%Y-%m-%d"),+ id = ns("validate_messages"),
|
|
| 65 | -4x | +1x |
- POSIXlt = function(x) format(x, "%Y-%m-%d"),+ class = "teal_validated", |
|
| 66 | -4x | +1x |
- Date = function(x) format(x, "%Y-%m-%d")+ uiOutput(ns("error_wrapper"))
|
|
| 67 | -4x | +
- )), "verbatim")+ ) |
||
| 68 |
- } else {
+ ) |
|||
| 69 | -! | +
- stop("yaml package is required to format the encodings list")
+ ) |
||
| 70 |
- }+ ) |
|||
| 71 | -4x | +
- self$append_metadata("Encodings", encodings)
+ } |
||
| 72 | -4x | +
- invisible(self)+ ) |
||
| 73 |
- }+ } |
|||
| 74 |
- ),+ |
|||
| 75 |
- private = list(+ #' @export |
|||
| 76 |
- dispatch_block = function(block_class) {
+ #' @rdname module_transform_data |
|||
| 77 | -! | +
- eval(str2lang(block_class))+ srv_transform_teal_data <- function(id, data, transformators, modules = NULL, is_transform_failed = reactiveValues()) {
|
||
| 78 | -+ | 94x |
- }+ checkmate::assert_string(id) |
|
| 79 | -+ | 94x |
- )+ assert_reactive(data) |
|
| 80 | -+ | 94x |
- )+ checkmate::assert_class(modules, "teal_module", null.ok = TRUE) |
|
| 81 | -+ | 94x |
-
+ if (length(transformators) == 0L) {
|
|
| 82 | -+ | 71x |
- #' @title `TealSlicesBlock`+ return(data) |
|
| 83 |
- #' @docType class+ } |
|||
| 84 | -+ | 23x |
- #' @description+ if (inherits(transformators, "teal_transform_module")) {
|
|
| 85 | -+ | 3x |
- #' Specialized `TealSlicesBlock` block for managing filter panel content in reports.+ transformators <- list(transformators) |
|
| 86 |
- #' @keywords internal+ } |
|||
| 87 | -+ | 23x |
- TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter.+ checkmate::assert_list(transformators, "teal_transform_module", null.ok = TRUE) |
|
| 88 | -+ | 23x |
- classname = "TealSlicesBlock",+ names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))
|
|
| 89 |
- inherit = teal.reporter:::TextBlock,+ |
|||
| 90 | -+ | 23x |
- public = list(+ moduleServer(id, function(input, output, session) {
|
|
| 91 | -+ | 23x |
- #' @description Returns a `TealSlicesBlock` object.+ module_output <- Reduce( |
|
| 92 | -+ | 23x |
- #'+ function(data_previous, name) {
|
|
| 93 | -+ | 26x |
- #' @details Returns a `TealSlicesBlock` object with no content and no parameters.+ moduleServer(name, function(input, output, session) {
|
|
| 94 | -+ | 26x |
- #'+ logger::log_debug("srv_transform_teal_data initializing for { name }.")
|
|
| 95 | -+ | 26x |
- #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ is_transform_failed[[name]] <- FALSE |
|
| 96 | -+ | 26x |
- #' @param style (`character(1)`) string specifying style to apply.+ data_out <- transformators[[name]]$server("transform", data = data_previous)
|
|
| 97 | -+ | 26x |
- #'+ data_handled <- reactive(tryCatch(data_out(), error = function(e) e)) |
|
| 98 | -+ | 26x |
- #' @return Object of class `TealSlicesBlock`, invisibly.+ observeEvent(data_handled(), {
|
|
| 99 | -+ | 32x |
- #'+ if (inherits(data_handled(), "teal_data")) {
|
|
| 100 | -+ | 22x |
- initialize = function(content = teal_slices(), style = "verbatim") {
+ is_transform_failed[[name]] <- FALSE |
|
| 101 | -9x | +
- self$set_content(content)+ } else {
|
||
| 102 | -8x | +10x |
- self$set_style(style)+ is_transform_failed[[name]] <- TRUE |
|
| 103 | -8x | +
- invisible(self)+ } |
||
| 104 |
- },+ }) |
|||
| 106 | -+ | 26x |
- #' @description Sets content of this `TealSlicesBlock`.+ is_previous_failed <- reactive({
|
|
| 107 | -+ | 29x |
- #' Sets content as `YAML` text which represents a list generated from `teal_slices`.+ idx_this <- which(names(is_transform_failed) == name) |
|
| 108 | -+ | 29x |
- #' The list displays limited number of fields from `teal_slice` objects, but this list is+ is_transform_failed_list <- reactiveValuesToList(is_transform_failed) |
|
| 109 | -+ | 29x |
- #' sufficient to conclude which filters were applied.+ idx_failures <- which(unlist(is_transform_failed_list)) |
|
| 110 | -+ | 29x |
- #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"+ any(idx_failures < idx_this) |
|
| 111 |
- #'+ }) |
|||
| 112 |
- #'+ |
|||
| 113 | -+ | 26x |
- #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
|
|
| 114 | -+ | 26x |
- #' @return `self`, invisibly.+ srv_check_class_teal_data("class_teal_data", data_handled)
|
|
| 115 | -+ | 26x |
- set_content = function(content) {
+ if (!is.null(modules)) {
|
|
| 116 | -9x | +20x |
- checkmate::assert_class(content, "teal_slices")+ srv_check_module_datanames("datanames_warning", data_handled, modules)
|
|
| 117 | -8x | +
- if (length(content) != 0) {
+ } |
||
| 118 | -6x | +
- states_list <- lapply(content, function(x) {
+
|
||
| 119 | -6x | +
- x_list <- shiny::isolate(as.list(x))+ # When there is no UI (`ui = NULL`) it should still show the errors |
||
| 120 | -6x | +26x |
- if (+ observe({
|
|
| 121 | -6x | +32x |
- inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
+ if (!inherits(data_handled(), "teal_data") && !is_previous_failed()) {
|
|
| 122 | -6x | +10x |
- length(x_list$choices) == 2 &&+ shinyjs::show("wrapper")
|
|
| 123 | -6x | +
- length(x_list$selected) == 2+ } |
||
| 124 |
- ) {
+ }) |
|||
| 125 | -! | +
- x_list$range <- paste(x_list$selected, collapse = " - ")+ |
||
| 126 | -! | +26x |
- x_list["selected"] <- NULL+ transform_wrapper_id <- sprintf("wrapper_%s", name)
|
|
| 127 | -+ | 26x |
- }+ output$error_wrapper <- renderUI({
|
|
| 128 | -6x | +29x |
- if (!is.null(x_list$arg)) {
+ if (is_previous_failed()) {
|
|
| 129 | ! |
- x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"+ shinyjs::disable(transform_wrapper_id) |
||
| 130 | -+ | ! |
- }+ tags$div("One of previous transformators failed. Please check its inputs.", class = "teal-output-warning")
|
|
| 131 |
-
+ } else {
|
|||
| 132 | -6x | +29x |
- x_list <- x_list[+ shinyjs::enable(transform_wrapper_id) |
|
| 133 | -6x | +29x |
- c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
+ shiny::tagList( |
|
| 134 | -+ | 29x |
- ]+ ui_validate_error(session$ns("silent_error")),
|
|
| 135 | -6x | +29x |
- names(x_list) <- c(+ ui_check_class_teal_data(session$ns("class_teal_data")),
|
|
| 136 | -6x | +29x |
- "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",+ ui_check_module_datanames(session$ns("datanames_warning"))
|
|
| 137 | -6x | ++ |
+ )+ |
+ |
| 138 | ++ |
+ }+ |
+ ||
| 139 | ++ |
+ })+ |
+ ||
| 140 | ++ | + + | +||
| 141 | +26x | +
+ .trigger_on_success(data_handled)+ |
+ ||
| 142 | ++ |
+ })+ |
+ ||
| 143 | ++ |
+ },+ |
+ ||
| 144 | +23x |
- "Selected Values", "Selected range", "Include NA values", "Include Inf values"+ x = names(transformators), |
||
| 138 | -+ | |||
| 145 | +23x |
- )+ init = data |
||
| 139 | +146 |
-
+ ) |
||
| 140 | -6x | +147 | +23x |
- Filter(Negate(is.null), x_list)+ module_output |
| 141 | +148 |
- })+ }) |
||
| 142 | +149 |
-
+ } |
||
| 143 | -6x | +
| 1 | +
- if (requireNamespace("yaml", quietly = TRUE)) {
+ #' Create a `teal` module for previewing a report |
|||
| 144 | -6x | +|||
| 2 | +
- super$set_content(yaml::as.yaml(states_list))+ #' |
|||
| 145 | +3 |
- } else {
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 146 | -! | +|||
| 4 | +
- stop("yaml package is required to format the filter state list")
+ #' |
|||
| 147 | +5 |
- }+ #' This function wraps [teal.reporter::reporter_previewer_ui()] and |
||
| 148 | +6 |
- }+ #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be |
||
| 149 | -8x | +|||
| 7 | +
- private$teal_slices <- content+ #' used in `teal` applications. |
|||
| 150 | -8x | +|||
| 8 | +
- invisible(self)+ #' |
|||
| 151 | +9 |
- },+ #' If you are creating a `teal` application using [init()] then this |
||
| 152 | +10 |
- #' @description Create the `TealSlicesBlock` from a list.+ #' module will be added to your application automatically if any of your `teal_modules` |
||
| 153 | +11 |
- #'+ #' support report generation. |
||
| 154 | +12 |
- #' @param x (`named list`) with two fields `text` and `style`.+ #' |
||
| 155 | +13 |
- #' Use the `get_available_styles` method to get all possible styles.+ #' @inheritParams teal_modules |
||
| 156 | +14 |
- #'+ #' @param server_args (named `list`) |
||
| 157 | +15 |
- #' @return `self`, invisibly.+ #' Arguments passed to [teal.reporter::reporter_previewer_srv()]. |
||
| 158 | +16 |
- #' @examples+ #' |
||
| 159 | +17 |
- #' TealSlicesBlock <- getFromNamespace("TealSlicesBlock", "teal")
+ #' @return |
||
| 160 | +18 |
- #' block <- TealSlicesBlock$new()+ #' `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer functionality. |
||
| 161 | +19 |
- #' block$from_list(list(text = "sth", style = "default"))+ #' |
||
| 162 | +20 |
- #'+ #' @export |
||
| 163 | +21 |
- from_list = function(x) {
+ #' |
||
| 164 | -1x | +|||
| 22 | +
- checkmate::assert_list(x)+ reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
|
|||
| 165 | -1x | +23 | +7x |
- checkmate::assert_names(names(x), must.include = c("text", "style"))
+ checkmate::assert_string(label) |
| 166 | -1x | +24 | +5x |
- super$set_content(x$text)+ checkmate::assert_list(server_args, names = "named") |
| 167 | -1x | +25 | +5x |
- super$set_style(x$style)+ checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv)))) |
| 168 | -1x | +|||
| 26 | +
- invisible(self)+ |
|||
| 169 | -+ | |||
| 27 | +3x |
- },+ message("Initializing reporter_previewer_module")
|
||
| 170 | +28 |
- #' @description Convert the `TealSlicesBlock` to a list.+ |
||
| 171 | -+ | |||
| 29 | +3x |
- #'+ srv <- function(id, reporter, ...) {
|
||
| 172 | -+ | |||
| 30 | +! |
- #' @return `named list` with a text and style.+ teal.reporter::reporter_previewer_srv(id, reporter, ...) |
||
| 173 | +31 |
- #' @examples+ } |
||
| 174 | +32 |
- #' TealSlicesBlock <- getFromNamespace("TealSlicesBlock", "teal")
+
|
||
| 175 | -+ | |||
| 33 | +3x |
- #' block <- TealSlicesBlock$new()+ ui <- function(id, ...) {
|
||
| 176 | -+ | |||
| 34 | +! |
- #' block$to_list()+ teal.reporter::reporter_previewer_ui(id, ...) |
||
| 177 | +35 |
- #'+ } |
||
| 178 | +36 |
- to_list = function() {
+
|
||
| 179 | -2x | +37 | +3x |
- content <- self$get_content()+ module <- module( |
| 180 | -2x | +38 | +3x |
- list(+ label = "temporary label", |
| 181 | -2x | +39 | +3x |
- text = if (length(content)) content else "",+ server = srv, ui = ui, |
| 182 | -2x | +40 | +3x |
- style = self$get_style()+ server_args = server_args, ui_args = list(), datanames = NULL |
| 183 | +41 |
- )+ ) |
||
| 184 | +42 |
- }+ # Module is created with a placeholder label and the label is changed later. |
||
| 185 | +43 |
- ),+ # This is to prevent another module being labeled "Report previewer". |
||
| 186 | -+ | |||
| 44 | +3x |
- private = list(+ class(module) <- c(class(module), "teal_module_previewer") |
||
| 187 | -+ | |||
| 45 | +3x |
- style = "verbatim",+ module$label <- label |
||
| 188 | -+ | |||
| 46 | +3x |
- teal_slices = NULL # teal_slices+ attr(module, "teal_bookmarkable") <- TRUE |
||
| 189 | -+ | |||
| 47 | +3x |
- )+ module |
||
| 190 | +48 |
- )+ } |
| 1 |
- #' Module to transform `reactive` `teal_data`+ #' Include `CSS` files from `/inst/css/` package directory to application header |
||
| 3 |
- #' Module calls [teal_transform_module()] in sequence so that `reactive teal_data` output+ #' `system.file` should not be used to access files in other packages, it does |
||
| 4 |
- #' from one module is handed over to the following module's input.+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 5 |
- #'+ #' as needed. Thus, we do not export this method. |
||
| 6 |
- #' @inheritParams module_teal_data+ #' |
||
| 7 |
- #' @inheritParams teal_modules+ #' @param pattern (`character`) pattern of files to be included |
||
| 8 |
- #' @param class (character(1)) CSS class to be added in the `div` wrapper tag.+ #' |
||
| 9 |
-
+ #' @return HTML code that includes `CSS` files. |
||
| 10 |
- #' @return `reactive` `teal_data`+ #' @keywords internal |
||
| 11 |
- #'+ include_css_files <- function(pattern = "*") {
|
||
| 12 | -+ | ! |
- #' @name module_transform_data+ css_files <- list.files( |
| 13 | -+ | ! |
- NULL+ system.file("css", package = "teal", mustWork = TRUE),
|
| 14 | -+ | ! |
-
+ pattern = pattern, full.names = TRUE |
| 15 |
- #' @export+ ) |
||
| 16 |
- #' @rdname module_transform_data+ |
||
| 17 | -+ | ! |
- ui_transform_teal_data <- function(id, transformators, class = "well") {
+ singleton( |
| 18 | -1x | +! |
- checkmate::assert_string(id)+ tags$head(lapply(css_files, includeCSS)) |
| 19 | -1x | +
- if (length(transformators) == 0L) {
+ ) |
|
| 20 | -! | +
- return(NULL)+ } |
|
| 21 |
- }+ |
||
| 22 | -1x | +
- if (inherits(transformators, "teal_transform_module")) {
+ #' Include `JS` files from `/inst/js/` package directory to application header |
|
| 23 | -1x | +
- transformators <- list(transformators)+ #' |
|
| 24 |
- }+ #' `system.file` should not be used to access files in other packages, it does |
||
| 25 | -1x | +
- checkmate::assert_list(transformators, "teal_transform_module")+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 26 | -1x | +
- names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))
+ #' as needed. Thus, we do not export this method |
|
| 27 |
-
+ #' |
||
| 28 | -1x | +
- lapply(+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file` |
|
| 29 | -1x | +
- names(transformators),+ #' @param except (`character`) vector of basename filenames to be excluded |
|
| 30 | -1x | +
- function(name) {
+ #' |
|
| 31 | -1x | +
- child_id <- NS(id, name)+ #' @return HTML code that includes `JS` files. |
|
| 32 | -1x | +
- ns <- NS(child_id)+ #' @keywords internal |
|
| 33 | -1x | +
- data_mod <- transformators[[name]]+ include_js_files <- function(pattern = NULL, except = NULL) {
|
|
| 34 | -1x | +! |
- transform_wrapper_id <- ns(sprintf("wrapper_%s", name))
+ checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE) |
| 35 | -+ | ! |
-
+ js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
|
| 36 | -1x | +! |
- display_fun <- if (is.null(data_mod$ui)) shinyjs::hidden else function(x) x+ js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL |
| 38 | -1x | +! |
- display_fun(+ singleton(lapply(js_files, includeScript)) |
| 39 | -1x | +
- div(+ } |
|
| 40 |
- # class .teal_validated changes the color of the boarder on error in ui_validate_reactive_teal_data+ |
||
| 41 |
- # For details see tealValidate.js file.+ #' Run `JS` file from `/inst/js/` package directory |
||
| 42 | -1x | +
- id = ns("wrapper"),
+ #' |
|
| 43 | -1x | +
- class = c(class, "teal_validated"),+ #' This is triggered from the server to execute on the client |
|
| 44 | -1x | +
- title = attr(data_mod, "label"),+ #' rather than triggered directly on the client. |
|
| 45 | -1x | +
- tags$span(+ #' Unlike `include_js_files` which includes `JavaScript` functions, |
|
| 46 | -1x | +
- class = "text-primary mb-4",+ #' the `run_js` actually executes `JavaScript` functions. |
|
| 47 | -1x | +
- icon("fas fa-square-pen"),
+ #' |
|
| 48 | -1x | +
- attr(data_mod, "label")+ #' `system.file` should not be used to access files in other packages, it does |
|
| 49 |
- ),+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 50 | -1x | +
- tags$i(+ #' as needed. Thus, we do not export this method. |
|
| 51 | -1x | +
- class = "remove pull-right fa fa-angle-down",+ #' |
|
| 52 | -1x | +
- style = "cursor: pointer;",+ #' @param files (`character`) vector of filenames. |
|
| 53 | -1x | +
- title = "fold/expand transformator panel",+ #' |
|
| 54 | -1x | +
- onclick = sprintf("togglePanelItems(this, '%s', 'fa-angle-right', 'fa-angle-down');", transform_wrapper_id)
+ #' @return `NULL`, invisibly. |
|
| 55 |
- ),+ #' @keywords internal |
||
| 56 | -1x | +
- tags$div(+ run_js_files <- function(files) {
|
|
| 57 | -1x | +88x |
- id = transform_wrapper_id,+ checkmate::assert_character(files, min.len = 1, any.missing = FALSE) |
| 58 | -1x | +88x |
- if (is.null(data_mod$ui)) {
+ lapply(files, function(file) {
|
| 59 | -! | +88x |
- return(NULL)+ shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
|
| 60 |
- } else {
+ }) |
||
| 61 | -1x | +88x |
- data_mod$ui(id = ns("transform"))
+ invisible(NULL) |
| 62 |
- },+ } |
||
| 63 | -1x | +
- div(+ |
|
| 64 | -1x | +
- id = ns("validate_messages"),
+ #' Code to include `teal` `CSS` and `JavaScript` files |
|
| 65 | -1x | +
- class = "teal_validated",+ #' |
|
| 66 | -1x | +
- uiOutput(ns("error_wrapper"))
+ #' This is useful when you want to use the same `JavaScript` and `CSS` files that are |
|
| 67 |
- )+ #' used with the `teal` application. |
||
| 68 |
- )+ #' This is also useful for running standalone modules in `teal` with the correct |
||
| 69 |
- )+ #' styles. |
||
| 70 |
- )+ #' Also initializes `shinyjs` so you can use it. |
||
| 71 |
- }+ #' |
||
| 72 |
- )+ #' Simply add `include_teal_css_js()` as one of the UI elements. |
||
| 73 |
- }+ #' @return A `shiny.tag.list`. |
||
| 74 |
-
+ #' @keywords internal |
||
| 75 |
- #' @export+ include_teal_css_js <- function() {
|
||
| 76 | -+ | ! |
- #' @rdname module_transform_data+ tagList( |
| 77 | -+ | ! |
- srv_transform_teal_data <- function(id, data, transformators, modules = NULL, is_transform_failed = reactiveValues()) {
+ shinyjs::useShinyjs(), |
| 78 | -94x | +! |
- checkmate::assert_string(id)+ include_css_files(), |
| 79 | -94x | +
- assert_reactive(data)+ # init.js is executed from the server |
|
| 80 | -94x | +! |
- checkmate::assert_class(modules, "teal_module", null.ok = TRUE)+ include_js_files(except = "init.js"), |
| 81 | -94x | +! |
- if (length(transformators) == 0L) {
+ shinyjs::hidden(icon("fas fa-gear")), # add hidden icon to load font-awesome css for icons
|
| 82 | -71x | +
- return(data)+ ) |
|
| 83 |
- }- |
- ||
| 84 | -23x | -
- if (inherits(transformators, "teal_transform_module")) {
+ } |
|
| 85 | -3x | +
| 1 | +
- transformators <- list(transformators)+ .onLoad <- function(libname, pkgname) {
|
|||
| 86 | +2 |
- }+ # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R |
||
| 87 | -23x | +|||
| 3 | +
- checkmate::assert_list(transformators, "teal_transform_module", null.ok = TRUE)+ |
|||
| 88 | -23x | +|||
| 4 | +! |
- names(transformators) <- sprintf("transform_%d", seq_len(length(transformators)))
+ teal_default_options <- list( |
||
| 89 | -+ | |||
| 5 | +! |
-
+ teal.show_js_log = FALSE, |
||
| 90 | -23x | +|||
| 6 | +! |
- moduleServer(id, function(input, output, session) {
+ teal.lockfile.mode = "auto", |
||
| 91 | -23x | +|||
| 7 | +! |
- module_output <- Reduce(+ shiny.sanitize.errors = FALSE |
||
| 92 | -23x | +|||
| 8 | +
- function(data_previous, name) {
+ ) |
|||
| 93 | -26x | +|||
| 9 | +
- moduleServer(name, function(input, output, session) {
+
|
|||
| 94 | -26x | +|||
| 10 | +! |
- logger::log_debug("srv_transform_teal_data initializing for { name }.")
+ op <- options() |
||
| 95 | -26x | +|||
| 11 | +! |
- is_transform_failed[[name]] <- FALSE+ toset <- !(names(teal_default_options) %in% names(op)) |
||
| 96 | -26x | +|||
| 12 | +! |
- data_out <- transformators[[name]]$server("transform", data = data_previous)
+ if (any(toset)) options(teal_default_options[toset]) |
||
| 97 | -26x | +|||
| 13 | +
- data_handled <- reactive(tryCatch(data_out(), error = function(e) e))+ |
|||
| 98 | -26x | +|||
| 14 | +
- observeEvent(data_handled(), {
+ # Set up the teal logger instance |
|||
| 99 | -32x | +|||
| 15 | +! |
- if (inherits(data_handled(), "teal_data")) {
+ teal.logger::register_logger("teal")
|
||
| 100 | -22x | +|||
| 16 | +! |
- is_transform_failed[[name]] <- FALSE+ teal.logger::register_handlers("teal")
|
||
| 101 | +17 |
- } else {
+
|
||
| 102 | -10x | +|||
| 18 | +! |
- is_transform_failed[[name]] <- TRUE+ invisible() |
||
| 103 | +19 |
- }+ } |
||
| 104 | +20 |
- })+ |
||
| 105 | +21 | - - | -||
| 106 | -26x | -
- is_previous_failed <- reactive({
- |
- ||
| 107 | -29x | -
- idx_this <- which(names(is_transform_failed) == name)- |
- ||
| 108 | -29x | -
- is_transform_failed_list <- reactiveValuesToList(is_transform_failed)+ .onAttach <- function(libname, pkgname) {
|
||
| 109 | -29x | +22 | +2x |
- idx_failures <- which(unlist(is_transform_failed_list))+ packageStartupMessage( |
| 110 | -29x | +23 | +2x |
- any(idx_failures < idx_this)+ "\nYou are using teal version ", |
| 111 | +24 |
- })+ # `system.file` uses the `shim` of `system.file` by `teal` |
||
| 112 | +25 | - - | -||
| 113 | -26x | -
- srv_validate_error("silent_error", data_handled, validate_shiny_silent_error = FALSE)
- |
- ||
| 114 | -26x | -
- srv_check_class_teal_data("class_teal_data", data_handled)
+ # we avoid `desc` dependency here to get the version |
||
| 115 | -26x | +26 | +2x |
- if (!is.null(modules)) {
+ read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
|
| 116 | -20x | +|||
| 27 | +
- srv_check_module_datanames("datanames_warning", data_handled, modules)
+ ) |
|||
| 117 | +28 |
- }+ } |
||
| 118 | +29 | |||
| 119 | +30 |
- # When there is no UI (`ui = NULL`) it should still show the errors+ # This one is here because setdiff_teal_slice should not be exported from teal.slice. |
||
| 120 | -26x | +|||
| 31 | +
- observe({
+ setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
|
|||
| 121 | -32x | +|||
| 32 | +
- if (!inherits(data_handled(), "teal_data") && !is_previous_failed()) {
+ # This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice. |
|||
| 122 | -10x | +|||
| 33 | +
- shinyjs::show("wrapper")
+ coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
|
|||
| 123 | +34 |
- }+ # all *Block objects are private in teal.reporter |
||
| 124 | +35 |
- })+ RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint: object_name.
|
||
| 125 | +36 | |||
| 126 | -26x | +|||
| 37 | +
- transform_wrapper_id <- sprintf("wrapper_%s", name)
+ # Use non-exported function(s) from teal.code |
|||
| 127 | -26x | +|||
| 38 | +
- output$error_wrapper <- renderUI({
+ # This one is here because lang2calls should not be exported from teal.code |
|||
| 128 | -29x | +|||
| 39 | +
- if (is_previous_failed()) {
+ lang2calls <- getFromNamespace("lang2calls", "teal.code")
|
|||
| 129 | -! | +|||
| 40 | +
- shinyjs::disable(transform_wrapper_id)+ code2list <- getFromNamespace("code2list", "teal.data")
|
|||
| 130 | -! | +
| 1 | +
- tags$div("One of previous transformators failed. Please check its inputs.", class = "teal-output-warning")
+ #' Data Module for teal |
||
| 131 | +2 |
- } else {
+ #' |
|
| 132 | -29x | +||
| 3 | +
- shinyjs::enable(transform_wrapper_id)+ #' This module manages the `data` argument for `srv_teal`. The `teal` framework uses [teal.data::teal_data()], |
||
| 133 | -29x | +||
| 4 | +
- shiny::tagList(+ #' which can be provided in various ways: |
||
| 134 | -29x | +||
| 5 | +
- ui_validate_error(session$ns("silent_error")),
+ #' 1. Directly as a [teal.data::teal_data()] object. This will automatically convert it into a `reactive` `teal_data`. |
||
| 135 | -29x | +||
| 6 | +
- ui_check_class_teal_data(session$ns("class_teal_data")),
+ #' 2. As a `reactive` object that returns a [teal.data::teal_data()] object. |
||
| 136 | -29x | +||
| 7 | +
- ui_check_module_datanames(session$ns("datanames_warning"))
+ #' |
||
| 137 | +8 |
- )+ #' @details |
|
| 138 | +9 |
- }+ #' ## Reactive `teal_data`: |
|
| 139 | +10 |
- })+ #' |
|
| 140 | +11 |
-
+ #' The data in the application can be reactively updated, prompting [srv_teal()] to rebuild the |
|
| 141 | -26x | +||
| 12 | +
- .trigger_on_success(data_handled)+ #' content accordingly. There are two methods for creating interactive `teal_data`: |
||
| 142 | +13 |
- })+ #' 1. Using a `reactive` object provided from outside the `teal` application. In this scenario, |
|
| 143 | +14 |
- },+ #' reactivity is controlled by an external module, and `srv_teal` responds to changes. |
|
| 144 | -23x | +||
| 15 | +
- x = names(transformators),+ #' 2. Using [teal_data_module()], which is embedded within the `teal` application, allowing data to |
||
| 145 | -23x | +||
| 16 | +
- init = data+ #' be resubmitted by the user as needed. |
||
| 146 | +17 |
- )+ #' |
|
| 147 | -23x | +||
| 18 | +
- module_output+ #' Since the server of [teal_data_module()] must return a `reactive` `teal_data` object, both |
||
| 148 | +19 |
- })+ #' methods (1 and 2) produce the same reactive behavior within a `teal` application. The distinction |
|
| 149 | +20 |
- }+ #' lies in data control: the first method involves external control, while the second method |
| 1 | +21 |
- #' `teal_data` utils+ #' involves control from a custom module within the app. |
||
| 2 | +22 |
#' |
||
| 3 | +23 |
- #' In `teal` we need to recreate the `teal_data` object due to two operations:+ #' For more details, see [`module_teal_data`]. |
||
| 4 | +24 |
- #' - we need to append filter-data code and objects which have been evaluated in `FilteredData` and+ #' |
||
| 5 | +25 |
- #' we want to avoid double-evaluation.+ #' @inheritParams init |
||
| 6 | +26 |
- #' - we need to subset `teal_data` to `datanames` used by the module, to shorten obtainable R-code+ #' |
||
| 7 | +27 |
- #'+ #' @param data (`teal_data`, `teal_data_module`, or `reactive` returning `teal_data`) |
||
| 8 | +28 |
- #' Due to above recreation of `teal_data` object can't be done simply by using public+ #' The data which application will depend on. |
||
| 9 | +29 |
- #' `teal.code` and `teal.data` methods.+ #' |
||
| 10 | +30 |
- #'+ #' @return A `reactive` object that returns: |
||
| 11 | +31 |
- #' @param data (`teal_data`)+ #' Output of the `data`. If `data` fails then returned error is handled (after [tryCatch()]) so that |
||
| 12 | +32 |
- #' @param code (`character`) code to append to the object's code slot.+ #' rest of the application can respond to this respectively. |
||
| 13 | +33 |
- #' @param objects (`list`) objects to append to object's environment.+ #' |
||
| 14 | +34 |
- #' @return modified `teal_data`+ #' @rdname module_init_data |
||
| 15 | +35 |
- #' @keywords internal+ #' @name module_init_data |
||
| 16 | +36 |
- #' @name teal_data_utilities+ #' @keywords internal |
||
| 17 | +37 |
NULL |
||
| 18 | +38 | |||
| 19 | +39 |
- #' @rdname teal_data_utilities+ #' @rdname module_init_data |
||
| 20 | +40 |
- .append_evaluated_code <- function(data, code) {
+ ui_init_data <- function(id) {
|
||
| 21 | -89x | +41 | +9x |
- checkmate::assert_class(data, "teal_data")+ ns <- shiny::NS(id) |
| 22 | -89x | +42 | +9x |
- data@code <- c(data@code, code2list(code))+ shiny::div( |
| 23 | -89x | +43 | +9x |
- methods::validObject(data)+ id = ns("content"),
|
| 24 | -89x | +44 | +9x |
- data+ style = "display: inline-block; width: 100%;",+ |
+
| 45 | +9x | +
+ uiOutput(ns("data"))
|
||
| 25 | +46 | ++ |
+ )+ |
+ |
| 47 |
} |
|||
| 26 | +48 | |||
| 27 | +49 |
- #' @rdname teal_data_utilities+ #' @rdname module_init_data |
||
| 28 | +50 |
- .append_modified_data <- function(data, objects) {
+ srv_init_data <- function(id, data) {
|
||
| 29 | -89x | +51 | +88x |
- checkmate::assert_class(data, "teal_data")+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
| 30 | -89x | +52 | +88x |
- checkmate::assert_class(objects, "list")+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module", "reactive"))
+ |
+
| 53 | ++ | + | ||
| 31 | -89x | +54 | +88x |
- new_env <- list2env(objects, parent = .GlobalEnv)+ moduleServer(id, function(input, output, session) {
|
| 32 | -89x | +55 | +88x |
- rlang::env_coalesce(new_env, as.environment(data))+ logger::log_debug("srv_data initializing.")
|
| 33 | -89x | +56 | +88x |
- data@.xData <- new_env+ data_out <- if (inherits(data, "teal_data_module")) {
|
| 34 | -89x | +57 | +10x |
- data+ output$data <- renderUI(data$ui(id = session$ns("teal_data_module")))
|
| 35 | -+ | |||
| 58 | +10x |
- }+ data$server("teal_data_module")
|
| 1 | -+ | ||
| 59 | +88x |
- #' Send input validation messages to output+ } else if (inherits(data, "teal_data")) {
|
|
| 2 | -+ | ||
| 60 | +48x |
- #'+ reactiveVal(data) |
|
| 3 | -+ | ||
| 61 | +88x |
- #' Captures messages from `InputValidator` objects and collates them+ } else if (test_reactive(data)) {
|
|
| 4 | -+ | ||
| 62 | +30x |
- #' into one message passed to `validate`.+ data |
|
| 5 | +63 |
- #'+ } |
|
| 6 | +64 |
- #' `shiny::validate` is used to withhold rendering of an output element until+ |
|
| 7 | -+ | ||
| 65 | +87x |
- #' certain conditions are met and to print a validation message in place+ data_handled <- reactive({
|
|
| 8 | -+ | ||
| 66 | +80x |
- #' of the output element.+ tryCatch(data_out(), error = function(e) e) |
|
| 9 | +67 |
- #' `shinyvalidate::InputValidator` allows to validate input elements+ }) |
|
| 10 | +68 |
- #' and to display specific messages in their respective input widgets.+ |
|
| 11 | +69 |
- #' `validate_inputs` provides a hybrid solution.+ # We want to exclude teal_data_module elements from bookmarking as they might have some secrets |
|
| 12 | -+ | ||
| 70 | +87x |
- #' Given an `InputValidator` object, messages corresponding to inputs that fail validation+ observeEvent(data_handled(), {
+ |
+ |
| 71 | +80x | +
+ if (inherits(data_handled(), "teal_data")) {
+ |
+ |
| 72 | +75x | +
+ app_session <- .subset2(shiny::getDefaultReactiveDomain(), "parent")+ |
+ |
| 73 | +75x | +
+ setBookmarkExclude(+ |
+ |
| 74 | +75x | +
+ session$ns(+ |
+ |
| 75 | +75x | +
+ grep(+ |
+ |
| 76 | +75x | +
+ pattern = "teal_data_module-",+ |
+ |
| 77 | +75x | +
+ x = names(reactiveValuesToList(input)),+ |
+ |
| 78 | +75x | +
+ value = TRUE |
|
| 13 | +79 |
- #' are extracted and placed in one validation message that is passed to a `validate`/`need` call.+ ) |
|
| 14 | +80 |
- #' This way the input `validator` messages are repeated in the output.+ ),+ |
+ |
| 81 | +75x | +
+ session = app_session |
|
| 15 | +82 |
- #'+ ) |
|
| 16 | +83 |
- #' The `...` argument accepts any number of `InputValidator` objects+ } |
|
| 17 | +84 |
- #' or a nested list of such objects.+ }) |
|
| 18 | +85 |
- #' If `validators` are passed directly, all their messages are printed together+ + |
+ |
| 86 | +87x | +
+ data_handled |
|
| 19 | +87 |
- #' under one (optional) header message specified by `header`. If a list is passed,+ }) |
|
| 20 | +88 |
- #' messages are grouped by `validator`. The list's names are used as headers+ } |
|
| 21 | +89 |
- #' for their respective message groups.+ |
|
| 22 | +90 |
- #' If neither of the nested list elements is named, a header message is taken from `header`.+ #' Adds signature protection to the `datanames` in the data |
|
| 23 | +91 |
- #'+ #' @param data (`teal_data`) |
|
| 24 | +92 |
- #' @param ... either any number of `InputValidator` objects+ #' @return `teal_data` with additional code that has signature of the `datanames` |
|
| 25 | +93 |
- #' or an optionally named, possibly nested `list` of `InputValidator`+ #' @keywords internal |
|
| 26 | +94 |
- #' objects, see `Details`+ .add_signature_to_data <- function(data) {
+ |
+ |
| 95 | +75x | +
+ hashes <- .get_hashes_code(data)+ |
+ |
| 96 | +75x | +
+ tdata <- do.call(+ |
+ |
| 97 | +75x | +
+ teal.data::teal_data,+ |
+ |
| 98 | +75x | +
+ c(+ |
+ |
| 99 | +75x | +
+ list(code = trimws(c(teal.code::get_code(data), hashes), which = "right")),+ |
+ |
| 100 | +75x | +
+ list(join_keys = teal.data::join_keys(data)),+ |
+ |
| 101 | +75x | +
+ sapply(+ |
+ |
| 102 | +75x | +
+ names(data), |
|
| 27 | -+ | ||
| 103 | +75x |
- #' @param header (`character(1)`) generic validation message; set to NULL to omit+ teal.code::get_var, |
|
| 28 | -+ | ||
| 104 | +75x |
- #'+ object = data, |
|
| 29 | -+ | ||
| 105 | +75x |
- #' @return+ simplify = FALSE |
|
| 30 | +106 |
- #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails.+ ) |
|
| 31 | +107 |
- #'+ ) |
|
| 32 | +108 |
- #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`]+ ) |
|
| 33 | +109 |
- #'+ |
|
| 34 | -+ | ||
| 110 | +75x |
- #' @examplesIf require("shinyvalidate")
+ tdata@verified <- data@verified |
|
| 35 | -+ | ||
| 111 | +75x |
- #' library(shiny)+ tdata |
|
| 36 | +112 |
- #' library(shinyvalidate)+ } |
|
| 37 | +113 |
- #'+ |
|
| 38 | +114 |
- #' ui <- fluidPage(+ #' Get code that tests the integrity of the reproducible data |
|
| 39 | +115 |
- #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
+ #' |
|
| 40 | +116 |
- #' sidebarLayout(+ #' @param data (`teal_data`) object holding the data |
|
| 41 | +117 |
- #' sidebarPanel(+ #' @param datanames (`character`) names of `datasets` |
|
| 42 | +118 |
- #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
+ #' |
|
| 43 | +119 |
- #' selectInput("number", "select a number:", 1:6),
+ #' @return A character vector with the code lines. |
|
| 44 | +120 |
- #' tags$br(),+ #' @keywords internal |
|
| 45 | +121 |
- #' selectInput("color", "select a color:",
+ #' |
|
| 46 | +122 |
- #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
+ .get_hashes_code <- function(data, datanames = names(data)) {
|
|
| 47 | -+ | ||
| 123 | +75x |
- #' multiple = TRUE+ vapply( |
|
| 48 | -+ | ||
| 124 | +75x |
- #' ),+ datanames, |
|
| 49 | -+ | ||
| 125 | +75x |
- #' sliderInput("size", "select point size:",
+ function(dataname, datasets) {
|
|
| 50 | -+ | ||
| 126 | +133x |
- #' min = 0.1, max = 4, value = 0.25+ x <- data[[dataname]] |
|
| 51 | +127 |
- #' )+ |
|
| 52 | -+ | ||
| 128 | +133x |
- #' ),+ code <- if (is.function(x) && !is.primitive(x)) {
|
|
| 53 | -+ | ||
| 129 | +6x |
- #' mainPanel(plotOutput("plot"))
+ x <- deparse1(x) |
|
| 54 | -+ | ||
| 130 | +6x |
- #' )+ bquote(rlang::hash(deparse1(.(as.name(dataname))))) |
|
| 55 | +131 |
- #' )+ } else {
|
|
| 56 | -+ | ||
| 132 | +127x |
- #'+ bquote(rlang::hash(.(as.name(dataname)))) |
|
| 57 | +133 |
- #' server <- function(input, output) {
+ } |
|
| 58 | -+ | ||
| 134 | +133x |
- #' # set up input validation+ sprintf( |
|
| 59 | -+ | ||
| 135 | +133x |
- #' iv <- InputValidator$new()+ "stopifnot(%s == %s) # @linksto %s", |
|
| 60 | -+ | ||
| 136 | +133x |
- #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
+ deparse1(code), |
|
| 61 | -+ | ||
| 137 | +133x |
- #' iv$add_rule("number", function(x) {
+ deparse1(rlang::hash(x)), |
|
| 62 | -+ | ||
| 138 | +133x |
- #' if (as.integer(x) %% 2L == 1L) "choose an even number"+ dataname |
|
| 63 | +139 |
- #' })+ ) |
|
| 64 | +140 |
- #' iv$enable()+ }, |
|
| 65 | -+ | ||
| 141 | +75x |
- #' # more input validation+ character(1L), |
|
| 66 | -+ | ||
| 142 | +75x |
- #' iv_par <- InputValidator$new()+ USE.NAMES = TRUE |
|
| 67 | +143 |
- #' iv_par$add_rule("color", sv_required(message = "choose a color"))
+ ) |
|
| 68 | +144 |
- #' iv_par$add_rule("color", function(x) {
+ } |
| 69 | +1 |
- #' if (length(x) > 1L) "choose only one color"+ #' Check that argument is reactive. |
||
| 70 | +2 |
- #' })+ #' |
||
| 71 | +3 |
- #' iv_par$add_rule(+ #' @inherit checkmate::check_class params return |
||
| 72 | +4 |
- #' "size",+ #' |
||
| 73 | +5 |
- #' sv_between(+ #' @keywords internal |
||
| 74 | +6 |
- #' left = 0.5, right = 3,+ check_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
|
||
| 75 | -+ | |||
| 7 | +1134x |
- #' message_fmt = "choose a value between {left} and {right}"
+ if (!isTRUE(checkmate::test_class(x, classes = "reactive", null.ok = null.ok))) {
|
||
| 76 | -+ | |||
| 8 | +4x |
- #' )+ cl <- class(x) |
||
| 77 | -+ | |||
| 9 | +4x |
- #' )+ return(sprintf( |
||
| 78 | -+ | |||
| 10 | +4x |
- #' iv_par$enable()+ "Must be a reactive (i.e. inherit from 'reactive' class) but has class%s '%s'", |
||
| 79 | -+ | |||
| 11 | +4x |
- #'+ if (length(cl) > 1L) "es" else "", |
||
| 80 | -+ | |||
| 12 | +4x |
- #' output$plot <- renderPlot({
+ paste0(cl, collapse = "','") |
||
| 81 | +13 |
- #' # validate output+ )) |
||
| 82 | +14 |
- #' switch(input[["method"]],+ } |
||
| 83 | -+ | |||
| 15 | +1130x |
- #' "sequential" = {
+ return(TRUE) |
||
| 84 | +16 |
- #' validate_inputs(iv)+ } |
||
| 85 | +17 |
- #' validate_inputs(iv_par, header = "Set proper graphical parameters")+ #' @rdname check_reactive |
||
| 86 | +18 |
- #' },+ test_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
|
||
| 87 | -+ | |||
| 19 | +30x |
- #' "combined" = validate_inputs(iv, iv_par),+ isTRUE(check_reactive(x, null.ok = null.ok)) |
||
| 88 | +20 |
- #' "grouped" = validate_inputs(list(+ } |
||
| 89 | +21 |
- #' "Some inputs require attention" = iv,+ #' @rdname check_reactive |
||
| 90 | +22 |
- #' "Set proper graphical parameters" = iv_par+ assert_reactive <- checkmate::makeAssertionFunction(check_reactive) |
||
| 91 | +23 |
- #' ))+ |
||
| 92 | +24 |
- #' )+ #' Capture error and decorate error message. |
||
| 93 | +25 |
#' |
||
| 94 | +26 |
- #' plot(faithful$eruptions ~ faithful$waiting,+ #' @param x object to evaluate |
||
| 95 | +27 |
- #' las = 1, pch = 16,+ #' @param pre (`character(1)`) A string to prepend to error message |
||
| 96 | +28 |
- #' col = input[["color"]], cex = input[["size"]]+ #' @param post (`character(1)`) A string to append to error message |
||
| 97 | +29 |
- #' )+ #' |
||
| 98 | +30 |
- #' })+ #' @return `x` if no error, otherwise throws error with decorated message |
||
| 99 | +31 |
- #' }+ #' |
||
| 100 | +32 |
- #'+ #' @keywords internal |
||
| 101 | +33 |
- #' if (interactive()) {
+ decorate_err_msg <- function(x, pre = character(0), post = character(0)) {
|
||
| 102 | -+ | |||
| 34 | +47x |
- #' shinyApp(ui, server)+ tryCatch( |
||
| 103 | -+ | |||
| 35 | +47x |
- #' }+ x, |
||
| 104 | -+ | |||
| 36 | +47x |
- #'+ error = function(e) {
|
||
| 105 | -+ | |||
| 37 | +2x |
- #' @export+ stop( |
||
| 106 | -+ | |||
| 38 | +2x |
- #'+ "\n", |
||
| 107 | -+ | |||
| 39 | +2x |
- validate_inputs <- function(..., header = "Some inputs require attention") {
+ pre, |
||
| 108 | -36x | +40 | +2x |
- dots <- list(...)+ "\n", |
| 109 | +41 | 2x |
- if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
+ e$message, |
|
| 110 | -+ | |||
| 42 | +2x |
-
+ "\n", |
||
| 111 | -34x | +43 | +2x |
- messages <- extract_validator(dots, header)+ post, |
| 112 | -34x | +44 | +2x |
- failings <- if (!any_names(dots)) {
+ call. = FALSE |
| 113 | -29x | +|||
| 45 | +
- add_header(messages, header)+ )+ |
+ |||
| 46 | ++ |
+ } |
||
| 114 | +47 |
- } else {
+ ) |
||
| 115 | -5x | +48 | +45x |
- unlist(messages)+ x |
| 116 | +49 |
- }+ } |
| 117 | +1 | - - | -||
| 118 | -34x | -
- shiny::validate(shiny::need(is.null(failings), failings))+ #' Evaluate expression on `teal_data_module` |
||
| 119 | +2 |
- }+ #' |
||
| 120 | +3 |
-
+ #' @details |
||
| 121 | +4 |
- ### internal functions+ #' `within` is a convenience function for evaluating inline code inside the environment of a `teal_data_module`. |
||
| 122 | +5 |
-
+ #' It accepts only inline expressions (both simple and compound) and allows for injecting values into `expr` through |
||
| 123 | +6 |
- #' @noRd+ #' the `...` argument: as `name:value` pairs are passed to `...`, `name` in `expr` will be replaced with `value.` |
||
| 124 | +7 |
- #' @keywords internal+ #' |
||
| 125 | +8 |
- # recursive object type test+ #' @param data (`teal_data_module`) object |
||
| 126 | +9 |
- # returns logical of length 1+ #' @param expr (`expression`) to evaluate. Must be inline code. See [within()] |
||
| 127 | +10 |
- is_validators <- function(x) {
+ #' @param ... See `Details`. |
||
| 128 | -118x | +|||
| 11 | +
- all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))+ #' |
|||
| 129 | +12 |
- }+ #' @return |
||
| 130 | +13 |
-
+ #' `within` returns a `teal_data_module` object with a delayed evaluation of `expr` when the module is run. |
||
| 131 | +14 |
- #' @noRd+ #' |
||
| 132 | +15 |
- #' @keywords internal+ #' @examples |
||
| 133 | +16 |
- # test if an InputValidator object is enabled+ #' within(tdm, dataset1 <- subset(dataset1, Species == "virginica")) |
||
| 134 | +17 |
- # returns logical of length 1+ #' |
||
| 135 | +18 |
- # official method requested at https://github.com/rstudio/shinyvalidate/issues/64+ #' # use additional parameter for expression value substitution. |
||
| 136 | +19 |
- validator_enabled <- function(x) {
+ #' valid_species <- "versicolor" |
||
| 137 | -49x | +|||
| 20 | +
- x$.__enclos_env__$private$enabled+ #' within(tdm, dataset1 <- subset(dataset1, Species %in% species), species = valid_species) |
|||
| 138 | +21 |
- }+ #' @include teal_data_module.R |
||
| 139 | +22 |
-
+ #' @name within |
||
| 140 | +23 |
- #' Recursively extract messages from validator list+ #' @rdname teal_data_module |
||
| 141 | +24 |
- #' @return A character vector or a list of character vectors, possibly nested and named.+ #' |
||
| 142 | +25 |
- #' @noRd+ #' @export |
||
| 143 | +26 |
- #' @keywords internal+ #' |
||
| 144 | +27 |
- extract_validator <- function(iv, header) {
+ within.teal_data_module <- function(data, expr, ...) {
|
||
| 145 | -113x | +28 | +2x |
- if (inherits(iv, "InputValidator")) {
+ expr <- substitute(expr) |
| 146 | -49x | +29 | +2x |
- add_header(gather_messages(iv), header)+ extras <- list(...) |
| 147 | +30 |
- } else {
+
+ |
+ ||
| 31 | ++ |
+ # Add braces for consistency. |
||
| 148 | -58x | +32 | +2x |
- if (is.null(names(iv))) names(iv) <- rep("", length(iv))
+ if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
|
| 149 | -64x | +33 | +2x |
- mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)+ expr <- call("{", expr)
|
| 150 | +34 |
} |
||
| 151 | +35 |
- }+ + |
+ ||
| 36 | +2x | +
+ calls <- as.list(expr)[-1] |
||
| 152 | +37 | |||
| 153 | +38 |
- #' Collate failing messages from validator.+ # Inject extra values into expressions.+ |
+ ||
| 39 | +2x | +
+ calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras))) |
||
| 154 | +40 |
- #' @return `list`+ + |
+ ||
| 41 | +2x | +
+ eval_code(object = data, code = as.expression(calls)) |
||
| 155 | +42 |
- #' @noRd+ } |
| 156 | +1 |
- #' @keywords internal+ #' `teal_data` utils |
||
| 157 | +2 |
- gather_messages <- function(iv) {
+ #' |
||
| 158 | -49x | +|||
| 3 | +
- if (validator_enabled(iv)) {
+ #' In `teal` we need to recreate the `teal_data` object due to two operations: |
|||
| 159 | -46x | +|||
| 4 | +
- status <- iv$validate()+ #' - we need to append filter-data code and objects which have been evaluated in `FilteredData` and |
|||
| 160 | -46x | +|||
| 5 | +
- failing_inputs <- Filter(Negate(is.null), status)+ #' we want to avoid double-evaluation. |
|||
| 161 | -46x | +|||
| 6 | +
- unique(lapply(failing_inputs, function(x) x[["message"]]))+ #' - we need to subset `teal_data` to `datanames` used by the module, to shorten obtainable R-code |
|||
| 162 | +7 |
- } else {
+ #' |
||
| 163 | -3x | +|||
| 8 | +
- warning("Validator is disabled and will be omitted.")
+ #' Due to above recreation of `teal_data` object can't be done simply by using public |
|||
| 164 | -3x | +|||
| 9 | +
- list()+ #' `teal.code` and `teal.data` methods. |
|||
| 165 | +10 |
- }+ #' |
||
| 166 | +11 |
- }+ #' @param data (`teal_data`) |
||
| 167 | +12 |
-
+ #' @param code (`character`) code to append to the object's code slot. |
||
| 168 | +13 |
- #' Add optional header to failing messages+ #' @param objects (`list`) objects to append to object's environment. |
||
| 169 | +14 |
- #' @noRd+ #' @return modified `teal_data` |
||
| 170 | +15 |
#' @keywords internal |
||
| 171 | +16 |
- add_header <- function(messages, header = "") {
+ #' @name teal_data_utilities |
||
| 172 | -78x | +|||
| 17 | +
- ans <- unlist(messages)+ NULL |
|||
| 173 | -78x | +|||
| 18 | +
- if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
+
|
|||
| 174 | -31x | +|||
| 19 | +
- ans <- c(paste0(header, "\n"), ans, "\n")+ #' @rdname teal_data_utilities |
|||
| 175 | +20 |
- }+ .append_evaluated_code <- function(data, code) {
|
||
| 176 | -78x | +21 | +89x |
- ans+ checkmate::assert_class(data, "teal_data") |
| 177 | -+ | |||
| 22 | +89x |
- }+ data@code <- c(data@code, code2list(code)) |
||
| 178 | -+ | |||
| 23 | +89x |
-
+ methods::validObject(data) |
||
| 179 | -+ | |||
| 24 | +89x |
- #' Recursively check if the object contains a named list+ data |
||
| 180 | +25 |
- #' @noRd+ } |
||
| 181 | +26 |
- #' @keywords internal+ |
||
| 182 | +27 |
- any_names <- function(x) {
+ #' @rdname teal_data_utilities |
||
| 183 | -103x | +|||
| 28 | +
- any(+ .append_modified_data <- function(data, objects) {
|
|||
| 184 | -103x | +29 | +89x |
- if (is.list(x)) {
+ checkmate::assert_class(data, "teal_data") |
| 185 | -58x | +30 | +89x |
- if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))+ checkmate::assert_class(objects, "list") |
| 186 | -+ | |||
| 31 | +89x |
- } else {
+ new_env <- list2env(objects, parent = .GlobalEnv) |
||
| 187 | -40x | +32 | +89x |
- FALSE+ rlang::env_coalesce(new_env, as.environment(data)) |
| 188 | -+ | |||
| 33 | +89x |
- }+ data@.xData <- new_env |
||
| 189 | -+ | |||
| 34 | +89x |
- )+ data |
||
| 190 | +35 |
}@@ -45924,633 +45712,620 @@ teal coverage - 60.02% |
| 1 |
- .onLoad <- function(libname, pkgname) {
+ #' Landing popup module |
||
| 2 |
- # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R+ #' |
||
| 3 |
-
+ #' @description Creates a landing welcome popup for `teal` applications. |
||
| 4 | -! | +
- teal_default_options <- list(+ #' |
|
| 5 | -! | +
- teal.show_js_log = FALSE,+ #' This module is used to display a popup dialog when the application starts. |
|
| 6 | -! | +
- teal.lockfile.mode = "auto",+ #' The dialog blocks access to the application and must be closed with a button before the application can be viewed. |
|
| 7 | -! | +
- shiny.sanitize.errors = FALSE+ #' |
|
| 8 |
- )+ #' @param label (`character(1)`) Label of the module. |
||
| 9 |
-
+ #' @param title (`character(1)`) Text to be displayed as popup title. |
||
| 10 | -! | +
- op <- options()+ #' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup. |
|
| 11 | -! | +
- toset <- !(names(teal_default_options) %in% names(op))+ #' Passed to `...` of `shiny::modalDialog`. See examples. |
|
| 12 | -! | +
- if (any(toset)) options(teal_default_options[toset])+ #' @param buttons (`shiny.tag` or `shiny.tag.list`) Typically a `modalButton` or `actionButton`. See examples. |
|
| 13 |
-
+ #' |
||
| 14 |
- # Set up the teal logger instance+ #' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications. |
||
| 15 | -! | +
- teal.logger::register_logger("teal")
+ #' |
|
| 16 | -! | +
- teal.logger::register_handlers("teal")
+ #' @examples |
|
| 17 |
-
+ #' app1 <- init( |
||
| 18 | -! | +
- invisible()+ #' data = teal_data(iris = iris), |
|
| 19 |
- }+ #' modules = modules( |
||
| 20 |
-
+ #' example_module() |
||
| 21 |
- .onAttach <- function(libname, pkgname) {
+ #' ), |
||
| 22 | -2x | +
- packageStartupMessage(+ #' landing_popup = landing_popup_module( |
|
| 23 | -2x | +
- "\nYou are using teal version ",+ #' content = "A place for the welcome message or a disclaimer statement.", |
|
| 24 |
- # `system.file` uses the `shim` of `system.file` by `teal`+ #' buttons = modalButton("Proceed")
|
||
| 25 |
- # we avoid `desc` dependency here to get the version+ #' ) |
||
| 26 | -2x | +
- read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
+ #' ) |
|
| 27 |
- )+ #' if (interactive()) {
|
||
| 28 |
- }+ #' shinyApp(app1$ui, app1$server) |
||
| 29 |
-
+ #' } |
||
| 30 |
- # This one is here because setdiff_teal_slice should not be exported from teal.slice.+ #' |
||
| 31 |
- setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
+ #' app2 <- init( |
||
| 32 |
- # This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice.+ #' data = teal_data(iris = iris), |
||
| 33 |
- coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
+ #' modules = modules( |
||
| 34 |
- # all *Block objects are private in teal.reporter+ #' example_module() |
||
| 35 |
- RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint: object_name.
+ #' ), |
||
| 36 |
-
+ #' landing_popup = landing_popup_module( |
||
| 37 |
- # Use non-exported function(s) from teal.code+ #' title = "Welcome", |
||
| 38 |
- # This one is here because lang2calls should not be exported from teal.code+ #' content = tags$b( |
||
| 39 |
- lang2calls <- getFromNamespace("lang2calls", "teal.code")
+ #' "A place for the welcome message or a disclaimer statement.", |
||
| 40 |
- code2list <- getFromNamespace("code2list", "teal.data")
+ #' style = "color: red;" |
| 1 | +41 |
- #' Check that argument is reactive.+ #' ), |
|
| 2 | +42 |
- #'+ #' buttons = tagList( |
|
| 3 | +43 |
- #' @inherit checkmate::check_class params return+ #' modalButton("Proceed"),
|
|
| 4 | +44 |
- #'+ #' actionButton("read", "Read more",
|
|
| 5 | +45 |
- #' @keywords internal+ #' onclick = "window.open('http://google.com', '_blank')"
|
|
| 6 | +46 |
- check_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
- |
- |
| 7 | -1134x | -
- if (!isTRUE(checkmate::test_class(x, classes = "reactive", null.ok = null.ok))) {
- |
- |
| 8 | -4x | -
- cl <- class(x)+ #' ), |
|
| 9 | -4x | +||
| 47 | +
- return(sprintf(+ #' actionButton("close", "Reject", onclick = "window.close()")
|
||
| 10 | -4x | +||
| 48 | +
- "Must be a reactive (i.e. inherit from 'reactive' class) but has class%s '%s'",+ #' ) |
||
| 11 | -4x | +||
| 49 | +
- if (length(cl) > 1L) "es" else "",+ #' ) |
||
| 12 | -4x | +||
| 50 | +
- paste0(cl, collapse = "','")+ #' ) |
||
| 13 | +51 |
- ))+ #' |
|
| 14 | +52 |
- }+ #' if (interactive()) {
|
|
| 15 | -1130x | +||
| 53 | +
- return(TRUE)+ #' shinyApp(app2$ui, app2$server) |
||
| 16 | +54 |
- }+ #' } |
|
| 17 | +55 |
- #' @rdname check_reactive+ #' |
|
| 18 | +56 |
- test_reactive <- function(x, null.ok = FALSE) { # nolint: object_name_linter.
+ #' @export |
|
| 19 | -30x | +||
| 57 | +
- isTRUE(check_reactive(x, null.ok = null.ok))+ landing_popup_module <- function(label = "Landing Popup", |
||
| 20 | +58 |
- }+ title = NULL, |
|
| 21 | +59 |
- #' @rdname check_reactive+ content = NULL, |
|
| 22 | +60 |
- assert_reactive <- checkmate::makeAssertionFunction(check_reactive)+ buttons = modalButton("Accept")) {
|
|
| 23 | -+ | ||
| 61 | +! |
-
+ checkmate::assert_string(label) |
|
| 24 | -+ | ||
| 62 | +! |
- #' Capture error and decorate error message.+ checkmate::assert_string(title, null.ok = TRUE) |
|
| 25 | -+ | ||
| 63 | +! |
- #'+ checkmate::assert_multi_class( |
|
| 26 | -+ | ||
| 64 | +! |
- #' @param x object to evaluate+ content, |
|
| 27 | -+ | ||
| 65 | +! |
- #' @param pre (`character(1)`) A string to prepend to error message+ classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
|
|
| 28 | +66 |
- #' @param post (`character(1)`) A string to append to error message+ ) |
|
| 29 | -+ | ||
| 67 | +! |
- #'+ checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
|
|
| 30 | +68 |
- #' @return `x` if no error, otherwise throws error with decorated message+ |
|
| 31 | -+ | ||
| 69 | +! |
- #'+ message("Initializing landing_popup_module")
|
|
| 32 | +70 |
- #' @keywords internal+ |
|
| 33 | -+ | ||
| 71 | +! |
- decorate_err_msg <- function(x, pre = character(0), post = character(0)) {
+ module <- module( |
|
| 34 | -47x | +||
| 72 | +! |
- tryCatch(+ label = label, |
|
| 35 | -47x | +||
| 73 | +! |
- x,+ server = function(id) {
|
|
| 36 | -47x | +||
| 74 | +! |
- error = function(e) {
+ moduleServer(id, function(input, output, session) {
|
|
| 37 | -2x | +||
| 75 | +! |
- stop(+ showModal( |
|
| 38 | -2x | +||
| 76 | +! |
- "\n",+ modalDialog( |
|
| 39 | -2x | +||
| 77 | +! |
- pre,+ id = "landingpopup", |
|
| 40 | -2x | +||
| 78 | +! |
- "\n",+ title = title, |
|
| 41 | -2x | +||
| 79 | +! |
- e$message,+ content, |
|
| 42 | -2x | +||
| 80 | +! |
- "\n",+ footer = buttons |
|
| 43 | -2x | +||
| 81 | +
- post,+ ) |
||
| 44 | -2x | +||
| 82 | +
- call. = FALSE+ ) |
||
| 45 | +83 |
- )+ }) |
|
| 46 | +84 |
} |
|
| 47 | +85 |
) |
|
| 48 | -45x | +||
| 86 | +! |
- x+ class(module) <- c("teal_module_landing", class(module))
+ |
+ |
| 87 | +! | +
+ module |
|
| 49 | +88 |
}@@ -46559,1527 +46334,1641 @@ teal coverage - 60.02% |
| 1 |
- #' Evaluate expression on `teal_data_module`+ #' @title `TealReportCard` |
|||
| 2 |
- #'+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 3 |
- #' @details+ #' Child class of [`teal.reporter::ReportCard`] that is used for `teal` specific applications. |
|||
| 4 |
- #' `within` is a convenience function for evaluating inline code inside the environment of a `teal_data_module`.+ #' In addition to the parent methods, it supports rendering `teal` specific elements such as |
|||
| 5 |
- #' It accepts only inline expressions (both simple and compound) and allows for injecting values into `expr` through+ #' the source code, the encodings panel content and the filter panel content as part of the |
|||
| 6 |
- #' the `...` argument: as `name:value` pairs are passed to `...`, `name` in `expr` will be replaced with `value.`+ #' meta data. |
|||
| 7 |
- #'+ #' @export |
|||
| 8 |
- #' @param data (`teal_data_module`) object+ #' |
|||
| 9 |
- #' @param expr (`expression`) to evaluate. Must be inline code. See [within()]+ TealReportCard <- R6::R6Class( # nolint: object_name. |
|||
| 10 |
- #' @param ... See `Details`.+ classname = "TealReportCard", |
|||
| 11 |
- #'+ inherit = teal.reporter::ReportCard, |
|||
| 12 |
- #' @return+ public = list( |
|||
| 13 |
- #' `within` returns a `teal_data_module` object with a delayed evaluation of `expr` when the module is run.+ #' @description Appends the source code to the `content` meta data of this `TealReportCard`. |
|||
| 14 |
- #'+ #' |
|||
| 15 |
- #' @examples+ #' @param src (`character(1)`) code as text. |
|||
| 16 |
- #' within(tdm, dataset1 <- subset(dataset1, Species == "virginica"))+ #' @param ... any `rmarkdown` `R` chunk parameter and its value.+ |
+ |||
| 17 | ++ |
+ #' But `eval` parameter is always set to `FALSE`.+ |
+ ||
| 18 | ++ |
+ #' @return Object of class `TealReportCard`, invisibly.+ |
+ ||
| 19 | ++ |
+ #' @examples+ |
+ ||
| 20 | ++ |
+ #' card <- TealReportCard$new()$append_src(+ |
+ ||
| 21 | ++ |
+ #' "plot(iris)"+ |
+ ||
| 22 | ++ |
+ #' )+ |
+ ||
| 23 | ++ |
+ #' card$get_content()[[1]]$get_content()+ |
+ ||
| 24 | ++ |
+ append_src = function(src, ...) {
+ |
+ ||
| 25 | +4x | +
+ checkmate::assert_character(src, min.len = 0, max.len = 1)+ |
+ ||
| 26 | +4x | +
+ params <- list(...)+ |
+ ||
| 27 | +4x | +
+ params$eval <- FALSE+ |
+ ||
| 28 | +4x | +
+ rblock <- RcodeBlock$new(src)+ |
+ ||
| 29 | +4x | +
+ rblock$set_params(params)+ |
+ ||
| 30 | +4x | +
+ self$append_content(rblock)+ |
+ ||
| 31 | +4x | +
+ self$append_metadata("SRC", src)
+ |
+ ||
| 32 | +4x | +
+ invisible(self) |
||
| 17 | +33 |
- #'+ }, |
||
| 18 | +34 |
- #' # use additional parameter for expression value substitution.+ #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`. |
||
| 19 | +35 |
- #' valid_species <- "versicolor"+ #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses |
||
| 20 | +36 |
- #' within(tdm, dataset1 <- subset(dataset1, Species %in% species), species = valid_species)+ #' the default `yaml::as.yaml` to format the list. |
||
| 21 | +37 |
- #' @include teal_data_module.R+ #' If the filter state list is empty, nothing is appended to the `content`. |
||
| 22 | +38 |
- #' @name within+ #' |
||
| 23 | +39 |
- #' @rdname teal_data_module+ #' @param fs (`teal_slices`) object returned from [teal_slices()] function. |
||
| 24 | +40 |
- #'+ #' @return `self`, invisibly. |
||
| 25 | +41 |
- #' @export+ append_fs = function(fs) {
|
||
| 26 | -+ | |||
| 42 | +5x |
- #'+ checkmate::assert_class(fs, "teal_slices") |
||
| 27 | -+ | |||
| 43 | +4x |
- within.teal_data_module <- function(data, expr, ...) {
+ self$append_text("Filter State", "header3")
|
||
| 28 | -2x | +44 | +4x |
- expr <- substitute(expr)+ if (length(fs)) {
|
| 29 | -2x | +45 | +3x |
- extras <- list(...)+ self$append_content(TealSlicesBlock$new(fs)) |
| 30 | +46 |
-
+ } else {
|
||
| 31 | -+ | |||
| 47 | +1x |
- # Add braces for consistency.+ self$append_text("No filters specified.")
|
||
| 32 | -2x | +|||
| 48 | +
- if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
+ } |
|||
| 33 | -2x | +49 | +4x |
- expr <- call("{", expr)
+ invisible(self) |
| 34 | +50 |
- }+ }, |
||
| 35 | +51 |
-
+ #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`. |
||
| 36 | -2x | +|||
| 52 | +
- calls <- as.list(expr)[-1]+ #' |
|||
| 37 | +53 |
-
+ #' @param encodings (`list`) list of encodings selections of the `teal` app. |
||
| 38 | +54 |
- # Inject extra values into expressions.+ #' @return `self`, invisibly. |
||
| 39 | -2x | +|||
| 55 | +
- calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))+ #' @examples |
|||
| 40 | +56 |
-
+ #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X")) |
||
| 41 | -2x | +|||
| 57 | +
- eval_code(object = data, code = as.expression(calls))+ #' card$get_content()[[1]]$get_content() |
|||
| 42 | +58 |
- }+ #' |
| 1 | +59 |
- #' Create a `tdata` object+ append_encodings = function(encodings) {
|
|
| 2 | -+ | ||
| 60 | +4x |
- #'+ checkmate::assert_list(encodings) |
|
| 3 | -+ | ||
| 61 | +4x |
- #' @description `r lifecycle::badge("superseded")`
+ self$append_text("Selected Options", "header3")
|
|
| 4 | -+ | ||
| 62 | +4x |
- #'+ if (requireNamespace("yaml", quietly = TRUE)) {
|
|
| 5 | -+ | ||
| 63 | +4x |
- #' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object+ self$append_text(yaml::as.yaml(encodings, handlers = list( |
|
| 6 | -+ | ||
| 64 | +4x |
- #' to be passed to the `data` argument but instead they receive a `teal_data` object,+ POSIXct = function(x) format(x, "%Y-%m-%d"), |
|
| 7 | -+ | ||
| 65 | +4x |
- #' which is additionally wrapped in a reactive expression in the server functions.+ POSIXlt = function(x) format(x, "%Y-%m-%d"), |
|
| 8 | -+ | ||
| 66 | +4x |
- #' In order to easily adapt such modules without a proper refactor,+ Date = function(x) format(x, "%Y-%m-%d") |
|
| 9 | -+ | ||
| 67 | +4x |
- #' use this function to downgrade the `data` argument.+ )), "verbatim") |
|
| 10 | +68 |
- #'+ } else {
|
|
| 11 | -+ | ||
| 69 | +! |
- #' @name tdata+ stop("yaml package is required to format the encodings list")
|
|
| 12 | +70 |
- #' @param ... ignored+ } |
|
| 13 | -+ | ||
| 71 | +4x |
- #' @return nothing+ self$append_metadata("Encodings", encodings)
|
|
| 14 | -+ | ||
| 72 | +4x |
- NULL+ invisible(self) |
|
| 15 | +73 |
-
+ } |
|
| 16 | +74 |
- #' @rdname tdata+ ), |
|
| 17 | +75 |
- #' @export+ private = list( |
|
| 18 | +76 |
- new_tdata <- function(...) {
+ dispatch_block = function(block_class) {
|
|
| 19 | +77 | ! |
- .deprecate_tdata_msg()+ eval(str2lang(block_class)) |
| 20 | +78 |
- }+ } |
|
| 21 | +79 |
-
+ ) |
|
| 22 | +80 |
- #' @rdname tdata+ ) |
|
| 23 | +81 |
- #' @export+ |
|
| 24 | +82 |
- tdata2env <- function(...) {
+ #' @title `TealSlicesBlock` |
|
| 25 | -! | +||
| 83 | +
- .deprecate_tdata_msg()+ #' @docType class |
||
| 26 | +84 |
- }+ #' @description |
|
| 27 | +85 |
-
+ #' Specialized `TealSlicesBlock` block for managing filter panel content in reports. |
|
| 28 | +86 |
- #' @rdname tdata+ #' @keywords internal |
|
| 29 | +87 |
- #' @export+ TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter. |
|
| 30 | +88 |
- get_code_tdata <- function(...) {
+ classname = "TealSlicesBlock", |
|
| 31 | -! | +||
| 89 | +
- .deprecate_tdata_msg()+ inherit = teal.reporter:::TextBlock, |
||
| 32 | +90 |
- }+ public = list( |
|
| 33 | +91 |
-
+ #' @description Returns a `TealSlicesBlock` object. |
|
| 34 | +92 |
- #' @rdname tdata+ #' |
|
| 35 | +93 |
- #' @export+ #' @details Returns a `TealSlicesBlock` object with no content and no parameters. |
|
| 36 | +94 |
- join_keys.tdata <- function(...) {
+ #' |
|
| 37 | -! | +||
| 95 | +
- .deprecate_tdata_msg()+ #' @param content (`teal_slices`) object returned from [teal_slices()] function. |
||
| 38 | +96 |
- }+ #' @param style (`character(1)`) string specifying style to apply. |
|
| 39 | +97 |
-
+ #' |
|
| 40 | +98 |
- #' @rdname tdata+ #' @return Object of class `TealSlicesBlock`, invisibly. |
|
| 41 | +99 |
- #' @export+ #' |
|
| 42 | +100 |
- get_metadata <- function(...) {
+ initialize = function(content = teal_slices(), style = "verbatim") {
|
|
| 43 | -! | +||
| 101 | +9x |
- .deprecate_tdata_msg()+ self$set_content(content)+ |
+ |
| 102 | +8x | +
+ self$set_style(style)+ |
+ |
| 103 | +8x | +
+ invisible(self) |
|
| 44 | +104 |
- }+ }, |
|
| 45 | +105 | ||
| 46 | +106 |
- #' @rdname tdata+ #' @description Sets content of this `TealSlicesBlock`. |
|
| 47 | +107 |
- #' @export+ #' Sets content as `YAML` text which represents a list generated from `teal_slices`. |
|
| 48 | +108 |
- as_tdata <- function(...) {
+ #' The list displays limited number of fields from `teal_slice` objects, but this list is |
|
| 49 | -! | +||
| 109 | +
- .deprecate_tdata_msg()+ #' sufficient to conclude which filters were applied. |
||
| 50 | +110 |
- }+ #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min" |
|
| 51 | +111 |
-
+ #' |
|
| 52 | +112 |
-
+ #' |
|
| 53 | +113 |
- .deprecate_tdata_msg <- function() {
+ #' @param content (`teal_slices`) object returned from [teal_slices()] function. |
|
| 54 | -! | +||
| 114 | +
- lifecycle::deprecate_stop(+ #' @return `self`, invisibly. |
||
| 55 | -! | +||
| 115 | +
- when = "0.16",+ set_content = function(content) {
|
||
| 56 | -! | +||
| 116 | +9x |
- what = "tdata()",+ checkmate::assert_class(content, "teal_slices") |
|
| 57 | -! | +||
| 117 | +8x |
- details = paste(+ if (length(content) != 0) {
|
|
| 58 | -! | +||
| 118 | +6x |
- "tdata has been removed in favour of `teal_data`.\n",+ states_list <- lapply(content, function(x) {
|
|
| 59 | -! | +||
| 119 | +6x |
- "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."+ x_list <- shiny::isolate(as.list(x)) |
|
| 60 | -+ | ||
| 120 | +6x |
- )+ if ( |
|
| 61 | -+ | ||
| 121 | +6x |
- )+ inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
|
|
| 62 | -+ | ||
| 122 | +6x |
- }+ length(x_list$choices) == 2 &&+ |
+ |
| 123 | +6x | +
+ length(x_list$selected) == 2 |
| 1 | +124 |
- #' Generates library calls from current session info+ ) {
|
||
| 2 | -+ | |||
| 125 | +! |
- #'+ x_list$range <- paste(x_list$selected, collapse = " - ") |
||
| 3 | -+ | |||
| 126 | +! |
- #' Function to create multiple library calls out of current session info to ensure reproducible code works.+ x_list["selected"] <- NULL |
||
| 4 | +127 |
- #'+ } |
||
| 5 | -+ | |||
| 128 | +6x |
- #' @return Character vector of `library(<package>)` calls.+ if (!is.null(x_list$arg)) {
|
||
| 6 | -+ | |||
| 129 | +! |
- #' @keywords internal+ x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples" |
||
| 7 | +130 |
- get_rcode_libraries <- function() {
- |
- ||
| 8 | -1x | -
- libraries <- vapply(+ } |
||
| 9 | -1x | +|||
| 131 | +
- utils::sessionInfo()$otherPkgs,+ |
|||
| 10 | -1x | +132 | +6x |
- function(x) {
+ x_list <- x_list[ |
| 11 | -15x | +133 | +6x |
- paste0("library(", x$Package, ")")
+ c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
|
| 12 | +134 |
- },+ ] |
||
| 13 | -1x | +135 | +6x |
- character(1)+ names(x_list) <- c( |
| 14 | -+ | |||
| 136 | +6x |
- )+ "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression", |
||
| 15 | -1x | +137 | +6x |
- paste0(paste0(rev(libraries), sep = "\n"), collapse = "")+ "Selected Values", "Selected range", "Include NA values", "Include Inf values" |
| 16 | +138 |
- }+ ) |
||
| 17 | +139 | |||
| 18 | -+ | |||
| 140 | +6x |
-
+ Filter(Negate(is.null), x_list) |
||
| 19 | +141 |
- #' @noRd+ }) |
||
| 20 | +142 |
- #' @keywords internal+ |
||
| 21 | -+ | |||
| 143 | +6x |
- get_rcode_str_install <- function() {
+ if (requireNamespace("yaml", quietly = TRUE)) {
|
||
| 22 | -5x | +144 | +6x |
- code_string <- getOption("teal.load_nest_code")
+ super$set_content(yaml::as.yaml(states_list)) |
| 23 | -5x | +|||
| 145 | +
- if (is.character(code_string)) {
+ } else {
|
|||
| 24 | -2x | +|||
| 146 | +! |
- code_string+ stop("yaml package is required to format the filter state list")
|
||
| 25 | +147 |
- } else {
+ } |
||
| 26 | -3x | +|||
| 148 | +
- "# Add any code to install/load your NEST environment here\n"+ } |
|||
| 27 | -+ | |||
| 149 | +8x |
- }+ private$teal_slices <- content |
||
| 28 | -+ | |||
| 150 | +8x |
- }+ invisible(self) |
| 1 | +151 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ }, |
|
| 2 | +152 |
- #'+ #' @description Create the `TealSlicesBlock` from a list. |
|
| 3 | +153 |
- #' `system.file` should not be used to access files in other packages, it does+ #' |
|
| 4 | +154 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' @param x (`named list`) with two fields `text` and `style`. |
|
| 5 | +155 |
- #' as needed. Thus, we do not export this method.+ #' Use the `get_available_styles` method to get all possible styles. |
|
| 6 | +156 |
- #'+ #' |
|
| 7 | +157 |
- #' @param pattern (`character`) pattern of files to be included+ #' @return `self`, invisibly. |
|
| 8 | +158 |
- #'+ #' @examples |
|
| 9 | +159 |
- #' @return HTML code that includes `CSS` files.+ #' TealSlicesBlock <- getFromNamespace("TealSlicesBlock", "teal")
|
|
| 10 | +160 |
- #' @keywords internal+ #' block <- TealSlicesBlock$new() |
|
| 11 | +161 |
- include_css_files <- function(pattern = "*") {
+ #' block$from_list(list(text = "sth", style = "default")) |
|
| 12 | -! | +||
| 162 | +
- css_files <- list.files(+ #' |
||
| 13 | -! | +||
| 163 | +
- system.file("css", package = "teal", mustWork = TRUE),
+ from_list = function(x) {
|
||
| 14 | -! | +||
| 164 | +1x |
- pattern = pattern, full.names = TRUE+ checkmate::assert_list(x) |
|
| 15 | -+ | ||
| 165 | +1x |
- )+ checkmate::assert_names(names(x), must.include = c("text", "style"))
|
|
| 16 | -+ | ||
| 166 | +1x |
-
+ super$set_content(x$text) |
|
| 17 | -! | +||
| 167 | +1x |
- singleton(+ super$set_style(x$style) |
|
| 18 | -! | +||
| 168 | +1x |
- tags$head(lapply(css_files, includeCSS))+ invisible(self) |
|
| 19 | +169 |
- )+ }, |
|
| 20 | +170 |
- }+ #' @description Convert the `TealSlicesBlock` to a list. |
|
| 21 | +171 |
-
+ #' |
|
| 22 | +172 |
- #' Include `JS` files from `/inst/js/` package directory to application header+ #' @return `named list` with a text and style. |
|
| 23 | +173 |
- #'+ #' @examples |
|
| 24 | +174 |
- #' `system.file` should not be used to access files in other packages, it does+ #' TealSlicesBlock <- getFromNamespace("TealSlicesBlock", "teal")
|
|
| 25 | +175 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' block <- TealSlicesBlock$new() |
|
| 26 | +176 |
- #' as needed. Thus, we do not export this method+ #' block$to_list() |
|
| 27 | +177 |
- #'+ #' |
|
| 28 | +178 |
- #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ to_list = function() {
|
|
| 29 | -+ | ||
| 179 | +2x |
- #' @param except (`character`) vector of basename filenames to be excluded+ content <- self$get_content() |
|
| 30 | -+ | ||
| 180 | +2x |
- #'+ list( |
|
| 31 | -+ | ||
| 181 | +2x |
- #' @return HTML code that includes `JS` files.+ text = if (length(content)) content else "", |
|
| 32 | -+ | ||
| 182 | +2x |
- #' @keywords internal+ style = self$get_style() |
|
| 33 | +183 |
- include_js_files <- function(pattern = NULL, except = NULL) {
+ ) |
|
| 34 | -! | +||
| 184 | +
- checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)+ } |
||
| 35 | -! | +||
| 185 | +
- js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
+ ), |
||
| 36 | -! | +||
| 186 | +
- js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL+ private = list( |
||
| 37 | +187 |
-
+ style = "verbatim", |
|
| 38 | -! | +||
| 188 | +
- singleton(lapply(js_files, includeScript))+ teal_slices = NULL # teal_slices |
||
| 39 | +189 |
- }+ ) |
|
| 40 | +190 |
-
+ ) |
| 41 | +1 |
- #' Run `JS` file from `/inst/js/` package directory+ #' Show `R` code modal |
|
| 42 | +2 |
#' |
|
| 43 | +3 |
- #' This is triggered from the server to execute on the client+ #' @description `r lifecycle::badge("deprecated")`
|
|
| 44 | +4 |
- #' rather than triggered directly on the client.+ #' |
|
| 45 | +5 |
- #' Unlike `include_js_files` which includes `JavaScript` functions,+ #' Use the [shiny::showModal()] function to show the `R` code inside. |
|
| 46 | +6 |
- #' the `run_js` actually executes `JavaScript` functions.+ #' |
|
| 47 | +7 |
- #'+ #' @param title (`character(1)`) |
|
| 48 | +8 |
- #' `system.file` should not be used to access files in other packages, it does+ #' Title of the modal, displayed in the first comment of the `R` code. |
|
| 49 | +9 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' @param rcode (`character`) |
|
| 50 | +10 |
- #' as needed. Thus, we do not export this method.+ #' vector with `R` code to show inside the modal. |
|
| 51 | +11 |
- #'+ #' @param session (`ShinySession`) optional |
|
| 52 | +12 |
- #' @param files (`character`) vector of filenames.+ #' `shiny` session object, defaults to [shiny::getDefaultReactiveDomain()]. |
|
| 53 | +13 |
#' |
|
| 54 | +14 |
- #' @return `NULL`, invisibly.+ #' @references [shiny::showModal()] |
|
| 55 | +15 |
- #' @keywords internal+ #' @export |
|
| 56 | +16 |
- run_js_files <- function(files) {
- |
- |
| 57 | -88x | -
- checkmate::assert_character(files, min.len = 1, any.missing = FALSE)+ show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) {
|
|
| 58 | -88x | +||
| 17 | +! |
- lapply(files, function(file) {
+ lifecycle::deprecate_soft( |
|
| 59 | -88x | +||
| 18 | +! |
- shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
+ when = "0.16", |
|
| 60 | -+ | ||
| 19 | +! |
- })+ what = "show_rcode_modal()", |
|
| 61 | -88x | +||
| 20 | +! |
- invisible(NULL)+ details = "This function will be removed in the next release." |
|
| 62 | +21 |
- }+ ) |
|
| 63 | +22 | ||
| 64 | -+ | ||
| 23 | +! |
- #' Code to include `teal` `CSS` and `JavaScript` files+ rcode <- paste(rcode, collapse = "\n") |
|
| 65 | +24 |
- #'+ |
|
| 66 | -+ | ||
| 25 | +! |
- #' This is useful when you want to use the same `JavaScript` and `CSS` files that are+ ns <- session$ns |
|
| 67 | -+ | ||
| 26 | +! |
- #' used with the `teal` application.+ showModal(modalDialog( |
|
| 68 | -+ | ||
| 27 | +! |
- #' This is also useful for running standalone modules in `teal` with the correct+ tagList( |
|
| 69 | -+ | ||
| 28 | +! |
- #' styles.+ tags$div( |
|
| 70 | -+ | ||
| 29 | +! |
- #' Also initializes `shinyjs` so you can use it.+ actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
|
|
| 71 | -+ | ||
| 30 | +! |
- #'+ modalButton("Dismiss"),
|
|
| 72 | -+ | ||
| 31 | +! |
- #' Simply add `include_teal_css_js()` as one of the UI elements.+ style = "mb-4" |
|
| 73 | +32 |
- #' @return A `shiny.tag.list`.+ ), |
|
| 74 | -+ | ||
| 33 | +! |
- #' @keywords internal+ tags$div(tags$pre(id = ns("r_code"), rcode)),
|
|
| 75 | +34 |
- include_teal_css_js <- function() {
+ ), |
|
| 76 | +35 | ! |
- tagList(+ title = title, |
| 77 | +36 | ! |
- shinyjs::useShinyjs(),+ footer = tagList( |
| 78 | +37 | ! |
- include_css_files(),+ actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ |
+
| 38 | +! | +
+ modalButton("Dismiss")
|
|
| 79 | +39 |
- # init.js is executed from the server+ ), |
|
| 80 | +40 | ! |
- include_js_files(except = "init.js"),+ size = "l", |
| 81 | +41 | ! |
- shinyjs::hidden(icon("fas fa-gear")), # add hidden icon to load font-awesome css for icons
+ easyClose = TRUE |
| 82 | +42 |
- )+ )) |
|
| 83 | +43 |
}@@ -48570,14 +48459,14 @@ teal coverage - 60.02% |
| 1 |
- #' Show `R` code modal+ #' Data module for `teal` applications |
||
| 3 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @description |
||
| 4 |
- #'+ #' `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' Use the [shiny::showModal()] function to show the `R` code inside.+ #' |
||
| 6 |
- #'+ #' Create a `teal_data_module` object and evaluate code on it with history tracking. |
||
| 7 |
- #' @param title (`character(1)`)+ #' |
||
| 8 |
- #' Title of the modal, displayed in the first comment of the `R` code.+ #' @details |
||
| 9 |
- #' @param rcode (`character`)+ #' `teal_data_module` creates a `shiny` module to interactively supply or modify data in a `teal` application. |
||
| 10 |
- #' vector with `R` code to show inside the modal.+ #' The module allows for running any code (creation _and_ some modification) after the app starts or reloads. |
||
| 11 |
- #' @param session (`ShinySession`) optional+ #' The body of the server function will be run in the app rather than in the global environment. |
||
| 12 |
- #' `shiny` session object, defaults to [shiny::getDefaultReactiveDomain()].+ #' This means it will be run every time the app starts, so use sparingly. |
||
| 14 |
- #' @references [shiny::showModal()]+ #' Pass this module instead of a `teal_data` object in a call to [init()]. |
||
| 15 |
- #' @export+ #' Note that the server function must always return a `teal_data` object wrapped in a reactive expression. |
||
| 16 |
- show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) {
+ #' |
||
| 17 | -! | +
- lifecycle::deprecate_soft(+ #' See vignette `vignette("data-as-shiny-module", package = "teal")` for more details.
|
|
| 18 | -! | +
- when = "0.16",+ #' |
|
| 19 | -! | +
- what = "show_rcode_modal()",+ #' @param ui (`function(id)`) |
|
| 20 | -! | +
- details = "This function will be removed in the next release."+ #' `shiny` module UI function; must only take `id` argument |
|
| 21 |
- )+ #' @param server (`function(id)`) |
||
| 22 |
-
+ #' `shiny` module server function; must only take `id` argument; |
||
| 23 | -! | +
- rcode <- paste(rcode, collapse = "\n")+ #' must return reactive expression containing `teal_data` object |
|
| 24 |
-
+ #' @param label (`character(1)`) Label of the module. |
||
| 25 | -! | +
- ns <- session$ns+ #' @param once (`logical(1)`) |
|
| 26 | -! | +
- showModal(modalDialog(+ #' If `TRUE`, the data module will be shown only once and will disappear after successful data loading. |
|
| 27 | -! | +
- tagList(+ #' App user will no longer be able to interact with this module anymore. |
|
| 28 | -! | +
- tags$div(+ #' If `FALSE`, the data module can be reused multiple times. |
|
| 29 | -! | +
- actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ #' App user will be able to interact and change the data output from the module multiple times. |
|
| 30 | -! | +
- modalButton("Dismiss"),
+ #' |
|
| 31 | -! | +
- style = "mb-4"+ #' @return |
|
| 32 |
- ),+ #' `teal_data_module` returns a list of class `teal_data_module` containing two elements, `ui` and |
||
| 33 | -! | ++ |
+ #' `server` provided via arguments.+ |
+
| 34 | ++ |
+ #'+ |
+ |
| 35 | ++ |
+ #' @examples+ |
+ |
| 36 | ++ |
+ #' tdm <- teal_data_module(+ |
+ |
| 37 | ++ |
+ #' ui = function(id) {
+ |
+ |
| 38 | ++ |
+ #' ns <- NS(id)+ |
+ |
| 39 | ++ |
+ #' actionButton(ns("submit"), label = "Load data")
+ |
+ |
| 40 | ++ |
+ #' },+ |
+ |
| 41 | ++ |
+ #' server = function(id) {
+ |
+ |
| 42 | ++ |
+ #' moduleServer(id, function(input, output, session) {
+ |
+ |
| 43 | ++ |
+ #' eventReactive(input$submit, {
+ |
+ |
| 44 | ++ |
+ #' data <- within(+ |
+ |
| 45 | ++ |
+ #' teal_data(),+ |
+ |
| 46 | ++ |
+ #' {
+ |
+ |
| 47 | ++ |
+ #' dataset1 <- iris+ |
+ |
| 48 | ++ |
+ #' dataset2 <- mtcars+ |
+ |
| 49 | ++ |
+ #' }+ |
+ |
| 50 | ++ |
+ #' )+ |
+ |
| 51 | ++ |
+ #'+ |
+ |
| 52 | ++ |
+ #' data+ |
+ |
| 53 | ++ |
+ #' })+ |
+ |
| 54 | ++ |
+ #' })+ |
+ |
| 55 | ++ |
+ #' }+ |
+ |
| 56 | ++ |
+ #' )+ |
+ |
| 57 | ++ |
+ #'+ |
+ |
| 58 | ++ |
+ #' @name teal_data_module+ |
+ |
| 59 | ++ |
+ #' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]+ |
+ |
| 60 | ++ |
+ #'+ |
+ |
| 61 | ++ |
+ #' @export+ |
+ |
| 62 | ++ |
+ teal_data_module <- function(ui, server, label = "data module", once = TRUE) {
+ |
+ |
| 63 | +33x | +
+ checkmate::assert_function(ui, args = "id", nargs = 1)+ |
+ |
| 64 | +32x | +
+ checkmate::assert_function(server, args = "id", nargs = 1)+ |
+ |
| 65 | +30x | +
+ checkmate::assert_string(label)+ |
+ |
| 66 | +30x | +
+ checkmate::assert_flag(once)+ |
+ |
| 67 | +30x | +
+ structure(+ |
+ |
| 68 | +30x | +
+ list(+ |
+ |
| 69 | +30x | +
+ ui = ui,+ |
+ |
| 70 | +30x | +
+ server = function(id) {
+ |
+ |
| 71 | +23x | +
+ data_out <- server(id)+ |
+ |
| 72 | +22x |
- tags$div(tags$pre(id = ns("r_code"), rcode)),
+ decorate_err_msg( |
|
| 34 | -+ | ||
| 73 | +22x |
- ),+ assert_reactive(data_out), |
|
| 35 | -! | +||
| 74 | +22x |
- title = title,+ pre = sprintf("From: 'teal_data_module()':\nA 'teal_data_module' with \"%s\" label:", label),
|
|
| 36 | -! | +||
| 75 | +22x |
- footer = tagList(+ post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter. |
|
| 37 | -! | +||
| 76 | +
- actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ ) |
||
| 38 | -! | +||
| 77 | +
- modalButton("Dismiss")
+ } |
||
| 39 | +78 |
), |
|
| 40 | -! | +||
| 79 | +30x |
- size = "l",+ label = label, |
|
| 41 | -! | +||
| 80 | +30x |
- easyClose = TRUE+ class = "teal_data_module",+ |
+ |
| 81 | +30x | +
+ once = once |
|
| 42 | +82 |
- ))+ ) |
|
| 43 | +83 |
}@@ -48877,864 +49046,857 @@ teal coverage - 60.02% |
| 1 |
- #' Data module for `teal` applications+ setOldClass("teal_data_module")
|
||
| 2 |
- #'+ |
||
| 3 |
- #' @description+ #' Evaluate code on `teal_data_module` |
||
| 4 |
- #' `r lifecycle::badge("experimental")`
+ #' |
||
| 5 |
- #'+ #' @details |
||
| 6 |
- #' Create a `teal_data_module` object and evaluate code on it with history tracking.+ #' `eval_code` evaluates given code in the environment of the `teal_data` object created by the `teal_data_module`. |
||
| 7 |
- #'+ #' The code is added to the `@code` slot of the `teal_data`. |
||
| 8 |
- #' @details+ #' |
||
| 9 |
- #' `teal_data_module` creates a `shiny` module to interactively supply or modify data in a `teal` application.+ #' @param object (`teal_data_module`) |
||
| 10 |
- #' The module allows for running any code (creation _and_ some modification) after the app starts or reloads.+ #' @inheritParams teal.code::eval_code |
||
| 11 |
- #' The body of the server function will be run in the app rather than in the global environment.+ #' |
||
| 12 |
- #' This means it will be run every time the app starts, so use sparingly.+ #' @return |
||
| 13 |
- #'+ #' `eval_code` returns a `teal_data_module` object with a delayed evaluation of `code` when the module is run. |
||
| 14 |
- #' Pass this module instead of a `teal_data` object in a call to [init()].+ #' |
||
| 15 |
- #' Note that the server function must always return a `teal_data` object wrapped in a reactive expression.+ #' @examples |
||
| 16 |
- #'+ #' eval_code(tdm, "dataset1 <- subset(dataset1, Species == 'virginica')") |
||
| 17 |
- #' See vignette `vignette("data-as-shiny-module", package = "teal")` for more details.
+ #' |
||
| 18 |
- #'+ #' @include teal_data_module.R |
||
| 19 |
- #' @param ui (`function(id)`)+ #' @name eval_code |
||
| 20 |
- #' `shiny` module UI function; must only take `id` argument+ #' @rdname teal_data_module |
||
| 21 |
- #' @param server (`function(id)`)+ #' @aliases eval_code,teal_data_module,character-method |
||
| 22 |
- #' `shiny` module server function; must only take `id` argument;+ #' @aliases eval_code,teal_data_module,language-method |
||
| 23 |
- #' must return reactive expression containing `teal_data` object+ #' @aliases eval_code,teal_data_module,expression-method |
||
| 24 |
- #' @param label (`character(1)`) Label of the module.+ #' |
||
| 25 |
- #' @param once (`logical(1)`)+ #' @importFrom methods setMethod |
||
| 26 |
- #' If `TRUE`, the data module will be shown only once and will disappear after successful data loading.+ #' @importMethodsFrom teal.code eval_code |
||
| 27 |
- #' App user will no longer be able to interact with this module anymore.+ #' |
||
| 28 |
- #' If `FALSE`, the data module can be reused multiple times.+ setMethod("eval_code", signature = c("teal_data_module", "character"), function(object, code) {
|
||
| 29 | -+ | 9x |
- #' App user will be able to interact and change the data output from the module multiple times.+ teal_data_module( |
| 30 | -+ | 9x |
- #'+ ui = function(id) {
|
| 31 | -+ | 1x |
- #' @return+ ns <- NS(id) |
| 32 | -+ | 1x |
- #' `teal_data_module` returns a list of class `teal_data_module` containing two elements, `ui` and+ object$ui(ns("mutate_inner"))
|
| 33 |
- #' `server` provided via arguments.+ }, |
||
| 34 | -+ | 9x |
- #'+ server = function(id) {
|
| 35 | -+ | 7x |
- #' @examples+ moduleServer(id, function(input, output, session) {
|
| 36 | -+ | 7x |
- #' tdm <- teal_data_module(+ data <- object$server("mutate_inner")
|
| 37 | -+ | 6x |
- #' ui = function(id) {
+ td <- eventReactive(data(), |
| 38 |
- #' ns <- NS(id)+ {
|
||
| 39 | -+ | 6x |
- #' actionButton(ns("submit"), label = "Load data")
+ if (inherits(data(), c("teal_data", "qenv.error"))) {
|
| 40 | -+ | 4x |
- #' },+ eval_code(data(), code) |
| 41 |
- #' server = function(id) {
+ } else {
|
||
| 42 | -+ | 2x |
- #' moduleServer(id, function(input, output, session) {
+ data() |
| 43 |
- #' eventReactive(input$submit, {
+ } |
||
| 44 |
- #' data <- within(+ }, |
||
| 45 | -+ | 6x |
- #' teal_data(),+ ignoreNULL = FALSE |
| 46 |
- #' {
+ ) |
||
| 47 | -+ | 6x |
- #' dataset1 <- iris+ td |
| 48 |
- #' dataset2 <- mtcars+ }) |
||
| 49 |
- #' }+ } |
||
| 50 |
- #' )+ ) |
||
| 51 |
- #'+ }) |
||
| 52 |
- #' data+ |
||
| 53 |
- #' })+ setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
|
||
| 54 | -+ | 1x |
- #' })+ eval_code(object, code = paste(lang2calls(code), collapse = "\n")) |
| 55 |
- #' }+ }) |
||
| 56 |
- #' )+ |
||
| 57 |
- #'+ setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
|
||
| 58 | -+ | 2x |
- #' @name teal_data_module+ eval_code(object, code = paste(lang2calls(code), collapse = "\n")) |
| 59 |
- #' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]+ }) |
| 60 | +1 |
- #'+ #' Create a `tdata` object |
|
| 61 | +2 |
- #' @export+ #' |
|
| 62 | +3 |
- teal_data_module <- function(ui, server, label = "data module", once = TRUE) {
- |
- |
| 63 | -33x | -
- checkmate::assert_function(ui, args = "id", nargs = 1)- |
- |
| 64 | -32x | -
- checkmate::assert_function(server, args = "id", nargs = 1)- |
- |
| 65 | -30x | -
- checkmate::assert_string(label)+ #' @description `r lifecycle::badge("superseded")`
|
|
| 66 | -30x | +||
| 4 | +
- checkmate::assert_flag(once)+ #' |
||
| 67 | -30x | +||
| 5 | +
- structure(+ #' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object |
||
| 68 | -30x | +||
| 6 | +
- list(+ #' to be passed to the `data` argument but instead they receive a `teal_data` object, |
||
| 69 | -30x | +||
| 7 | +
- ui = ui,+ #' which is additionally wrapped in a reactive expression in the server functions. |
||
| 70 | -30x | +||
| 8 | +
- server = function(id) {
+ #' In order to easily adapt such modules without a proper refactor, |
||
| 71 | -23x | +||
| 9 | +
- data_out <- server(id)+ #' use this function to downgrade the `data` argument. |
||
| 72 | -22x | +||
| 10 | +
- decorate_err_msg(+ #' |
||
| 73 | -22x | +||
| 11 | +
- assert_reactive(data_out),+ #' @name tdata |
||
| 74 | -22x | +||
| 12 | +
- pre = sprintf("From: 'teal_data_module()':\nA 'teal_data_module' with \"%s\" label:", label),
+ #' @param ... ignored |
||
| 75 | -22x | +||
| 13 | +
- post = "Please make sure that this module returns a 'reactive` object containing 'teal_data' class of object." # nolint: line_length_linter.+ #' @return nothing |
||
| 76 | +14 |
- )+ NULL |
|
| 77 | +15 |
- }+ |
|
| 78 | +16 |
- ),+ #' @rdname tdata |
|
| 79 | -30x | +||
| 17 | +
- label = label,+ #' @export |
||
| 80 | -30x | +||
| 18 | +
- class = "teal_data_module",+ new_tdata <- function(...) {
|
||
| 81 | -30x | +||
| 19 | +! |
- once = once+ .deprecate_tdata_msg() |
|
| 82 | +20 |
- )+ } |
|
| 83 | +21 |
- }+ |
| 1 | +22 |
- #' UI and server modules of `teal`+ #' @rdname tdata |
|
| 2 | +23 |
- #'+ #' @export |
|
| 3 | +24 |
- #' @description `r lifecycle::badge("deprecated")`
+ tdata2env <- function(...) {
|
|
| 4 | -+ | ||
| 25 | +! |
- #' Please use [`module_teal`] instead.+ .deprecate_tdata_msg() |
|
| 5 | +26 |
- #'+ } |
|
| 6 | +27 |
- #' @inheritParams ui_teal+ |
|
| 7 | +28 |
- #' @inheritParams srv_teal+ #' @rdname tdata |
|
| 8 | +29 |
- #'+ #' @export |
|
| 9 | +30 |
- #' @return+ get_code_tdata <- function(...) {
|
|
| 10 | -+ | ||
| 31 | +! |
- #' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not.+ .deprecate_tdata_msg() |
|
| 11 | +32 |
- #' @name module_teal_with_splash+ } |
|
| 12 | +33 |
- #'+ |
|
| 13 | +34 |
- NULL+ #' @rdname tdata |
|
| 14 | +35 |
-
+ #' @export |
|
| 15 | +36 |
- #' @export+ join_keys.tdata <- function(...) {
|
|
| 16 | -+ | ||
| 37 | +! |
- #' @rdname module_teal_with_splash+ .deprecate_tdata_msg() |
|
| 17 | +38 |
- ui_teal_with_splash <- function(id,+ } |
|
| 18 | +39 |
- data,+ |
|
| 19 | +40 |
- title = build_app_title(),+ #' @rdname tdata |
|
| 20 | +41 |
- header = tags$p(),+ #' @export |
|
| 21 | +42 |
- footer = tags$p()) {
+ get_metadata <- function(...) {
|
|
| 22 | +43 | ! |
- lifecycle::deprecate_soft(+ .deprecate_tdata_msg() |
| 23 | -! | +||
| 44 | +
- when = "0.16",+ } |
||
| 24 | -! | +||
| 45 | +
- what = "ui_teal_with_splash()",+ |
||
| 25 | -! | +||
| 46 | +
- details = "Deprecated, please use `ui_teal` instead"+ #' @rdname tdata |
||
| 26 | +47 |
- )+ #' @export+ |
+ |
| 48 | ++ |
+ as_tdata <- function(...) {
|
|
| 27 | +49 | ! |
- ui_teal(id = id, title = title, header = header, footer = footer)+ .deprecate_tdata_msg() |
| 28 | +50 |
} |
|
| 29 | +51 | ||
| 30 | +52 |
- #' @export+ |
|
| 31 | +53 |
- #' @rdname module_teal_with_splash+ .deprecate_tdata_msg <- function() {
|
|
| 32 | -+ | ||
| 54 | +! |
- srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
+ lifecycle::deprecate_stop( |
|
| 33 | +55 | ! |
- lifecycle::deprecate_soft(+ when = "0.16", |
| 34 | +56 | ! |
- when = "0.16",+ what = "tdata()", |
| 35 | +57 | ! |
- what = "srv_teal_with_splash()",+ details = paste( |
| 36 | +58 | ! |
- details = "Deprecated, please use `srv_teal` instead"+ "tdata has been removed in favour of `teal_data`.\n",+ |
+
| 59 | +! | +
+ "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987." |
|
| 37 | +60 |
- )+ ) |
|
| 38 | -! | +||
| 61 | +
- srv_teal(id = id, data = data, modules = modules, filter = filter)+ ) |
||
| 39 | +62 |
}@@ -49743,14 +49905,14 @@ teal coverage - 60.02% |
| 1 |
- #' Landing popup module+ #' Generates library calls from current session info |
||
| 3 |
- #' @description Creates a landing welcome popup for `teal` applications.+ #' Function to create multiple library calls out of current session info to ensure reproducible code works. |
||
| 5 |
- #' This module is used to display a popup dialog when the application starts.+ #' @return Character vector of `library(<package>)` calls. |
||
| 6 |
- #' The dialog blocks access to the application and must be closed with a button before the application can be viewed.+ #' @keywords internal |
||
| 7 |
- #'+ get_rcode_libraries <- function() {
|
||
| 8 | -+ | 1x |
- #' @param label (`character(1)`) Label of the module.+ libraries <- vapply( |
| 9 | -+ | 1x |
- #' @param title (`character(1)`) Text to be displayed as popup title.+ utils::sessionInfo()$otherPkgs, |
| 10 | -+ | 1x |
- #' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup.+ function(x) {
|
| 11 | -+ | 15x |
- #' Passed to `...` of `shiny::modalDialog`. See examples.+ paste0("library(", x$Package, ")")
|
| 12 |
- #' @param buttons (`shiny.tag` or `shiny.tag.list`) Typically a `modalButton` or `actionButton`. See examples.+ }, |
||
| 13 | -+ | 1x |
- #'+ character(1) |
| 14 |
- #' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications.+ ) |
||
| 15 | -+ | 1x |
- #'+ paste0(paste0(rev(libraries), sep = "\n"), collapse = "") |
| 16 |
- #' @examples+ } |
||
| 17 |
- #' app1 <- init(+ |
||
| 18 |
- #' data = teal_data(iris = iris),+ |
||
| 19 |
- #' modules = modules(+ #' @noRd |
||
| 20 |
- #' example_module()+ #' @keywords internal |
||
| 21 |
- #' ),+ get_rcode_str_install <- function() {
|
||
| 22 | -+ | 5x |
- #' landing_popup = landing_popup_module(+ code_string <- getOption("teal.load_nest_code")
|
| 23 | -+ | 5x |
- #' content = "A place for the welcome message or a disclaimer statement.",+ if (is.character(code_string)) {
|
| 24 | -+ | 2x |
- #' buttons = modalButton("Proceed")
+ code_string |
| 25 |
- #' )+ } else {
|
||
| 26 | -+ | 3x |
- #' )+ "# Add any code to install/load your NEST environment here\n" |
| 27 |
- #' if (interactive()) {
+ } |
||
| 28 |
- #' shinyApp(app1$ui, app1$server)+ } |
| 29 | +1 |
- #' }+ #' UI and server modules of `teal` |
|
| 30 | +2 |
#' |
|
| 31 | -- |
- #' app2 <- init(- |
- |
| 32 | -- |
- #' data = teal_data(iris = iris),- |
- |
| 33 | -- |
- #' modules = modules(- |
- |
| 34 | -- |
- #' example_module()- |
- |
| 35 | -- |
- #' ),- |
- |
| 36 | -- |
- #' landing_popup = landing_popup_module(- |
- |
| 37 | -- |
- #' title = "Welcome",- |
- |
| 38 | -- |
- #' content = tags$b(- |
- |
| 39 | -- |
- #' "A place for the welcome message or a disclaimer statement.",- |
- |
| 40 | -- |
- #' style = "color: red;"- |
- |
| 41 | -- |
- #' ),- |
- |
| 42 | +3 |
- #' buttons = tagList(+ #' @description `r lifecycle::badge("deprecated")`
|
|
| 43 | +4 |
- #' modalButton("Proceed"),
+ #' Please use [`module_teal`] instead. |
|
| 44 | +5 |
- #' actionButton("read", "Read more",
+ #' |
|
| 45 | +6 |
- #' onclick = "window.open('http://google.com', '_blank')"
+ #' @inheritParams ui_teal |
|
| 46 | +7 |
- #' ),+ #' @inheritParams srv_teal |
|
| 47 | +8 |
- #' actionButton("close", "Reject", onclick = "window.close()")
+ #' |
|
| 48 | +9 |
- #' )+ #' @return |
|
| 49 | +10 |
- #' )+ #' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not. |
|
| 50 | +11 |
- #' )+ #' @name module_teal_with_splash |
|
| 51 | +12 |
#' |
|
| 52 | +13 |
- #' if (interactive()) {
+ NULL |
|
| 53 | +14 |
- #' shinyApp(app2$ui, app2$server)+ |
|
| 54 | +15 |
- #' }+ #' @export |
|
| 55 | +16 |
- #'+ #' @rdname module_teal_with_splash |
|
| 56 | +17 |
- #' @export+ ui_teal_with_splash <- function(id, |
|
| 57 | +18 |
- landing_popup_module <- function(label = "Landing Popup",+ data, |
|
| 58 | +19 |
- title = NULL,+ title = build_app_title(), |
|
| 59 | +20 |
- content = NULL,+ header = tags$p(), |
|
| 60 | +21 |
- buttons = modalButton("Accept")) {
- |
- |
| 61 | -! | -
- checkmate::assert_string(label)+ footer = tags$p()) {
|
|
| 62 | +22 | ! |
- checkmate::assert_string(title, null.ok = TRUE)+ lifecycle::deprecate_soft( |
| 63 | +23 | ! |
- checkmate::assert_multi_class(+ when = "0.16", |
| 64 | +24 | ! |
- content,+ what = "ui_teal_with_splash()", |
| 65 | +25 | ! |
- classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
+ details = "Deprecated, please use `ui_teal` instead" |
| 66 | +26 |
) |
|
| 67 | +27 | ! |
- checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
+ ui_teal(id = id, title = title, header = header, footer = footer) |
| 68 | +28 | - - | -|
| 69 | -! | -
- message("Initializing landing_popup_module")
+ } |
|
| 70 | +29 | ||
| 71 | -! | -
- module <- module(- |
- |
| 72 | -! | -
- label = label,- |
- |
| 73 | -! | -
- server = function(id) {
- |
- |
| 74 | -! | +||
| 30 | +
- moduleServer(id, function(input, output, session) {
+ #' @export |
||
| 75 | -! | +||
| 31 | +
- showModal(+ #' @rdname module_teal_with_splash |
||
| 76 | -! | +||
| 32 | +
- modalDialog(+ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
|
||
| 77 | +33 | ! |
- id = "landingpopup",+ lifecycle::deprecate_soft( |
| 78 | +34 | ! |
- title = title,+ when = "0.16", |
| 79 | +35 | ! |
- content,+ what = "srv_teal_with_splash()", |
| 80 | +36 | ! |
- footer = buttons- |
-
| 81 | -- |
- )- |
- |
| 82 | -- |
- )- |
- |
| 83 | -- |
- })- |
- |
| 84 | -- |
- }+ details = "Deprecated, please use `srv_teal` instead" |
|
| 85 | +37 |
) |
|
| 86 | -! | -
- class(module) <- c("teal_module_landing", class(module))
- |
- |
| 87 | +38 | ! |
- module+ srv_teal(id = id, data = data, modules = modules, filter = filter) |
| 88 | +39 |
} |