| 1 |
- #' Filter settings for teal applications+ #' Get Client Timezone |
||
| 3 |
- #' Filter settings for teal applications+ #' Local timezone in the browser may differ from the system timezone from the server. |
||
| 4 |
- #'+ #' This script can be run to register a shiny input which contains information about |
||
| 5 |
- #' @inheritParams teal.slice::teal_slices+ #' the timezone in the browser. |
||
| 7 |
- #' @param module_specific (`logical(1)`)\cr+ #' @param ns (`function`) namespace function passed from the `session` object in the |
||
| 8 |
- #' - `TRUE` when filter panel should be module-specific. All modules can have different set+ #' Shiny server. For Shiny modules this will allow for proper name spacing of the |
||
| 9 |
- #' of filters specified - see `mapping` argument.+ #' registered input. |
||
| 10 |
- #' - `FALSE` when one filter panel needed to all modules. All filters will be shared+ #' |
||
| 11 |
- #' by all modules.+ #' @return (`Shiny`) input variable accessible with `input$tz` which is a (`character`) |
||
| 12 |
- #' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
+ #' string containing the timezone of the browser/client. |
||
| 13 |
- #' (`named list`)\cr+ #' @keywords internal |
||
| 14 |
- #' Specifies which filters will be active in which modules on app start.+ get_client_timezone <- function(ns) {
|
||
| 15 | -+ | 8x |
- #' Elements should contain character vector of `teal_slice` `id`s (see [teal.slice::teal_slice()]).+ script <- sprintf( |
| 16 | -+ | 8x |
- #' Names of the list should correspond to `teal_module` `label` set in [module()] function.+ "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)", |
| 17 | -+ | 8x |
- #' `id`s listed under `"global_filters` will be active in all modules.+ ns("timezone")
|
| 18 |
- #' If missing, all filters will be applied to all modules.+ ) |
||
| 19 | -+ | 8x |
- #' If empty list, all filters will be available to all modules but will start inactive.+ shinyjs::runjs(script) # function does not return anything |
| 20 | -+ | 8x |
- #' If `module_specific` is `FALSE`, only `global_filters` will be active on start.+ return(invisible(NULL)) |
| 21 |
- #'+ } |
||
| 22 |
- #' @param x (`list`) of lists to convert to `teal_slices`+ |
||
| 23 |
- #'+ #' Resolve the expected bootstrap theme |
||
| 24 |
- #' @examples+ #' @keywords internal |
||
| 25 |
- #' filter <- teal_slices(+ get_teal_bs_theme <- function() {
|
||
| 26 | -+ | 36x |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"),+ bs_theme <- getOption("teal.bs_theme")
|
| 27 | -+ | 36x |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),+ if (is.null(bs_theme)) {
|
| 28 | -+ | 33x |
- #' teal.slice::teal_slice(+ NULL |
| 29 | -+ | 3x |
- #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"+ } else if (!inherits(bs_theme, "bs_theme")) {
|
| 30 | -+ | 2x |
- #' ),+ warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
|
| 31 | -+ | 2x |
- #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),+ NULL |
| 32 |
- #' mapping = list(+ } else {
|
||
| 33 | -+ | 1x |
- #' module1 = c("species", "sepal_length"),
+ bs_theme |
| 34 |
- #' module2 = c("mtcars_mpg"),
+ } |
||
| 35 |
- #' global_filters = "long_petals"+ } |
||
| 36 |
- #' )+ |
||
| 37 |
- #' )+ include_parent_datanames <- function(dataname, join_keys) {
|
||
| 38 | -+ | 145x |
- #'+ parents <- character(0) |
| 39 | -+ | 145x |
- #' app <- teal::init(+ for (i in dataname) {
|
| 40 | -+ | 25x |
- #' modules = list(+ while (length(i) > 0) {
|
| 41 | -+ | 25x |
- #' module("module1"),
+ parent_i <- join_keys$get_parent(i) |
| 42 | -+ | 25x |
- #' module("module2")
+ parents <- c(parent_i, parents) |
| 43 | -+ | 25x |
- #' ),+ i <- parent_i |
| 44 |
- #' data = list(iris, mtcars),+ } |
||
| 45 |
- #' filter = filter+ } |
||
| 46 |
- #' )+ |
||
| 47 | -+ | 145x |
- #'+ return(unique(c(parents, dataname))) |
| 48 |
- #' if (interactive()) {
+ } |
||
| 49 |
- #' shiny::runApp(app)+ |
||
| 50 |
- #' }+ #' Template Function for `TealReportCard` Creation and Customization |
||
| 52 |
- #' @export+ #' This function generates a report card with a title, |
||
| 53 |
- teal_slices <- function(...,+ #' an optional description, and the option to append the filter state list. |
||
| 54 |
- exclude_varnames = NULL,+ #' |
||
| 55 |
- include_varnames = NULL,+ #' @param title (`character(1)`) title of the card (unless overwritten by label) |
||
| 56 |
- count_type = NULL,+ #' @param label (`character(1)`) label provided by the user when adding the card |
||
| 57 |
- allow_add = TRUE,+ #' @param description (`character(1)`) optional additional description |
||
| 58 |
- module_specific = FALSE,+ #' @param with_filter (`logical(1)`) flag indicating to add filter state |
||
| 59 |
- mapping) {
+ #' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation |
||
| 60 | -91x | +
- shiny::isolate({
+ #' of the filter state in the report |
|
| 61 | -91x | +
- checkmate::assert_flag(allow_add)+ #' |
|
| 62 | -91x | +
- checkmate::assert_flag(module_specific)+ #' @return (`TealReportCard`) populated with a title, description and filter state |
|
| 63 | -45x | +
- if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
+ #' |
|
| 64 |
-
+ #' @export |
||
| 65 | -88x | +
- slices <- list(...)+ report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
|
|
| 66 | -88x | +2x |
- all_slice_id <- vapply(slices, `[[`, character(1L), "id")+ checkmate::assert_string(title) |
| 67 | -+ | 2x |
-
+ checkmate::assert_string(label) |
| 68 | -88x | +2x |
- if (missing(mapping)) {
+ checkmate::assert_string(description, null.ok = TRUE) |
| 69 | -46x | +2x |
- mapping <- list(global_filters = all_slice_id)+ checkmate::assert_flag(with_filter) |
| 70 | -+ | 2x |
- }+ checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI") |
| 71 | -88x | +
- if (!module_specific) {
+
|
|
| 72 | -84x | +2x |
- mapping[setdiff(names(mapping), "global_filters")] <- NULL+ card <- teal::TealReportCard$new() |
| 73 | -+ | 2x |
- }+ title <- if (label == "") title else label |
| 74 | -+ | 2x |
-
+ card$set_name(title) |
| 75 | -88x | +2x |
- failed_slice_id <- setdiff(unlist(mapping), all_slice_id)+ card$append_text(title, "header2") |
| 76 | -88x | +1x |
- if (length(failed_slice_id)) {
+ if (!is.null(description)) card$append_text(description, "header3") |
| 77 | 1x |
- stop(sprintf(+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
|
| 78 | -1x | +2x |
- "Filters in mapping don't match any available filter.\n %s not in %s",+ card |
| 79 | -1x | +
- toString(failed_slice_id),+ } |
|
| 80 | -1x | +
| 1 | +
- toString(all_slice_id)+ # This module is the main teal module that puts everything together. |
|||
| 81 | +2 |
- ))+ |
||
| 82 | +3 |
- }+ #' teal main app module |
||
| 83 | +4 |
-
+ #' |
||
| 84 | -87x | +|||
| 5 | +
- tss <- teal.slice::teal_slices(+ #' This is the main teal app that puts everything together. |
|||
| 85 | +6 |
- ...,+ #' |
||
| 86 | -87x | +|||
| 7 | +
- exclude_varnames = exclude_varnames,+ #' It displays the splash UI which is used to fetch the data, possibly |
|||
| 87 | -87x | +|||
| 8 | +
- include_varnames = include_varnames,+ #' prompting for a password input to fetch the data. Once the data is ready, |
|||
| 88 | -87x | +|||
| 9 | +
- count_type = count_type,+ #' the splash screen is replaced by the actual teal UI that is tabsetted and |
|||
| 89 | -87x | +|||
| 10 | +
- allow_add = allow_add+ #' has a filter panel with `datanames` that are relevant for the current tab. |
|||
| 90 | +11 |
- )+ #' Nested tabs are possible, but we limit it to two nesting levels for reasons |
||
| 91 | -87x | +|||
| 12 | +
- attr(tss, "mapping") <- mapping+ #' of clarity of the UI. |
|||
| 92 | -87x | +|||
| 13 | +
- attr(tss, "module_specific") <- module_specific+ #' |
|||
| 93 | -87x | +|||
| 14 | +
- class(tss) <- c("modules_teal_slices", class(tss))
+ #' The splash screen functionality can also be used |
|||
| 94 | -87x | +|||
| 15 | +
- tss+ #' for non-delayed data which takes time to load into memory, avoiding |
|||
| 95 | +16 |
- })+ #' Shiny session timeouts. |
||
| 96 | +17 |
- }+ #' |
||
| 97 | +18 |
-
+ #' Server evaluates the `raw_data` (delayed data mechanism) and creates the |
||
| 98 | +19 |
-
+ #' `datasets` object that is shared across modules. |
||
| 99 | +20 |
- #' @rdname teal_slices+ #' Once it is ready and non-`NULL`, the splash screen is replaced by the |
||
| 100 | +21 |
- #' @export+ #' main teal UI that depends on the data. |
||
| 101 | +22 |
- #' @keywords internal+ #' The currently active tab is tracked and the right filter panel |
||
| 102 | +23 |
- #'+ #' updates the displayed datasets to filter for according to the active `datanames` |
||
| 103 | +24 |
- as.teal_slices <- function(x) { # nolint
+ #' of the tab. |
||
| 104 | -33x | +|||
| 25 | +
- checkmate::assert_list(x)+ #' |
|||
| 105 | -33x | +|||
| 26 | +
- lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")+ #' It is written as a Shiny module so it can be added into other apps as well. |
|||
| 106 | +27 |
-
+ #' |
||
| 107 | -33x | +|||
| 28 | +
- attrs <- attributes(unclass(x))+ #' @name module_teal |
|||
| 108 | -33x | +|||
| 29 | +
- ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))+ #' |
|||
| 109 | -33x | +|||
| 30 | +
- do.call(teal_slices, c(ans, attrs))+ #' @inheritParams ui_teal_with_splash |
|||
| 110 | +31 |
- }+ #' |
||
| 111 | +32 |
-
+ #' @param splash_ui (`shiny.tag`)\cr UI to display initially, |
||
| 112 | +33 |
-
+ #' can be a splash screen or a Shiny module UI. For the latter, see |
||
| 113 | +34 |
- #' @rdname teal_slices+ #' [init()] about how to call the corresponding server function. |
||
| 114 | +35 |
- #' @export+ #' |
||
| 115 | +36 |
- #' @keywords internal+ #' @param raw_data (`reactive`)\cr |
||
| 116 | +37 |
- #'+ #' returns the `TealData`, only evaluated once, `NULL` value is ignored |
||
| 117 | +38 |
- c.teal_slices <- function(...) {
+ #' |
||
| 118 | -! | +|||
| 39 | +
- x <- list(...)+ #' @return |
|||
| 119 | -! | +|||
| 40 | +
- checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ #' `ui_teal` returns `HTML` for Shiny module UI. |
|||
| 120 | +41 |
-
+ #' `srv_teal` returns `reactive` which returns the currently active module. |
||
| 121 | -! | +|||
| 42 | +
- all_attributes <- lapply(x, attributes)- |
- |||
| 122 | -! | -
- all_attributes <- coalesce_r(all_attributes)+ #' |
||
| 123 | -! | +|||
| 43 | +
- all_attributes <- all_attributes[names(all_attributes) != "class"]+ #' @keywords internal |
|||
| 124 | +44 |
-
+ #' |
||
| 125 | -! | +|||
| 45 | +
- do.call(+ #' @examples |
|||
| 126 | -! | +|||
| 46 | +
- teal_slices,+ #' mods <- teal:::example_modules() |
|||
| 127 | -! | +|||
| 47 | +
- c(+ #' raw_data <- reactive(teal:::example_cdisc_data()) |
|||
| 128 | -! | +|||
| 48 | +
- unique(unlist(x, recursive = FALSE)),+ #' app <- shinyApp( |
|||
| 129 | -! | +|||
| 49 | +
- all_attributes+ #' ui = function() {
|
|||
| 130 | +50 |
- )+ #' teal:::ui_teal("dummy")
|
||
| 131 | +51 |
- )+ #' }, |
||
| 132 | +52 |
- }+ #' server = function(input, output, session) {
|
||
| 133 | +53 |
-
+ #' active_module <- teal:::srv_teal(id = "dummy", modules = mods, raw_data = raw_data) |
||
| 134 | +54 |
-
+ #' } |
||
| 135 | +55 |
- #' Deep copy `teal_slices`+ #' ) |
||
| 136 | +56 |
- #'+ #' if (interactive()) {
|
||
| 137 | +57 |
- #' it's important to create a new copy of `teal_slices` when+ #' runApp(app) |
||
| 138 | +58 |
- #' starting a new `shiny` session. Otherwise, object will be shared+ #' } |
||
| 139 | +59 |
- #' by multiple users as it is created in global environment before+ NULL |
||
| 140 | +60 |
- #' `shiny` session starts.+ |
||
| 141 | +61 |
- #' @param filter (`teal_slices`)+ #' @rdname module_teal |
||
| 142 | +62 |
- #' @return `teal_slices`+ ui_teal <- function(id, |
||
| 143 | +63 |
- #' @keywords internal+ splash_ui = tags$h2("Starting the Teal App"),
|
||
| 144 | +64 |
- deep_copy_filter <- function(filter) {
+ title = NULL, |
||
| 145 | -1x | +|||
| 65 | +
- checkmate::assert_class(filter, "teal_slices")+ header = tags$p(""),
|
|||
| 146 | -1x | +|||
| 66 | +
- shiny::isolate({
+ footer = tags$p("")) {
|
|||
| 147 | -1x | +67 | +32x |
- filter_copy <- lapply(filter, function(slice) {
+ if (checkmate::test_string(header)) {
|
| 148 | -2x | +|||
| 68 | +! |
- teal.slice::as.teal_slice(as.list(slice))+ header <- tags$h1(header) |
||
| 149 | +69 |
- })+ } |
||
| 150 | -1x | +70 | +32x |
- attributes(filter_copy) <- attributes(filter)+ if (checkmate::test_string(footer)) {
|
| 151 | -1x | +|||
| 71 | +! |
- filter_copy+ footer <- tags$p(footer) |
||
| 152 | +72 |
- })+ } |
||
| 153 | -+ | |||
| 73 | +32x |
- }+ checkmate::assert( |
| 1 | -+ | |||
| 74 | +32x |
- # This module is the main teal module that puts everything together.+ checkmate::check_class(splash_ui, "shiny.tag"), |
||
| 2 | -+ | |||
| 75 | +32x |
-
+ checkmate::check_class(splash_ui, "shiny.tag.list"), |
||
| 3 | -+ | |||
| 76 | +32x |
- #' teal main app module+ checkmate::check_class(splash_ui, "html") |
||
| 4 | +77 |
- #'+ ) |
||
| 5 | -+ | |||
| 78 | +32x |
- #' This is the main teal app that puts everything together.+ checkmate::assert( |
||
| 6 | -+ | |||
| 79 | +32x |
- #'+ checkmate::check_class(header, "shiny.tag"), |
||
| 7 | -+ | |||
| 80 | +32x |
- #' It displays the splash UI which is used to fetch the data, possibly+ checkmate::check_class(header, "shiny.tag.list"), |
||
| 8 | -+ | |||
| 81 | +32x |
- #' prompting for a password input to fetch the data. Once the data is ready,+ checkmate::check_class(header, "html") |
||
| 9 | +82 |
- #' the splash screen is replaced by the actual teal UI that is tabsetted and+ ) |
||
| 10 | -- |
- #' has a filter panel with `datanames` that are relevant for the current tab.+ | ||
| 83 | +32x | +
+ checkmate::assert( |
||
| 11 | -+ | |||
| 84 | +32x |
- #' Nested tabs are possible, but we limit it to two nesting levels for reasons+ checkmate::check_class(footer, "shiny.tag"), |
||
| 12 | -+ | |||
| 85 | +32x |
- #' of clarity of the UI.+ checkmate::check_class(footer, "shiny.tag.list"), |
||
| 13 | -+ | |||
| 86 | +32x |
- #'+ checkmate::check_class(footer, "html") |
||
| 14 | +87 |
- #' The splash screen functionality can also be used+ ) |
||
| 15 | +88 |
- #' for non-delayed data which takes time to load into memory, avoiding+ |
||
| 16 | -+ | |||
| 89 | +32x |
- #' Shiny session timeouts.+ ns <- NS(id) |
||
| 17 | +90 |
- #'+ # Once the data is loaded, we will remove this element and add the real teal UI instead |
||
| 18 | -+ | |||
| 91 | +32x |
- #' Server evaluates the `raw_data` (delayed data mechanism) and creates the+ splash_ui <- div( |
||
| 19 | +92 |
- #' `datasets` object that is shared across modules.+ # id so we can remove the splash screen once ready, which is the first child of this container |
||
| 20 | -+ | |||
| 93 | +32x |
- #' Once it is ready and non-`NULL`, the splash screen is replaced by the+ id = ns("main_ui_container"),
|
||
| 21 | +94 |
- #' main teal UI that depends on the data.+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not |
||
| 22 | +95 |
- #' The currently active tab is tracked and the right filter panel+ # just the first item of the tagList) |
||
| 23 | -+ | |||
| 96 | +32x |
- #' updates the displayed datasets to filter for according to the active `datanames`+ div(splash_ui) |
||
| 24 | +97 |
- #' of the tab.+ ) |
||
| 25 | +98 |
- #'+ |
||
| 26 | +99 |
- #' It is written as a Shiny module so it can be added into other apps as well.+ # show busy icon when shiny session is busy computing stuff |
||
| 27 | +100 |
- #'+ # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 #nolint |
||
| 28 | -+ | |||
| 101 | +32x |
- #' @name module_teal+ shiny_busy_message_panel <- conditionalPanel( |
||
| 29 | -+ | |||
| 102 | +32x |
- #'+ condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
|
||
| 30 | -+ | |||
| 103 | +32x |
- #' @inheritParams ui_teal_with_splash+ div( |
||
| 31 | -+ | |||
| 104 | +32x |
- #'+ icon("arrows-rotate", "spin fa-spin"),
|
||
| 32 | -+ | |||
| 105 | +32x |
- #' @param splash_ui (`shiny.tag`)\cr UI to display initially,+ "Computing ...", |
||
| 33 | +106 |
- #' can be a splash screen or a Shiny module UI. For the latter, see+ # CSS defined in `custom.css` |
||
| 34 | -+ | |||
| 107 | +32x |
- #' [init()] about how to call the corresponding server function.+ class = "shinybusymessage" |
||
| 35 | +108 |
- #'+ ) |
||
| 36 | +109 |
- #' @param raw_data (`reactive`)\cr+ ) |
||
| 37 | +110 |
- #' returns the `TealData`, only evaluated once, `NULL` value is ignored+ |
||
| 38 | -+ | |||
| 111 | +32x |
- #'+ res <- fluidPage( |
||
| 39 | -+ | |||
| 112 | +32x |
- #' @return+ title = title, |
||
| 40 | -+ | |||
| 113 | +32x |
- #' `ui_teal` returns `HTML` for Shiny module UI.+ theme = get_teal_bs_theme(), |
||
| 41 | -+ | |||
| 114 | +32x |
- #' `srv_teal` returns `reactive` which returns the currently active module.+ include_teal_css_js(), |
||
| 42 | -+ | |||
| 115 | +32x |
- #'+ tags$header(header), |
||
| 43 | -+ | |||
| 116 | +32x |
- #' @keywords internal+ tags$hr(class = "my-2"), |
||
| 44 | -+ | |||
| 117 | +32x |
- #'+ shiny_busy_message_panel, |
||
| 45 | -+ | |||
| 118 | +32x |
- #' @examples+ splash_ui, |
||
| 46 | -+ | |||
| 119 | +32x |
- #' mods <- teal:::example_modules()+ tags$hr(), |
||
| 47 | -+ | |||
| 120 | +32x |
- #' raw_data <- reactive(teal:::example_cdisc_data())+ tags$footer( |
||
| 48 | -+ | |||
| 121 | +32x |
- #' app <- shinyApp(+ div( |
||
| 49 | -+ | |||
| 122 | +32x |
- #' ui = function() {
+ footer, |
||
| 50 | -+ | |||
| 123 | +32x |
- #' teal:::ui_teal("dummy")
+ teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
|
||
| 51 | -+ | |||
| 124 | +32x |
- #' },+ textOutput(ns("identifier"))
|
||
| 52 | +125 |
- #' server = function(input, output, session) {
+ ) |
||
| 53 | +126 |
- #' active_module <- teal:::srv_teal(id = "dummy", modules = mods, raw_data = raw_data)+ ) |
||
| 54 | +127 |
- #' }+ ) |
||
| 55 | -+ | |||
| 128 | +32x |
- #' )+ return(res) |
||
| 56 | +129 |
- #' if (interactive()) {
+ } |
||
| 57 | +130 |
- #' runApp(app)+ |
||
| 58 | +131 |
- #' }+ |
||
| 59 | +132 |
- NULL+ #' @rdname module_teal |
||
| 60 | +133 |
-
+ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
|
||
| 61 | -+ | |||
| 134 | +9x |
- #' @rdname module_teal+ stopifnot(is.reactive(raw_data)) |
||
| 62 | -+ | |||
| 135 | +8x |
- ui_teal <- function(id,+ moduleServer(id, function(input, output, session) {
|
||
| 63 | -+ | |||
| 136 | +8x |
- splash_ui = tags$h2("Starting the Teal App"),
+ logger::log_trace("srv_teal initializing the module.")
|
||
| 64 | +137 |
- title = NULL,+ + |
+ ||
| 138 | +8x | +
+ output$identifier <- renderText(+ |
+ ||
| 139 | +8x | +
+ paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
|
||
| 65 | +140 |
- header = tags$p(""),
+ ) |
||
| 66 | +141 |
- footer = tags$p("")) {
+
|
||
| 67 | -32x | +142 | +8x |
- if (checkmate::test_string(header)) {
+ teal.widgets::verbatim_popup_srv( |
| 68 | -! | +|||
| 143 | +8x |
- header <- tags$h1(header)+ "sessionInfo", |
||
| 69 | -+ | |||
| 144 | +8x |
- }+ verbatim_content = utils::capture.output(utils::sessionInfo()), |
||
| 70 | -32x | +145 | +8x |
- if (checkmate::test_string(footer)) {
+ title = "SessionInfo" |
| 71 | -! | +|||
| 146 | +
- footer <- tags$p(footer)+ ) |
|||
| 72 | +147 |
- }+ |
||
| 73 | -32x | +|||
| 148 | +
- checkmate::assert(+ # `JavaScript` code |
|||
| 74 | -32x | +149 | +8x |
- checkmate::check_class(splash_ui, "shiny.tag"),+ run_js_files(files = "init.js") # `JavaScript` code to make the clipboard accessible |
| 75 | -32x | +|||
| 150 | +
- checkmate::check_class(splash_ui, "shiny.tag.list"),+ # set timezone in shiny app |
|||
| 76 | -32x | +|||
| 151 | +
- checkmate::check_class(splash_ui, "html")+ # timezone is set in the early beginning so it will be available also |
|||
| 77 | +152 |
- )+ # for `DDL` and all shiny modules |
||
| 78 | -32x | +153 | +8x |
- checkmate::assert(+ get_client_timezone(session$ns) |
| 79 | -32x | +154 | +8x |
- checkmate::check_class(header, "shiny.tag"),+ observeEvent( |
| 80 | -32x | +155 | +8x |
- checkmate::check_class(header, "shiny.tag.list"),+ eventExpr = input$timezone, |
| 81 | -32x | -
- checkmate::check_class(header, "html")- |
- ||
| 82 | -+ | 156 | +8x |
- )+ once = TRUE, |
| 83 | -32x | +157 | +8x |
- checkmate::assert(+ handlerExpr = {
|
| 84 | -32x | +|||
| 158 | +! |
- checkmate::check_class(footer, "shiny.tag"),+ session$userData$timezone <- input$timezone |
||
| 85 | -32x | +|||
| 159 | +! |
- checkmate::check_class(footer, "shiny.tag.list"),+ logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
|
||
| 86 | -32x | +|||
| 160 | +
- checkmate::check_class(footer, "html")+ } |
|||
| 87 | +161 |
- )+ ) |
||
| 88 | +162 | |||
| 89 | -32x | -
- ns <- NS(id)- |
- ||
| 90 | +163 |
- # Once the data is loaded, we will remove this element and add the real teal UI instead+ # loading the data ----- |
||
| 91 | -32x | +164 | +8x |
- splash_ui <- div(+ env <- environment() |
| 92 | -+ | |||
| 165 | +8x |
- # id so we can remove the splash screen once ready, which is the first child of this container+ datasets_reactive <- reactive({
|
||
| 93 | -32x | +166 | +6x |
- id = ns("main_ui_container"),
+ if (is.null(raw_data())) {
|
| 94 | -+ | |||
| 167 | +1x |
- # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ return(NULL) |
||
| 95 | +168 |
- # just the first item of the tagList)+ } |
||
| 96 | -32x | +169 | +5x |
- div(splash_ui)+ env$progress <- shiny::Progress$new(session) |
| 97 | -+ | |||
| 170 | +5x |
- )+ env$progress$set(0.25, message = "Setting data") |
||
| 98 | +171 | |||
| 99 | +172 |
- # show busy icon when shiny session is busy computing stuff+ # create a list of data following structure of the nested modules list structure. |
||
| 100 | +173 |
- # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 #nolint+ # Because it's easier to unpack modules and datasets when they follow the same nested structure. |
||
| 101 | -32x | +174 | +5x |
- shiny_busy_message_panel <- conditionalPanel(+ datasets_singleton <- teal.slice::init_filtered_data(raw_data()) |
| 102 | -32x | +|||
| 175 | +
- condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
+ # Singleton starts with only global filters active. |
|||
| 103 | -32x | +176 | +5x |
- div(+ filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter) |
| 104 | -32x | +177 | +5x |
- icon("arrows-rotate", "spin fa-spin"),
+ datasets_singleton$set_filter_state(filter_global) |
| 105 | -32x | -
- "Computing ...",- |
- ||
| 106 | -+ | 178 | +5x |
- # CSS defined in `custom.css`+ module_datasets <- function(modules) {
|
| 107 | -32x | -
- class = "shinybusymessage"- |
- ||
| 108 | -- |
- )- |
- ||
| 109 | -+ | 179 | +19x |
- )+ if (inherits(modules, "teal_modules")) {
|
| 110 | -+ | |||
| 180 | +8x |
-
+ datasets <- lapply(modules$children, module_datasets) |
||
| 111 | -32x | +181 | +8x |
- res <- fluidPage(+ labels <- vapply(modules$children, `[[`, character(1), "label") |
| 112 | -32x | +182 | +8x |
- title = title,+ names(datasets) <- labels |
| 113 | -32x | +183 | +8x |
- theme = get_teal_bs_theme(),+ datasets |
| 114 | -32x | +184 | +11x |
- include_teal_css_js(),+ } else if (isTRUE(attr(filter, "module_specific"))) {
|
| 115 | -32x | +|||
| 185 | +
- tags$header(header),+ # we should create FilteredData even if modules$datanames is null |
|||
| 116 | -32x | +|||
| 186 | +
- tags$hr(class = "my-2"),+ # null controls a display of filter panel but data should be still passed |
|||
| 117 | -32x | +187 | +3x |
- shiny_busy_message_panel,+ datanames <- if (is.null(modules$datanames)) raw_data()$get_datanames() else modules$datanames |
| 118 | -32x | +188 | +3x |
- splash_ui,+ data_objects <- sapply( |
| 119 | -32x | +189 | +3x |
- tags$hr(),+ datanames, |
| 120 | -32x | +190 | +3x |
- tags$footer(+ function(dataname) {
|
| 121 | -32x | +191 | +6x |
- div(+ dataset <- raw_data()$get_dataset(dataname) |
| 122 | -32x | +192 | +6x |
- footer,+ list( |
| 123 | -32x | +193 | +6x |
- teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
+ dataset = dataset$get_raw_data(), |
| 124 | -32x | +194 | +6x |
- textOutput(ns("identifier"))
+ metadata = dataset$get_metadata(), |
| 125 | -+ | |||
| 195 | +6x |
- )+ label = dataset$get_dataset_label() |
||
| 126 | +196 |
- )+ ) |
||
| 127 | +197 |
- )+ }, |
||
| 128 | -32x | +198 | +3x |
- return(res)+ simplify = FALSE |
| 129 | +199 |
- }+ ) |
||
| 130 | -+ | |||
| 200 | +3x |
-
+ datasets_module <- teal.slice::init_filtered_data( |
||
| 131 | -- | - - | -||
| 132 | -+ | |||
| 201 | +3x |
- #' @rdname module_teal+ data_objects, |
||
| 133 | -+ | |||
| 202 | +3x |
- srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
+ join_keys = raw_data()$get_join_keys(), |
||
| 134 | -9x | +203 | +3x |
- stopifnot(is.reactive(raw_data))+ code = raw_data()$get_code_class(), |
| 135 | -8x | +204 | +3x |
- moduleServer(id, function(input, output, session) {
+ check = raw_data()$get_check() |
| 136 | -8x | +|||
| 205 | +
- logger::log_trace("srv_teal initializing the module.")
+ ) |
|||
| 137 | +206 | |||
| 138 | -8x | +|||
| 207 | +
- output$identifier <- renderText(+ # set initial filters |
|||
| 139 | -8x | +208 | +3x |
- paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
+ slices <- Filter(x = filter, f = function(x) {
|
| 140 | -+ | |||
| 209 | +! |
- )+ x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&+ |
+ ||
| 210 | +! | +
+ x$dataname %in% datanames |
||
| 141 | +211 |
-
+ }) |
||
| 142 | -8x | +212 | +3x |
- teal.widgets::verbatim_popup_srv(+ include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames] |
| 143 | -8x | +213 | +3x |
- "sessionInfo",+ exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames] |
| 144 | -8x | +214 | +3x |
- verbatim_content = utils::capture.output(utils::sessionInfo()),+ slices$include_varnames <- include_varnames |
| 145 | -8x | +215 | +3x |
- title = "SessionInfo"+ slices$exclude_varnames <- exclude_varnames |
| 146 | -+ | |||
| 216 | +3x |
- )+ datasets_module$set_filter_state(slices) |
||
| 147 | -+ | |||
| 217 | +3x |
-
+ datasets_module |
||
| 148 | +218 |
- # `JavaScript` code+ } else {
|
||
| 149 | +219 | 8x |
- run_js_files(files = "init.js") # `JavaScript` code to make the clipboard accessible+ datasets_singleton |
|
| 150 | +220 |
- # set timezone in shiny app+ } |
||
| 151 | +221 |
- # timezone is set in the early beginning so it will be available also+ }+ |
+ ||
| 222 | +5x | +
+ datasets <- module_datasets(modules) |
||
| 152 | +223 |
- # for `DDL` and all shiny modules+ |
||
| 153 | -8x | +224 | +5x |
- get_client_timezone(session$ns)+ logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
|
| 154 | -8x | +225 | +5x |
- observeEvent(+ datasets |
| 155 | -8x | +|||
| 226 | +
- eventExpr = input$timezone,+ })+ |
+ |||
| 227 | ++ | + | ||
| 156 | +228 | 8x |
- once = TRUE,+ reporter <- teal.reporter::Reporter$new() |
|
| 157 | +229 | 8x |
- handlerExpr = {
+ is_any_previewer <- function(modules) {
|
|
| 158 | +230 | ! |
- session$userData$timezone <- input$timezone+ if (inherits(modules, "teal_modules")) {
|
|
| 159 | +231 | ! |
- logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
+ any(unlist(lapply(modules$children, is_any_previewer), use.names = FALSE)) |
|
| 160 | -+ | |||
| 232 | +! |
- }+ } else if (inherits(modules, "teal_module_previewer")) {
|
||
| 161 | -+ | |||
| 233 | +! |
- )+ TRUE |
||
| 162 | +234 |
-
+ } else {
+ |
+ ||
| 235 | +! | +
+ FALSE |
||
| 163 | +236 |
- # loading the data -----+ } |
||
| 164 | -8x | +|||
| 237 | +
- env <- environment()+ } |
|||
| 165 | +238 | 8x |
- datasets_reactive <- reactive({
+ if (is_arg_used(modules, "reporter") && !is_any_previewer(modules)) {
|
|
| 166 | -6x | +|||
| 239 | +! |
- if (is.null(raw_data())) {
+ modules <- append_module(modules, reporter_previewer_module()) |
||
| 167 | -1x | +|||
| 240 | +
- return(NULL)+ } |
|||
| 168 | +241 |
- }+ |
||
| 169 | -5x | +|||
| 242 | +
- env$progress <- shiny::Progress$new(session)+ # Replace splash / welcome screen once data is loaded ---- |
|||
| 170 | -5x | +|||
| 243 | +
- env$progress$set(0.25, message = "Setting data")+ # ignoreNULL to not trigger at the beginning when data is NULL |
|||
| 171 | +244 |
-
+ # just handle it once because data obtained through delayed loading should |
||
| 172 | +245 |
- # create a list of data following structure of the nested modules list structure.+ # usually not change afterwards |
||
| 173 | +246 |
- # Because it's easier to unpack modules and datasets when they follow the same nested structure.+ # if restored from bookmarked state, `filter` is ignored |
||
| 174 | -5x | -
- datasets_singleton <- teal.slice::init_filtered_data(raw_data())- |
- ||
| 175 | -+ | 247 | +8x |
- # Singleton starts with only global filters active.+ observeEvent(datasets_reactive(), ignoreNULL = TRUE, once = TRUE, {
|
| 176 | -5x | +248 | +1x |
- filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)+ logger::log_trace("srv_teal@5 setting main ui after data was pulled")
|
| 177 | -5x | +249 | +1x |
- datasets_singleton$set_filter_state(filter_global)+ env$progress$set(0.5, message = "Setting up main UI") |
| 178 | -5x | +250 | +1x |
- module_datasets <- function(modules) {
+ on.exit(env$progress$close()) |
| 179 | -19x | +|||
| 251 | +
- if (inherits(modules, "teal_modules")) {
+ # main_ui_container contains splash screen first and we remove it and replace it by the real UI |
|||
| 180 | -8x | +|||
| 252 | +
- datasets <- lapply(modules$children, module_datasets)+ |
|||
| 181 | -8x | +253 | +1x |
- labels <- vapply(modules$children, `[[`, character(1), "label")+ removeUI(sprintf("#%s:first-child", session$ns("main_ui_container")))
|
| 182 | -8x | +254 | +1x |
- names(datasets) <- labels+ insertUI( |
| 183 | -8x | +255 | +1x |
- datasets+ selector = paste0("#", session$ns("main_ui_container")),
|
| 184 | -11x | +256 | +1x |
- } else if (isTRUE(attr(filter, "module_specific"))) {
+ where = "beforeEnd", |
| 185 | +257 |
- # we should create FilteredData even if modules$datanames is null+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not |
||
| 186 | +258 |
- # null controls a display of filter panel but data should be still passed+ # just the first item of the tagList) |
||
| 187 | -3x | +259 | +1x |
- datanames <- if (is.null(modules$datanames)) raw_data()$get_datanames() else modules$datanames+ ui = div(ui_tabs_with_filters( |
| 188 | -3x | +260 | +1x |
- data_objects <- sapply(+ session$ns("main_ui"),
|
| 189 | -3x | +261 | +1x |
- datanames,+ modules = modules, |
| 190 | -3x | +262 | +1x |
- function(dataname) {
+ datasets = datasets_reactive(), |
| 191 | -6x | +263 | +1x |
- dataset <- raw_data()$get_dataset(dataname)+ filter = filter |
| 192 | -6x | +|||
| 264 | +
- list(+ )), |
|||
| 193 | -6x | +|||
| 265 | +
- dataset = dataset$get_raw_data(),+ # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not |
|||
| 194 | -6x | +|||
| 266 | +
- metadata = dataset$get_metadata(),+ # have any effect as they are ignored when not present |
|||
| 195 | -6x | +267 | +1x |
- label = dataset$get_dataset_label()+ immediate = TRUE |
| 196 | +268 |
- )+ ) |
||
| 197 | +269 |
- },+ |
||
| 198 | -3x | +|||
| 270 | +
- simplify = FALSE+ # must make sure that this is only executed once as modules assume their observers are only |
|||
| 199 | +271 |
- )+ # registered once (calling server functions twice would trigger observers twice each time) |
||
| 200 | -3x | +272 | +1x |
- datasets_module <- teal.slice::init_filtered_data(+ active_module <- srv_tabs_with_filters( |
| 201 | -3x | +273 | +1x |
- data_objects,+ id = "main_ui", |
| 202 | -3x | +274 | +1x |
- join_keys = raw_data()$get_join_keys(),+ datasets = datasets_reactive(), |
| 203 | -3x | +275 | +1x |
- code = raw_data()$get_code_class(),+ modules = modules, |
| 204 | -3x | -
- check = raw_data()$get_check()- |
- ||
| 205 | -+ | 276 | +1x |
- )+ reporter = reporter, |
| 206 | -+ | |||
| 277 | +1x |
-
+ filter = filter |
||
| 207 | +278 |
- # set initial filters+ ) |
||
| 208 | -3x | +279 | +1x |
- slices <- Filter(x = filter, f = function(x) {
+ return(active_module) |
| 209 | -! | +|||
| 280 | +
- x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&+ }) |
|||
| 210 | -! | +|||
| 281 | +
- x$dataname %in% datanames+ }) |
|||
| 211 | +282 |
- })+ } |
||
| 212 | -3x | +
| 1 | +
- include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]+ #' Validate that dataset has a minimum number of observations |
|||
| 213 | -3x | +|||
| 2 | +
- exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]+ #' |
|||
| 214 | -3x | +|||
| 3 | +
- slices$include_varnames <- include_varnames+ #' @description `r lifecycle::badge("stable")`
|
|||
| 215 | -3x | +|||
| 4 | +
- slices$exclude_varnames <- exclude_varnames+ #' @param x a data.frame |
|||
| 216 | -3x | +|||
| 5 | +
- datasets_module$set_filter_state(slices)+ #' @param min_nrow minimum number of rows in \code{x}
|
|||
| 217 | -3x | +|||
| 6 | +
- datasets_module+ #' @param complete \code{logical} default \code{FALSE} when set to \code{TRUE} then complete cases are checked.
|
|||
| 218 | +7 |
- } else {
+ #' @param allow_inf \code{logical} default \code{TRUE} when set to \code{FALSE} then error thrown if any values are
|
||
| 219 | -8x | +|||
| 8 | +
- datasets_singleton+ #' infinite. |
|||
| 220 | +9 |
- }+ #' @param msg (`character(1)`) additional message to display alongside the default message. |
||
| 221 | +10 |
- }+ #' |
||
| 222 | -5x | +|||
| 11 | +
- datasets <- module_datasets(modules)+ #' @details This function is a wrapper for `shiny::validate`. |
|||
| 223 | +12 |
-
+ #' |
||
| 224 | -5x | +|||
| 13 | +
- logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
+ #' @export |
|||
| 225 | -5x | +|||
| 14 | +
- datasets+ #' |
|||
| 226 | +15 |
- })+ #' @examples |
||
| 227 | +16 |
-
+ #' library(teal) |
||
| 228 | -8x | +|||
| 17 | +
- reporter <- teal.reporter::Reporter$new()+ #' ui <- fluidPage( |
|||
| 229 | -8x | +|||
| 18 | +
- is_any_previewer <- function(modules) {
+ #' sliderInput("len", "Max Length of Sepal",
|
|||
| 230 | -! | +|||
| 19 | +
- if (inherits(modules, "teal_modules")) {
+ #' min = 4.3, max = 7.9, value = 5 |
|||
| 231 | -! | +|||
| 20 | +
- any(unlist(lapply(modules$children, is_any_previewer), use.names = FALSE))+ #' ), |
|||
| 232 | -! | +|||
| 21 | +
- } else if (inherits(modules, "teal_module_previewer")) {
+ #' plotOutput("plot")
|
|||
| 233 | -! | +|||
| 22 | +
- TRUE+ #' ) |
|||
| 234 | +23 |
- } else {
+ #' |
||
| 235 | -! | +|||
| 24 | +
- FALSE+ #' server <- function(input, output) {
|
|||
| 236 | +25 |
- }+ #' output$plot <- renderPlot({
|
||
| 237 | +26 |
- }+ #' df <- iris[iris$Sepal.Length <= input$len, ] |
||
| 238 | -8x | +|||
| 27 | +
- if (is_arg_used(modules, "reporter") && !is_any_previewer(modules)) {
+ #' validate_has_data( |
|||
| 239 | -! | +|||
| 28 | +
- modules <- append_module(modules, reporter_previewer_module())+ #' iris_f, |
|||
| 240 | +29 |
- }+ #' min_nrow = 10, |
||
| 241 | +30 |
-
+ #' complete = FALSE, |
||
| 242 | +31 |
- # Replace splash / welcome screen once data is loaded ----+ #' msg = "Please adjust Max Length of Sepal" |
||
| 243 | +32 |
- # ignoreNULL to not trigger at the beginning when data is NULL+ #' ) |
||
| 244 | +33 |
- # just handle it once because data obtained through delayed loading should+ #' |
||
| 245 | +34 |
- # usually not change afterwards+ #' hist(iris_f$Sepal.Length, breaks = 5) |
||
| 246 | +35 |
- # if restored from bookmarked state, `filter` is ignored+ #' }) |
||
| 247 | -8x | +|||
| 36 | +
- observeEvent(datasets_reactive(), ignoreNULL = TRUE, once = TRUE, {
+ #' } |
|||
| 248 | -1x | +|||
| 37 | +
- logger::log_trace("srv_teal@5 setting main ui after data was pulled")
+ #' if (interactive()) {
|
|||
| 249 | -1x | +|||
| 38 | +
- env$progress$set(0.5, message = "Setting up main UI")+ #' shinyApp(ui, server) |
|||
| 250 | -1x | +|||
| 39 | +
- on.exit(env$progress$close())+ #' } |
|||
| 251 | +40 |
- # main_ui_container contains splash screen first and we remove it and replace it by the real UI+ #' |
||
| 252 | +41 |
-
+ validate_has_data <- function(x, |
||
| 253 | -1x | +|||
| 42 | +
- removeUI(sprintf("#%s:first-child", session$ns("main_ui_container")))
+ min_nrow = NULL, |
|||
| 254 | -1x | +|||
| 43 | +
- insertUI(+ complete = FALSE,+ |
+ |||
| 44 | ++ |
+ allow_inf = TRUE,+ |
+ ||
| 45 | ++ |
+ msg = NULL) {
|
||
| 255 | -1x | +46 | +17x |
- selector = paste0("#", session$ns("main_ui_container")),
+ stopifnot( |
| 256 | -1x | +47 | +17x |
- where = "beforeEnd",+ "Please provide a character vector in msg argument of validate_has_data." = is.character(msg) || is.null(msg) |
| 257 | +48 |
- # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ ) |
||
| 258 | -+ | |||
| 49 | +15x |
- # just the first item of the tagList)+ validate(need(!is.null(x) && is.data.frame(x), "No data left.")) |
||
| 259 | -1x | +50 | +15x |
- ui = div(ui_tabs_with_filters(+ if (!is.null(min_nrow)) {
|
| 260 | -1x | +51 | +15x |
- session$ns("main_ui"),
+ if (complete) {
|
| 261 | -1x | +52 | +5x |
- modules = modules,+ complete_index <- stats::complete.cases(x) |
| 262 | -1x | +53 | +5x |
- datasets = datasets_reactive(),+ validate(need( |
| 263 | -1x | +54 | +5x |
- filter = filter+ sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow, |
| 264 | -+ | |||
| 55 | +5x |
- )),+ paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
|
||
| 265 | +56 |
- # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not+ )) |
||
| 266 | +57 |
- # have any effect as they are ignored when not present+ } else {
|
||
| 267 | -1x | +58 | +10x |
- immediate = TRUE+ validate(need( |
| 268 | -+ | |||
| 59 | +10x |
- )+ nrow(x) >= min_nrow, |
||
| 269 | -+ | |||
| 60 | +10x |
-
+ paste(+ |
+ ||
| 61 | +10x | +
+ c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
+ |
+ ||
| 62 | +10x | +
+ collapse = "\n" |
||
| 270 | +63 |
- # must make sure that this is only executed once as modules assume their observers are only+ ) |
||
| 271 | +64 |
- # registered once (calling server functions twice would trigger observers twice each time)+ )) |
||
| 272 | -1x | +|||
| 65 | +
- active_module <- srv_tabs_with_filters(+ } |
|||
| 273 | -1x | +|||
| 66 | +
- id = "main_ui",+ |
|||
| 274 | -1x | +67 | +10x |
- datasets = datasets_reactive(),+ if (!allow_inf) {
|
| 275 | -1x | +68 | +6x |
- modules = modules,+ validate(need( |
| 276 | -1x | +69 | +6x |
- reporter = reporter,+ all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))), |
| 277 | -1x | +70 | +6x |
- filter = filter+ "Dataframe contains Inf values which is not allowed." |
| 278 | +71 |
- )+ )) |
||
| 279 | -1x | +|||
| 72 | +
- return(active_module)+ } |
|||
| 280 | +73 |
- })+ } |
||
| 281 | +74 |
- })+ } |
||
| 282 | +75 |
- }+ |
| 1 | +76 |
- #' Create a `tdata` Object+ #' Validate that dataset has unique rows for key variables |
|
| 2 | +77 |
#' |
|
| 3 | +78 |
- #' Create a new object called `tdata` which contains `data`, a `reactive` list of data.frames+ #' @description `r lifecycle::badge("stable")`
|
|
| 4 | +79 |
- #' (or `MultiAssayExperiment`), with attributes:+ #' @param x a data.frame |
|
| 5 | +80 |
- #' \itemize{
+ #' @param key a vector of ID variables from \code{x} that identify unique records
|
|
| 6 | +81 |
- #' \item{`code` (`reactive`) containing code used to generate the data}
+ #' |
|
| 7 | +82 |
- #' \item{join_keys (`JoinKeys`) containing the relationships between the data}
+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 8 | +83 |
- #' \item{metadata (`named list`) containing any metadata associated with the data frames}
+ #' |
|
| 9 | +84 |
- #' }+ #' @export |
|
| 10 | +85 |
- #' @name tdata+ #' |
|
| 11 | +86 |
- #' @param data A `named list` of `data.frames` (or `MultiAssayExperiment`)+ #' @examples |
|
| 12 | +87 |
- #' which optionally can be `reactive`.+ #' iris$id <- rep(1:50, times = 3) |
|
| 13 | +88 |
- #' Inside this object all of these items will be made `reactive`.+ #' ui <- fluidPage( |
|
| 14 | +89 |
- #' @param code A `character` (or `reactive` which evaluates to a `character`) containing+ #' selectInput( |
|
| 15 | +90 |
- #' the code used to generate the data. This should be `reactive` if the code is changing+ #' inputId = "species", |
|
| 16 | +91 |
- #' during a reactive context (e.g. if filtering changes the code). Inside this+ #' label = "Select species", |
|
| 17 | +92 |
- #' object `code` will be made reactive+ #' choices = c("setosa", "versicolor", "virginica"),
|
|
| 18 | +93 |
- #' @param join_keys A `teal.data::JoinKeys` object containing relationships between the+ #' selected = "setosa", |
|
| 19 | +94 |
- #' datasets.+ #' multiple = TRUE |
|
| 20 | +95 |
- #' @param metadata A `named list` each element contains a list of metadata about the named data.frame+ #' ), |
|
| 21 | +96 |
- #' Each element of these list should be atomic and length one.+ #' plotOutput("plot")
|
|
| 22 | +97 |
- #' @return A `tdata` object+ #' ) |
|
| 23 | +98 |
- #' @examples+ #' server <- function(input, output) {
|
|
| 24 | +99 |
- #'+ #' output$plot <- renderPlot({
|
|
| 25 | +100 |
- #' data <- new_tdata(+ #' iris_f <- iris[iris$Species %in% input$species, ] |
|
| 26 | +101 |
- #' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),+ #' validate_one_row_per_id(iris_f, key = c("id"))
|
|
| 27 | +102 |
- #' code = "iris <- iris+ #' |
|
| 28 | +103 |
- #' mtcars <- mtcars+ #' hist(iris_f$Sepal.Length, breaks = 5) |
|
| 29 | +104 |
- #' dd <- data.frame(x = 1:10)",+ #' }) |
|
| 30 | +105 |
- #' metadata = list(dd = list(author = "NEST"), iris = list(version = 1))+ #' } |
|
| 31 | +106 |
- #' )+ #' if (interactive()) {
|
|
| 32 | +107 |
- #'+ #' shinyApp(ui, server) |
|
| 33 | +108 |
- #' # Extract a data.frame+ #' } |
|
| 34 | +109 |
- #' isolate(data[["iris"]]())+ #' |
|
| 35 | +110 |
- #'+ validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
|
|
| 36 | -+ | ||
| 111 | +! |
- #' # Get code+ validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
|
|
| 37 | +112 |
- #' isolate(get_code(data))+ } |
|
| 38 | +113 |
- #'+ |
|
| 39 | +114 |
- #' # Get metadata+ #' Validates that vector includes all expected values |
|
| 40 | +115 |
- #' get_metadata(data, "iris")+ #' |
|
| 41 | +116 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
|
| 42 | +117 |
- #' @export+ #' @param x values to test. All must be in \code{choices}
|
|
| 43 | +118 |
- new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
+ #' @param choices a vector to test for values of \code{x}
|
|
| 44 | -40x | +||
| 119 | +
- checkmate::assert_list(+ #' @param msg warning message to display |
||
| 45 | -40x | +||
| 120 | +
- data,+ #' |
||
| 46 | -40x | +||
| 121 | +
- any.missing = FALSE, names = "unique",+ #' @details This function is a wrapper for `shiny::validate`. |
||
| 47 | -40x | +||
| 122 | +
- types = c("data.frame", "reactive", "MultiAssayExperiment")
+ #' |
||
| 48 | +123 |
- )+ #' @export |
|
| 49 | -36x | +||
| 124 | +
- checkmate::assert_class(join_keys, "JoinKeys", null.ok = TRUE)+ #' |
||
| 50 | -35x | +||
| 125 | +
- checkmate::assert_multi_class(code, c("character", "reactive"))
+ #' @examples |
||
| 51 | +126 |
-
+ #' ui <- fluidPage( |
|
| 52 | -34x | +||
| 127 | +
- checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)+ #' selectInput( |
||
| 53 | -32x | +||
| 128 | +
- checkmate::assert_subset(names(metadata), names(data))+ #' "species", |
||
| 54 | -20x | +||
| 129 | +
- for (m in metadata) teal.data::validate_metadata(m)+ #' "Select species", |
||
| 55 | +130 |
-
+ #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
|
|
| 56 | -31x | +||
| 131 | +
- if (is.reactive(code)) {
+ #' selected = "setosa", |
||
| 57 | -15x | +||
| 132 | +
- isolate(checkmate::assert_class(code(), "character", .var.name = "code"))+ #' multiple = FALSE |
||
| 58 | +133 |
- }+ #' ), |
|
| 59 | +134 |
-
+ #' verbatimTextOutput("summary")
|
|
| 60 | +135 |
- # create reactive data.frames+ #' ) |
|
| 61 | -30x | +||
| 136 | +
- for (x in names(data)) {
- |
- ||
| 62 | -49x | -
- if (!is.reactive(data[[x]])) {
- |
- |
| 63 | -29x | -
- data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))+ #' |
|
| 64 | +137 |
- } else {
- |
- |
| 65 | -20x | -
- isolate(+ #' server <- function(input, output) {
|
|
| 66 | -20x | +||
| 138 | +
- checkmate::assert_multi_class(+ #' output$summary <- renderPrint({
|
||
| 67 | -20x | +||
| 139 | +
- data[[x]](), c("data.frame", "MultiAssayExperiment"),
+ #' validate_in(input$species, iris$Species, "Species does not exist.") |
||
| 68 | -20x | +||
| 140 | +
- .var.name = "data"+ #' nrow(iris[iris$Species == input$species, ]) |
||
| 69 | +141 |
- )+ #' }) |
|
| 70 | +142 |
- )+ #' } |
|
| 71 | +143 |
- }+ #' if (interactive()) {
|
|
| 72 | +144 |
- }+ #' shinyApp(ui, server) |
|
| 73 | +145 |
-
+ #' } |
|
| 74 | +146 |
- # set attributes+ #' |
|
| 75 | -29x | +||
| 147 | +
- attr(data, "code") <- if (is.reactive(code)) code else reactive(code)+ validate_in <- function(x, choices, msg) {
|
||
| 76 | -29x | +||
| 148 | +! |
- attr(data, "join_keys") <- join_keys+ validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg)) |
|
| 77 | -29x | +||
| 149 | +
- attr(data, "metadata") <- metadata+ } |
||
| 78 | +150 | ||
| 79 | +151 |
- # set class- |
- |
| 80 | -29x | -
- class(data) <- c("tdata", class(data))
+ #' Validates that vector has length greater than 0 |
|
| 81 | -29x | +||
| 152 | +
- data+ #' |
||
| 82 | +153 |
- }+ #' @description `r lifecycle::badge("stable")`
|
|
| 83 | +154 |
-
+ #' @param x vector |
|
| 84 | +155 |
- #' Function to convert a `tdata` object to an `environment`+ #' @param msg message to display |
|
| 85 | +156 |
- #' Any `reactives` inside `tdata` are first evaluated+ #' |
|
| 86 | +157 |
- #' @param data a `tdata` object+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 87 | +158 |
- #' @return an `environment`+ #' |
|
| 88 | +159 |
- #' @examples+ #' @export |
|
| 89 | +160 |
#' |
|
| 90 | +161 |
- #' data <- new_tdata(+ #' @examples |
|
| 91 | +162 |
- #' data = list(iris = iris, mtcars = reactive(mtcars)),+ #' data <- data.frame( |
|
| 92 | +163 |
- #' code = "iris <- iris+ #' id = c(1:10, 11:20, 1:10), |
|
| 93 | +164 |
- #' mtcars = mtcars"+ #' strata = rep(c("A", "B"), each = 15)
|
|
| 94 | +165 |
#' ) |
|
| 95 | +166 |
- #'+ #' ui <- fluidPage( |
|
| 96 | +167 |
- #' my_env <- isolate(tdata2env(data))+ #' selectInput("ref1", "Select strata1 to compare",
|
|
| 97 | +168 |
- #'+ #' choices = c("A", "B", "C"), selected = "A"
|
|
| 98 | +169 |
- #' @export+ #' ), |
|
| 99 | +170 |
- tdata2env <- function(data) { # nolint
- |
- |
| 100 | -2x | -
- checkmate::assert_class(data, "tdata")+ #' selectInput("ref2", "Select strata2 to compare",
|
|
| 101 | -1x | +||
| 171 | +
- list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))+ #' choices = c("A", "B", "C"), selected = "B"
|
||
| 102 | +172 |
- }+ #' ), |
|
| 103 | +173 |
-
+ #' verbatimTextOutput("arm_summary")
|
|
| 104 | +174 |
- #' @rdname tdata+ #' ) |
|
| 105 | +175 |
- #' @param x a `tdata` object+ #' |
|
| 106 | +176 |
- #' @param ... additional arguments for the generic+ #' server <- function(input, output) {
|
|
| 107 | +177 |
- #' @export+ #' output$arm_summary <- renderText({
|
|
| 108 | +178 |
- get_code.tdata <- function(x, ...) { # nolint
+ #' sample_1 <- data$id[data$strata == input$ref1] |
|
| 109 | +179 |
- # note teal.data which teal depends on defines the get_code method+ #' sample_2 <- data$id[data$strata == input$ref2] |
|
| 110 | -6x | +||
| 180 | +
- attr(x, "code")()+ #' |
||
| 111 | +181 |
- }+ #' validate_has_elements(sample_1, "No subjects in strata1.") |
|
| 112 | +182 |
-
+ #' validate_has_elements(sample_2, "No subjects in strata2.") |
|
| 113 | +183 |
-
+ #' |
|
| 114 | +184 |
- #' Wrapper for `get_code.tdata`+ #' paste0( |
|
| 115 | +185 |
- #' This wrapper is to be used by downstream packages to extract the code of a `tdata` object+ #' "Number of samples in: strata1=", length(sample_1), |
|
| 116 | +186 |
- #'+ #' " comparions strata2=", length(sample_2) |
|
| 117 | +187 |
- #' @param data (`tdata`) object+ #' ) |
|
| 118 | +188 |
- #'+ #' }) |
|
| 119 | +189 |
- #' @return (`character`) code used in the `tdata` object.+ #' } |
|
| 120 | +190 |
- #' @export+ #' if (interactive()) {
|
|
| 121 | +191 |
- get_code_tdata <- function(data) {
+ #' shinyApp(ui, server) |
|
| 122 | -4x | +||
| 192 | +
- checkmate::assert_class(data, "tdata")+ #' } |
||
| 123 | -2x | +||
| 193 | +
- get_code(data)+ validate_has_elements <- function(x, msg) {
|
||
| 124 | -+ | ||
| 194 | +! |
- }+ validate(need(length(x) > 0, msg)) |
|
| 125 | +195 |
-
+ } |
|
| 126 | +196 | ||
| 127 | +197 |
- #' Function to get join keys from a `tdata` object+ #' Validates no intersection between two vectors |
|
| 128 | +198 |
- #' @param data `tdata` - object to extract the join keys+ #' |
|
| 129 | +199 |
- #' @return Either `JoinKeys` object or `NULL` if no join keys+ #' @description `r lifecycle::badge("stable")`
|
|
| 130 | +200 |
- #' @export+ #' @param x vector |
|
| 131 | +201 |
- get_join_keys <- function(data) {
- |
- |
| 132 | -3x | -
- UseMethod("get_join_keys", data)
+ #' @param y vector |
|
| 133 | +202 |
- }+ #' @param msg message to display if \code{x} and \code{y} intersect
|
|
| 134 | +203 |
-
+ #' |
|
| 135 | +204 |
-
+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 136 | +205 |
- #' @rdname get_join_keys+ #' |
|
| 137 | +206 |
#' @export |
|
| 138 | +207 |
- get_join_keys.tdata <- function(data) {
+ #' |
|
| 139 | -3x | +||
| 208 | +
- attr(data, "join_keys")+ #' @examples |
||
| 140 | +209 |
- }+ #' data <- data.frame( |
|
| 141 | +210 |
-
+ #' id = c(1:10, 11:20, 1:10), |
|
| 142 | +211 |
-
+ #' strata = rep(c("A", "B", "C"), each = 10)
|
|
| 143 | +212 |
- #' @rdname get_join_keys+ #' ) |
|
| 144 | +213 |
- #' @export+ #' |
|
| 145 | +214 |
- get_join_keys.default <- function(data) {
+ #' ui <- fluidPage( |
|
| 146 | -! | +||
| 215 | +
- stop("get_join_keys function not implemented for this object")
+ #' selectInput("ref1", "Select strata1 to compare",
|
||
| 147 | +216 |
- }+ #' choices = c("A", "B", "C"),
|
|
| 148 | +217 |
-
+ #' selected = "A" |
|
| 149 | +218 |
- #' Function to get metadata from a `tdata` object+ #' ), |
|
| 150 | +219 |
- #' @param data `tdata` - object to extract the data from+ #' selectInput("ref2", "Select strata2 to compare",
|
|
| 151 | +220 |
- #' @param dataname `character(1)` the dataset name whose metadata is requested+ #' choices = c("A", "B", "C"),
|
|
| 152 | +221 |
- #' @return Either list of metadata or NULL if no metadata+ #' selected = "B" |
|
| 153 | +222 |
- #' @export+ #' ), |
|
| 154 | +223 |
- get_metadata <- function(data, dataname) {
+ #' verbatimTextOutput("summary")
|
|
| 155 | -6x | +||
| 224 | +
- checkmate::assert_string(dataname)+ #' ) |
||
| 156 | -6x | +||
| 225 | +
- UseMethod("get_metadata", data)
+ #' |
||
| 157 | +226 |
- }+ #' server <- function(input, output) {
|
|
| 158 | +227 |
-
+ #' output$summary <- renderText({
|
|
| 159 | +228 |
- #' @rdname get_metadata+ #' sample_1 <- data$id[data$strata == input$ref1] |
|
| 160 | +229 |
- #' @export+ #' sample_2 <- data$id[data$strata == input$ref2] |
|
| 161 | +230 |
- get_metadata.tdata <- function(data, dataname) {
+ #' |
|
| 162 | -6x | +||
| 231 | +
- metadata <- attr(data, "metadata")+ #' validate_no_intersection( |
||
| 163 | -6x | +||
| 232 | +
- if (is.null(metadata)) {
+ #' sample_1, sample_2, |
||
| 164 | -1x | +||
| 233 | +
- return(NULL)+ #' "subjects within strata1 and strata2 cannot overlap" |
||
| 165 | +234 |
- }+ #' ) |
|
| 166 | -5x | +||
| 235 | +
- metadata[[dataname]]+ #' paste0( |
||
| 167 | +236 |
- }+ #' "Number of subject in: reference treatment=", length(sample_1), |
|
| 168 | +237 |
-
+ #' " comparions treatment=", length(sample_2) |
|
| 169 | +238 |
- #' @rdname get_metadata+ #' ) |
|
| 170 | +239 |
- #' @export+ #' }) |
|
| 171 | +240 |
- get_metadata.default <- function(data, dataname) {
+ #' } |
|
| 172 | -! | +||
| 241 | +
- stop("get_metadata function not implemented for this object")
+ #' if (interactive()) {
|
||
| 173 | +242 |
- }+ #' shinyApp(ui, server) |
| 1 | +243 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ #' } |
|
| 2 | +244 |
#' |
|
| 3 | +245 |
- #' `system.file` should not be used to access files in other packages, it does+ validate_no_intersection <- function(x, y, msg) {
|
|
| 4 | -+ | ||
| 246 | +! |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ validate(need(length(intersect(x, y)) == 0, msg)) |
|
| 5 | +247 |
- #' as needed. Thus, we do not export this method+ } |
|
| 6 | +248 |
- #'+ |
|
| 7 | +249 |
- #' @param pattern (`character`) pattern of files to be included+ |
|
| 8 | +250 |
- #'+ #' Validates that dataset contains specific variable |
|
| 9 | +251 |
- #' @return HTML code that includes `CSS` files+ #' |
|
| 10 | +252 |
- #' @keywords internal+ #' @description `r lifecycle::badge("stable")`
|
|
| 11 | +253 |
- include_css_files <- function(pattern = "*") {
- |
- |
| 12 | -32x | -
- css_files <- list.files(- |
- |
| 13 | -32x | -
- system.file("css", package = "teal", mustWork = TRUE),
- |
- |
| 14 | -32x | -
- pattern = pattern, full.names = TRUE+ #' @param data a data.frame |
|
| 15 | +254 |
- )+ #' @param varname name of variable in \code{data}
|
|
| 16 | -32x | +||
| 255 | +
- return(+ #' @param msg message to display if \code{data} does not include \code{varname}
|
||
| 17 | -32x | +||
| 256 | +
- shiny::singleton(+ #' |
||
| 18 | -32x | +||
| 257 | +
- shiny::tags$head(lapply(css_files, shiny::includeCSS))+ #' @details This function is a wrapper for `shiny::validate`. |
||
| 19 | +258 |
- )+ #' |
|
| 20 | +259 |
- )+ #' @export |
|
| 21 | +260 |
- }+ #' |
|
| 22 | +261 |
-
+ #' @examples |
|
| 23 | +262 |
- #' Include `JS` files from `/inst/js/` package directory to application header+ #' data <- data.frame( |
|
| 24 | +263 |
- #'+ #' one = rep("a", length.out = 20),
|
|
| 25 | +264 |
- #' `system.file` should not be used to access files in other packages, it does+ #' two = rep(c("a", "b"), length.out = 20)
|
|
| 26 | +265 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' ) |
|
| 27 | +266 |
- #' as needed. Thus, we do not export this method+ #' ui <- fluidPage( |
|
| 28 | +267 |
- #'+ #' selectInput( |
|
| 29 | +268 |
- #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ #' "var", |
|
| 30 | +269 |
- #' @param except (`character`) vector of basename filenames to be excluded+ #' "Select variable", |
|
| 31 | +270 |
- #'+ #' choices = c("one", "two", "three", "four"),
|
|
| 32 | +271 |
- #' @return HTML code that includes `JS` files+ #' selected = "one" |
|
| 33 | +272 |
- #' @keywords internal+ #' ), |
|
| 34 | +273 |
- include_js_files <- function(pattern = NULL, except = NULL) {
+ #' verbatimTextOutput("summary")
|
|
| 35 | -32x | +||
| 274 | +
- checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)+ #' ) |
||
| 36 | -32x | +||
| 275 | +
- js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
+ #' |
||
| 37 | -32x | +||
| 276 | +
- js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL+ #' server <- function(input, output) {
|
||
| 38 | +277 |
-
+ #' output$summary <- renderText({
|
|
| 39 | -32x | +||
| 278 | +
- return(singleton(lapply(js_files, includeScript)))+ #' validate_has_variable(data, input$var) |
||
| 40 | +279 |
- }+ #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
|
|
| 41 | +280 |
-
+ #' }) |
|
| 42 | +281 |
- #' Run `JS` file from `/inst/js/` package directory+ #' } |
|
| 43 | +282 |
- #'+ #' if (interactive()) {
|
|
| 44 | +283 |
- #' This is triggered from the server to execute on the client+ #' shinyApp(ui, server) |
|
| 45 | +284 |
- #' rather than triggered directly on the client.+ #' } |
|
| 46 | +285 |
- #' Unlike `include_js_files` which includes `JavaScript` functions,+ validate_has_variable <- function(data, varname, msg) {
|
|
| 47 | -+ | ||
| 286 | +! |
- #' the `run_js` actually executes `JavaScript` functions.+ if (length(varname) != 0) {
|
|
| 48 | -+ | ||
| 287 | +! |
- #'+ has_vars <- varname %in% names(data) |
|
| 49 | +288 |
- #' `system.file` should not be used to access files in other packages, it does+ |
|
| 50 | -+ | ||
| 289 | +! |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ if (!all(has_vars)) {
|
|
| 51 | -+ | ||
| 290 | +! |
- #' as needed. Thus, we do not export this method+ if (missing(msg)) {
|
|
| 52 | -+ | ||
| 291 | +! |
- #'+ msg <- sprintf( |
|
| 53 | -+ | ||
| 292 | +! |
- #' @param files (`character`) vector of filenames+ "%s does not have the required variables: %s.", |
|
| 54 | -+ | ||
| 293 | +! |
- #' @keywords internal+ deparse(substitute(data)), |
|
| 55 | -+ | ||
| 294 | +! |
- run_js_files <- function(files) {
+ toString(varname[!has_vars]) |
|
| 56 | -8x | +||
| 295 | +
- checkmate::assert_character(files, min.len = 1, any.missing = FALSE)+ ) |
||
| 57 | -8x | +||
| 296 | +
- lapply(files, function(file) {
+ } |
||
| 58 | -8x | +||
| 297 | +! |
- shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
+ validate(need(FALSE, msg)) |
|
| 59 | +298 |
- })+ } |
|
| 60 | -8x | +||
| 299 | +
- return(invisible(NULL))+ } |
||
| 61 | +300 |
} |
|
| 62 | +301 | ||
| 63 | +302 |
- #' Code to include teal `CSS` and `JavaScript` files+ #' Validate that variables has expected number of levels |
|
| 64 | +303 |
#' |
|
| 65 | +304 |
- #' This is useful when you want to use the same `JavaScript` and `CSS` files that are+ #' @description `r lifecycle::badge("stable")`
|
|
| 66 | +305 |
- #' used with the teal application.+ #' @param x variable name. If \code{x} is not a factor, the unique values
|
|
| 67 | +306 |
- #' This is also useful for running standalone modules in teal with the correct+ #' are treated as levels. |
|
| 68 | +307 |
- #' styles.+ #' @param min_levels cutoff for minimum number of levels of \code{x}
|
|
| 69 | +308 |
- #' Also initializes `shinyjs` so you can use it.+ #' @param max_levels cutoff for maximum number of levels of \code{x}
|
|
| 70 | +309 |
- #'+ #' @param var_name name of variable being validated for use in |
|
| 71 | +310 |
- #' @return HTML code to include+ #' validation message |
|
| 72 | +311 |
- #' @examples+ #' |
|
| 73 | +312 |
- #' shiny_ui <- tagList(+ #' @details If the number of levels of \code{x} is less than \code{min_levels}
|
|
| 74 | +313 |
- #' teal:::include_teal_css_js(),+ #' or greater than \code{max_levels} the validation will fail.
|
|
| 75 | +314 |
- #' p("Hello")
+ #' This function is a wrapper for `shiny::validate`. |
|
| 76 | +315 |
- #' )+ #' |
|
| 77 | +316 |
- #' @keywords internal+ #' @export |
|
| 78 | +317 |
- include_teal_css_js <- function() {
+ #' @examples |
|
| 79 | -32x | +||
| 318 | +
- tagList(+ #' data <- data.frame( |
||
| 80 | -32x | +||
| 319 | +
- shinyjs::useShinyjs(),+ #' one = rep("a", length.out = 20),
|
||
| 81 | -32x | +||
| 320 | +
- include_css_files(),+ #' two = rep(c("a", "b"), length.out = 20),
|
||
| 82 | +321 |
- # init.js is executed from the server+ #' three = rep(c("a", "b", "c"), length.out = 20),
|
|
| 83 | -32x | +||
| 322 | +
- include_js_files(except = "init.js"),+ #' four = rep(c("a", "b", "c", "d"), length.out = 20),
|
||
| 84 | -32x | +||
| 323 | +
- shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
+ #' stringsAsFactors = TRUE |
||
| 85 | +324 |
- )+ #' ) |
|
| 86 | +325 |
- }+ #' ui <- fluidPage( |
| 1 | +326 |
- # This file adds a splash screen for delayed data loading on top of teal+ #' selectInput( |
|
| 2 | +327 |
-
+ #' "var", |
|
| 3 | +328 |
- #' UI to show a splash screen in the beginning, then delegate to [srv_teal()]+ #' "Select variable", |
|
| 4 | +329 |
- #'+ #' choices = c("one", "two", "three", "four"),
|
|
| 5 | +330 |
- #' @description `r lifecycle::badge("stable")`
+ #' selected = "one" |
|
| 6 | +331 |
- #' The splash screen could be used to query for a password to fetch the data.+ #' ), |
|
| 7 | +332 |
- #' [init()] is a very thin wrapper around this module useful for end-users which+ #' verbatimTextOutput("summary")
|
|
| 8 | +333 |
- #' assumes that it is a top-level module and cannot be embedded.+ #' ) |
|
| 9 | +334 |
- #' This function instead adheres to the Shiny module conventions.+ #' |
|
| 10 | +335 |
- #'+ #' server <- function(input, output) {
|
|
| 11 | +336 |
- #' If data is obtained through delayed loading, its splash screen is used. Otherwise,+ #' output$summary <- renderText({
|
|
| 12 | +337 |
- #' a default splash screen is shown.+ #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var) |
|
| 13 | +338 |
- #'+ #' paste0( |
|
| 14 | +339 |
- #' Please also refer to the doc of [init()].+ #' "Levels of selected treatment variable: ", |
|
| 15 | +340 |
- #'+ #' paste(levels(data[[input$var]]), |
|
| 16 | +341 |
- #' @param id (`character(1)`)\cr+ #' collapse = ", " |
|
| 17 | +342 |
- #' module id+ #' ) |
|
| 18 | +343 |
- #' @inheritParams init+ #' ) |
|
| 19 | +344 |
- #' @export+ #' }) |
|
| 20 | +345 |
- ui_teal_with_splash <- function(id,+ #' } |
|
| 21 | +346 |
- data,+ #' if (interactive()) {
|
|
| 22 | +347 |
- title,+ #' shinyApp(ui, server) |
|
| 23 | +348 |
- header = tags$p("Add Title Here"),
+ #' } |
|
| 24 | +349 |
- footer = tags$p("Add Footer Here")) {
- |
- |
| 25 | -32x | -
- checkmate::assert_class(data, "TealDataAbstract")- |
- |
| 26 | -32x | -
- is_pulled_data <- teal.data::is_pulled(data)+ validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
|
|
| 27 | -32x | +||
| 350 | +! |
- ns <- NS(id)+ x_levels <- if (is.factor(x)) {
|
|
| 28 | -+ | ||
| 351 | +! |
-
+ levels(x) |
|
| 29 | +352 |
- # Startup splash screen for delayed loading+ } else {
|
|
| 30 | -+ | ||
| 353 | +! |
- # We use delayed loading in all cases, even when the data does not need to be fetched.+ unique(x) |
|
| 31 | +354 |
- # This has the benefit that when filtering the data takes a lot of time initially, the+ } |
|
| 32 | +355 |
- # Shiny app does not time out.+ |
|
| 33 | -32x | +||
| 356 | +! |
- splash_ui <- if (is_pulled_data) {
+ if (!is.null(min_levels) && !(is.null(max_levels))) {
|
|
| 34 | -+ | ||
| 357 | +! |
- # blank ui if data is already pulled+ validate(need( |
|
| 35 | -28x | +||
| 358 | +! |
- div()+ length(x_levels) >= min_levels && length(x_levels) <= max_levels, |
|
| 36 | -+ | ||
| 359 | +! |
- } else {
+ sprintf( |
|
| 37 | -4x | +||
| 360 | +! |
- message("App was initialized with delayed data loading.")
+ "%s variable needs minimum %s level(s) and maximum %s level(s).", |
|
| 38 | -4x | +||
| 361 | +! |
- data$get_ui(ns("startapp_module"))
+ var_name, min_levels, max_levels |
|
| 39 | +362 |
- }+ ) |
|
| 40 | +363 |
-
+ )) |
|
| 41 | -32x | +||
| 364 | +! |
- ui_teal(id = ns("teal"), splash_ui = splash_ui, title = title, header = header, footer = footer)
+ } else if (!is.null(min_levels)) {
|
|
| 42 | -+ | ||
| 365 | +! |
- }+ validate(need( |
|
| 43 | -+ | ||
| 366 | +! |
-
+ length(x_levels) >= min_levels, |
|
| 44 | -+ | ||
| 367 | +! |
- #' Server function that loads the data through reactive loading and then delegates+ sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
|
|
| 45 | +368 |
- #' to [srv_teal()].+ )) |
|
| 46 | -+ | ||
| 369 | +! |
- #'+ } else if (!is.null(max_levels)) {
|
|
| 47 | -+ | ||
| 370 | +! |
- #' @description `r lifecycle::badge("stable")`
+ validate(need( |
|
| 48 | -+ | ||
| 371 | +! |
- #' Please also refer to the doc of [init()].+ length(x_levels) <= max_levels, |
|
| 49 | -+ | ||
| 372 | +! |
- #'+ sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
|
|
| 50 | +373 |
- #' @inheritParams init+ )) |
|
| 51 | +374 |
- #' @param modules `teal_modules` object containing the output modules which+ } |
|
| 52 | +375 |
- #' will be displayed in the teal application. See [modules()] and [module()] for+ } |
|
| 53 | +
| 1 |
- #' more details.+ #' Create a `tdata` Object |
||
| 54 | +2 |
- #' @inheritParams shiny::moduleServer+ #' |
|
| 55 | +3 |
- #' @return `reactive`, return value of [srv_teal()]+ #' Create a new object called `tdata` which contains `data`, a `reactive` list of data.frames |
|
| 56 | +4 |
- #' @export+ #' (or `MultiAssayExperiment`), with attributes: |
|
| 57 | +5 |
- srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
- |
- |
| 58 | -4x | -
- checkmate::assert_class(data, "TealDataAbstract")- |
- |
| 59 | -4x | -
- moduleServer(id, function(input, output, session) {
- |
- |
| 60 | -4x | -
- logger::log_trace(- |
- |
| 61 | -4x | -
- "srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
+ #' \itemize{
|
|
| 62 | +6 |
- )+ #' \item{`code` (`reactive`) containing code used to generate the data}
|
|
| 63 | +7 | - - | -|
| 64 | -4x | -
- if (getOption("teal.show_js_log", default = FALSE)) {
+ #' \item{join_keys (`JoinKeys`) containing the relationships between the data}
|
|
| 65 | -! | +||
| 8 | +
- shinyjs::showLog()+ #' \item{metadata (`named list`) containing any metadata associated with the data frames}
|
||
| 66 | +9 |
- }+ #' } |
|
| 67 | +10 |
-
+ #' @name tdata |
|
| 68 | -4x | +||
| 11 | +
- is_pulled_data <- teal.data::is_pulled(data)+ #' @param data A `named list` of `data.frames` (or `MultiAssayExperiment`) |
||
| 69 | +12 |
- # raw_data contains TealDataAbstract, i.e. R6 object and container for data+ #' which optionally can be `reactive`. |
|
| 70 | +13 |
- # reactive to get data through delayed loading+ #' Inside this object all of these items will be made `reactive`. |
|
| 71 | +14 |
- # we must leave it inside the server because of callModule which needs to pick up the right session+ #' @param code A `character` (or `reactive` which evaluates to a `character`) containing |
|
| 72 | -4x | +||
| 15 | +
- if (is_pulled_data) {
+ #' the code used to generate the data. This should be `reactive` if the code is changing |
||
| 73 | -2x | +||
| 16 | +
- raw_data <- reactiveVal(data) # will trigger by setting it+ #' during a reactive context (e.g. if filtering changes the code). Inside this |
||
| 74 | +17 |
- } else {
+ #' object `code` will be made reactive |
|
| 75 | -2x | +||
| 18 | +
- raw_data <- data$get_server()(id = "startapp_module")+ #' @param join_keys A `teal.data::JoinKeys` object containing relationships between the |
||
| 76 | -2x | +||
| 19 | +
- if (!is.reactive(raw_data)) {
+ #' datasets. |
||
| 77 | -! | +||
| 20 | +
- stop("The delayed loading module has to return a reactive object.")
+ #' @param metadata A `named list` each element contains a list of metadata about the named data.frame |
||
| 78 | +21 |
- }+ #' Each element of these list should be atomic and length one. |
|
| 79 | +22 |
- }+ #' @return A `tdata` object |
|
| 80 | +23 |
-
+ #' @examples |
|
| 81 | -4x | +||
| 24 | +
- res <- srv_teal(id = "teal", modules = modules, raw_data = raw_data, filter = filter)+ #' |
||
| 82 | -4x | +||
| 25 | +
- logger::log_trace(+ #' data <- new_tdata( |
||
| 83 | -4x | +||
| 26 | +
- "srv_teal_with_splash initialized the module with data { paste(data$get_datanames(), collapse = ' ') }."
+ #' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)), |
||
| 84 | +27 |
- )+ #' code = "iris <- iris |
|
| 85 | -4x | +||
| 28 | +
- return(res)+ #' mtcars <- mtcars |
||
| 86 | +29 |
- })+ #' dd <- data.frame(x = 1:10)", |
|
| 87 | +30 |
- }+ #' metadata = list(dd = list(author = "NEST"), iris = list(version = 1)) |
| 1 | +31 |
- #' Filter state snapshot management.+ #' ) |
||
| 2 | +32 |
#' |
||
| 3 | +33 |
- #' Capture and restore snapshots of the global (app) filter state.+ #' # Extract a data.frame |
||
| 4 | +34 |
- #'+ #' isolate(data[["iris"]]()) |
||
| 5 | +35 |
- #' This module introduces snapshots: stored descriptions of the filter state of the entire application.+ #' |
||
| 6 | +36 |
- #' Snapshots allow the user to save the current filter state of the application for later use in the session,+ #' # Get code |
||
| 7 | +37 |
- #' as well as to save it to file in order to share it with an app developer or other users.+ #' isolate(get_code(data)) |
||
| 8 | +38 |
#' |
||
| 9 | +39 |
- #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner.+ #' # Get metadata |
||
| 10 | +40 |
- #' At the beginning of a session it presents two icons: a camera and an circular arrow.+ #' get_metadata(data, "iris") |
||
| 11 | +41 |
- #' Clicking the camera captures a snapshot and clicking the arrow resets initial application state.+ #' |
||
| 12 | +42 |
- #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.+ #' @export |
||
| 13 | +43 |
- #'+ new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
|
||
| 14 | -+ | |||
| 44 | +40x |
- #' @section Server logic:+ checkmate::assert_list( |
||
| 15 | -+ | |||
| 45 | +40x |
- #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance+ data, |
||
| 16 | -+ | |||
| 46 | +40x |
- #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`+ any.missing = FALSE, names = "unique", |
||
| 17 | -+ | |||
| 47 | +40x |
- #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation+ types = c("data.frame", "reactive", "MultiAssayExperiment")
|
||
| 18 | +48 |
- #' (attributes are maintained).+ ) |
||
| 19 | -+ | |||
| 49 | +36x |
- #'+ checkmate::assert_class(join_keys, "JoinKeys", null.ok = TRUE) |
||
| 20 | -+ | |||
| 50 | +35x |
- #' Snapshots are stored in a `reactiveVal` as a named list.+ checkmate::assert_multi_class(code, c("character", "reactive"))
|
||
| 21 | +51 |
- #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.+ |
||
| 22 | -+ | |||
| 52 | +34x |
- #'+ checkmate::assert_list(metadata, names = "unique", null.ok = TRUE) |
||
| 23 | -+ | |||
| 53 | +32x |
- #' For every snapshot except the initial one, a piece of UI is generated that contains+ checkmate::assert_subset(names(metadata), names(data)) |
||
| 24 | -+ | |||
| 54 | +20x |
- #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.+ for (m in metadata) teal.data::validate_metadata(m) |
||
| 25 | +55 |
- #' The initial snapshot is restored by a separate "reset" button.+ |
||
| 26 | -+ | |||
| 56 | +31x |
- #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.+ if (is.reactive(code)) {
|
||
| 27 | -+ | |||
| 57 | +15x |
- #'+ isolate(checkmate::assert_class(code(), "character", .var.name = "code")) |
||
| 28 | +58 |
- #' @section Snapshot mechanics:+ } |
||
| 29 | +59 |
- #' When a snapshot is captured, the user is prompted to name it.+ |
||
| 30 | +60 |
- #' Names are displayed as is but since they are used to create button ids,+ # create reactive data.frames |
||
| 31 | -+ | |||
| 61 | +30x |
- #' under the hood they are converted to syntactically valid strings.+ for (x in names(data)) {
|
||
| 32 | -+ | |||
| 62 | +49x |
- #' New snapshot names are validated so that their valid versions are unique.+ if (!is.reactive(data[[x]])) {
|
||
| 33 | -+ | |||
| 63 | +29x |
- #' Leading and trailing white space is trimmed.+ data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x])) |
||
| 34 | +64 |
- #'+ } else {
|
||
| 35 | -+ | |||
| 65 | +20x |
- #' The module can read the global state of the application from `slices_global` and `mapping_matrix`.+ isolate( |
||
| 36 | -+ | |||
| 66 | +20x |
- #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.+ checkmate::assert_multi_class( |
||
| 37 | -+ | |||
| 67 | +20x |
- #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.+ data[[x]](), c("data.frame", "MultiAssayExperiment"),
|
||
| 38 | -+ | |||
| 68 | +20x |
- #' The snapshot contains the `mapping` attribute of the initial application state+ .var.name = "data" |
||
| 39 | +69 |
- #' (or one that has been restored), which may not reflect the current one,+ ) |
||
| 40 | +70 |
- #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,+ ) |
||
| 41 | +71 |
- #' when passed to the `mapping` argument of [`teal::teal_slices`], would result in the current mapping.+ } |
||
| 42 | +72 |
- #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.+ } |
||
| 43 | +73 |
- #'+ |
||
| 44 | +74 |
- #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.+ # set attributes |
||
| 45 | -+ | |||
| 75 | +29x |
- #' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared+ attr(data, "code") <- if (is.reactive(code)) code else reactive(code) |
||
| 46 | -+ | |||
| 76 | +29x |
- #' and set anew according to the `mapping` attribute of the snapshot.+ attr(data, "join_keys") <- join_keys |
||
| 47 | -+ | |||
| 77 | +29x |
- #' The snapshot is then set as the current content of `slices_global`.+ attr(data, "metadata") <- metadata |
||
| 48 | +78 |
- #'+ |
||
| 49 | +79 |
- #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,+ # set class |
||
| 50 | -+ | |||
| 80 | +29x |
- #' and then saved to file with [`teal.slice::slices_store`].+ class(data) <- c("tdata", class(data))
|
||
| 51 | -+ | |||
| 81 | +29x |
- #'+ data |
||
| 52 | +82 |
- #' @param id (`character(1)`) `shiny` module id+ } |
||
| 53 | +83 |
- #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object+ |
||
| 54 | +84 |
- #' containing all `teal_slice`s existing in the app, both active and inactive+ #' Function to convert a `tdata` object to an `environment` |
||
| 55 | +85 |
- #' @param mapping_matrix (`reactive`) that contains a `data.frame` representation+ #' Any `reactives` inside `tdata` are first evaluated |
||
| 56 | +86 |
- #' of the mapping of filter state ids (rows) to modules labels (columns);+ #' @param data a `tdata` object |
||
| 57 | +87 |
- #' all columns are `logical` vectors+ #' @return an `environment` |
||
| 58 | +88 |
- #' @param filtered_data_list non-nested (`named list`) that contains `FilteredData` objects+ #' @examples |
||
| 59 | +89 |
#' |
||
| 60 | -- |
- #' @return Nothing is returned.- |
- ||
| 61 | +90 |
- #'+ #' data <- new_tdata( |
||
| 62 | +91 |
- #' @name snapshot_manager_module+ #' data = list(iris = iris, mtcars = reactive(mtcars)), |
||
| 63 | +92 |
- #' @aliases snapshot snapshot_manager+ #' code = "iris <- iris |
||
| 64 | +93 |
- #'+ #' mtcars = mtcars" |
||
| 65 | +94 |
- #' @author Aleksander Chlebowski+ #' ) |
||
| 66 | +95 |
#' |
||
| 67 | +96 |
- #' @rdname snapshot_manager_module+ #' my_env <- isolate(tdata2env(data)) |
||
| 68 | +97 |
- #' @keywords internal+ #' |
||
| 69 | +98 |
- #'+ #' @export |
||
| 70 | +99 |
- snapshot_manager_ui <- function(id) {
+ tdata2env <- function(data) { # nolint
|
||
| 71 | -! | +|||
| 100 | +2x |
- ns <- NS(id)+ checkmate::assert_class(data, "tdata") |
||
| 72 | -! | +|||
| 101 | +1x |
- div(+ list2env(lapply(data, function(x) if (is.reactive(x)) x() else x)) |
||
| 73 | -! | +|||
| 102 | +
- class = "snapshot_manager_content",+ } |
|||
| 74 | -! | +|||
| 103 | +
- div(+ |
|||
| 75 | -! | +|||
| 104 | +
- class = "snapshot_table_row",+ #' @rdname tdata |
|||
| 76 | -! | +|||
| 105 | +
- span(tags$b("Snapshot manager")),
+ #' @param x a `tdata` object |
|||
| 77 | -! | +|||
| 106 | +
- actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
+ #' @param ... additional arguments for the generic |
|||
| 78 | -! | +|||
| 107 | +
- actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
+ #' @export |
|||
| 79 | -! | +|||
| 108 | +
- NULL+ get_code.tdata <- function(x, ...) { # nolint
|
|||
| 80 | +109 |
- ),+ # note teal.data which teal depends on defines the get_code method |
||
| 81 | -! | +|||
| 110 | +6x |
- uiOutput(ns("snapshot_list"))
+ attr(x, "code")() |
||
| 82 | +111 |
- )+ } |
||
| 83 | +112 |
- }+ |
||
| 84 | +113 | |||
| 85 | +114 |
- #' @rdname snapshot_manager_module+ #' Wrapper for `get_code.tdata` |
||
| 86 | +115 |
- #' @keywords internal+ #' This wrapper is to be used by downstream packages to extract the code of a `tdata` object |
||
| 87 | +116 |
#' |
||
| 88 | +117 |
- snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
+ #' @param data (`tdata`) object |
||
| 89 | -7x | +|||
| 118 | +
- checkmate::assert_character(id)+ #' |
|||
| 90 | -7x | +|||
| 119 | +
- checkmate::assert_true(is.reactive(slices_global))+ #' @return (`character`) code used in the `tdata` object. |
|||
| 91 | -7x | +|||
| 120 | +
- checkmate::assert_class(isolate(slices_global()), "teal_slices")+ #' @export |
|||
| 92 | -7x | +|||
| 121 | +
- checkmate::assert_true(is.reactive(mapping_matrix))+ get_code_tdata <- function(data) {
|
|||
| 93 | -7x | +122 | +4x |
- checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)+ checkmate::assert_class(data, "tdata") |
| 94 | -7x | +123 | +2x |
- checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named")+ get_code(data) |
| 95 | +124 |
-
+ } |
||
| 96 | -7x | +|||
| 125 | +
- moduleServer(id, function(input, output, session) {
+
|
|||
| 97 | -7x | +|||
| 126 | +
- ns <- session$ns+ |
|||
| 98 | +127 |
-
+ #' Function to get join keys from a `tdata` object |
||
| 99 | +128 |
- # Store global filter states.+ #' @param data `tdata` - object to extract the join keys |
||
| 100 | -7x | +|||
| 129 | +
- filter <- isolate(slices_global())+ #' @return Either `JoinKeys` object or `NULL` if no join keys |
|||
| 101 | -7x | +|||
| 130 | +
- snapshot_history <- reactiveVal({
+ #' @export |
|||
| 102 | -7x | +|||
| 131 | +
- list(+ get_join_keys <- function(data) {
|
|||
| 103 | -7x | +132 | +3x |
- "Initial application state" = as.list(filter, recursive = TRUE)+ UseMethod("get_join_keys", data)
|
| 104 | +133 |
- )+ } |
||
| 105 | +134 |
- })+ |
||
| 106 | +135 | |||
| 107 | +136 |
- # Snapshot current application state - name snaphsot.+ #' @rdname get_join_keys |
||
| 108 | -7x | +|||
| 137 | +
- observeEvent(input$snapshot_add, {
+ #' @export |
|||
| 109 | -! | +|||
| 138 | +
- showModal(+ get_join_keys.tdata <- function(data) {
|
|||
| 110 | -! | +|||
| 139 | +3x |
- modalDialog(+ attr(data, "join_keys") |
||
| 111 | -! | +|||
| 140 | +
- textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
+ } |
|||
| 112 | -! | +|||
| 141 | +
- footer = tagList(+ |
|||
| 113 | -! | +|||
| 142 | +
- actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
+
|
|||
| 114 | -! | +|||
| 143 | +
- modalButton(label = "Cancel", icon = icon("thumbs-down"))
+ #' @rdname get_join_keys |
|||
| 115 | +144 |
- ),+ #' @export+ |
+ ||
| 145 | ++ |
+ get_join_keys.default <- function(data) {
|
||
| 116 | +146 | ! |
- size = "s"+ stop("get_join_keys function not implemented for this object")
|
|
| 117 | +147 |
- )+ } |
||
| 118 | +148 |
- )+ |
||
| 119 | +149 |
- })+ #' Function to get metadata from a `tdata` object |
||
| 120 | +150 |
- # Snapshot current application state - store snaphsot.+ #' @param data `tdata` - object to extract the data from |
||
| 121 | -7x | +|||
| 151 | +
- observeEvent(input$snapshot_name_accept, {
+ #' @param dataname `character(1)` the dataset name whose metadata is requested |
|||
| 122 | -! | +|||
| 152 | +
- snapshot_name <- trimws(input$snapshot_name)+ #' @return Either list of metadata or NULL if no metadata |
|||
| 123 | -! | +|||
| 153 | +
- if (identical(snapshot_name, "")) {
+ #' @export |
|||
| 124 | -! | +|||
| 154 | +
- showNotification(+ get_metadata <- function(data, dataname) {
|
|||
| 125 | -! | +|||
| 155 | +6x |
- "Please name the snapshot.",+ checkmate::assert_string(dataname) |
||
| 126 | -! | +|||
| 156 | +6x |
- type = "message"+ UseMethod("get_metadata", data)
|
||
| 127 | +157 |
- )+ } |
||
| 128 | -! | +|||
| 158 | +
- updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ |
|||
| 129 | -! | +|||
| 159 | +
- } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ #' @rdname get_metadata |
|||
| 130 | -! | +|||
| 160 | +
- showNotification(+ #' @export |
|||
| 131 | -! | +|||
| 161 | +
- "This name is in conflict with other snapshot names. Please choose a different one.",+ get_metadata.tdata <- function(data, dataname) {
|
|||
| 132 | -! | +|||
| 162 | +6x |
- type = "message"+ metadata <- attr(data, "metadata") |
||
| 133 | -+ | |||
| 163 | +6x |
- )+ if (is.null(metadata)) {
|
||
| 134 | -! | +|||
| 164 | +1x |
- updateTextInput(inputId = "snapshot_name", value = , placeholder = "Meaningful, unique name")+ return(NULL) |
||
| 135 | +165 |
- } else {
+ } |
||
| 136 | -! | +|||
| 166 | +5x |
- snapshot <- as.list(slices_global(), recursive = TRUE)+ metadata[[dataname]] |
||
| 137 | -! | +|||
| 167 | +
- attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())+ } |
|||
| 138 | -! | +|||
| 168 | +
- snapshot_update <- c(snapshot_history(), list(snapshot))+ |
|||
| 139 | -! | -
- names(snapshot_update)[length(snapshot_update)] <- snapshot_name- |
- ||
| 140 | -! | +|||
| 169 | +
- snapshot_history(snapshot_update)+ #' @rdname get_metadata |
|||
| 141 | -! | +|||
| 170 | +
- removeModal()+ #' @export |
|||
| 142 | +171 |
- # Reopen filter manager modal by clicking button in the main application.+ get_metadata.default <- function(data, dataname) {
|
||
| 143 | +172 | ! |
- shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE)+ stop("get_metadata function not implemented for this object")
|
|
| 144 | +173 |
- }+ } |
| 145 | +1 |
- })+ #' Include `CSS` files from `/inst/css/` package directory to application header |
||
| 146 | +2 |
-
+ #' |
||
| 147 | +3 |
- # Restore initial state.+ #' `system.file` should not be used to access files in other packages, it does |
||
| 148 | -7x | +|||
| 4 | +
- observeEvent(input$snapshot_reset, {
+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|||
| 149 | -! | +|||
| 5 | +
- s <- "Initial application state"+ #' as needed. Thus, we do not export this method |
|||
| 150 | +6 |
- ### Begin restore procedure. ###+ #' |
||
| 151 | -! | +|||
| 7 | +
- snapshot <- snapshot_history()[[s]]+ #' @param pattern (`character`) pattern of files to be included |
|||
| 152 | -! | +|||
| 8 | +
- snapshot_state <- as.teal_slices(snapshot)+ #' |
|||
| 153 | -! | +|||
| 9 | +
- mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ #' @return HTML code that includes `CSS` files |
|||
| 154 | -! | +|||
| 10 | +
- mapply(+ #' @keywords internal |
|||
| 155 | -! | +|||
| 11 | +
- function(filtered_data, filter_ids) {
+ include_css_files <- function(pattern = "*") {
|
|||
| 156 | -! | +|||
| 12 | +32x |
- filtered_data$clear_filter_states(force = TRUE)+ css_files <- list.files( |
||
| 157 | -! | +|||
| 13 | +32x |
- slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ system.file("css", package = "teal", mustWork = TRUE),
|
||
| 158 | -! | +|||
| 14 | +32x |
- filtered_data$set_filter_state(slices)+ pattern = pattern, full.names = TRUE |
||
| 159 | +15 |
- },+ ) |
||
| 160 | -! | +|||
| 16 | +32x |
- filtered_data = filtered_data_list,+ return( |
||
| 161 | -! | +|||
| 17 | +32x |
- filter_ids = mapping_unfolded+ shiny::singleton(+ |
+ ||
| 18 | +32x | +
+ shiny::tags$head(lapply(css_files, shiny::includeCSS)) |
||
| 162 | +19 |
- )+ ) |
||
| 163 | -! | +|||
| 20 | +
- slices_global(snapshot_state)+ ) |
|||
| 164 | -! | +|||
| 21 | +
- removeModal()+ } |
|||
| 165 | +22 |
- ### End restore procedure. ###+ |
||
| 166 | +23 |
- })+ #' Include `JS` files from `/inst/js/` package directory to application header |
||
| 167 | +24 |
-
+ #' |
||
| 168 | +25 |
- # Create UI elements and server logic for the snapshot table.+ #' `system.file` should not be used to access files in other packages, it does |
||
| 169 | +26 |
- # Observers must be tracked to avoid duplication and excess reactivity.+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 170 | +27 |
- # Remaining elements are tracked likewise for consistency and a slight speed margin.+ #' as needed. Thus, we do not export this method |
||
| 171 | -7x | +|||
| 28 | +
- observers <- reactiveValues()+ #' |
|||
| 172 | -7x | +|||
| 29 | +
- handlers <- reactiveValues()+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file` |
|||
| 173 | -7x | +|||
| 30 | +
- divs <- reactiveValues()+ #' @param except (`character`) vector of basename filenames to be excluded |
|||
| 174 | +31 |
-
+ #' |
||
| 175 | -7x | +|||
| 32 | +
- observeEvent(snapshot_history(), {
+ #' @return HTML code that includes `JS` files |
|||
| 176 | -3x | +|||
| 33 | +
- lapply(names(snapshot_history())[-1L], function(s) {
- |
- |||
| 177 | -! | -
- id_pickme <- sprintf("pickme_%s", make.names(s))
- |
- ||
| 178 | -! | -
- id_saveme <- sprintf("saveme_%s", make.names(s))
- |
- ||
| 179 | -! | -
- id_rowme <- sprintf("rowme_%s", make.names(s))
+ #' @keywords internal |
||
| 180 | +34 |
-
+ include_js_files <- function(pattern = NULL, except = NULL) {
|
||
| 181 | -+ | |||
| 35 | +32x |
- # Observer for restoring snapshot.+ checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE) |
||
| 182 | -! | +|||
| 36 | +32x |
- if (!is.element(id_pickme, names(observers))) {
+ js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
|
||
| 183 | -! | +|||
| 37 | +32x |
- observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
+ js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL |
||
| 184 | +38 |
- ### Begin restore procedure. ###- |
- ||
| 185 | -! | -
- snapshot <- snapshot_history()[[s]]- |
- ||
| 186 | -! | -
- snapshot_state <- as.teal_slices(snapshot)+ |
||
| 187 | -! | +|||
| 39 | +32x |
- mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ return(singleton(lapply(js_files, includeScript))) |
||
| 188 | -! | +|||
| 40 | +
- mapply(+ } |
|||
| 189 | -! | +|||
| 41 | +
- function(filtered_data, filter_ids) {
+
|
|||
| 190 | -! | +|||
| 42 | +
- filtered_data$clear_filter_states(force = TRUE)+ #' Run `JS` file from `/inst/js/` package directory |
|||
| 191 | -! | +|||
| 43 | +
- slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ #' |
|||
| 192 | -! | +|||
| 44 | +
- filtered_data$set_filter_state(slices)+ #' This is triggered from the server to execute on the client |
|||
| 193 | +45 |
- },+ #' rather than triggered directly on the client. |
||
| 194 | -! | +|||
| 46 | +
- filtered_data = filtered_data_list,+ #' Unlike `include_js_files` which includes `JavaScript` functions, |
|||
| 195 | -! | +|||
| 47 | +
- filter_ids = mapping_unfolded+ #' the `run_js` actually executes `JavaScript` functions. |
|||
| 196 | +48 |
- )+ #' |
||
| 197 | -! | +|||
| 49 | +
- slices_global(snapshot_state)+ #' `system.file` should not be used to access files in other packages, it does |
|||
| 198 | -! | +|||
| 50 | +
- removeModal()+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|||
| 199 | +51 |
- ### End restore procedure. ###+ #' as needed. Thus, we do not export this method |
||
| 200 | +52 |
- })+ #' |
||
| 201 | +53 |
- }+ #' @param files (`character`) vector of filenames |
||
| 202 | +54 |
- # Create handler for downloading snapshot.+ #' @keywords internal |
||
| 203 | -! | +|||
| 55 | +
- if (!is.element(id_saveme, names(handlers))) {
+ run_js_files <- function(files) {
|
|||
| 204 | -! | +|||
| 56 | +8x |
- output[[id_saveme]] <- downloadHandler(+ checkmate::assert_character(files, min.len = 1, any.missing = FALSE) |
||
| 205 | -! | +|||
| 57 | +8x |
- filename = function() {
+ lapply(files, function(file) {
|
||
| 206 | -! | +|||
| 58 | +8x |
- sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
+ shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
|
||
| 207 | +59 |
- },+ }) |
||
| 208 | -! | +|||
| 60 | +8x |
- content = function(file) {
+ return(invisible(NULL)) |
||
| 209 | -! | +|||
| 61 | +
- snapshot <- snapshot_history()[[s]]+ } |
|||
| 210 | -! | +|||
| 62 | +
- snapshot_state <- as.teal_slices(snapshot)+ |
|||
| 211 | -! | +|||
| 63 | +
- teal.slice::slices_store(tss = snapshot_state, file = file)+ #' Code to include teal `CSS` and `JavaScript` files |
|||
| 212 | +64 |
- }+ #' |
||
| 213 | +65 |
- )+ #' This is useful when you want to use the same `JavaScript` and `CSS` files that are |
||
| 214 | -! | +|||
| 66 | +
- handlers[[id_saveme]] <- id_saveme+ #' used with the teal application. |
|||
| 215 | +67 |
- }+ #' This is also useful for running standalone modules in teal with the correct |
||
| 216 | +68 |
- # Create a row for the snapshot table.- |
- ||
| 217 | -! | -
- if (!is.element(id_rowme, names(divs))) {
- |
- ||
| 218 | -! | -
- divs[[id_rowme]] <- div(+ #' styles. |
||
| 219 | -! | +|||
| 69 | +
- class = "snapshot_table_row",+ #' Also initializes `shinyjs` so you can use it. |
|||
| 220 | -! | +|||
| 70 | +
- span(h5(s)),+ #' |
|||
| 221 | -! | +|||
| 71 | +
- actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
+ #' @return HTML code to include |
|||
| 222 | -! | +|||
| 72 | +
- downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
+ #' @examples |
|||
| 223 | +73 |
- )+ #' shiny_ui <- tagList( |
||
| 224 | +74 |
- }+ #' teal:::include_teal_css_js(), |
||
| 225 | +75 |
- })+ #' p("Hello")
|
||
| 226 | +76 |
- })+ #' ) |
||
| 227 | +77 |
-
+ #' @keywords internal |
||
| 228 | +78 |
- # Create table to display list of snapshots and their actions.+ include_teal_css_js <- function() {
|
||
| 229 | -7x | +79 | +32x |
- output$snapshot_list <- renderUI({
+ tagList( |
| 230 | -3x | +80 | +32x |
- rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d)+ shinyjs::useShinyjs(), |
| 231 | -3x | +81 | +32x |
- if (length(rows) == 0L) {
+ include_css_files(), |
| 232 | -3x | +|||
| 82 | +
- div(+ # init.js is executed from the server |
|||
| 233 | -3x | +83 | +32x |
- class = "snapshot_manager_placeholder",+ include_js_files(except = "init.js"), |
| 234 | -3x | +84 | +32x |
- "Snapshots will appear here."+ shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
|
| 235 | +85 |
- )+ ) |
||
| 236 | +86 |
- } else {
+ } |
||
| 237 | -! | +
| 1 | +
- rows+ # This file adds a splash screen for delayed data loading on top of teal |
||
| 238 | +2 |
- }+ |
|
| 239 | +3 |
- })+ #' UI to show a splash screen in the beginning, then delegate to [srv_teal()] |
|
| 240 | +4 |
- })+ #' |
|
| 241 | +5 |
- }+ #' @description `r lifecycle::badge("stable")`
|
|
| 242 | +6 |
-
+ #' The splash screen could be used to query for a password to fetch the data. |
|
| 243 | +7 |
-
+ #' [init()] is a very thin wrapper around this module useful for end-users which |
|
| 244 | +8 |
-
+ #' assumes that it is a top-level module and cannot be embedded. |
|
| 245 | +9 |
-
+ #' This function instead adheres to the Shiny module conventions. |
|
| 246 | +10 |
- ### utility functions ----+ #' |
|
| 247 | +11 |
-
+ #' If data is obtained through delayed loading, its splash screen is used. Otherwise, |
|
| 248 | +12 |
- #' Explicitly enumerate global filters.+ #' a default splash screen is shown. |
|
| 249 | +13 |
#' |
|
| 250 | +14 |
- #' Transform module mapping such that global filters are explicitly specified for every module.+ #' Please also refer to the doc of [init()]. |
|
| 251 | +15 |
#' |
|
| 252 | +16 |
- #' @param mapping (`named list`) as stored in mapping parameter of `teal_slices`+ #' @param id (`character(1)`)\cr |
|
| 253 | +17 |
- #' @param module_names (`character`) vector containing names of all modules in the app+ #' module id |
|
| 254 | +18 |
- #' @return A `named_list` with one element per module, each element containing all filters applied to that module.+ #' @inheritParams init |
|
| 255 | +19 |
- #' @keywords internal+ #' @export |
|
| 256 | +20 |
- #'+ ui_teal_with_splash <- function(id, |
|
| 257 | +21 |
- unfold_mapping <- function(mapping, module_names) {
+ data, |
|
| 258 | -! | +||
| 22 | +
- module_names <- structure(module_names, names = module_names)+ title, |
||
| 259 | -! | +||
| 23 | +
- lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))+ header = tags$p("Add Title Here"),
|
||
| 260 | +24 |
- }+ footer = tags$p("Add Footer Here")) {
|
|
| 261 | -+ | ||
| 25 | +32x |
-
+ checkmate::assert_class(data, "TealDataAbstract") |
|
| 262 | -+ | ||
| 26 | +32x |
- #' Convert mapping matrix to filter mapping specification.+ is_pulled_data <- teal.data::is_pulled(data) |
|
| 263 | -+ | ||
| 27 | +32x |
- #'+ ns <- NS(id) |
|
| 264 | +28 |
- #' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,+ |
|
| 265 | -- |
- #' to a list specification like the one used in the `mapping` attribute of `teal_slices`.- |
- |
| 266 | -- |
- #' Global filters are gathered in one list element.- |
- |
| 267 | +29 |
- #' If a module has no active filters but the global ones, it will not be mentioned in the output.+ # Startup splash screen for delayed loading |
|
| 268 | +30 |
- #'+ # We use delayed loading in all cases, even when the data does not need to be fetched. |
|
| 269 | +31 |
- #' @param mapping_matrix (`data.frame`) of logical vectors where+ # This has the benefit that when filtering the data takes a lot of time initially, the |
|
| 270 | +32 |
- #' columns represent modules and row represent `teal_slice`s+ # Shiny app does not time out. |
|
| 271 | -+ | ||
| 33 | +32x |
- #' @return `named list` like that in the `mapping` attribute of a `teal_slices` object.+ splash_ui <- if (is_pulled_data) {
|
|
| 272 | +34 |
- #' @keywords internal+ # blank ui if data is already pulled |
|
| 273 | -+ | ||
| 35 | +28x |
- #'+ div() |
|
| 274 | +36 |
- matrix_to_mapping <- function(mapping_matrix) {
- |
- |
| 275 | -! | -
- mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x))+ } else {
|
|
| 276 | -! | +||
| 37 | +4x |
- global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))+ message("App was initialized with delayed data loading.")
|
|
| 277 | -! | +||
| 38 | +4x |
- global_filters <- names(global[global])+ data$get_ui(ns("startapp_module"))
|
|
| 278 | -! | +||
| 39 | +
- local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]+ } |
||
| 279 | +40 | ||
| 280 | -! | -
- mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))- |
- |
| 281 | -! | +||
| 41 | +32x |
- Filter(function(x) length(x) != 0L, mapping)+ ui_teal(id = ns("teal"), splash_ui = splash_ui, title = title, header = header, footer = footer)
|
|
| 282 | +42 |
} |
| 1 | +43 |
- #' Create a UI of nested tabs of `teal_modules`+ |
|
| 2 | +44 |
- #'+ #' Server function that loads the data through reactive loading and then delegates |
|
| 3 | +45 |
- #' @section `ui_nested_tabs`:+ #' to [srv_teal()]. |
|
| 4 | +46 |
- #' Each `teal_modules` is translated to a `tabsetPanel` and each+ #' |
|
| 5 | +47 |
- #' of its children is another tab-module called recursively. The UI of a+ #' @description `r lifecycle::badge("stable")`
|
|
| 6 | +48 |
- #' `teal_module` is obtained by calling the `ui` function on it.+ #' Please also refer to the doc of [init()]. |
|
| 7 | +49 |
#' |
|
| 8 | +50 |
- #' The `datasets` argument is required to resolve the teal arguments in an+ #' @inheritParams init |
|
| 9 | +51 |
- #' isolated context (with respect to reactivity)+ #' @param modules `teal_modules` object containing the output modules which |
|
| 10 | +52 |
- #'+ #' will be displayed in the teal application. See [modules()] and [module()] for |
|
| 11 | +53 |
- #' @section `srv_nested_tabs`:+ #' more details. |
|
| 12 | +54 |
- #' This module calls recursively all elements of the `modules` returns one which+ #' @inheritParams shiny::moduleServer |
|
| 13 | +55 |
- #' is currently active.+ #' @return `reactive`, return value of [srv_teal()] |
|
| 14 | +56 |
- #' - `teal_module` returns self as a active module.+ #' @export |
|
| 15 | +57 |
- #' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.+ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
|
|
| 16 | -+ | ||
| 58 | +4x |
- #'+ checkmate::assert_class(data, "TealDataAbstract") |
|
| 17 | -+ | ||
| 59 | +4x |
- #' @name module_nested_tabs+ moduleServer(id, function(input, output, session) {
|
|
| 18 | -+ | ||
| 60 | +4x |
- #'+ logger::log_trace( |
|
| 19 | -+ | ||
| 61 | +4x |
- #' @inheritParams module_tabs_with_filters+ "srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
|
|
| 20 | +62 |
- #'+ ) |
|
| 21 | +63 |
- #' @param depth (`integer(1)`)\cr+ |
|
| 22 | -+ | ||
| 64 | +4x |
- #' number which helps to determine depth of the modules nesting.+ if (getOption("teal.show_js_log", default = FALSE)) {
|
|
| 23 | -+ | ||
| 65 | +! |
- #' @param is_module_specific (`logical(1)`)\cr+ shinyjs::showLog() |
|
| 24 | +66 |
- #' flag determining if the filter panel is global or module-specific.+ } |
|
| 25 | +67 |
- #' When set to `TRUE`, a filter panel is called inside of each module tab.+ |
|
| 26 | -+ | ||
| 68 | +4x |
- #' @return depending on class of `modules`, `ui_nested_tabs` returns:+ is_pulled_data <- teal.data::is_pulled(data) |
|
| 27 | +69 |
- #' - `teal_module`: instantiated UI of the module+ # raw_data contains TealDataAbstract, i.e. R6 object and container for data |
|
| 28 | +70 |
- #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively+ # reactive to get data through delayed loading |
|
| 29 | +71 |
- #' calling this function on it.\cr+ # we must leave it inside the server because of callModule which needs to pick up the right session |
|
| 30 | -- |
- #' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.+ | |
| 72 | +4x | +
+ if (is_pulled_data) {
|
|
| 31 | -+ | ||
| 73 | +2x |
- #'+ raw_data <- reactiveVal(data) # will trigger by setting it |
|
| 32 | +74 |
- #' @examples+ } else {
|
|
| 33 | -+ | ||
| 75 | +2x |
- #' mods <- teal:::example_modules()+ raw_data <- data$get_server()(id = "startapp_module") |
|
| 34 | -+ | ||
| 76 | +2x |
- #' datasets <- teal:::example_datasets()+ if (!is.reactive(raw_data)) {
|
|
| 35 | -+ | ||
| 77 | +! |
- #' app <- shinyApp(+ stop("The delayed loading module has to return a reactive object.")
|
|
| 36 | +78 |
- #' ui = function() {
+ } |
|
| 37 | +79 |
- #' tagList(+ } |
|
| 38 | +80 |
- #' teal:::include_teal_css_js(),+ |
|
| 39 | -+ | ||
| 81 | +4x |
- #' textOutput("info"),
+ res <- srv_teal(id = "teal", modules = modules, raw_data = raw_data, filter = filter) |
|
| 40 | -+ | ||
| 82 | +4x |
- #' fluidPage( # needed for nice tabs+ logger::log_trace(+ |
+ |
| 83 | +4x | +
+ "srv_teal_with_splash initialized the module with data { paste(data$get_datanames(), collapse = ' ') }."
|
|
| 41 | +84 |
- #' teal:::ui_nested_tabs("dummy", modules = mods, datasets = datasets)
+ )+ |
+ |
| 85 | +4x | +
+ return(res) |
|
| 42 | +86 |
- #' )+ }) |
|
| 43 | +87 |
- #' )+ } |
| 44 | +1 |
- #' },+ #' Filter state snapshot management. |
||
| 45 | +2 |
- #' server = function(input, output, session) {
+ #' |
||
| 46 | +3 |
- #' active_module <- teal:::srv_nested_tabs(+ #' Capture and restore snapshots of the global (app) filter state. |
||
| 47 | +4 |
- #' "dummy",+ #' |
||
| 48 | +5 |
- #' datasets = datasets,+ #' This module introduces snapshots: stored descriptions of the filter state of the entire application. |
||
| 49 | +6 |
- #' modules = mods+ #' Snapshots allow the user to save the current filter state of the application for later use in the session, |
||
| 50 | +7 |
- #' )+ #' as well as to save it to file in order to share it with an app developer or other users. |
||
| 51 | +8 |
- #' output$info <- renderText({
+ #' |
||
| 52 | +9 |
- #' paste0("The currently active tab name is ", active_module()$label)
+ #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner. |
||
| 53 | +10 |
- #' })+ #' At the beginning of a session it presents two icons: a camera and an circular arrow. |
||
| 54 | +11 |
- #' }+ #' Clicking the camera captures a snapshot and clicking the arrow resets initial application state. |
||
| 55 | +12 |
- #' )+ #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button. |
||
| 56 | +13 |
- #' if (interactive()) {
+ #' |
||
| 57 | +14 |
- #' runApp(app)+ #' @section Server logic: |
||
| 58 | +15 |
- #' }+ #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance |
||
| 59 | +16 |
- #' @keywords internal+ #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices` |
||
| 60 | +17 |
- NULL+ #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation |
||
| 61 | +18 |
-
+ #' (attributes are maintained). |
||
| 62 | +19 |
- #' @rdname module_nested_tabs+ #' |
||
| 63 | +20 |
- ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ #' Snapshots are stored in a `reactiveVal` as a named list. |
||
| 64 | -2x | +|||
| 21 | +
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit. |
|||
| 65 | -2x | +|||
| 22 | +
- checkmate::assert_count(depth)+ #' |
|||
| 66 | -2x | +|||
| 23 | +
- UseMethod("ui_nested_tabs", modules)
+ #' For every snapshot except the initial one, a piece of UI is generated that contains |
|||
| 67 | +24 |
- }+ #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file. |
||
| 68 | +25 |
-
+ #' The initial snapshot is restored by a separate "reset" button. |
||
| 69 | +26 |
- #' @rdname module_nested_tabs+ #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that. |
||
| 70 | +27 |
- #' @export+ #' |
||
| 71 | +28 |
- ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ #' @section Snapshot mechanics: |
||
| 72 | -! | +|||
| 29 | +
- stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ #' When a snapshot is captured, the user is prompted to name it. |
|||
| 73 | +30 |
- }+ #' Names are displayed as is but since they are used to create button ids, |
||
| 74 | +31 |
-
+ #' under the hood they are converted to syntactically valid strings. |
||
| 75 | +32 |
- #' @rdname module_nested_tabs+ #' New snapshot names are validated so that their valid versions are unique. |
||
| 76 | +33 |
- #' @export+ #' Leading and trailing white space is trimmed. |
||
| 77 | +34 |
- ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ #' |
||
| 78 | -1x | -
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
- |
- ||
| 79 | -1x | +|||
| 35 | +
- ns <- NS(id)+ #' The module can read the global state of the application from `slices_global` and `mapping_matrix`. |
|||
| 80 | -1x | +|||
| 36 | +
- do.call(+ #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module. |
|||
| 81 | -1x | +|||
| 37 | +
- tabsetPanel,+ #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot. |
|||
| 82 | -1x | +|||
| 38 | +
- c(+ #' The snapshot contains the `mapping` attribute of the initial application state |
|||
| 83 | +39 |
- # by giving an id, we can reactively respond to tab changes+ #' (or one that has been restored), which may not reflect the current one, |
||
| 84 | -1x | +|||
| 40 | +
- list(+ #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that, |
|||
| 85 | -1x | +|||
| 41 | +
- id = ns("active_tab"),
+ #' when passed to the `mapping` argument of [`teal::teal_slices`], would result in the current mapping. |
|||
| 86 | -1x | +|||
| 42 | +
- type = if (modules$label == "root") "pills" else "tabs"+ #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list. |
|||
| 87 | +43 |
- ),+ #' |
||
| 88 | -1x | +|||
| 44 | +
- lapply(+ #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object. |
|||
| 89 | -1x | +|||
| 45 | +
- names(modules$children),+ #' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared |
|||
| 90 | -1x | +|||
| 46 | +
- function(module_id) {
+ #' and set anew according to the `mapping` attribute of the snapshot. |
|||
| 91 | -1x | +|||
| 47 | +
- module_label <- modules$children[[module_id]]$label+ #' The snapshot is then set as the current content of `slices_global`. |
|||
| 92 | -1x | +|||
| 48 | +
- tabPanel(+ #' |
|||
| 93 | -1x | +|||
| 49 | +
- title = module_label,+ #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring, |
|||
| 94 | -1x | +|||
| 50 | +
- value = module_id, # when clicked this tab value changes input$<tabset panel id>+ #' and then saved to file with [`slices_store`]. |
|||
| 95 | -1x | +|||
| 51 | +
- ui_nested_tabs(+ #' |
|||
| 96 | -1x | +|||
| 52 | +
- id = ns(module_id),+ #' @param id (`character(1)`) `shiny` module id |
|||
| 97 | -1x | +|||
| 53 | +
- modules = modules$children[[module_id]],+ #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object |
|||
| 98 | -1x | +|||
| 54 | +
- datasets = datasets[[module_label]],+ #' containing all `teal_slice`s existing in the app, both active and inactive |
|||
| 99 | -1x | +|||
| 55 | +
- depth = depth + 1L,+ #' @param mapping_matrix (`reactive`) that contains a `data.frame` representation |
|||
| 100 | -1x | +|||
| 56 | +
- is_module_specific = is_module_specific+ #' of the mapping of filter state ids (rows) to modules labels (columns); |
|||
| 101 | +57 |
- )+ #' all columns are `logical` vectors |
||
| 102 | +58 |
- )+ #' @param filtered_data_list non-nested (`named list`) that contains `FilteredData` objects |
||
| 103 | +59 |
- }+ #' |
||
| 104 | +60 |
- )+ #' @return Nothing is returned. |
||
| 105 | +61 |
- )+ #' |
||
| 106 | +62 |
- )+ #' @name snapshot_manager_module |
||
| 107 | +63 |
- }+ #' @aliases snapshot snapshot_manager |
||
| 108 | +64 |
-
+ #' |
||
| 109 | +65 |
- #' @rdname module_nested_tabs+ #' @author Aleksander Chlebowski |
||
| 110 | +66 |
- #' @export+ #' |
||
| 111 | +67 |
- ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ #' @rdname snapshot_manager_module |
||
| 112 | -1x | +|||
| 68 | +
- checkmate::assert_class(datasets, class = "FilteredData")+ #' @keywords internal |
|||
| 113 | -1x | +|||
| 69 | +
- ns <- NS(id)+ #' |
|||
| 114 | +70 |
-
+ snapshot_manager_ui <- function(id) {
|
||
| 115 | -1x | +|||
| 71 | +! |
- args <- isolate(teal.transform::resolve_delayed(modules$ui_args, datasets))+ ns <- NS(id) |
||
| 116 | -1x | +|||
| 72 | +! |
- args <- c(list(id = ns("module")), args)
- |
- ||
| 117 | -- | - - | -||
| 118 | -1x | -
- if (is_arg_used(modules$ui, "datasets")) {
+ div( |
||
| 119 | +73 | ! |
- args <- c(args, datasets = datasets)+ class = "snapshot_manager_content", |
|
| 120 | -+ | |||
| 74 | +! |
- }+ div( |
||
| 121 | -+ | |||
| 75 | +! |
-
+ class = "snapshot_table_row", |
||
| 122 | -1x | +|||
| 76 | +! |
- if (is_arg_used(modules$ui, "data")) {
+ span(tags$b("Snapshot manager")),
|
||
| 123 | +77 | ! |
- data <- .datasets_to_data(modules, datasets)+ actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
|
|
| 124 | +78 | ! |
- args <- c(args, data = list(data))+ actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
|
|
| 125 | -+ | |||
| 79 | +! |
- }+ NULL |
||
| 126 | +80 |
-
+ ), |
||
| 127 | -1x | +|||
| 81 | +! |
- teal_ui <- tags$div(+ uiOutput(ns("snapshot_list"))
|
||
| 128 | -1x | +|||
| 82 | +
- id = id,+ ) |
|||
| 129 | -1x | +|||
| 83 | +
- class = "teal_module",+ } |
|||
| 130 | -1x | +|||
| 84 | +
- uiOutput(ns("data_reactive"), inline = TRUE),
+
|
|||
| 131 | -1x | +|||
| 85 | +
- tagList(+ #' @rdname snapshot_manager_module |
|||
| 132 | -1x | +|||
| 86 | +
- if (depth >= 2L) div(style = "mt-6"),+ #' @keywords internal |
|||
| 133 | -1x | +|||
| 87 | +
- do.call(modules$ui, args)+ #' |
|||
| 134 | +88 |
- )+ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
|
||
| 135 | -+ | |||
| 89 | +7x |
- )+ checkmate::assert_character(id) |
||
| 136 | -+ | |||
| 90 | +7x |
-
+ checkmate::assert_true(is.reactive(slices_global)) |
||
| 137 | -1x | +91 | +7x |
- if (!is.null(modules$datanames) && is_module_specific) {
+ checkmate::assert_class(isolate(slices_global()), "teal_slices") |
| 138 | -! | +|||
| 92 | +7x |
- fluidRow(+ checkmate::assert_true(is.reactive(mapping_matrix)) |
||
| 139 | -! | +|||
| 93 | +7x |
- column(width = 9, teal_ui, class = "teal_primary_col"),+ checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE) |
||
| 140 | -! | +|||
| 94 | +7x |
- column(+ checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named") |
||
| 141 | -! | +|||
| 95 | +
- width = 3,+ |
|||
| 142 | -! | +|||
| 96 | +7x |
- datasets$ui_filter_panel(ns("module_filter_panel")),
+ moduleServer(id, function(input, output, session) {
|
||
| 143 | -! | +|||
| 97 | +7x |
- class = "teal_secondary_col"+ ns <- session$ns |
||
| 144 | +98 |
- )+ |
||
| 145 | +99 |
- )+ # Store global filter states. |
||
| 146 | -+ | |||
| 100 | +7x |
- } else {
+ filter <- isolate(slices_global()) |
||
| 147 | -1x | +101 | +7x |
- teal_ui+ snapshot_history <- reactiveVal({
|
| 148 | -+ | |||
| 102 | +7x |
- }+ list( |
||
| 149 | -+ | |||
| 103 | +7x |
- }+ "Initial application state" = as.list(filter, recursive = TRUE) |
||
| 150 | +104 |
-
+ ) |
||
| 151 | +105 |
- #' @rdname module_nested_tabs+ }) |
||
| 152 | +106 |
- srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,+ |
||
| 153 | +107 |
- reporter = teal.reporter::Reporter$new()) {
+ # Snapshot current application state - name snaphsot. |
||
| 154 | -54x | +108 | +7x |
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ observeEvent(input$snapshot_add, {
|
| 155 | -54x | +|||
| 109 | +! |
- checkmate::assert_class(reporter, "Reporter")+ showModal( |
||
| 156 | -53x | -
- UseMethod("srv_nested_tabs", modules)
- |
- ||
| 157 | -+ | |||
| 110 | +! |
- }+ modalDialog( |
||
| 158 | -+ | |||
| 111 | +! |
-
+ textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
|
||
| 159 | -+ | |||
| 112 | +! |
- #' @rdname module_nested_tabs+ footer = tagList( |
||
| 160 | -+ | |||
| 113 | +! |
- #' @export+ actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
|
||
| 161 | -+ | |||
| 114 | +! |
- srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,+ modalButton(label = "Cancel", icon = icon("thumbs-down"))
|
||
| 162 | +115 |
- reporter = teal.reporter::Reporter$new()) {
+ ), |
||
| 163 | +116 | ! |
- stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ size = "s" |
|
| 164 | +117 |
- }+ ) |
||
| 165 | +118 |
-
+ ) |
||
| 166 | +119 |
- #' @rdname module_nested_tabs+ }) |
||
| 167 | +120 |
- #' @export+ # Snapshot current application state - store snaphsot. |
||
| 168 | -+ | |||
| 121 | +7x |
- srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,+ observeEvent(input$snapshot_name_accept, {
|
||
| 169 | -+ | |||
| 122 | +! |
- reporter = teal.reporter::Reporter$new()) {
+ snapshot_name <- trimws(input$snapshot_name) |
||
| 170 | -24x | +|||
| 123 | +! |
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ if (identical(snapshot_name, "")) {
|
||
| 171 | -+ | |||
| 124 | +! |
-
+ showNotification( |
||
| 172 | -24x | +|||
| 125 | +! |
- moduleServer(id = id, module = function(input, output, session) {
+ "Please name the snapshot.", |
||
| 173 | -24x | +|||
| 126 | +! |
- logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
+ type = "message" |
||
| 174 | +127 |
-
+ ) |
||
| 175 | -24x | +|||
| 128 | +! |
- labels <- vapply(modules$children, `[[`, character(1), "label")+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
||
| 176 | -24x | +|||
| 129 | +! |
- modules_reactive <- sapply(+ } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
|
||
| 177 | -24x | +|||
| 130 | +! |
- names(modules$children),+ showNotification( |
||
| 178 | -24x | +|||
| 131 | +! |
- function(module_id) {
+ "This name is in conflict with other snapshot names. Please choose a different one.", |
||
| 179 | -35x | +|||
| 132 | +! |
- srv_nested_tabs(+ type = "message" |
||
| 180 | -35x | +|||
| 133 | +
- id = module_id,+ ) |
|||
| 181 | -35x | +|||
| 134 | +! |
- datasets = datasets[[labels[module_id]]],+ updateTextInput(inputId = "snapshot_name", value = , placeholder = "Meaningful, unique name") |
||
| 182 | -35x | +|||
| 135 | +
- modules = modules$children[[module_id]],+ } else {
|
|||
| 183 | -35x | +|||
| 136 | +! |
- is_module_specific = is_module_specific,+ snapshot <- as.list(slices_global(), recursive = TRUE) |
||
| 184 | -35x | +|||
| 137 | +! |
- reporter = reporter+ attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix()) |
||
| 185 | -+ | |||
| 138 | +! |
- )+ snapshot_update <- c(snapshot_history(), list(snapshot))+ |
+ ||
| 139 | +! | +
+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ |
+ ||
| 140 | +! | +
+ snapshot_history(snapshot_update)+ |
+ ||
| 141 | +! | +
+ removeModal() |
||
| 186 | +142 |
- },+ # Reopen filter manager modal by clicking button in the main application. |
||
| 187 | -24x | +|||
| 143 | +! |
- simplify = FALSE+ shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE) |
||
| 188 | +144 |
- )+ } |
||
| 189 | +145 |
-
+ }) |
||
| 190 | +146 |
- # when not ready input$active_tab would return NULL - this would fail next reactive+ |
||
| 191 | -24x | +|||
| 147 | +
- input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)+ # Restore initial state. |
|||
| 192 | -24x | +148 | +7x |
- get_active_module <- reactive({
+ observeEvent(input$snapshot_reset, {
|
| 193 | -13x | +|||
| 149 | +! |
- if (length(modules$children) == 1L) {
+ s <- "Initial application state" |
||
| 194 | +150 |
- # single tab is active by default+ ### Begin restore procedure. ### |
||
| 195 | -2x | +|||
| 151 | +! |
- modules_reactive[[1]]()+ snapshot <- snapshot_history()[[s]] |
||
| 196 | -+ | |||
| 152 | +! |
- } else {
+ snapshot_state <- as.teal_slices(snapshot) |
||
| 197 | -+ | |||
| 153 | +! |
- # switch to active tab+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
||
| 198 | -11x | +|||
| 154 | +! |
- modules_reactive[[input_validated()]]()+ mapply( |
||
| 199 | -+ | |||
| 155 | +! |
- }+ function(filtered_data, filter_ids) {
+ |
+ ||
| 156 | +! | +
+ filtered_data$clear_filter_states(force = TRUE)+ |
+ ||
| 157 | +! | +
+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ |
+ ||
| 158 | +! | +
+ filtered_data$set_filter_state(slices) |
||
| 200 | +159 |
- })+ },+ |
+ ||
| 160 | +! | +
+ filtered_data = filtered_data_list,+ |
+ ||
| 161 | +! | +
+ filter_ids = mapping_unfolded |
||
| 201 | +162 |
-
+ ) |
||
| 202 | -24x | +|||
| 163 | +! |
- get_active_module+ slices_global(snapshot_state)+ |
+ ||
| 164 | +! | +
+ removeModal() |
||
| 203 | +165 |
- })+ ### End restore procedure. ### |
||
| 204 | +166 |
- }+ }) |
||
| 205 | +167 | |||
| 206 | +168 |
- #' @rdname module_nested_tabs+ # Create UI elements and server logic for the snapshot table. |
||
| 207 | +169 |
- #' @export+ # Observers must be tracked to avoid duplication and excess reactivity. |
||
| 208 | +170 |
- srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,+ # Remaining elements are tracked likewise for consistency and a slight speed margin. |
||
| 209 | -+ | |||
| 171 | +7x |
- reporter = teal.reporter::Reporter$new()) {
+ observers <- reactiveValues() |
||
| 210 | -29x | +172 | +7x |
- checkmate::assert_class(datasets, "FilteredData")+ handlers <- reactiveValues() |
| 211 | -29x | +173 | +7x |
- logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
+ divs <- reactiveValues() |
| 212 | +174 | |||
| 213 | -29x | +175 | +7x |
- moduleServer(id = id, module = function(input, output, session) {
+ observeEvent(snapshot_history(), {
|
| 214 | -29x | +176 | +3x |
- modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets)+ lapply(names(snapshot_history())[-1L], function(s) {
|
| 215 | -29x | +|||
| 177 | +! |
- if (!is.null(modules$datanames) && is_module_specific) {
+ id_pickme <- sprintf("pickme_%s", make.names(s))
|
||
| 216 | +178 | ! |
- datasets$srv_filter_panel("module_filter_panel", active_datanames = reactive(modules$datanames))
+ id_saveme <- sprintf("saveme_%s", make.names(s))
|
|
| 217 | -+ | |||
| 179 | +! |
- }+ id_rowme <- sprintf("rowme_%s", make.names(s))
|
||
| 218 | +180 | |||
| 219 | +181 |
- # Create two triggers to limit reactivity between filter-panel and modules.+ # Observer for restoring snapshot. |
||
| 220 | -+ | |||
| 182 | +! |
- # We want to recalculate only visible modules+ if (!is.element(id_pickme, names(observers))) {
|
||
| 221 | -+ | |||
| 183 | +! |
- # - trigger the data when the tab is selected+ observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
|
||
| 222 | +184 |
- # - trigger module to be called when the tab is selected for the first time+ ### Begin restore procedure. ### |
||
| 223 | -29x | +|||
| 185 | +! |
- trigger_data <- reactiveVal(1L)+ snapshot <- snapshot_history()[[s]] |
||
| 224 | -29x | +|||
| 186 | +! |
- trigger_module <- reactiveVal(NULL)+ snapshot_state <- as.teal_slices(snapshot) |
||
| 225 | -29x | +|||
| 187 | +! |
- output$data_reactive <- renderUI({
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
||
| 226 | -18x | +|||
| 188 | +! |
- lapply(datasets$datanames(), function(x) {
+ mapply( |
||
| 227 | -22x | +|||
| 189 | +! |
- datasets$get_data(x, filtered = TRUE)+ function(filtered_data, filter_ids) {
|
||
| 228 | -+ | |||
| 190 | +! |
- })+ filtered_data$clear_filter_states(force = TRUE) |
||
| 229 | -18x | +|||
| 191 | +! |
- isolate(trigger_data(trigger_data() + 1))+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state) |
||
| 230 | -18x | +|||
| 192 | +! |
- isolate(trigger_module(TRUE))+ filtered_data$set_filter_state(slices) |
||
| 231 | +193 |
-
+ }, |
||
| 232 | -18x | +|||
| 194 | +! |
- NULL+ filtered_data = filtered_data_list, |
||
| 233 | -+ | |||
| 195 | +! |
- })+ filter_ids = mapping_unfolded |
||
| 234 | +196 |
-
+ ) |
||
| 235 | -+ | |||
| 197 | +! |
- # collect arguments to run teal_module+ slices_global(snapshot_state) |
||
| 236 | -29x | +|||
| 198 | +! |
- args <- c(list(id = "module"), modules$server_args)+ removeModal() |
||
| 237 | -29x | +|||
| 199 | +
- if (is_arg_used(modules$server, "reporter")) {
+ ### End restore procedure. ### |
|||
| 238 | -! | +|||
| 200 | +
- args <- c(args, list(reporter = reporter))+ }) |
|||
| 239 | +201 |
- }+ } |
||
| 240 | +202 |
-
+ # Create handler for downloading snapshot. |
||
| 241 | -29x | +|||
| 203 | +! |
- if (is_arg_used(modules$server, "datasets")) {
+ if (!is.element(id_saveme, names(handlers))) {
|
||
| 242 | -2x | +|||
| 204 | +! |
- args <- c(args, datasets = datasets)+ output[[id_saveme]] <- downloadHandler( |
||
| 243 | -+ | |||
| 205 | +! |
- }+ filename = function() {
+ |
+ ||
| 206 | +! | +
+ sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
|
||
| 244 | +207 |
-
+ }, |
||
| 245 | -29x | +|||
| 208 | +! |
- if (is_arg_used(modules$server, "data")) {
+ content = function(file) {
|
||
| 246 | -8x | +|||
| 209 | +! |
- data <- .datasets_to_data(modules, datasets, trigger_data)+ snapshot <- snapshot_history()[[s]] |
||
| 247 | -8x | +|||
| 210 | +! |
- args <- c(args, data = list(data))+ snapshot_state <- as.teal_slices(snapshot) |
||
| 248 | -+ | |||
| 211 | +! |
- }+ slices_store(tss = snapshot_state, file = file) |
||
| 249 | +212 |
-
+ } |
||
| 250 | -29x | +|||
| 213 | +
- if (is_arg_used(modules$server, "filter_panel_api")) {
+ ) |
|||
| 251 | -2x | +|||
| 214 | +! |
- filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)+ handlers[[id_saveme]] <- id_saveme |
||
| 252 | -2x | +|||
| 215 | +
- args <- c(args, filter_panel_api = filter_panel_api)+ } |
|||
| 253 | +216 |
- }+ # Create a row for the snapshot table. |
||
| 254 | -+ | |||
| 217 | +! |
-
+ if (!is.element(id_rowme, names(divs))) {
|
||
| 255 | -29x | +|||
| 218 | +! |
- if (is_arg_used(modules$server, "datasets") && is_arg_used(modules$server, "data")) {
+ divs[[id_rowme]] <- div( |
||
| 256 | -1x | +|||
| 219 | +! |
- warning(+ class = "snapshot_table_row", |
||
| 257 | -1x | +|||
| 220 | +! |
- "Module '", modules$label, "' has `data` and `datasets` arguments in the formals.",+ span(h5(s)), |
||
| 258 | -1x | +|||
| 221 | +! |
- "\nIt's recommended to use `data` to work with filtered objects."+ actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
|
||
| 259 | -+ | |||
| 222 | +! |
- )+ downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
|
||
| 260 | +223 |
- }+ ) |
||
| 261 | +224 |
-
+ } |
||
| 262 | +225 |
- # observe the trigger_module above to induce the module once the renderUI is triggered+ }) |
||
| 263 | -29x | +|||
| 226 | +
- observeEvent(+ }) |
|||
| 264 | -29x | +|||
| 227 | +
- ignoreNULL = TRUE,+ |
|||
| 265 | -29x | +|||
| 228 | +
- once = TRUE,+ # Create table to display list of snapshots and their actions. |
|||
| 266 | -29x | +229 | +7x |
- eventExpr = trigger_module(),+ output$snapshot_list <- renderUI({
|
| 267 | -29x | +230 | +3x |
- handlerExpr = {
+ rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d) |
| 268 | -18x | +231 | +3x |
- module_output <- if (is_arg_used(modules$server, "id")) {
+ if (length(rows) == 0L) {
|
| 269 | -18x | +232 | +3x |
- do.call(modules$server, args)+ div( |
| 270 | -+ | |||
| 233 | +3x |
- } else {
+ class = "snapshot_manager_placeholder", |
||
| 271 | -! | +|||
| 234 | +3x |
- do.call(callModule, c(args, list(module = modules$server)))+ "Snapshots will appear here." |
||
| 272 | +235 |
- }+ ) |
||
| 273 | +236 |
- }+ } else {
|
||
| 274 | -+ | |||
| 237 | +! |
- )+ rows |
||
| 275 | +238 |
-
+ } |
||
| 276 | -29x | +|||
| 239 | +
- reactive(modules)+ }) |
|||
| 277 | +240 |
}) |
||
| 278 | +241 |
} |
||
| 279 | +242 | |||
| 280 | +243 |
- #' Convert `FilteredData` to reactive list of datasets of the `tdata` type.+ |
||
| 281 | +244 |
- #'+ |
||
| 282 | +245 |
- #' Converts `FilteredData` object to `tdata` object containing datasets needed for a specific module.+ |
||
| 283 | +246 |
- #' Please note that if module needs dataset which has a parent, then parent will be also returned.+ ### utility functions ---- |
||
| 284 | +247 |
- #' A hash per `dataset` is calculated internally and returned in the code.+ |
||
| 285 | +248 |
- #'+ #' Explicitly enumerate global filters. |
||
| 286 | +249 |
- #' @param module (`teal_module`) module where needed filters are taken from+ #' |
||
| 287 | +250 |
- #' @param datasets (`FilteredData`) object where needed data are taken from+ #' Transform module mapping such that global filters are explicitly specified for every module. |
||
| 288 | +251 |
- #' @param trigger_data (`reactiveVal`) to trigger getting the filtered data+ #' |
||
| 289 | +252 |
- #' @return list of reactive datasets with following attributes:+ #' @param mapping (`named list`) as stored in mapping parameter of `teal_slices` |
||
| 290 | +253 |
- #' - `code` (`character`) containing datasets reproducible code.+ #' @param module_names (`character`) vector containing names of all modules in the app |
||
| 291 | +254 |
- #' - `join_keys` (`JoinKeys`) containing relationships between datasets.+ #' @return A `named_list` with one element per module, each element containing all filters applied to that module. |
||
| 292 | +255 |
- #' - `metadata` (`list`) containing metadata of datasets.+ #' @keywords internal |
||
| 293 | +256 |
#' |
||
| 294 | +257 |
- #' @keywords internal+ unfold_mapping <- function(mapping, module_names) {
|
||
| 295 | -+ | |||
| 258 | +! |
- .datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) {
+ module_names <- structure(module_names, names = module_names) |
||
| 296 | -13x | +|||
| 259 | +! |
- checkmate::assert_class(module, "teal_module")+ lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]])) |
||
| 297 | -13x | +|||
| 260 | +
- checkmate::assert_class(datasets, "FilteredData")+ } |
|||
| 298 | -13x | +|||
| 261 | +
- checkmate::assert_class(trigger_data, "reactiveVal")+ |
|||
| 299 | +262 |
-
+ #' Convert mapping matrix to filter mapping specification. |
||
| 300 | -12x | +|||
| 263 | +
- datanames <- if (is.null(module$datanames)) datasets$datanames() else module$datanames+ #' |
|||
| 301 | +264 |
-
+ #' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module, |
||
| 302 | +265 |
- # list of reactive filtered data+ #' to a list specification like the one used in the `mapping` attribute of `teal_slices`. |
||
| 303 | -12x | +|||
| 266 | +
- data <- sapply(+ #' Global filters are gathered in one list element. |
|||
| 304 | -12x | +|||
| 267 | +
- datanames,+ #' If a module has no active filters but the global ones, it will not be mentioned in the output. |
|||
| 305 | -12x | +|||
| 268 | +
- function(x) eventReactive(trigger_data(), datasets$get_data(x, filtered = TRUE)),+ #' |
|||
| 306 | -12x | +|||
| 269 | +
- simplify = FALSE+ #' @param mapping_matrix (`data.frame`) of logical vectors where |
|||
| 307 | +270 |
- )+ #' columns represent modules and row represent `teal_slice`s |
||
| 308 | +271 |
-
+ #' @return `named list` like that in the `mapping` attribute of a `teal_slices` object. |
||
| 309 | -12x | +|||
| 272 | +
- hashes <- calculate_hashes(datanames, datasets)- |
- |||
| 310 | -12x | -
- metadata <- lapply(datanames, datasets$get_metadata)- |
- ||
| 311 | -12x | -
- names(metadata) <- datanames- |
- ||
| 312 | -- | - - | -||
| 313 | -12x | -
- new_tdata(- |
- ||
| 314 | -12x | -
- data,- |
- ||
| 315 | -12x | -
- eventReactive(- |
- ||
| 316 | -12x | -
- trigger_data(),- |
- ||
| 317 | -12x | -
- c(- |
- ||
| 318 | -12x | -
- get_rcode_str_install(),- |
- ||
| 319 | -12x | -
- get_rcode_libraries(),- |
- ||
| 320 | -12x | -
- get_datasets_code(datanames, datasets, hashes),- |
- ||
| 321 | -12x | -
- teal.slice::get_filter_expr(datasets, datanames)- |
- ||
| 322 | -- |
- )- |
- ||
| 323 | -- |
- ),- |
- ||
| 324 | -12x | -
- datasets$get_join_keys(),- |
- ||
| 325 | -12x | -
- metadata- |
- ||
| 326 | -- |
- )- |
- ||
| 327 | -- |
- }- |
- ||
| 328 | -- | - - | -||
| 329 | -- |
- #' Get the hash of a dataset+ #' @keywords internal |
||
| 330 | +273 |
#' |
||
| 331 | +274 |
- #' @param datanames (`character`) names of datasets+ matrix_to_mapping <- function(mapping_matrix) {
|
||
| 332 | -+ | |||
| 275 | +! |
- #' @param datasets (`FilteredData`) object holding the data+ mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x)) |
||
| 333 | -+ | |||
| 276 | +! |
- #'+ global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L)) |
||
| 334 | -+ | |||
| 277 | +! |
- #' @return A list of hashes per dataset+ global_filters <- names(global[global]) |
||
| 335 | -+ | |||
| 278 | +! |
- #' @keywords internal+ local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ] |
||
| 336 | +279 |
- #'+ |
||
| 337 | -+ | |||
| 280 | +! |
- calculate_hashes <- function(datanames, datasets) {
+ mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters)) |
||
| 338 | -16x | +|||
| 281 | +! |
- sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)+ Filter(function(x) length(x) != 0L, mapping) |
||
| 339 | +282 |
}@@ -9967,14 +9701,14 @@ teal coverage - 72.73% |
| 1 |
- #' Add right filter panel into each of the top-level `teal_modules` UIs.+ #' Create a UI of nested tabs of `teal_modules` |
||
| 3 |
- #' The [ui_nested_tabs] function returns a nested tabbed UI corresponding+ #' @section `ui_nested_tabs`: |
||
| 4 |
- #' to the nested modules.+ #' Each `teal_modules` is translated to a `tabsetPanel` and each |
||
| 5 |
- #' This function adds the right filter panel to each main tab.+ #' of its children is another tab-module called recursively. The UI of a |
||
| 6 |
- #'+ #' `teal_module` is obtained by calling the `ui` function on it. |
||
| 7 |
- #' The right filter panel's filter choices affect the `datasets` object. Therefore,+ #' |
||
| 8 |
- #' all modules using the same `datasets` share the same filters.+ #' The `datasets` argument is required to resolve the teal arguments in an |
||
| 9 |
- #'+ #' isolated context (with respect to reactivity) |
||
| 10 |
- #' This works with nested modules of depth greater than 2, though the filter+ #' |
||
| 11 |
- #' panel is inserted at the right of the modules at depth 1 and not at the leaves.+ #' @section `srv_nested_tabs`: |
||
| 12 |
- #'+ #' This module calls recursively all elements of the `modules` returns one which |
||
| 13 |
- #' @name module_tabs_with_filters+ #' is currently active. |
||
| 14 |
- #'+ #' - `teal_module` returns self as a active module. |
||
| 15 |
- #' @inheritParams module_teal+ #' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`. |
||
| 17 |
- #' @param datasets (`named list` of `FilteredData`)\cr+ #' @name module_nested_tabs |
||
| 18 |
- #' object to store filter state and filtered datasets, shared across modules. For more+ #' |
||
| 19 |
- #' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure+ #' @inheritParams module_tabs_with_filters |
||
| 20 |
- #' of the `modules` argument and list names must correspond to the labels in `modules`.+ #' |
||
| 21 |
- #' When filter is not module-specific then list contains the same object in all elements.+ #' @param depth (`integer(1)`)\cr |
||
| 22 |
- #' @param reporter (`Reporter`) object from `teal.reporter`+ #' number which helps to determine depth of the modules nesting. |
||
| 23 |
- #'+ #' @param is_module_specific (`logical(1)`)\cr |
||
| 24 |
- #' @return A `tagList` of The main menu, place holders for filters and+ #' flag determining if the filter panel is global or module-specific. |
||
| 25 |
- #' place holders for the teal modules+ #' When set to `TRUE`, a filter panel is called inside of each module tab. |
||
| 26 |
- #'+ #' @return depending on class of `modules`, `ui_nested_tabs` returns: |
||
| 27 |
- #'+ #' - `teal_module`: instantiated UI of the module |
||
| 28 |
- #' @keywords internal+ #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively |
||
| 29 |
- #'+ #' calling this function on it.\cr |
||
| 30 |
- #' @examples+ #' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab. |
||
| 32 |
- #' mods <- teal:::example_modules()+ #' @examples |
||
| 33 |
- #' datasets <- teal:::example_datasets()+ #' mods <- teal:::example_modules() |
||
| 34 |
- #'+ #' datasets <- teal:::example_datasets() |
||
| 41 |
- #' ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
+ #' teal:::ui_nested_tabs("dummy", modules = mods, datasets = datasets)
|
||
| 46 |
- #' output$info <- renderText({
+ #' active_module <- teal:::srv_nested_tabs( |
||
| 47 |
- #' paste0("The currently active tab name is ", active_module()$label)
+ #' "dummy", |
||
| 48 |
- #' })+ #' datasets = datasets, |
||
| 49 |
- #' active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods)+ #' modules = mods |
||
| 50 |
- #' }+ #' ) |
||
| 51 |
- #' )+ #' output$info <- renderText({
|
||
| 52 |
- #' if (interactive()) {
+ #' paste0("The currently active tab name is ", active_module()$label)
|
||
| 53 |
- #' runApp(app)+ #' }) |
||
| 54 |
- #' }+ #' } |
||
| 55 |
- #'+ #' ) |
||
| 56 |
- NULL+ #' if (interactive()) {
|
||
| 57 |
-
+ #' runApp(app) |
||
| 58 |
- #' @rdname module_tabs_with_filters+ #' } |
||
| 59 |
- ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
+ #' @keywords internal |
||
| 60 | -1x | +
- checkmate::assert_class(modules, "teal_modules")+ NULL |
|
| 61 | -1x | +
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+
|
|
| 62 | -1x | +
- checkmate::assert_class(filter, "teal_slices")+ #' @rdname module_nested_tabs |
|
| 63 |
-
+ ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 64 | -1x | +2x |
- ns <- NS(id)+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
| 65 | -1x | +2x |
- is_module_specific <- isTRUE(attr(filter, "module_specific"))+ checkmate::assert_count(depth) |
| 66 | -+ | 2x |
-
+ UseMethod("ui_nested_tabs", modules)
|
| 67 | -1x | +
- teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
+ } |
|
| 68 | -1x | +
- filter_panel_btns <- tags$li(+ |
|
| 69 | -1x | +
- class = "flex-grow",+ #' @rdname module_nested_tabs |
|
| 70 | -1x | +
- tags$button(+ #' @export |
|
| 71 | -1x | +
- class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger+ ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
|
| 72 | -1x | +! |
- href = "javascript:void(0)",+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
|
| 73 | -1x | +
- onclick = "toggleFilterPanel();", # see sidebar.js+ } |
|
| 74 | -1x | +
- title = "Toggle filter panels",+ |
|
| 75 | -1x | +
- icon("fas fa-bars")
+ #' @rdname module_nested_tabs |
|
| 76 |
- ),+ #' @export |
||
| 77 | -1x | +
- filter_manager_modal_ui(ns("filter_manager"))
+ ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
|
| 78 | -+ | 1x |
- )+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
| 79 | 1x |
- teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)+ ns <- NS(id) |
|
| 80 | -+ | 1x |
-
+ do.call( |
| 81 | 1x |
- if (!is_module_specific) {
+ tabsetPanel, |
|
| 82 | -+ | 1x |
- # need to rearrange html so that filter panel is within tabset+ c( |
| 83 | -1x | +
- tabset_bar <- teal_ui$children[[1]]+ # by giving an id, we can reactively respond to tab changes |
|
| 84 | 1x |
- teal_modules <- teal_ui$children[[2]]+ list( |
|
| 85 | 1x |
- filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
+ id = ns("active_tab"),
|
|
| 86 | 1x |
- list(+ type = if (modules$label == "root") "pills" else "tabs" |
|
| 87 | -1x | +
- tabset_bar,+ ), |
|
| 88 | 1x |
- tags$hr(class = "my-2"),+ lapply( |
|
| 89 | 1x |
- fluidRow(+ names(modules$children), |
|
| 90 | 1x |
- column(width = 9, teal_modules, class = "teal_primary_col"),+ function(module_id) {
|
|
| 91 | 1x |
- column(width = 3, filter_ui, class = "teal_secondary_col")+ module_label <- modules$children[[module_id]]$label |
|
| 92 | -+ | 1x |
- )+ tabPanel( |
| 93 | -+ | 1x |
- )+ title = module_label, |
| 94 | -+ | 1x |
- } else {
+ value = module_id, # when clicked this tab value changes input$<tabset panel id> |
| 95 | -! | +1x |
- teal_ui+ ui_nested_tabs( |
| 96 | -+ | 1x |
- }+ id = ns(module_id), |
| 97 | -+ | 1x |
- }+ modules = modules$children[[module_id]], |
| 98 | -+ | 1x |
-
+ datasets = datasets[[module_label]], |
| 99 | -+ | 1x |
- #' @rdname module_tabs_with_filters+ depth = depth + 1L, |
| 100 | -+ | 1x |
- srv_tabs_with_filters <- function(id,+ is_module_specific = is_module_specific |
| 101 |
- datasets,+ ) |
||
| 102 |
- modules,+ ) |
||
| 103 |
- reporter = teal.reporter::Reporter$new(),+ } |
||
| 104 |
- filter = teal_slices()) {
+ ) |
||
| 105 | -6x | +
- checkmate::assert_class(modules, "teal_modules")+ ) |
|
| 106 | -6x | +
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ ) |
|
| 107 | -6x | +
- checkmate::assert_class(reporter, "Reporter")+ } |
|
| 108 | -4x | +
- checkmate::assert_class(filter, "teal_slices")+ |
|
| 109 |
-
+ #' @rdname module_nested_tabs |
||
| 110 | -4x | +
- moduleServer(id, function(input, output, session) {
+ #' @export |
|
| 111 | -4x | +
- logger::log_trace("srv_tabs_with_filters initializing the module.")
+ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
|
| 112 | -+ | 1x |
-
+ checkmate::assert_class(datasets, class = "FilteredData") |
| 113 | -4x | +1x |
- is_module_specific <- isTRUE(attr(filter, "module_specific"))+ ns <- NS(id) |
| 114 | -4x | +
- manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
+
|
|
| 115 | -+ | 1x |
-
+ args <- isolate(teal.transform::resolve_delayed(modules$ui_args, datasets)) |
| 116 | -4x | +1x |
- active_module <- srv_nested_tabs(+ args <- c(list(id = ns("module")), args)
|
| 117 | -4x | +
- id = "root",+ |
|
| 118 | -4x | +1x |
- datasets = datasets,+ if (is_arg_used(modules$ui, "datasets")) {
|
| 119 | -4x | +! |
- modules = modules,+ args <- c(args, datasets = datasets) |
| 120 | -4x | +
- reporter = reporter,+ } |
|
| 121 | -4x | +
- is_module_specific = is_module_specific+ |
|
| 122 | -+ | 1x |
- )+ if (is_arg_used(modules$ui, "data")) {
|
| 123 | -+ | ! |
-
+ data <- .datasets_to_data(modules, datasets) |
| 124 | -4x | +! |
- if (!is_module_specific) {
+ args <- c(args, data = list(data)) |
| 125 | -4x | +
- active_datanames <- reactive(active_module()$datanames)+ } |
|
| 126 | -4x | +
- singleton <- unlist(datasets)[[1]]+ |
|
| 127 | -4x | +1x |
- singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
+ teal_ui <- tags$div( |
| 128 | -+ | 1x |
-
+ id = id, |
| 129 | -4x | +1x |
- observeEvent(+ class = "teal_module", |
| 130 | -4x | +1x |
- eventExpr = active_datanames(),+ uiOutput(ns("data_reactive"), inline = TRUE),
|
| 131 | -4x | +1x |
- handlerExpr = {
+ tagList( |
| 132 | -5x | +1x |
- script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
+ if (depth >= 2L) div(style = "mt-6"), |
| 133 | -+ | 1x |
- # hide the filter panel and disable the burger button+ do.call(modules$ui, args) |
| 134 | -1x | +
- "handleNoActiveDatasets();"+ ) |
|
| 135 |
- } else {
+ ) |
||
| 136 |
- # show the filter panel and enable the burger button+ |
||
| 137 | -4x | +1x |
- "handleActiveDatasetsPresent();"+ if (!is.null(modules$datanames) && is_module_specific) {
|
| 138 | -+ | ! |
- }+ fluidRow( |
| 139 | -5x | +! |
- shinyjs::runjs(script)+ column(width = 9, teal_ui, class = "teal_primary_col"), |
| 140 | -+ | ! |
- },+ column( |
| 141 | -4x | +! |
- ignoreNULL = FALSE+ width = 3, |
| 142 | -+ | ! |
- )+ datasets$ui_filter_panel(ns("module_filter_panel")),
|
| 143 | -+ | ! |
- }+ class = "teal_secondary_col" |
| 144 |
-
+ ) |
||
| 145 | -4x | +
- showNotification("Data loaded - App fully started up")
+ ) |
|
| 146 | -4x | +
- logger::log_trace("srv_tabs_with_filters initialized the module")
+ } else {
|
|
| 147 | -4x | +1x |
- return(active_module)+ teal_ui |
| 148 |
- })+ } |
||
| 1 | +150 |
- #' Creates a `teal_modules` object.+ |
||
| 2 | +151 |
- #'+ #' @rdname module_nested_tabs |
||
| 3 | +152 |
- #' @description `r lifecycle::badge("stable")`
+ srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE, |
||
| 4 | +153 |
- #' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object+ reporter = teal.reporter::Reporter$new()) {
|
||
| 5 | -+ | |||
| 154 | +54x |
- #' containing the passed objects.+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
||
| 6 | -+ | |||
| 155 | +54x |
- #'+ checkmate::assert_class(reporter, "Reporter") |
||
| 7 | -+ | |||
| 156 | +53x |
- #' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules`+ UseMethod("srv_nested_tabs", modules)
|
||
| 8 | +157 |
- #' shapes the navigation panel of a `teal` application.+ } |
||
| 9 | +158 |
- #'+ |
||
| 10 | +159 |
- #' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details+ #' @rdname module_nested_tabs |
||
| 11 | +160 |
- #' @param label (`character(1)`) label of modules collection (default `"root"`).+ #' @export |
||
| 12 | +161 |
- #' If using the `label` argument then it must be explicitly named.+ srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE, |
||
| 13 | +162 |
- #' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
+ reporter = teal.reporter::Reporter$new()) {
|
||
| 14 | -+ | |||
| 163 | +! |
- #'+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
|
||
| 15 | +164 |
- #' @export+ } |
||
| 16 | +165 |
- #'+ |
||
| 17 | +166 |
- #' @return object of class \code{teal_modules}. Object contains following fields
+ #' @rdname module_nested_tabs |
||
| 18 | +167 |
- #' - `label`: taken from the `label` argument+ #' @export |
||
| 19 | +168 |
- #' - `children`: a list containing objects passed in `...`. List elements are named after+ srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE, |
||
| 20 | +169 |
- #' their `label` attribute converted to a valid `shiny` id.+ reporter = teal.reporter::Reporter$new()) {
|
||
| 21 | -+ | |||
| 170 | +24x |
- #' @examples+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
||
| 22 | +171 |
- #' library(shiny)+ |
||
| 23 | -+ | |||
| 172 | +24x |
- #'+ moduleServer(id = id, module = function(input, output, session) {
|
||
| 24 | -+ | |||
| 173 | +24x |
- #' app <- init(+ logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
|
||
| 25 | +174 |
- #' data = teal_data(dataset("iris", iris)),
+
|
||
| 26 | -+ | |||
| 175 | +24x |
- #' modules = modules(+ labels <- vapply(modules$children, `[[`, character(1), "label") |
||
| 27 | -+ | |||
| 176 | +24x |
- #' label = "Modules",+ modules_reactive <- sapply( |
||
| 28 | -+ | |||
| 177 | +24x |
- #' modules(+ names(modules$children), |
||
| 29 | -+ | |||
| 178 | +24x |
- #' label = "Module",+ function(module_id) {
|
||
| 30 | -+ | |||
| 179 | +35x |
- #' module(+ srv_nested_tabs( |
||
| 31 | -+ | |||
| 180 | +35x |
- #' label = "Inner module",+ id = module_id, |
||
| 32 | -+ | |||
| 181 | +35x |
- #' server = function(id, data) {
+ datasets = datasets[[labels[module_id]]], |
||
| 33 | -+ | |||
| 182 | +35x |
- #' moduleServer(+ modules = modules$children[[module_id]], |
||
| 34 | -+ | |||
| 183 | +35x |
- #' id,+ is_module_specific = is_module_specific, |
||
| 35 | -+ | |||
| 184 | +35x |
- #' module = function(input, output, session) {
+ reporter = reporter |
||
| 36 | +185 |
- #' output$data <- renderDataTable(data[["iris"]]())+ ) |
||
| 37 | +186 |
- #' }+ }, |
||
| 38 | -+ | |||
| 187 | +24x |
- #' )+ simplify = FALSE |
||
| 39 | +188 |
- #' },+ ) |
||
| 40 | +189 |
- #' ui = function(id) {
+
|
||
| 41 | +190 |
- #' ns <- NS(id)+ # when not ready input$active_tab would return NULL - this would fail next reactive |
||
| 42 | -+ | |||
| 191 | +24x |
- #' tagList(dataTableOutput(ns("data")))
+ input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE) |
||
| 43 | -+ | |||
| 192 | +24x |
- #' },+ get_active_module <- reactive({
|
||
| 44 | -+ | |||
| 193 | +13x |
- #' datanames = "all"+ if (length(modules$children) == 1L) {
|
||
| 45 | +194 |
- #' )+ # single tab is active by default |
||
| 46 | -+ | |||
| 195 | +2x |
- #' ),+ modules_reactive[[1]]() |
||
| 47 | +196 |
- #' module(+ } else {
|
||
| 48 | +197 |
- #' label = "Another module",+ # switch to active tab |
||
| 49 | -+ | |||
| 198 | +11x |
- #' server = function(id) {
+ modules_reactive[[input_validated()]]() |
||
| 50 | +199 |
- #' moduleServer(+ } |
||
| 51 | +200 |
- #' id,+ }) |
||
| 52 | +201 |
- #' module = function(input, output, session) {
+
|
||
| 53 | -+ | |||
| 202 | +24x |
- #' output$text <- renderText("Another module")
+ get_active_module |
||
| 54 | +203 |
- #' }+ }) |
||
| 55 | +204 |
- #' )+ } |
||
| 56 | +205 |
- #' },+ |
||
| 57 | +206 |
- #' ui = function(id) {
+ #' @rdname module_nested_tabs |
||
| 58 | +207 |
- #' ns <- NS(id)+ #' @export |
||
| 59 | +208 |
- #' tagList(textOutput(ns("text")))
+ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE, |
||
| 60 | +209 |
- #' },+ reporter = teal.reporter::Reporter$new()) {
|
||
| 61 | -+ | |||
| 210 | +29x |
- #' datanames = NULL+ checkmate::assert_class(datasets, "FilteredData") |
||
| 62 | -+ | |||
| 211 | +29x |
- #' )+ logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
|
||
| 63 | +212 |
- #' )+ + |
+ ||
| 213 | +29x | +
+ moduleServer(id = id, module = function(input, output, session) {
+ |
+ ||
| 214 | +29x | +
+ modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets)+ |
+ ||
| 215 | +29x | +
+ if (!is.null(modules$datanames) && is_module_specific) {
+ |
+ ||
| 216 | +! | +
+ datasets$srv_filter_panel("module_filter_panel", active_datanames = reactive(modules$datanames))
|
||
| 64 | +217 |
- #' )+ } |
||
| 65 | +218 |
- #' if (interactive()) {
+
|
||
| 66 | +219 |
- #' runApp(app)+ # Create two triggers to limit reactivity between filter-panel and modules. |
||
| 67 | +220 |
- #' }+ # We want to recalculate only visible modules |
||
| 68 | +221 |
- modules <- function(..., label = "root") {
+ # - trigger the data when the tab is selected |
||
| 69 | -79x | +|||
| 222 | +
- checkmate::assert_string(label)+ # - trigger module to be called when the tab is selected for the first time |
|||
| 70 | -77x | +223 | +29x |
- submodules <- list(...)+ trigger_data <- reactiveVal(1L) |
| 71 | -77x | +224 | +29x |
- if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
+ trigger_module <- reactiveVal(NULL) |
| 72 | -2x | +225 | +29x |
- stop(+ output$data_reactive <- renderUI({
|
| 73 | -2x | +226 | +18x |
- "The only character argument to modules() must be 'label' and it must be named, ",+ lapply(datasets$datanames(), function(x) {
|
| 74 | -2x | +227 | +22x |
- "change modules('lab', ...) to modules(label = 'lab', ...)"
+ datasets$get_data(x, filtered = TRUE) |
| 75 | +228 |
- )+ }) |
||
| 76 | -+ | |||
| 229 | +18x |
- }+ isolate(trigger_data(trigger_data() + 1))+ |
+ ||
| 230 | +18x | +
+ isolate(trigger_module(TRUE)) |
||
| 77 | +231 | |||
| 78 | -75x | +232 | +18x |
- checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+ NULL |
| 79 | +233 |
- # name them so we can more easily access the children+ }) |
||
| 80 | +234 |
- # beware however that the label of the submodules should not be changed as it must be kept synced- |
- ||
| 81 | -72x | -
- labels <- vapply(submodules, function(submodule) submodule$label, character(1))+ |
||
| 82 | -72x | +|||
| 235 | +
- names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
+ # collect arguments to run teal_module |
|||
| 83 | -72x | +236 | +29x |
- structure(+ args <- c(list(id = "module"), modules$server_args) |
| 84 | -72x | +237 | +29x |
- list(+ if (is_arg_used(modules$server, "reporter")) {
|
| 85 | -72x | +|||
| 238 | +! |
- label = label,+ args <- c(args, list(reporter = reporter)) |
||
| 86 | -72x | +|||
| 239 | +
- children = submodules+ } |
|||
| 87 | +240 |
- ),+ |
||
| 88 | -72x | +241 | +29x |
- class = "teal_modules"+ if (is_arg_used(modules$server, "datasets")) {
|
| 89 | -+ | |||
| 242 | +2x |
- )+ args <- c(args, datasets = datasets) |
||
| 90 | +243 |
- }+ } |
||
| 91 | +244 | |||
| 92 | -+ | |||
| 245 | +29x |
- #' Function which appends a teal_module onto the children of a teal_modules object- |
- ||
| 93 | -- |
- #' @keywords internal+ if (is_arg_used(modules$server, "data")) {
|
||
| 94 | -+ | |||
| 246 | +8x |
- #' @param modules `teal_modules`+ data <- .datasets_to_data(modules, datasets, trigger_data) |
||
| 95 | -+ | |||
| 247 | +8x |
- #' @param module `teal_module` object to be appended onto the children of `modules`+ args <- c(args, data = list(data)) |
||
| 96 | +248 |
- #' @return `teal_modules` object with `module` appended+ } |
||
| 97 | +249 |
- append_module <- function(modules, module) {
- |
- ||
| 98 | -7x | -
- checkmate::assert_class(modules, "teal_modules")- |
- ||
| 99 | -5x | -
- checkmate::assert_class(module, "teal_module")- |
- ||
| 100 | -3x | -
- modules$children <- c(modules$children, list(module))+ |
||
| 101 | -3x | +250 | +29x |
- labels <- vapply(modules$children, function(submodule) submodule$label, character(1))+ if (is_arg_used(modules$server, "filter_panel_api")) {
|
| 102 | -3x | +251 | +2x |
- names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
+ filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets) |
| 103 | -3x | +252 | +2x |
- modules+ args <- c(args, filter_panel_api = filter_panel_api) |
| 104 | +253 |
- }+ } |
||
| 105 | +254 | |||
| 106 | -+ | |||
| 255 | +29x |
- #' Does the object make use of the `arg`+ if (is_arg_used(modules$server, "datasets") && is_arg_used(modules$server, "data")) {
|
||
| 107 | -+ | |||
| 256 | +1x |
- #'+ warning( |
||
| 108 | -+ | |||
| 257 | +1x |
- #' @param modules (`teal_module` or `teal_modules`) object+ "Module '", modules$label, "' has `data` and `datasets` arguments in the formals.", |
||
| 109 | -+ | |||
| 258 | +1x |
- #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.+ "\nIt's recommended to use `data` to work with filtered objects." |
||
| 110 | +259 |
- #' @return `logical` whether the object makes use of `arg`+ ) |
||
| 111 | +260 |
- #' @rdname is_arg_used+ } |
||
| 112 | +261 |
- #' @keywords internal+ |
||
| 113 | +262 |
- is_arg_used <- function(modules, arg) {
+ # observe the trigger_module above to induce the module once the renderUI is triggered |
||
| 114 | -285x | +263 | +29x |
- checkmate::assert_string(arg)+ observeEvent( |
| 115 | -282x | +264 | +29x |
- if (inherits(modules, "teal_modules")) {
+ ignoreNULL = TRUE, |
| 116 | -19x | +265 | +29x |
- any(unlist(lapply(modules$children, is_arg_used, arg)))+ once = TRUE, |
| 117 | -263x | +266 | +29x |
- } else if (inherits(modules, "teal_module")) {
+ eventExpr = trigger_module(), |
| 118 | -32x | +267 | +29x |
- is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg)+ handlerExpr = {
|
| 119 | -231x | +268 | +18x |
- } else if (is.function(modules)) {
+ module_output <- if (is_arg_used(modules$server, "id")) {
|
| 120 | -229x | +269 | +18x |
- isTRUE(arg %in% names(formals(modules)))+ do.call(modules$server, args) |
| 121 | +270 |
- } else {
+ } else {
|
||
| 122 | -2x | +|||
| 271 | +! |
- stop("is_arg_used function not implemented for this object")
+ do.call(callModule, c(args, list(module = modules$server))) |
||
| 123 | +272 |
- }+ } |
||
| 124 | +273 |
- }+ } |
||
| 125 | +274 |
-
+ ) |
||
| 126 | +275 | |||
| 276 | +29x | +
+ reactive(modules)+ |
+ ||
| 127 | +277 |
- #' Creates a `teal_module` object.+ }) |
||
| 128 | +278 |
- #'+ } |
||
| 129 | +279 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 130 | +280 |
- #' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module.+ #' Convert `FilteredData` to reactive list of datasets of the `tdata` type. |
||
| 131 | +281 |
#' |
||
| 132 | +282 |
- #' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except+ #' Converts `FilteredData` object to `tdata` object containing datasets needed for a specific module. |
||
| 133 | +283 |
- #' `"global_filters"` - read more in `mapping` argument of [teal::teal_slices].+ #' Please note that if module needs dataset which has a parent, then parent will be also returned. |
||
| 134 | +284 |
- #' @param server (`function`) `shiny` module with following arguments:+ #' A hash per `dataset` is calculated internally and returned in the code. |
||
| 135 | +285 |
- #' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]).+ #' |
||
| 136 | +286 |
- #' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module.+ #' @param module (`teal_module`) module where needed filters are taken from |
||
| 137 | +287 |
- #' - `data` (optional) module will receive a `tdata` object, a list of reactive (filtered) data specified in+ #' @param datasets (`FilteredData`) object where needed data are taken from |
||
| 138 | +288 |
- #' the `filters` argument.+ #' @param trigger_data (`reactiveVal`) to trigger getting the filtered data |
||
| 139 | +289 |
- #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ #' @return list of reactive datasets with following attributes: |
||
| 140 | +290 |
- #' - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]).+ #' - `code` (`character`) containing datasets reproducible code. |
||
| 141 | +291 |
- # - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).+ #' - `join_keys` (`JoinKeys`) containing relationships between datasets. |
||
| 142 | +292 |
- #' - `...` (optional) `server_args` elements will be passed to the module named argument or to the `...`.+ #' - `metadata` (`list`) containing metadata of datasets. |
||
| 143 | +293 |
- #' @param ui (`function`) Shiny `ui` module function with following arguments:+ #' |
||
| 144 | +294 |
- #' - `id` - teal will set proper shiny namespace for this module.+ #' @keywords internal |
||
| 145 | +295 |
- #' - `data` (optional) module will receive list of reactive (filtered) data specified in the `filters` argument.+ .datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) {
|
||
| 146 | -+ | |||
| 296 | +13x |
- #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ checkmate::assert_class(module, "teal_module") |
||
| 147 | -+ | |||
| 297 | +13x |
- #' - `...` (optional) `ui_args` elements will be passed to the module named argument or to the `...`.+ checkmate::assert_class(datasets, "FilteredData") |
||
| 148 | -+ | |||
| 298 | +13x |
- #' @param filters (`character`) Deprecated. Use `datanames` instead.+ checkmate::assert_class(trigger_data, "reactiveVal") |
||
| 149 | +299 |
- #' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The+ |
||
| 150 | -+ | |||
| 300 | +12x |
- #' filter panel will automatically update the shown filters to include only+ datanames <- if (is.null(module$datanames)) datasets$datanames() else module$datanames |
||
| 151 | +301 |
- #' filters in the listed datasets. `NULL` will hide the filter panel,+ |
||
| 152 | +302 |
- #' and the keyword `'all'` will show filters of all datasets. `datanames` also determines+ # list of reactive filtered data |
||
| 153 | -+ | |||
| 303 | +12x |
- #' a subset of datasets which are appended to the `data` argument in `server` function.+ data <- sapply( |
||
| 154 | -+ | |||
| 304 | +12x |
- #' @param server_args (named `list`) with additional arguments passed on to the+ datanames, |
||
| 155 | -+ | |||
| 305 | +12x |
- #' `server` function.+ function(x) eventReactive(trigger_data(), datasets$get_data(x, filtered = TRUE)), |
||
| 156 | -+ | |||
| 306 | +12x |
- #' @param ui_args (named `list`) with additional arguments passed on to the+ simplify = FALSE |
||
| 157 | +307 |
- #' `ui` function.+ ) |
||
| 158 | +308 |
- #'+ |
||
| 159 | -+ | |||
| 309 | +12x |
- #' @return object of class `teal_module`.+ hashes <- calculate_hashes(datanames, datasets) |
||
| 160 | -+ | |||
| 310 | +12x |
- #' @export+ metadata <- lapply(datanames, datasets$get_metadata) |
||
| 161 | -+ | |||
| 311 | +12x |
- #' @examples+ names(metadata) <- datanames |
||
| 162 | +312 |
- #' library(shiny)+ |
||
| 163 | -+ | |||
| 313 | +12x |
- #'+ new_tdata( |
||
| 164 | -+ | |||
| 314 | +12x |
- #' app <- init(+ data, |
||
| 165 | -+ | |||
| 315 | +12x |
- #' data = teal_data(dataset("iris", iris)),
+ eventReactive( |
||
| 166 | -+ | |||
| 316 | +12x |
- #' modules = list(+ trigger_data(), |
||
| 167 | -+ | |||
| 317 | +12x |
- #' module(+ c( |
||
| 168 | -+ | |||
| 318 | +12x |
- #' label = "Module",+ get_rcode_str_install(), |
||
| 169 | -+ | |||
| 319 | +12x |
- #' server = function(id, data) {
+ get_rcode_libraries(), |
||
| 170 | -+ | |||
| 320 | +12x |
- #' moduleServer(+ get_datasets_code(datanames, datasets, hashes), |
||
| 171 | -+ | |||
| 321 | +12x |
- #' id,+ teal.slice::get_filter_expr(datasets, datanames) |
||
| 172 | +322 |
- #' module = function(input, output, session) {
+ ) |
||
| 173 | +323 |
- #' output$data <- renderDataTable(data[["iris"]]())+ ), |
||
| 174 | -+ | |||
| 324 | +12x |
- #' }+ datasets$get_join_keys(), |
||
| 175 | -+ | |||
| 325 | +12x |
- #' )+ metadata |
||
| 176 | +326 |
- #' },+ ) |
||
| 177 | +327 |
- #' ui = function(id) {
+ } |
||
| 178 | +328 |
- #' ns <- NS(id)+ |
||
| 179 | +329 |
- #' tagList(dataTableOutput(ns("data")))
+ #' Get the hash of a dataset |
||
| 180 | +330 |
- #' }+ #' |
||
| 181 | +331 |
- #' )+ #' @param datanames (`character`) names of datasets |
||
| 182 | +332 |
- #' )+ #' @param datasets (`FilteredData`) object holding the data |
||
| 183 | +333 |
- #' )+ #' |
||
| 184 | +334 |
- #' if (interactive()) {
+ #' @return A list of hashes per dataset |
||
| 185 | +335 |
- #' runApp(app)+ #' @keywords internal |
||
| 186 | +336 |
- #' }+ #' |
||
| 187 | +337 |
- module <- function(label = "module",+ calculate_hashes <- function(datanames, datasets) {
+ |
+ ||
| 338 | +16x | +
+ sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE) |
||
| 188 | +339 |
- server = function(id, ...) {
+ } |
||
| 189 | -1x | +
| 1 | +
- moduleServer(id, function(input, output, session) {}) # nolint
+ #' Filter settings for teal applications |
|||
| 190 | +2 |
- },+ #' |
||
| 191 | +3 |
- ui = function(id, ...) {
+ #' Filter settings for teal applications |
||
| 192 | -1x | +|||
| 4 | +
- tags$p(paste0("This module has no UI (id: ", id, " )"))
+ #' |
|||
| 193 | +5 |
- },+ #' @inheritParams teal.slice::teal_slices |
||
| 194 | +6 |
- filters,+ #' |
||
| 195 | +7 |
- datanames = "all",+ #' @param module_specific (`logical(1)`)\cr |
||
| 196 | +8 |
- server_args = NULL,+ #' - `TRUE` when filter panel should be module-specific. All modules can have different set |
||
| 197 | +9 |
- ui_args = NULL) {
+ #' of filters specified - see `mapping` argument. |
||
| 198 | -109x | +|||
| 10 | +
- checkmate::assert_string(label)+ #' - `FALSE` when one filter panel needed to all modules. All filters will be shared |
|||
| 199 | -106x | +|||
| 11 | +
- checkmate::assert_function(server)+ #' by all modules. |
|||
| 200 | -106x | +|||
| 12 | +
- checkmate::assert_function(ui)+ #' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
|
|||
| 201 | -106x | +|||
| 13 | +
- checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ #' (`named list`)\cr |
|||
| 202 | -105x | +|||
| 14 | +
- checkmate::assert_list(server_args, null.ok = TRUE, names = "named")+ #' Specifies which filters will be active in which modules on app start. |
|||
| 203 | -103x | +|||
| 15 | +
- checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")+ #' Elements should contain character vector of `teal_slice` `id`s (see [teal.slice::teal_slice()]). |
|||
| 204 | +16 |
-
+ #' Names of the list should correspond to `teal_module` `label` set in [module()] function. |
||
| 205 | -101x | +|||
| 17 | +
- if (!missing(filters)) {
+ #' `id`s listed under `"global_filters` will be active in all modules. |
|||
| 206 | -! | +|||
| 18 | +
- checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ #' If missing, all filters will be applied to all modules. |
|||
| 207 | -! | +|||
| 19 | +
- datanames <- filters+ #' If empty list, all filters will be available to all modules but will start inactive. |
|||
| 208 | -! | +|||
| 20 | +
- msg <-+ #' If `module_specific` is `FALSE`, only `global_filters` will be active on start. |
|||
| 209 | -! | +|||
| 21 | +
- "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."+ #' |
|||
| 210 | -! | +|||
| 22 | +
- logger::log_warn(msg)+ #' @param x (`list`) of lists to convert to `teal_slices` |
|||
| 211 | -! | +|||
| 23 | +
- warning(msg)+ #' |
|||
| 212 | +24 |
- }+ #' @examples |
||
| 213 | +25 |
-
+ #' filter <- teal_slices( |
||
| 214 | -101x | +|||
| 26 | +
- if (label == "global_filters") {
+ #' teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"), |
|||
| 215 | -1x | +|||
| 27 | +
- stop(+ #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"), |
|||
| 216 | -1x | +|||
| 28 | +
- sprintf("module(label = \"%s\", ...\n ", label),
+ #' teal.slice::teal_slice( |
|||
| 217 | -1x | +|||
| 29 | +
- "Label 'global_filters' is reserved in teal. Please change to something else.",+ #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5" |
|||
| 218 | -1x | +|||
| 30 | +
- call. = FALSE+ #' ), |
|||
| 219 | +31 |
- )+ #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"), |
||
| 220 | +32 |
- }+ #' mapping = list( |
||
| 221 | -100x | +|||
| 33 | +
- if (label == "Report previewer") {
+ #' module1 = c("species", "sepal_length"),
|
|||
| 222 | -! | -
- stop(- |
- ||
| 223 | -! | -
- sprintf("module(label = \"%s\", ...\n ", label),
- |
- ||
| 224 | -! | -
- "Label 'Report previewer' is reserved in teal.",- |
- ||
| 225 | -! | +|||
| 34 | +
- call. = FALSE+ #' module2 = c("mtcars_mpg"),
|
|||
| 226 | +35 |
- )+ #' global_filters = "long_petals" |
||
| 227 | +36 |
- }+ #' ) |
||
| 228 | -100x | +|||
| 37 | +
- server_formals <- names(formals(server))+ #' ) |
|||
| 229 | -100x | +|||
| 38 | +
- if (!(+ #' |
|||
| 230 | -100x | +|||
| 39 | +
- "id" %in% server_formals ||+ #' app <- teal::init( |
|||
| 231 | -100x | +|||
| 40 | +
- all(c("input", "output", "session") %in% server_formals)
+ #' modules = list( |
|||
| 232 | +41 |
- )) {
+ #' module("module1"),
|
||
| 233 | -2x | +|||
| 42 | +
- stop(+ #' module("module2")
|
|||
| 234 | -2x | +|||
| 43 | +
- "\nmodule() `server` argument requires a function with following arguments:",+ #' ), |
|||
| 235 | -2x | +|||
| 44 | +
- "\n - id - teal will set proper shiny namespace for this module.",+ #' data = list(iris, mtcars), |
|||
| 236 | -2x | +|||
| 45 | +
- "\n - input, output, session (not recommended) - then shiny::callModule will be used to call a module.",+ #' filter = filter |
|||
| 237 | -2x | +|||
| 46 | +
- "\n\nFollowing arguments can be used optionaly:",+ #' ) |
|||
| 238 | -2x | +|||
| 47 | +
- "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",+ #' |
|||
| 239 | -2x | +|||
| 48 | +
- "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ #' if (interactive()) {
|
|||
| 240 | -2x | +|||
| 49 | +
- "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",+ #' shiny::runApp(app) |
|||
| 241 | -2x | +|||
| 50 | +
- "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",+ #' } |
|||
| 242 | -2x | +|||
| 51 | +
- "\n - `...` server_args elements will be passed to the module named argument or to the `...`"+ #' |
|||
| 243 | +52 |
- )+ #' @export |
||
| 244 | +53 |
- }+ teal_slices <- function(..., |
||
| 245 | +54 |
-
+ exclude_varnames = NULL, |
||
| 246 | -98x | +|||
| 55 | +
- if (!is.element("data", server_formals) && !is.null(datanames)) {
+ include_varnames = NULL, |
|||
| 247 | -64x | +|||
| 56 | +
- message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
+ count_type = NULL, |
|||
| 248 | -64x | +|||
| 57 | +
- datanames <- NULL+ allow_add = TRUE, |
|||
| 249 | +58 |
- }+ module_specific = FALSE, |
||
| 250 | +59 |
-
+ mapping) {
|
||
| 251 | -98x | +60 | +103x |
- srv_extra_args <- setdiff(names(server_args), server_formals)+ shiny::isolate({
|
| 252 | -98x | +61 | +103x |
- if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
+ checkmate::assert_flag(allow_add) |
| 253 | -1x | +62 | +103x |
- stop(+ checkmate::assert_flag(module_specific) |
| 254 | -1x | +63 | +51x |
- "\nFollowing `server_args` elements have no equivalent in the formals of the `server`:\n",+ if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
|
| 255 | -1x | +|||
| 64 | +
- paste(paste(" -", srv_extra_args), collapse = "\n"),
+
|
|||
| 256 | -1x | -
- "\n\nUpdate the `server` arguments by including above or add `...`"- |
- ||
| 257 | -+ | 65 | +100x |
- )+ slices <- list(...) |
| 258 | -+ | |||
| 66 | +100x |
- }+ all_slice_id <- vapply(slices, `[[`, character(1L), "id") |
||
| 259 | +67 | |||
| 260 | -97x | +68 | +100x |
- ui_formals <- names(formals(ui))+ if (missing(mapping)) {
|
| 261 | -97x | +69 | +52x |
- if (!"id" %in% ui_formals) {
- |
-
| 262 | -1x | -
- stop(- |
- ||
| 263 | -1x | -
- "\nmodule() `ui` argument requires a function with following arguments:",- |
- ||
| 264 | -1x | -
- "\n - id - teal will set proper shiny namespace for this module.",- |
- ||
| 265 | -1x | -
- "\n\nFollowing arguments can be used optionaly:",+ mapping <- list(global_filters = all_slice_id) |
||
| 266 | -1x | +|||
| 70 | +
- "\n - `data` - module will receive list of reactive (filtered) data specied in the `filters` argument",+ } |
|||
| 267 | -1x | +71 | +100x |
- "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ if (!module_specific) {
|
| 268 | -1x | -
- "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"- |
- ||
| 269 | -+ | 72 | +96x |
- )+ mapping[setdiff(names(mapping), "global_filters")] <- NULL |
| 270 | +73 |
- }+ } |
||
| 271 | +74 | |||
| 272 | -96x | +75 | +100x |
- ui_extra_args <- setdiff(names(ui_args), ui_formals)+ failed_slice_id <- setdiff(unlist(mapping), all_slice_id) |
| 273 | -96x | +76 | +100x |
- if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
+ if (length(failed_slice_id)) {
|
| 274 | +77 | 1x |
- stop(+ stop(sprintf( |
|
| 275 | +78 | 1x |
- "\nFollowing `ui_args` elements have no equivalent in the formals of `ui`:\n",+ "Filters in mapping don't match any available filter.\n %s not in %s", |
|
| 276 | +79 | 1x |
- paste(paste(" -", ui_extra_args), collapse = "\n"),
+ toString(failed_slice_id), |
|
| 277 | +80 | 1x |
- "\n\nUpdate the `ui` arguments by including above or add `...`"+ toString(all_slice_id) |
|
| 278 | +81 |
- )+ )) |
||
| 279 | +82 |
- }+ } |
||
| 280 | +83 | |||
| 281 | -95x | +84 | +99x |
- structure(+ tss <- teal.slice::teal_slices(+ |
+
| 85 | ++ |
+ ..., |
||
| 282 | -95x | +86 | +99x |
- list(+ exclude_varnames = exclude_varnames, |
| 283 | -95x | +87 | +99x |
- label = label,+ include_varnames = include_varnames, |
| 284 | -95x | +88 | +99x |
- server = server, ui = ui, datanames = datanames,+ count_type = count_type, |
| 285 | -95x | +89 | +99x |
- server_args = server_args, ui_args = ui_args+ allow_add = allow_add |
| 286 | +90 |
- ),+ ) |
||
| 287 | -95x | +91 | +99x |
- class = "teal_module"+ attr(tss, "mapping") <- mapping+ |
+
| 92 | +99x | +
+ attr(tss, "module_specific") <- module_specific+ |
+ ||
| 93 | +99x | +
+ class(tss) <- c("modules_teal_slices", class(tss))
+ |
+ ||
| 94 | +99x | +
+ tss |
||
| 288 | +95 |
- )+ }) |
||
| 289 | +96 |
} |
||
| 290 | +97 | |||
| 291 | +98 | |||
| 292 | +99 |
- #' Get module depth+ #' @rdname teal_slices |
||
| 293 | +100 |
- #'+ #' @export |
||
| 294 | +101 |
- #' Depth starts at 0, so a single `teal.module` has depth 0.+ #' @keywords internal |
||
| 295 | +102 |
- #' Nesting it increases overall depth by 1.+ #' |
||
| 296 | +103 |
- #'+ as.teal_slices <- function(x) { # nolint
|
||
| 297 | -+ | |||
| 104 | +33x |
- #' @inheritParams init+ checkmate::assert_list(x) |
||
| 298 | -+ | |||
| 105 | +33x |
- #' @param depth optional, integer determining current depth level+ lapply(x, checkmate::assert_list, names = "named", .var.name = "list element") |
||
| 299 | +106 |
- #'+ |
||
| 300 | -+ | |||
| 107 | +33x |
- #' @return depth level for given module+ attrs <- attributes(unclass(x)) |
||
| 301 | -+ | |||
| 108 | +33x |
- #' @keywords internal+ ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x)) |
||
| 302 | -+ | |||
| 109 | +33x |
- #'+ do.call(teal_slices, c(ans, attrs)) |
||
| 303 | +110 |
- #' @examples+ } |
||
| 304 | +111 |
- #' mods <- modules(+ |
||
| 305 | +112 |
- #' label = "d1",+ |
||
| 306 | +113 |
- #' modules(+ #' @rdname teal_slices |
||
| 307 | +114 |
- #' label = "d2",+ #' @export |
||
| 308 | +115 |
- #' modules(+ #' @keywords internal |
||
| 309 | +116 |
- #' label = "d3",+ #' |
||
| 310 | +117 |
- #' module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3")+ c.teal_slices <- function(...) {
|
||
| 311 | -+ | |||
| 118 | +! |
- #' ),+ x <- list(...) |
||
| 312 | -+ | |||
| 119 | +! |
- #' module(label = "bbb")+ checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices") |
||
| 313 | +120 |
- #' ),+ |
||
| 314 | -+ | |||
| 121 | +! |
- #' module(label = "ccc")+ all_attributes <- lapply(x, attributes)+ |
+ ||
| 122 | +! | +
+ all_attributes <- coalesce_r(all_attributes)+ |
+ ||
| 123 | +! | +
+ all_attributes <- all_attributes[names(all_attributes) != "class"] |
||
| 315 | +124 |
- #' )+ + |
+ ||
| 125 | +! | +
+ do.call(+ |
+ ||
| 126 | +! | +
+ teal_slices,+ |
+ ||
| 127 | +! | +
+ c(+ |
+ ||
| 128 | +! | +
+ unique(unlist(x, recursive = FALSE)),+ |
+ ||
| 129 | +! | +
+ all_attributes |
||
| 316 | +130 |
- #' stopifnot(teal:::modules_depth(mods) == 3L)+ ) |
||
| 317 | +131 |
- #'+ ) |
||
| 318 | +132 |
- #' mods <- modules(+ } |
||
| 319 | +133 |
- #' label = "a",+ |
||
| 320 | +134 |
- #' modules(+ |
||
| 321 | +135 |
- #' label = "b1", module(label = "c")+ #' Deep copy `teal_slices` |
||
| 322 | +136 |
- #' ),+ #' |
||
| 323 | +137 |
- #' module(label = "b2")+ #' it's important to create a new copy of `teal_slices` when |
||
| 324 | +138 |
- #' )+ #' starting a new `shiny` session. Otherwise, object will be shared |
||
| 325 | +139 |
- #' stopifnot(teal:::modules_depth(mods) == 2L)+ #' by multiple users as it is created in global environment before |
||
| 326 | +140 |
- modules_depth <- function(modules, depth = 0L) {
+ #' `shiny` session starts. |
||
| 327 | -12x | +|||
| 141 | +
- checkmate::assert(+ #' @param filter (`teal_slices`) |
|||
| 328 | -12x | +|||
| 142 | +
- checkmate::check_class(modules, "teal_module"),+ #' @return `teal_slices` |
|||
| 329 | -12x | +|||
| 143 | +
- checkmate::check_class(modules, "teal_modules")+ #' @keywords internal |
|||
| 330 | +144 |
- )+ deep_copy_filter <- function(filter) {
|
||
| 331 | -12x | +145 | +1x |
- checkmate::assert_int(depth, lower = 0)+ checkmate::assert_class(filter, "teal_slices") |
| 332 | -11x | +146 | +1x |
- if (inherits(modules, "teal_modules")) {
+ shiny::isolate({
|
| 333 | -4x | +147 | +1x |
- max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))+ filter_copy <- lapply(filter, function(slice) {
+ |
+
| 148 | +2x | +
+ teal.slice::as.teal_slice(as.list(slice)) |
||
| 334 | +149 |
- } else {
+ }) |
||
| 335 | -7x | +150 | +1x |
- depth+ attributes(filter_copy) <- attributes(filter)+ |
+
| 151 | +1x | +
+ filter_copy |
||
| 336 | +152 |
- }+ }) |
||
| 337 | +153 |
} |
| 338 | +1 |
-
+ #' Store teal_slices object to a file |
|
| 339 | +2 |
-
+ #' |
|
| 340 | +3 |
- module_labels <- function(modules) {
+ #' This function takes a `teal_slices` object and saves it to a file in `JSON` format. |
|
| 341 | -! | +||
| 4 | +
- if (inherits(modules, "teal_modules")) {
+ #' The `teal_slices` object contains information about filter states and can be used to |
||
| 342 | -! | +||
| 5 | +
- lapply(modules$children, module_labels)+ #' create, modify, and delete filter states. The saved file can be later loaded using |
||
| 343 | +6 |
- } else {
+ #' the `slices_restore` function. |
|
| 344 | -! | +||
| 7 | +
- modules$label+ #' |
||
| 345 | +8 |
- }+ #' @param tss (`teal_slices`) object to be stored. |
|
| 346 | +9 |
- }- |
- |
| 347 | -- |
-
+ #' @param file (`character(1)`) The file path where `teal_slices` object will be saved. |
|
| 348 | +10 |
- #' Converts `teal_modules` to a string+ #' The file extension should be `".json"`. |
|
| 349 | +11 |
#' |
|
| 350 | -- |
- #' @param x (`teal_modules`) to print- |
- |
| 351 | +12 |
- #' @param indent (`integer`) indent level;+ #' @details `Date` class is stored in `"ISO8601"` format (`YYYY-MM-DD`). `POSIX*t` classes are converted to a |
|
| 352 | +13 |
- #' each `submodule` is indented one level more+ #' character by using `format.POSIX*t(usetz = TRUE, tz = "UTC")` (`YYYY-MM-DD {N}{N}:{N}{N}:{N}{N} UTC`, where
|
|
| 353 | +14 |
- #' @param ... (optional) additional parameters to pass to recursive calls of `toString`+ #' `{N} = [0-9]` is a number and `UTC` is `Coordinated Universal Time` timezone short-code).
|
|
| 354 | +15 |
- #' @return (`character`)+ #' This format is assumed during `slices_restore`. All `POSIX*t` objects in `selected` or `choices` fields of |
|
| 355 | +16 |
- #' @export+ #' `teal_slice` objects are always printed in `UTC` timezone as well. |
|
| 356 | +17 |
- #' @rdname modules+ #' |
|
| 357 | +18 |
- toString.teal_modules <- function(x, indent = 0, ...) { # nolint
+ #' @return `NULL`, invisibly. |
|
| 358 | +19 |
- # argument must be `x` to be consistent with base method- |
- |
| 359 | -! | -
- paste(c(- |
- |
| 360 | -! | -
- paste0(rep(" ", indent), "+ ", x$label),
- |
- |
| 361 | -! | -
- unlist(lapply(x$children, toString, indent = indent + 1, ...))- |
- |
| 362 | -! | -
- ), collapse = "\n")+ #' |
|
| 363 | +20 |
- }+ #' @keywords internal |
|
| 364 | +21 |
-
+ #' |
|
| 365 | +22 |
- #' Converts `teal_module` to a string+ #' @examples |
|
| 366 | +23 |
- #'+ #' # Create a teal_slices object |
|
| 367 | +24 |
- #' @inheritParams toString.teal_modules+ #' tss <- teal_slices( |
|
| 368 | +25 |
- #' @param x `teal_module`+ #' teal_slice(dataname = "data", varname = "var"), |
|
| 369 | +26 |
- #' @param ... ignored+ #' teal_slice(dataname = "data", expr = "x > 0", id = "positive_x", title = "Positive x") |
|
| 370 | +27 |
- #' @export+ #' ) |
|
| 371 | +28 |
- #' @rdname module+ #' |
|
| 372 | +29 |
- toString.teal_module <- function(x, indent = 0, ...) { # nolint
- |
- |
| 373 | -! | -
- paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
+ #' if (interactive()) {
|
|
| 374 | +30 |
- }+ #' # Store the teal_slices object to a file |
|
| 375 | +31 |
-
+ #' slices_store(tss, "path/to/file.json") |
|
| 376 | +32 |
- #' Prints `teal_modules`+ #' } |
|
| 377 | +33 |
- #' @param x `teal_modules`+ #' |
|
| 378 | +34 |
- #' @param ... parameters passed to `toString`+ slices_store <- function(tss, file) {
|
|
| 379 | -+ | ||
| 35 | +6x |
- #' @export+ checkmate::assert_class(tss, "teal_slices") |
|
| 380 | -+ | ||
| 36 | +6x |
- #' @rdname modules+ checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json") |
|
| 381 | +37 |
- print.teal_modules <- function(x, ...) {
- |
- |
| 382 | -! | -
- s <- toString(x, ...)- |
- |
| 383 | -! | -
- cat(s)+ |
|
| 384 | -! | +||
| 38 | +6x |
- return(invisible(s))+ cat(format(tss, trim_lines = FALSE), "\n", file = file) |
|
| 385 | +39 |
} |
|
| 386 | +40 | ||
| 387 | +41 |
- #' Prints `teal_module`+ #' Restore teal_slices object from a file |
|
| 388 | +42 |
- #' @param x `teal_module`+ #' |
|
| 389 | +43 |
- #' @param ... parameters passed to `toString`+ #' This function takes a file path to a `JSON` file containing a `teal_slices` object |
|
| 390 | +44 |
- #' @export+ #' and restores it to its original form. The restored `teal_slices` object can be used |
|
| 391 | +45 |
- #' @rdname module+ #' to access filter states and their corresponding attributes. |
|
| 392 | +46 |
- print.teal_module <- print.teal_modules+ #' |
| 1 | +47 |
- #' Filter manager modal+ #' @param file Path to file where `teal_slices` is stored. Must have a `.json` extension and read access. |
|
| 2 | +48 |
#' |
|
| 3 | +49 |
- #' Opens modal containing the filter manager UI.+ #' @return A `teal_slices` object restored from the file. |
|
| 4 | +50 |
#' |
|
| 5 | +51 |
- #' @name module_filter_manager_modal+ #' @keywords internal |
|
| 6 | +52 |
- #' @inheritParams filter_manager_srv+ #' |
|
| 7 | +53 |
#' @examples |
|
| 8 | +54 |
- #' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris)))+ #' if (interactive()) {
|
|
| 9 | +55 |
- #' fd2 <- teal.slice::init_filtered_data(+ #' # Restore a teal_slices object from a file |
|
| 10 | +56 |
- #' list(iris = list(dataset = iris), mtcars = list(dataset = mtcars))+ #' tss_restored <- slices_restore("path/to/file.json")
|
|
| 11 | +57 |
- #' )+ #' } |
|
| 12 | +58 |
- #' fd3 <- teal.slice::init_filtered_data(+ #' |
|
| 13 | +59 |
- #' list(iris = list(dataset = iris), women = list(dataset = women))+ slices_restore <- function(file) {
|
|
| 14 | -+ | ||
| 60 | +6x |
- #' )+ checkmate::assert_file_exists(file, access = "r", extension = "json") |
|
| 15 | +61 |
- #' filter <- teal_slices(+ |
|
| 16 | -+ | ||
| 62 | +6x |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length"),+ tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE) |
|
| 17 | -+ | ||
| 63 | +6x |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Species"),+ tss_json$slices <- |
|
| 18 | -+ | ||
| 64 | +6x |
- #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg"),+ lapply(tss_json$slices, function(slice) {
|
|
| 19 | -+ | ||
| 65 | +6x |
- #' teal.slice::teal_slice(dataname = "women", varname = "height"),+ for (field in c("selected", "choices")) {
|
|
| 20 | -+ | ||
| 66 | +12x |
- #' mapping = list(+ if (!is.null(slice[[field]])) {
|
|
| 21 | -+ | ||
| 67 | +9x |
- #' module2 = c("mtcars mpg"),
+ date_partial_regex <- "^[0-9]{4}-[0-9]{2}-[0-9]{2}"
|
|
| 22 | -+ | ||
| 68 | +9x |
- #' module3 = c("women height"),
+ time_stamp_regex <- paste0(date_partial_regex, "\\s[0-9]{2}:[0-9]{2}:[0-9]{2}\\sUTC$")
|
|
| 23 | +69 |
- #' global_filters = "iris Species"+ |
|
| 24 | -+ | ||
| 70 | +9x |
- #' )+ slice[[field]] <- |
|
| 25 | -+ | ||
| 71 | +9x |
- #' )+ if (all(grepl(paste0(date_partial_regex, "$"), slice[[field]]))) {
|
|
| 26 | -+ | ||
| 72 | +3x |
- #'+ as.Date(slice[[field]]) |
|
| 27 | -+ | ||
| 73 | +9x |
- #' app <- shinyApp(+ } else if (all(grepl(time_stamp_regex, slice[[field]]))) {
|
|
| 28 | -+ | ||
| 74 | +3x |
- #' ui = fluidPage(+ as.POSIXct(slice[[field]], tz = "UTC") |
|
| 29 | +75 |
- #' teal:::filter_manager_modal_ui("manager")
+ } else {
|
|
| 30 | -+ | ||
| 76 | +3x |
- #' ),+ slice[[field]] |
|
| 31 | +77 |
- #' server = function(input, output, session) {
+ } |
|
| 32 | +78 |
- #' teal:::filter_manager_modal_srv(+ } |
|
| 33 | +79 |
- #' "manager",+ } |
|
| 34 | -+ | ||
| 80 | +6x |
- #' filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3),+ slice |
|
| 35 | +81 |
- #' filter = filter+ }) |
|
| 36 | +82 |
- #' )+ + |
+ |
| 83 | +6x | +
+ tss_elements <- lapply(tss_json$slices, as.teal_slice) |
|
| 37 | +84 |
- #' }+ + |
+ |
| 85 | +6x | +
+ do.call(teal_slices, c(tss_elements, tss_json$attributes)) |
|
| 38 | +86 |
- #' )+ } |
| 39 | +1 |
- #' if (interactive()) {
+ #' Add right filter panel into each of the top-level `teal_modules` UIs. |
||
| 40 | +2 |
- #' runApp(app)+ #' |
||
| 41 | +3 |
- #' }+ #' The [ui_nested_tabs] function returns a nested tabbed UI corresponding |
||
| 42 | +4 |
- #'+ #' to the nested modules. |
||
| 43 | +5 |
- #' @keywords internal+ #' This function adds the right filter panel to each main tab. |
||
| 44 | +6 |
#' |
||
| 45 | +7 |
- NULL+ #' The right filter panel's filter choices affect the `datasets` object. Therefore, |
||
| 46 | +8 |
-
+ #' all modules using the same `datasets` share the same filters. |
||
| 47 | +9 |
- #' @rdname module_filter_manager_modal+ #' |
||
| 48 | +10 |
- filter_manager_modal_ui <- function(id) {
+ #' This works with nested modules of depth greater than 2, though the filter |
||
| 49 | -1x | +|||
| 11 | +
- ns <- NS(id)+ #' panel is inserted at the right of the modules at depth 1 and not at the leaves. |
|||
| 50 | -1x | +|||
| 12 | +
- tags$button(+ #' |
|||
| 51 | -1x | +|||
| 13 | +
- id = ns("show"),
+ #' @name module_tabs_with_filters |
|||
| 52 | -1x | +|||
| 14 | +
- class = "btn action-button filter_manager_button",+ #' |
|||
| 53 | -1x | +|||
| 15 | +
- title = "Show filters manager modal",+ #' @inheritParams module_teal |
|||
| 54 | -1x | +|||
| 16 | +
- icon("gear")
+ #' |
|||
| 55 | +17 |
- )+ #' @param datasets (`named list` of `FilteredData`)\cr |
||
| 56 | +18 |
- }+ #' object to store filter state and filtered datasets, shared across modules. For more |
||
| 57 | +19 |
-
+ #' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure |
||
| 58 | +20 |
- #' @rdname module_filter_manager_modal+ #' of the `modules` argument and list names must correspond to the labels in `modules`. |
||
| 59 | +21 |
- filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
- |
- ||
| 60 | -4x | -
- moduleServer(id, function(input, output, session) {
- |
- ||
| 61 | -4x | -
- observeEvent(input$show, {
- |
- ||
| 62 | -! | -
- logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
- |
- ||
| 63 | -! | -
- showModal(- |
- ||
| 64 | -! | -
- modalDialog(- |
- ||
| 65 | -! | -
- filter_manager_ui(session$ns("filter_manager")),
- |
- ||
| 66 | -! | -
- size = "l",- |
- ||
| 67 | -! | -
- footer = NULL,- |
- ||
| 68 | -! | -
- easyClose = TRUE+ #' When filter is not module-specific then list contains the same object in all elements. |
||
| 69 | +22 |
- )+ #' @param reporter (`Reporter`) object from `teal.reporter` |
||
| 70 | +23 |
- )+ #' |
||
| 71 | +24 |
- })+ #' @return A `tagList` of The main menu, place holders for filters and |
||
| 72 | +25 | - - | -||
| 73 | -4x | -
- filter_manager_srv("filter_manager", filtered_data_list, filter)
+ #' place holders for the teal modules |
||
| 74 | +26 |
- })+ #' |
||
| 75 | +27 |
- }+ #' |
||
| 76 | +28 |
-
+ #' @keywords internal |
||
| 77 | +29 |
- #' @rdname module_filter_manager+ #' |
||
| 78 | +30 |
- filter_manager_ui <- function(id) {
- |
- ||
| 79 | -! | -
- ns <- NS(id)- |
- ||
| 80 | -! | -
- div(+ #' @examples |
||
| 81 | -! | +|||
| 31 | +
- class = "filter_manager_content",+ #' |
|||
| 82 | -! | +|||
| 32 | +
- tableOutput(ns("slices_table")),
+ #' mods <- teal:::example_modules() |
|||
| 83 | -! | +|||
| 33 | +
- snapshot_manager_ui(ns("snapshot_manager"))
+ #' datasets <- teal:::example_datasets() |
|||
| 84 | +34 |
- )+ #' |
||
| 85 | +35 |
- }+ #' app <- shinyApp( |
||
| 86 | +36 |
-
+ #' ui = function() {
|
||
| 87 | +37 |
- #' Manage multiple `FilteredData` objects+ #' tagList( |
||
| 88 | +38 |
- #'+ #' teal:::include_teal_css_js(), |
||
| 89 | +39 |
- #' Oversee filter states in the whole application.+ #' textOutput("info"),
|
||
| 90 | +40 |
- #'+ #' fluidPage( # needed for nice tabs |
||
| 91 | +41 |
- #' @rdname module_filter_manager+ #' ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
|
||
| 92 | +42 |
- #' @details+ #' ) |
||
| 93 | +43 |
- #' This module observes the changes of the filters in each `FilteredData` object+ #' ) |
||
| 94 | +44 |
- #' and keeps track of all filters used. A mapping of filters to modules+ #' }, |
||
| 95 | +45 |
- #' is kept in the `mapping_matrix` object (which is actually a `data.frame`)+ #' server = function(input, output, session) {
|
||
| 96 | +46 |
- #' that tracks which filters (rows) are active in which modules (columns).+ #' output$info <- renderText({
|
||
| 97 | +47 |
- #'+ #' paste0("The currently active tab name is ", active_module()$label)
|
||
| 98 | +48 |
- #' @param id (`character(1)`)\cr+ #' }) |
||
| 99 | +49 |
- #' `shiny` module id.+ #' active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods) |
||
| 100 | +50 |
- #' @param filtered_data_list (`named list`)\cr+ #' } |
||
| 101 | +51 |
- #' A list, possibly nested, of `FilteredData` objects.+ #' ) |
||
| 102 | +52 |
- #' Each `FilteredData` will be served to one module in the `teal` application.+ #' if (interactive()) {
|
||
| 103 | +53 |
- #' The structure of the list must reflect the nesting of modules in tabs+ #' runApp(app) |
||
| 104 | +54 |
- #' and names of the list must be the same as labels of their respective modules.+ #' } |
||
| 105 | +55 |
- #' @inheritParams init+ #' |
||
| 106 | +56 |
- #' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.+ NULL |
||
| 107 | +57 |
- #' @keywords internal+ |
||
| 108 | +58 |
- #'+ #' @rdname module_tabs_with_filters |
||
| 109 | +59 |
- filter_manager_srv <- function(id, filtered_data_list, filter) {
+ ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
|
||
| 110 | -6x | +60 | +1x |
- moduleServer(id, function(input, output, session) {
+ checkmate::assert_class(modules, "teal_modules") |
| 111 | -6x | -
- logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
- |
- ||
| 112 | -+ | 61 | +1x |
-
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
| 113 | -6x | +62 | +1x |
- is_module_specific <- isTRUE(attr(filter, "module_specific"))+ checkmate::assert_class(filter, "teal_slices") |
| 114 | +63 | |||
| 115 | -- |
- # Create global list of slices.- |
- ||
| 116 | -- |
- # Contains all available teal_slice objects available to all modules.- |
- ||
| 117 | -- |
- # Passed whole to instances of FilteredData used for individual modules.- |
- ||
| 118 | -+ | |||
| 64 | +1x |
- # Down there a subset that pertains to the data sets used in that module is applied and displayed.+ ns <- NS(id) |
||
| 119 | -6x | +65 | +1x |
- slices_global <- reactiveVal(filter)+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
| 120 | +66 | |||
| 121 | -6x | +67 | +1x |
- filtered_data_list <-+ teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
|
| 122 | -6x | -
- if (!is_module_specific) {
- |
- ||
| 123 | -- |
- # Retrieve the first FilteredData from potentially nested list.- |
- ||
| 124 | -+ | 68 | +1x |
- # List of length one is named "global_filters" because that name is forbidden for a module label.+ filter_panel_btns <- tags$li( |
| 125 | -5x | +69 | +1x |
- list(global_filters = unlist(filtered_data_list)[[1]])+ class = "flex-grow", |
| 126 | -+ | |||
| 70 | +1x |
- } else {
+ tags$button( |
||
| 127 | -+ | |||
| 71 | +1x |
- # Flatten potentially nested list of FilteredData objects while maintaining useful names.+ class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger |
||
| 128 | -+ | |||
| 72 | +1x |
- # Simply using `unlist` would result in concatenated names.+ href = "javascript:void(0)", |
||
| 129 | +73 | 1x |
- flatten_nested <- function(x, name = NULL) {
+ onclick = "toggleFilterPanel();", # see sidebar.js |
|
| 130 | -5x | +74 | +1x |
- if (inherits(x, "FilteredData")) {
+ title = "Toggle filter panels", |
| 131 | -3x | +75 | +1x |
- setNames(list(x), name)+ icon("fas fa-bars")
|
| 132 | +76 |
- } else {
+ ), |
||
| 133 | -2x | +77 | +1x |
- unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))+ filter_manager_modal_ui(ns("filter_manager"))
|
| 134 | +78 |
- }+ )+ |
+ ||
| 79 | +1x | +
+ teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns) |
||
| 135 | +80 |
- }+ |
||
| 136 | +81 | 1x |
- flatten_nested(filtered_data_list)+ if (!is_module_specific) {
|
|
| 137 | +82 |
- }+ # need to rearrange html so that filter panel is within tabset |
||
| 138 | -+ | |||
| 83 | +1x |
-
+ tabset_bar <- teal_ui$children[[1]] |
||
| 139 | -+ | |||
| 84 | +1x |
- # Create mapping fo filters to modules in matrix form (presented as data.frame).+ teal_modules <- teal_ui$children[[2]] |
||
| 140 | -+ | |||
| 85 | +1x |
- # Modules get NAs for filteres that cannot be set for them.+ filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
|
||
| 141 | -6x | +86 | +1x |
- mapping_matrix <- reactive({
+ list( |
| 142 | -6x | +87 | +1x |
- state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")+ tabset_bar, |
| 143 | -6x | +88 | +1x |
- mapping_smooth <- lapply(filtered_data_list, function(x) {
+ tags$hr(class = "my-2"), |
| 144 | -8x | +89 | +1x |
- state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")+ fluidRow( |
| 145 | -8x | +90 | +1x |
- state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")+ column(width = 9, teal_modules, class = "teal_primary_col"), |
| 146 | -8x | +91 | +1x |
- states_active <- state_ids_global %in% state_ids_local+ column(width = 3, filter_ui, class = "teal_secondary_col") |
| 147 | -8x | +|||
| 92 | +
- ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)+ ) |
|||
| 148 | +93 |
- })+ ) |
||
| 149 | +94 |
-
+ } else {
|
||
| 150 | -6x | +|||
| 95 | +! |
- as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)+ teal_ui |
||
| 151 | +96 |
- })+ } |
||
| 152 | +97 | - - | -||
| 153 | -6x | -
- output$slices_table <- renderTable(- |
- ||
| 154 | -6x | -
- expr = {
+ } |
||
| 155 | +98 |
- # Display logical values as UTF characters.+ |
||
| 156 | -3x | +|||
| 99 | +
- mm <- mapping_matrix()+ #' @rdname module_tabs_with_filters |
|||
| 157 | -3x | +|||
| 100 | +
- mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))+ srv_tabs_with_filters <- function(id, |
|||
| 158 | -3x | +|||
| 101 | +
- mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))+ datasets, |
|||
| 159 | -3x | +|||
| 102 | +
- if (!is_module_specific) colnames(mm) <- "Global Filters"+ modules, |
|||
| 160 | +103 |
-
+ reporter = teal.reporter::Reporter$new(), |
||
| 161 | +104 |
- # Display placeholder if no filters defined.+ filter = teal_slices()) {
|
||
| 162 | -3x | +105 | +6x |
- if (nrow(mm) == 0L) {
+ checkmate::assert_class(modules, "teal_modules") |
| 163 | -3x | +106 | +6x |
- mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
| 164 | -3x | +107 | +6x |
- rownames(mm) <- ""+ checkmate::assert_class(reporter, "Reporter") |
| 165 | -+ | |||
| 108 | +4x |
- }+ checkmate::assert_class(filter, "teal_slices") |
||
| 166 | +109 | |||
| 167 | -+ | |||
| 110 | +4x |
- # Report Previewer will not be displayed.+ moduleServer(id, function(input, output, session) {
|
||
| 168 | -3x | +111 | +4x |
- mm[names(mm) != "Report previewer"]+ logger::log_trace("srv_tabs_with_filters initializing the module.")
|
| 169 | +112 |
- },+ |
||
| 170 | -6x | +113 | +4x |
- align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
| 171 | -6x | -
- rownames = TRUE- |
- ||
| 172 | -+ | 114 | +4x |
- )+ manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
|
| 173 | +115 | |||
| 174 | -- |
- # Create list of module calls.- |
- ||
| 175 | -6x | +116 | +4x |
- modules_out <- lapply(names(filtered_data_list), function(module_name) {
+ active_module <- srv_nested_tabs( |
| 176 | -8x | +117 | +4x |
- filter_manager_module_srv(+ id = "root", |
| 177 | -8x | +118 | +4x |
- id = module_name,+ datasets = datasets, |
| 178 | -8x | +119 | +4x |
- module_fd = filtered_data_list[[module_name]],+ modules = modules, |
| 179 | -8x | +120 | +4x |
- slices_global = slices_global+ reporter = reporter, |
| 180 | -+ | |||
| 121 | +4x |
- )+ is_module_specific = is_module_specific |
||
| 181 | +122 |
- })+ ) |
||
| 182 | +123 | |||
| 183 | -+ | |||
| 124 | +4x |
- # Call snapshot manager.+ if (!is_module_specific) {
|
||
| 184 | -6x | +125 | +4x |
- snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
+ active_datanames <- reactive(active_module()$datanames) |
| 185 | -+ | |||
| 126 | +4x |
-
+ singleton <- unlist(datasets)[[1]] |
||
| 186 | -6x | +127 | +4x |
- modules_out # returned for testing purpose+ singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
|
| 187 | +128 |
- })+ |
||
| 188 | -+ | |||
| 129 | +4x |
- }+ observeEvent( |
||
| 189 | -+ | |||
| 130 | +4x |
-
+ eventExpr = active_datanames(), |
||
| 190 | -+ | |||
| 131 | +4x |
- #' Module specific filter manager+ handlerExpr = {
|
||
| 191 | -+ | |||
| 132 | +5x |
- #'+ script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
|
||
| 192 | +133 |
- #' Track filter states in single module.+ # hide the filter panel and disable the burger button |
||
| 193 | -+ | |||
| 134 | +1x |
- #'+ "handleNoActiveDatasets();" |
||
| 194 | +135 |
- #' This module tracks the state of a single `FilteredData` object and global `teal_slices`+ } else {
|
||
| 195 | +136 |
- #' and updates both objects as necessary. Filter states added in different modules+ # show the filter panel and enable the burger button+ |
+ ||
| 137 | +4x | +
+ "handleActiveDatasetsPresent();" |
||
| 196 | +138 |
- #' Filter states added any individual module are added to global `teal_slices`+ }+ |
+ ||
| 139 | +5x | +
+ shinyjs::runjs(script) |
||
| 197 | +140 |
- #' and from there become available in other modules+ },+ |
+ ||
| 141 | +4x | +
+ ignoreNULL = FALSE |
||
| 198 | +142 |
- #' by setting `private$available_teal_slices` in each `FilteredData`.+ ) |
||
| 199 | +143 |
- #'+ } |
||
| 200 | +144 |
- #' @param id (`character(1)`)\cr+ + |
+ ||
| 145 | +4x | +
+ showNotification("Data loaded - App fully started up")
+ |
+ ||
| 146 | +4x | +
+ logger::log_trace("srv_tabs_with_filters initialized the module")
+ |
+ ||
| 147 | +4x | +
+ return(active_module) |
||
| 201 | +148 |
- #' `shiny` module id.+ }) |
||
| 202 | +149 |
- #' @param module_fd (`FilteredData`)\cr+ } |
| 203 | +1 |
- #' object to filter data in the teal-module+ #' Creates a `teal_modules` object. |
|
| 204 | +2 |
- #' @param slices_global (`reactiveVal`)\cr+ #' |
|
| 205 | +3 |
- #' stores `teal_slices` with all available filters; allows the following actions:+ #' @description `r lifecycle::badge("stable")`
|
|
| 206 | +4 |
- #' - to disable/enable a specific filter in a module+ #' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object |
|
| 207 | +5 |
- #' - to restore saved filter settings+ #' containing the passed objects. |
|
| 208 | +6 |
- #' - to save current filter panel settings+ #' |
|
| 209 | +7 |
- #' @return A `reactive` expression containing the slices active in this module.+ #' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules` |
|
| 210 | +8 |
- #' @keywords internal+ #' shapes the navigation panel of a `teal` application. |
|
| 211 | +9 |
#' |
|
| 212 | +10 |
- filter_manager_module_srv <- function(id, module_fd, slices_global) {
+ #' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details |
|
| 213 | -8x | +||
| 11 | +
- moduleServer(id, function(input, output, session) {
+ #' @param label (`character(1)`) label of modules collection (default `"root"`). |
||
| 214 | +12 |
- # Only operate on slices that refer to data sets present in this module.+ #' If using the `label` argument then it must be explicitly named. |
|
| 215 | -8x | +||
| 13 | +
- module_fd$set_available_teal_slices(reactive(slices_global()))+ #' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
|
||
| 216 | +14 |
-
+ #' |
|
| 217 | +15 |
- # Track filter state of this module.+ #' @export |
|
| 218 | -8x | +||
| 16 | +
- slices_module <- reactive(module_fd$get_filter_state())+ #' |
||
| 219 | +17 |
-
+ #' @return object of class \code{teal_modules}. Object contains following fields
|
|
| 220 | +18 |
- # Reactive values for comparing states.+ #' - `label`: taken from the `label` argument |
|
| 221 | -8x | +||
| 19 | +
- previous_slices <- reactiveVal(isolate(slices_module()))+ #' - `children`: a list containing objects passed in `...`. List elements are named after |
||
| 222 | -8x | +||
| 20 | +
- slices_added <- reactiveVal(NULL)+ #' their `label` attribute converted to a valid `shiny` id. |
||
| 223 | +21 |
-
+ #' @examples |
|
| 224 | +22 |
- # Observe changes in module filter state and trigger appropriate actions.+ #' library(shiny) |
|
| 225 | -8x | +||
| 23 | +
- observeEvent(slices_module(), ignoreNULL = FALSE, {
+ #' |
||
| 226 | -3x | +||
| 24 | +
- logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
+ #' app <- init( |
||
| 227 | -3x | +||
| 25 | +
- added <- setdiff_teal_slices(slices_module(), slices_global())+ #' data = teal_data(dataset("iris", iris)),
|
||
| 228 | -! | +||
| 26 | +
- if (length(added)) slices_added(added)+ #' modules = modules( |
||
| 229 | -3x | +||
| 27 | +
- previous_slices(slices_module())+ #' label = "Modules", |
||
| 230 | +28 |
- })+ #' modules( |
|
| 231 | +29 |
-
+ #' label = "Module", |
|
| 232 | -8x | +||
| 30 | +
- observeEvent(slices_added(), ignoreNULL = TRUE, {
+ #' module( |
||
| 233 | -! | +||
| 31 | +
- logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
+ #' label = "Inner module", |
||
| 234 | +32 |
- # In case the new state has the same id as an existing state, add a suffix to it.+ #' server = function(id, data) {
|
|
| 235 | -! | -
- global_ids <- vapply(slices_global(), `[[`, character(1L), "id")- |
- |
| 236 | -! | -
- lapply(- |
- |
| 237 | -! | -
- slices_added(),- |
- |
| 238 | -! | -
- function(slice) {
- |
- |
| 239 | -! | -
- if (slice$id %in% global_ids) {
- |
- |
| 240 | -! | +||
| 33 | +
- slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)+ #' moduleServer( |
||
| 241 | +34 |
- }+ #' id, |
|
| 242 | +35 |
- }+ #' module = function(input, output, session) {
|
|
| 243 | +36 |
- )+ #' output$data <- renderDataTable(data[["iris"]]()) |
|
| 244 | -! | +||
| 37 | +
- slices_global_new <- c(slices_global(), slices_added())+ #' } |
||
| 245 | -! | +||
| 38 | +
- slices_global(slices_global_new)+ #' ) |
||
| 246 | -! | +||
| 39 | +
- slices_added(NULL)+ #' }, |
||
| 247 | +40 |
- })+ #' ui = function(id) {
|
|
| 248 | +41 |
-
+ #' ns <- NS(id) |
|
| 249 | -8x | +||
| 42 | +
- slices_module # returned for testing purpose+ #' tagList(dataTableOutput(ns("data")))
|
||
| 250 | +43 |
- })+ #' }, |
|
| 251 | +44 |
- }+ #' datanames = "all" |
| 1 | +45 |
- # This file contains Shiny modules useful for debugging and developing teal.+ #' ) |
|
| 2 | +46 |
- # We do not export the functions in this file. They are for+ #' ), |
|
| 3 | +47 |
- # developers only and can be accessed via `:::`.+ #' module( |
|
| 4 | +48 |
-
+ #' label = "Another module", |
|
| 5 | +49 |
- #' Dummy module to show the filter calls generated by the right encoding panel+ #' server = function(id) {
|
|
| 6 | +50 |
- #'+ #' moduleServer( |
|
| 7 | +51 |
- #'+ #' id, |
|
| 8 | +52 |
- #' Please do not remove, this is useful for debugging teal without+ #' module = function(input, output, session) {
|
|
| 9 | +53 |
- #' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
+ #' output$text <- renderText("Another module")
|
|
| 10 | +54 |
- #' and avoids session restarts!+ #' } |
|
| 11 | +55 |
- #'+ #' ) |
|
| 12 | +56 |
- #' @param label `character` label of module+ #' }, |
|
| 13 | +57 |
- #' @keywords internal+ #' ui = function(id) {
|
|
| 14 | +58 |
- #'+ #' ns <- NS(id) |
|
| 15 | +59 |
- #' @examples+ #' tagList(textOutput(ns("text")))
|
|
| 16 | +60 |
- #' app <- init(+ #' }, |
|
| 17 | +61 |
- #' data = list(iris = iris, mtcars = mtcars),+ #' datanames = NULL |
|
| 18 | +62 |
- #' modules = teal:::filter_calls_module(),+ #' ) |
|
| 19 | +63 |
- #' header = "Simple teal app"+ #' ) |
|
| 20 | +64 |
#' ) |
|
| 21 | +65 |
#' if (interactive()) {
|
|
| 22 | +66 |
#' runApp(app) |
|
| 23 | +67 |
#' } |
|
| 24 | +68 |
- filter_calls_module <- function(label = "Filter Calls Module") { # nolint
+ modules <- function(..., label = "root") {
|
|
| 25 | -! | +||
| 69 | +79x |
checkmate::assert_string(label) |
|
| 26 | -+ | ||
| 70 | +77x |
-
+ submodules <- list(...) |
|
| 27 | -! | +||
| 71 | +77x |
- module(+ if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
|
|
| 28 | -! | +||
| 72 | +2x |
- label = label,+ stop( |
|
| 29 | -! | +||
| 73 | +2x |
- server = function(input, output, session, data) {
+ "The only character argument to modules() must be 'label' and it must be named, ", |
|
| 30 | -! | +||
| 74 | +2x |
- checkmate::assert_class(data, "tdata")+ "change modules('lab', ...) to modules(label = 'lab', ...)"
|
|
| 31 | +75 |
-
+ ) |
|
| 32 | -! | +||
| 76 | +
- output$filter_calls <- renderText({
+ } |
||
| 33 | -! | +||
| 77 | +
- get_code_tdata(data)+ + |
+ ||
| 78 | +75x | +
+ checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+ |
+ |
| 79 | ++ |
+ # name them so we can more easily access the children+ |
+ |
| 80 | ++ |
+ # beware however that the label of the submodules should not be changed as it must be kept synced+ |
+ |
| 81 | +72x | +
+ labels <- vapply(submodules, function(submodule) submodule$label, character(1))+ |
+ |
| 82 | +72x | +
+ names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
+ |
+ |
| 83 | +72x | +
+ structure(+ |
+ |
| 84 | +72x | +
+ list(+ |
+ |
| 85 | +72x | +
+ label = label,+ |
+ |
| 86 | +72x | +
+ children = submodules+ |
+ |
| 87 | ++ |
+ ),+ |
+ |
| 88 | +72x | +
+ class = "teal_modules"+ |
+ |
| 89 | ++ |
+ )+ |
+ |
| 90 | ++ |
+ }+ |
+ |
| 91 | ++ | + + | +|
| 92 | ++ |
+ #' Function which appends a teal_module onto the children of a teal_modules object+ |
+ |
| 93 | ++ |
+ #' @keywords internal+ |
+ |
| 94 | ++ |
+ #' @param modules `teal_modules`+ |
+ |
| 95 | ++ |
+ #' @param module `teal_module` object to be appended onto the children of `modules`+ |
+ |
| 96 | ++ |
+ #' @return `teal_modules` object with `module` appended+ |
+ |
| 97 | ++ |
+ append_module <- function(modules, module) {
+ |
+ |
| 98 | +7x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+ |
| 99 | +5x | +
+ checkmate::assert_class(module, "teal_module")+ |
+ |
| 100 | +3x | +
+ modules$children <- c(modules$children, list(module))+ |
+ |
| 101 | +3x | +
+ labels <- vapply(modules$children, function(submodule) submodule$label, character(1))+ |
+ |
| 102 | +3x | +
+ names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
+ |
+ |
| 103 | +3x | +
+ modules+ |
+ |
| 104 | ++ |
+ }+ |
+ |
| 105 | ++ | + + | +|
| 106 | ++ |
+ #' Does the object make use of the `arg`+ |
+ |
| 107 | ++ |
+ #'+ |
+ |
| 108 | ++ |
+ #' @param modules (`teal_module` or `teal_modules`) object+ |
+ |
| 109 | ++ |
+ #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.+ |
+ |
| 110 | ++ |
+ #' @return `logical` whether the object makes use of `arg`+ |
+ |
| 111 | ++ |
+ #' @rdname is_arg_used+ |
+ |
| 112 | ++ |
+ #' @keywords internal+ |
+ |
| 113 | ++ |
+ is_arg_used <- function(modules, arg) {
+ |
+ |
| 114 | +285x | +
+ checkmate::assert_string(arg)+ |
+ |
| 115 | +282x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+ |
| 116 | +19x | +
+ any(unlist(lapply(modules$children, is_arg_used, arg)))+ |
+ |
| 117 | +263x | +
+ } else if (inherits(modules, "teal_module")) {
+ |
+ |
| 118 | +32x | +
+ is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg)+ |
+ |
| 119 | +231x | +
+ } else if (is.function(modules)) {
+ |
+ |
| 120 | +229x | +
+ isTRUE(arg %in% names(formals(modules)))+ |
+ |
| 121 | ++ |
+ } else {
+ |
+ |
| 122 | +2x | +
+ stop("is_arg_used function not implemented for this object")
+ |
+ |
| 123 | ++ |
+ }+ |
+ |
| 124 | ++ |
+ }+ |
+ |
| 125 | ++ | + + | +|
| 126 | ++ | + + | +|
| 127 | ++ |
+ #' Creates a `teal_module` object.+ |
+ |
| 128 | ++ |
+ #'+ |
+ |
| 129 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 130 | ++ |
+ #' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module.+ |
+ |
| 131 | ++ |
+ #'+ |
+ |
| 132 | ++ |
+ #' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except+ |
+ |
| 133 | ++ |
+ #' `"global_filters"` - read more in `mapping` argument of [teal::teal_slices].+ |
+ |
| 134 | ++ |
+ #' @param server (`function`) `shiny` module with following arguments:+ |
+ |
| 135 | ++ |
+ #' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]).+ |
+ |
| 136 | ++ |
+ #' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module.+ |
+ |
| 137 | ++ |
+ #' - `data` (optional) module will receive a `tdata` object, a list of reactive (filtered) data specified in+ |
+ |
| 138 | ++ |
+ #' the `filters` argument.+ |
+ |
| 139 | ++ |
+ #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ |
+ |
| 140 | ++ |
+ #' - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]).+ |
+ |
| 141 | ++ |
+ # - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).+ |
+ |
| 142 | ++ |
+ #' - `...` (optional) `server_args` elements will be passed to the module named argument or to the `...`.+ |
+ |
| 143 | ++ |
+ #' @param ui (`function`) Shiny `ui` module function with following arguments:+ |
+ |
| 144 | ++ |
+ #' - `id` - teal will set proper shiny namespace for this module.+ |
+ |
| 145 | ++ |
+ #' - `data` (optional) module will receive list of reactive (filtered) data specified in the `filters` argument.+ |
+ |
| 146 | ++ |
+ #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ |
+ |
| 147 | ++ |
+ #' - `...` (optional) `ui_args` elements will be passed to the module named argument or to the `...`.+ |
+ |
| 148 | ++ |
+ #' @param filters (`character`) Deprecated. Use `datanames` instead.+ |
+ |
| 149 | ++ |
+ #' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The+ |
+ |
| 150 | ++ |
+ #' filter panel will automatically update the shown filters to include only+ |
+ |
| 151 | ++ |
+ #' filters in the listed datasets. `NULL` will hide the filter panel,+ |
+ |
| 152 | ++ |
+ #' and the keyword `'all'` will show filters of all datasets. `datanames` also determines+ |
+ |
| 153 | ++ |
+ #' a subset of datasets which are appended to the `data` argument in `server` function.+ |
+ |
| 154 | ++ |
+ #' @param server_args (named `list`) with additional arguments passed on to the+ |
+ |
| 155 | ++ |
+ #' `server` function.+ |
+ |
| 156 | ++ |
+ #' @param ui_args (named `list`) with additional arguments passed on to the+ |
+ |
| 157 | ++ |
+ #' `ui` function.+ |
+ |
| 158 | ++ |
+ #'+ |
+ |
| 159 | ++ |
+ #' @return object of class `teal_module`.+ |
+ |
| 160 | ++ |
+ #' @export+ |
+ |
| 161 | ++ |
+ #' @examples+ |
+ |
| 162 | ++ |
+ #' library(shiny)+ |
+ |
| 163 | ++ |
+ #'+ |
+ |
| 164 | ++ |
+ #' app <- init(+ |
+ |
| 165 | ++ |
+ #' data = teal_data(dataset("iris", iris)),
+ |
+ |
| 166 | ++ |
+ #' modules = list(+ |
+ |
| 167 | ++ |
+ #' module(+ |
+ |
| 168 | ++ |
+ #' label = "Module",+ |
+ |
| 169 | ++ |
+ #' server = function(id, data) {
+ |
+ |
| 170 | ++ |
+ #' moduleServer(+ |
+ |
| 171 | ++ |
+ #' id,+ |
+ |
| 172 | ++ |
+ #' module = function(input, output, session) {
+ |
+ |
| 173 | ++ |
+ #' output$data <- renderDataTable(data[["iris"]]())+ |
+ |
| 174 | ++ |
+ #' }+ |
+ |
| 175 | ++ |
+ #' )+ |
+ |
| 176 | ++ |
+ #' },+ |
+ |
| 177 | ++ |
+ #' ui = function(id) {
+ |
+ |
| 178 | ++ |
+ #' ns <- NS(id)+ |
+ |
| 179 | ++ |
+ #' tagList(dataTableOutput(ns("data")))
+ |
+ |
| 180 | ++ |
+ #' }+ |
+ |
| 181 | ++ |
+ #' )+ |
+ |
| 182 | ++ |
+ #' )+ |
+ |
| 183 | ++ |
+ #' )+ |
+ |
| 184 | ++ |
+ #' if (interactive()) {
+ |
+ |
| 185 | ++ |
+ #' runApp(app)+ |
+ |
| 186 | ++ |
+ #' }+ |
+ |
| 187 | ++ |
+ module <- function(label = "module",+ |
+ |
| 188 | ++ |
+ server = function(id, ...) {
+ |
+ |
| 189 | +1x | +
+ moduleServer(id, function(input, output, session) {}) # nolint
+ |
+ |
| 190 | ++ |
+ },+ |
+ |
| 191 | ++ |
+ ui = function(id, ...) {
+ |
+ |
| 192 | +1x | +
+ tags$p(paste0("This module has no UI (id: ", id, " )"))
+ |
+ |
| 193 | ++ |
+ },+ |
+ |
| 194 | ++ |
+ filters,+ |
+ |
| 195 | ++ |
+ datanames = "all",+ |
+ |
| 196 | ++ |
+ server_args = NULL,+ |
+ |
| 197 | ++ |
+ ui_args = NULL) {
+ |
+ |
| 198 | +109x | +
+ checkmate::assert_string(label)+ |
+ |
| 199 | +106x | +
+ checkmate::assert_function(server)+ |
+ |
| 200 | +106x | +
+ checkmate::assert_function(ui) |
|
| 34 | -+ | ||
| 201 | +106x |
- })+ checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ |
+ |
| 202 | +105x | +
+ checkmate::assert_list(server_args, null.ok = TRUE, names = "named")+ |
+ |
| 203 | +103x | +
+ checkmate::assert_list(ui_args, null.ok = TRUE, names = "named") |
|
| 35 | +204 |
- },+ + |
+ |
| 205 | +101x | +
+ if (!missing(filters)) {
|
|
| 36 | +206 | ! |
- ui = function(id, ...) {
+ checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
| 37 | +207 | ! |
- ns <- NS(id)+ datanames <- filters |
| 38 | +208 | ! |
- div(+ msg <- |
| 39 | +209 | ! |
- h2("The following filter calls are generated:"),
+ "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead." |
| 40 | +210 | ! |
- verbatimTextOutput(ns("filter_calls"))
+ logger::log_warn(msg)+ |
+
| 211 | +! | +
+ warning(msg) |
|
| 41 | +212 |
- )+ } |
|
| 42 | +213 |
- },+ + |
+ |
| 214 | +101x | +
+ if (label == "global_filters") {
+ |
+ |
| 215 | +1x | +
+ stop(+ |
+ |
| 216 | +1x | +
+ sprintf("module(label = \"%s\", ...\n ", label),
+ |
+ |
| 217 | +1x | +
+ "Label 'global_filters' is reserved in teal. Please change to something else.",+ |
+ |
| 218 | +1x | +
+ call. = FALSE+ |
+ |
| 219 | ++ |
+ )+ |
+ |
| 220 | ++ |
+ }+ |
+ |
| 221 | +100x | +
+ if (label == "Report previewer") {
|
|
| 43 | +222 | ! |
- datanames = "all"+ stop(+ |
+
| 223 | +! | +
+ sprintf("module(label = \"%s\", ...\n ", label),
+ |
+ |
| 224 | +! | +
+ "Label 'Report previewer' is reserved in teal.",+ |
+ |
| 225 | +! | +
+ call. = FALSE |
|
| 44 | +226 |
- )+ ) |
|
| 45 | +227 |
- }+ }+ |
+ |
| 228 | +100x | +
+ server_formals <- names(formals(server))+ |
+ |
| 229 | +100x | +
+ if (!(+ |
+ |
| 230 | +100x | +
+ "id" %in% server_formals ||+ |
+ |
| 231 | +100x | +
+ all(c("input", "output", "session") %in% server_formals)
|
| 1 | +232 |
- # This is the main function from teal to be used by the end-users. Although it delegates+ )) {
+ |
+ |
| 233 | +2x | +
+ stop(+ |
+ |
| 234 | +2x | +
+ "\nmodule() `server` argument requires a function with following arguments:",+ |
+ |
| 235 | +2x | +
+ "\n - id - teal will set proper shiny namespace for this module.",+ |
+ |
| 236 | +2x | +
+ "\n - input, output, session (not recommended) - then shiny::callModule will be used to call a module.",+ |
+ |
| 237 | +2x | +
+ "\n\nFollowing arguments can be used optionaly:",+ |
+ |
| 238 | +2x | +
+ "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",+ |
+ |
| 239 | +2x | +
+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ |
+ |
| 240 | +2x | +
+ "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",+ |
+ |
| 241 | +2x | +
+ "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).", |
|
| 2 | -+ | ||
| 242 | +2x |
- # directly to `module_teal_with_splash.R`, we keep it in a separate file because its doc is quite large+ "\n - `...` server_args elements will be passed to the module named argument or to the `...`" |
|
| 3 | +243 |
- # and it is very end-user oriented. It may also perform more argument checking with more informative+ ) |
|
| 4 | +244 |
- # error messages.+ } |
|
| 5 | +245 | ||
| 6 | -+ | ||
| 246 | +98x |
-
+ if (!is.element("data", server_formals) && !is.null(datanames)) {
|
|
| 7 | -+ | ||
| 247 | +64x |
- #' Create the Server and UI Function For the Shiny App+ message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
|
|
| 8 | -+ | ||
| 248 | +64x |
- #'+ datanames <- NULL |
|
| 9 | +249 |
- #' @description `r lifecycle::badge("stable")`
+ } |
|
| 10 | +250 |
- #' End-users: This is the most important function for you to start a+ |
|
| 11 | -+ | ||
| 251 | +98x |
- #' teal app that is composed out of teal modules.+ srv_extra_args <- setdiff(names(server_args), server_formals) |
|
| 12 | -+ | ||
| 252 | +98x |
- #'+ if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
|
|
| 13 | -+ | ||
| 253 | +1x |
- #' **Notes for developers**:+ stop( |
|
| 14 | -+ | ||
| 254 | +1x |
- #' This is a wrapper function around the `module_teal.R` functions. Unless you are+ "\nFollowing `server_args` elements have no equivalent in the formals of the `server`:\n", |
|
| 15 | -+ | ||
| 255 | +1x |
- #' an end-user, don't use this function, but instead this module.+ paste(paste(" -", srv_extra_args), collapse = "\n"),
|
|
| 16 | -+ | ||
| 256 | +1x |
- #'+ "\n\nUpdate the `server` arguments by including above or add `...`" |
|
| 17 | +257 |
- #' @param data (`TealData` or `TealDataset` or `TealDatasetConnector` or `list` or `data.frame`+ ) |
|
| 18 | +258 |
- #' or `MultiAssayExperiment`)\cr+ } |
|
| 19 | +259 |
- #' `R6` object as returned by [teal.data::cdisc_data()], [teal.data::teal_data()],+ |
|
| 20 | -+ | ||
| 260 | +97x |
- #' [teal.data::cdisc_dataset()], [teal.data::dataset()], [teal.data::dataset_connector()] or+ ui_formals <- names(formals(ui)) |
|
| 21 | -+ | ||
| 261 | +97x |
- #' [teal.data::cdisc_dataset_connector()] or a single `data.frame` or a `MultiAssayExperiment`+ if (!"id" %in% ui_formals) {
|
|
| 22 | -+ | ||
| 262 | +1x |
- #' or a list of the previous objects or function returning a named list.+ stop( |
|
| 23 | -+ | ||
| 263 | +1x |
- #' NOTE: teal does not guarantee reproducibility of the code when names of the list elements+ "\nmodule() `ui` argument requires a function with following arguments:", |
|
| 24 | -+ | ||
| 264 | +1x |
- #' do not match the original object names. To ensure reproducibility please use [teal.data::teal_data()]+ "\n - id - teal will set proper shiny namespace for this module.", |
|
| 25 | -+ | ||
| 265 | +1x |
- #' or [teal.data::cdisc_data()] with `check = TRUE` enabled.+ "\n\nFollowing arguments can be used optionaly:", |
|
| 26 | -+ | ||
| 266 | +1x |
- #' @param modules (`list`, `teal_modules` or `teal_module`)\cr+ "\n - `data` - module will receive list of reactive (filtered) data specied in the `filters` argument", |
|
| 27 | -+ | ||
| 267 | +1x |
- #' nested list of `teal_modules` or `teal_module` objects or a single+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`", |
|
| 28 | -+ | ||
| 268 | +1x |
- #' `teal_modules` or `teal_module` object. These are the specific output modules which+ "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`" |
|
| 29 | +269 |
- #' will be displayed in the teal application. See [modules()] and [module()] for+ ) |
|
| 30 | +270 |
- #' more details.+ } |
|
| 31 | +271 |
- #' @param title (`NULL` or `character`)\cr+ |
|
| 32 | -+ | ||
| 272 | +96x |
- #' The browser window title (defaults to the host URL of the page).+ ui_extra_args <- setdiff(names(ui_args), ui_formals) |
|
| 33 | -+ | ||
| 273 | +96x |
- #' @param filter (`teal_slices`)\cr+ if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
|
|
| 34 | -+ | ||
| 274 | +1x |
- #' Specification of initial filter. Filters can be specified using [teal::teal_slices()].+ stop( |
|
| 35 | -+ | ||
| 275 | +1x |
- #' Old way of specifying filters through a list is deprecated and will be removed in the+ "\nFollowing `ui_args` elements have no equivalent in the formals of `ui`:\n", |
|
| 36 | -+ | ||
| 276 | +1x |
- #' next release. Please fix your applications to use [teal::teal_slices()].+ paste(paste(" -", ui_extra_args), collapse = "\n"),
+ |
+ |
| 277 | +1x | +
+ "\n\nUpdate the `ui` arguments by including above or add `...`" |
|
| 37 | +278 |
- #' @param header (`shiny.tag` or `character`) \cr+ ) |
|
| 38 | +279 |
- #' the header of the app. Note shiny code placed here (and in the footer+ } |
|
| 39 | +280 |
- #' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function+ |
|
| 40 | -+ | ||
| 281 | +95x |
- #' (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here.+ structure( |
|
| 41 | -+ | ||
| 282 | +95x |
- #' @param footer (`shiny.tag` or `character`)\cr+ list( |
|
| 42 | -+ | ||
| 283 | +95x |
- #' the footer of the app+ label = label, |
|
| 43 | -+ | ||
| 284 | +95x |
- #' @param id (`character`)\cr+ server = server, ui = ui, datanames = datanames, |
|
| 44 | -+ | ||
| 285 | +95x |
- #' module id to embed it, if provided,+ server_args = server_args, ui_args = ui_args |
|
| 45 | +286 |
- #' the server function must be called with [shiny::moduleServer()];+ ), |
|
| 46 | -+ | ||
| 287 | +95x |
- #' See the vignette for an example. However, [ui_teal_with_splash()]+ class = "teal_module" |
|
| 47 | +288 |
- #' is then preferred to this function.+ ) |
|
| 48 | +289 |
- #'+ } |
|
| 49 | +290 |
- #' @return named list with `server` and `ui` function+ |
|
| 50 | +291 |
- #'+ |
|
| 51 | +292 |
- #' @export+ #' Get module depth |
|
| 52 | +293 |
#' |
|
| 53 | +294 |
- #' @include modules.R+ #' Depth starts at 0, so a single `teal.module` has depth 0. |
|
| 54 | +295 |
- #'+ #' Nesting it increases overall depth by 1. |
|
| 55 | +296 |
- #' @examples+ #' |
|
| 56 | +297 |
- #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ #' @inheritParams init |
|
| 57 | +298 |
- #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ #' @param depth optional, integer determining current depth level |
|
| 58 | +299 |
#' |
|
| 59 | +300 |
- #' app <- init(+ #' @return depth level for given module |
|
| 60 | +301 |
- #' data = teal_data(+ #' @keywords internal |
|
| 61 | +302 |
- #' dataset("new_iris", new_iris),
+ #' |
|
| 62 | +303 |
- #' dataset("new_mtcars", new_mtcars),
+ #' @examples |
|
| 63 | +304 |
- #' code = "+ #' mods <- modules( |
|
| 64 | +305 |
- #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ #' label = "d1", |
|
| 65 | +306 |
- #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ #' modules( |
|
| 66 | +307 |
- #' "+ #' label = "d2", |
|
| 67 | +308 |
- #' ),+ #' modules( |
|
| 68 | +309 |
- #' modules = modules(+ #' label = "d3", |
|
| 69 | +310 |
- #' module(+ #' module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3") |
|
| 70 | +311 |
- #' label = "data source",+ #' ), |
|
| 71 | +312 |
- #' server = function(input, output, session, data) {},
+ #' module(label = "bbb") |
|
| 72 | +313 |
- #' ui = function(id, ...) div(p("information about data source")),
+ #' ), |
|
| 73 | +314 |
- #' datanames = "all"+ #' module(label = "ccc") |
|
| 74 | +315 |
- #' ),+ #' ) |
|
| 75 | +316 |
- #' example_module(label = "example teal module"),+ #' stopifnot(teal:::modules_depth(mods) == 3L) |
|
| 76 | +317 |
- #' module(+ #' |
|
| 77 | +318 |
- #' "Iris Sepal.Length histogram",+ #' mods <- modules( |
|
| 78 | +319 |
- #' server = function(input, output, session, data) {
+ #' label = "a", |
|
| 79 | +320 |
- #' output$hist <- renderPlot(+ #' modules( |
|
| 80 | +321 |
- #' hist(data[["new_iris"]]()$Sepal.Length)+ #' label = "b1", module(label = "c") |
|
| 81 | +322 |
- #' )+ #' ), |
|
| 82 | +323 |
- #' },+ #' module(label = "b2") |
|
| 83 | +324 |
- #' ui = function(id, ...) {
+ #' ) |
|
| 84 | +325 |
- #' ns <- NS(id)+ #' stopifnot(teal:::modules_depth(mods) == 2L) |
|
| 85 | +326 |
- #' plotOutput(ns("hist"))
+ modules_depth <- function(modules, depth = 0L) {
|
|
| 86 | -+ | ||
| 327 | +12x |
- #' },+ checkmate::assert( |
|
| 87 | -+ | ||
| 328 | +12x |
- #' datanames = "new_iris"+ checkmate::check_class(modules, "teal_module"), |
|
| 88 | -+ | ||
| 329 | +12x |
- #' )+ checkmate::check_class(modules, "teal_modules") |
|
| 89 | +330 |
- #' ),+ ) |
|
| 90 | -+ | ||
| 331 | +12x |
- #' title = "App title",+ checkmate::assert_int(depth, lower = 0) |
|
| 91 | -+ | ||
| 332 | +11x |
- #' filter = teal_slices(+ if (inherits(modules, "teal_modules")) {
|
|
| 92 | -+ | ||
| 333 | +4x |
- #' teal_slice(dataname = "new_iris", varname = "Species"),+ max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L)) |
|
| 93 | +334 |
- #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),+ } else {
|
|
| 94 | -+ | ||
| 335 | +7x |
- #' teal_slice(dataname = "new_mtcars", varname = "cyl"),+ depth |
|
| 95 | +336 |
- #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
+ } |
|
| 96 | +337 |
- #' mapping = list(+ } |
|
| 97 | +338 |
- #' `example teal module` = "new_iris Species",+ |
|
| 98 | +339 |
- #' `Iris Sepal.Length histogram` = "new_iris Species",+ |
|
| 99 | +340 |
- #' global_filters = "new_mtcars cyl"+ module_labels <- function(modules) {
|
|
| 100 | -+ | ||
| 341 | +! |
- #' )+ if (inherits(modules, "teal_modules")) {
|
|
| 101 | -+ | ||
| 342 | +! |
- #' ),+ lapply(modules$children, module_labels) |
|
| 102 | +343 |
- #' header = tags$h1("Sample App"),
+ } else {
|
|
| 103 | -+ | ||
| 344 | +! |
- #' footer = tags$p("Copyright 2017 - 2023")
+ modules$label |
|
| 104 | +345 |
- #' )+ } |
|
| 105 | +346 |
- #' if (interactive()) {
+ } |
|
| 106 | +347 |
- #' shinyApp(app$ui, app$server)+ |
|
| 107 | +348 |
- #' }+ #' Converts `teal_modules` to a string |
|
| 108 | +349 |
#' |
|
| 109 | +350 |
- init <- function(data,+ #' @param x (`teal_modules`) to print |
|
| 110 | +351 |
- modules,+ #' @param indent (`integer`) indent level; |
|
| 111 | +352 |
- title = NULL,+ #' each `submodule` is indented one level more |
|
| 112 | +353 |
- filter = teal_slices(),+ #' @param ... (optional) additional parameters to pass to recursive calls of `toString` |
|
| 113 | +354 |
- header = tags$p(),+ #' @return (`character`) |
|
| 114 | +355 |
- footer = tags$p(),+ #' @export |
|
| 115 | +356 |
- id = character(0)) {
- |
- |
| 116 | -38x | -
- logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
- |
- |
| 117 | -38x | -
- data <- teal.data::to_relational_data(data = data)+ #' @rdname modules |
|
| 118 | +357 | - - | -|
| 119 | -33x | -
- checkmate::assert_class(data, "TealData")+ toString.teal_modules <- function(x, indent = 0, ...) { # nolint
|
|
| 120 | -33x | +||
| 358 | +
- checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
+ # argument must be `x` to be consistent with base method |
||
| 121 | -33x | +||
| 359 | +! |
- checkmate::assert_string(title, null.ok = TRUE)+ paste(c( |
|
| 122 | -33x | +||
| 360 | +! |
- checkmate::assert(+ paste0(rep(" ", indent), "+ ", x$label),
|
|
| 123 | -33x | +||
| 361 | +! |
- checkmate::check_class(filter, "teal_slices"),+ unlist(lapply(x$children, toString, indent = indent + 1, ...)) |
|
| 124 | -33x | +||
| 362 | +! |
- checkmate::check_list(filter, names = "named")+ ), collapse = "\n") |
|
| 125 | +363 |
- )- |
- |
| 126 | -32x | -
- checkmate::assert_multi_class(header, c("shiny.tag", "character"))
- |
- |
| 127 | -32x | -
- checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
- |
- |
| 128 | -32x | -
- checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ } |
|
| 129 | +364 | ||
| 130 | -32x | -
- teal.logger::log_system_info()- |
- |
| 131 | +365 | - - | -|
| 132 | -32x | -
- if (inherits(modules, "teal_module")) {
+ #' Converts `teal_module` to a string |
|
| 133 | -1x | +||
| 366 | +
- modules <- list(modules)+ #' |
||
| 134 | +367 |
- }+ #' @inheritParams toString.teal_modules |
|
| 135 | -32x | +||
| 368 | +
- if (inherits(modules, "list")) {
+ #' @param x `teal_module` |
||
| 136 | -2x | +||
| 369 | +
- modules <- do.call(teal::modules, modules)+ #' @param ... ignored |
||
| 137 | +370 |
- }+ #' @export |
|
| 138 | +371 |
-
+ #' @rdname module |
|
| 139 | +372 |
- # resolve modules datanames+ toString.teal_module <- function(x, indent = 0, ...) { # nolint
|
|
| 140 | -32x | +||
| 373 | +! |
- datanames <- teal.data::get_dataname(data)+ paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
|
|
| 141 | -32x | +||
| 374 | +
- join_keys <- data$get_join_keys()+ } |
||
| 142 | -32x | +||
| 375 | +
- resolve_modules_datanames <- function(modules) {
+
|
||
| 143 | -240x | +||
| 376 | +
- if (inherits(modules, "teal_modules")) {
+ #' Prints `teal_modules` |
||
| 144 | -90x | +||
| 377 | +
- modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE)+ #' @param x `teal_modules` |
||
| 145 | -90x | +||
| 378 | +
- modules+ #' @param ... parameters passed to `toString` |
||
| 146 | +379 |
- } else {
+ #' @export |
|
| 147 | -150x | +||
| 380 | +
- modules$datanames <- if (identical(modules$datanames, "all")) {
+ #' @rdname modules |
||
| 148 | -5x | +||
| 381 | +
- datanames+ print.teal_modules <- function(x, ...) {
|
||
| 149 | -150x | +||
| 382 | +! |
- } else if (is.character(modules$datanames)) {
+ s <- toString(x, ...) |
|
| 150 | -145x | +||
| 383 | +! |
- datanames_adjusted <- intersect(modules$datanames, datanames)+ cat(s) |
|
| 151 | -145x | +||
| 384 | +! |
- include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)+ return(invisible(s)) |
|
| 152 | +385 |
- }- |
- |
| 153 | -150x | -
- modules+ } |
|
| 154 | +386 |
- }+ |
|
| 155 | +387 |
- }+ #' Prints `teal_module` |
|
| 156 | -32x | +||
| 388 | +
- modules <- resolve_modules_datanames(modules = modules)+ #' @param x `teal_module` |
||
| 157 | +389 |
-
+ #' @param ... parameters passed to `toString` |
|
| 158 | -32x | +||
| 390 | +
- if (!inherits(filter, "teal_slices")) {
+ #' @export |
||
| 159 | -1x | +||
| 391 | +
- checkmate::assert_subset(names(filter), choices = datanames)+ #' @rdname module |
||
| 160 | +392 |
- # list_to_teal_slices is lifted from teal.slice package, see zzz.R+ print.teal_module <- print.teal_modules |
| 161 | +1 |
- # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).+ #' Filter manager modal |
||
| 162 | -1x | +|||
| 2 | +
- filter <- list_to_teal_slices(filter)+ #' |
|||
| 163 | +3 |
- }+ #' Opens modal containing the filter manager UI. |
||
| 164 | +4 |
- # convert teal.slice::teal_slices to teal::teal_slices+ #' |
||
| 165 | -32x | +|||
| 5 | +
- filter <- as.teal_slices(as.list(filter))+ #' @name module_filter_manager_modal |
|||
| 166 | +6 |
-
+ #' @inheritParams filter_manager_srv |
||
| 167 | +7 |
- # check teal_slices+ #' @examples |
||
| 168 | -32x | +|||
| 8 | +
- for (i in seq_along(filter)) {
+ #' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris))) |
|||
| 169 | -2x | +|||
| 9 | +
- dataname_i <- shiny::isolate(filter[[i]]$dataname)+ #' fd2 <- teal.slice::init_filtered_data( |
|||
| 170 | -2x | +|||
| 10 | +
- if (!dataname_i %in% datanames) {
+ #' list(iris = list(dataset = iris), mtcars = list(dataset = mtcars)) |
|||
| 171 | -! | +|||
| 11 | +
- stop(+ #' ) |
|||
| 172 | -! | +|||
| 12 | +
- sprintf(+ #' fd3 <- teal.slice::init_filtered_data( |
|||
| 173 | -! | +|||
| 13 | +
- "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s",+ #' list(iris = list(dataset = iris), women = list(dataset = women)) |
|||
| 174 | -! | +|||
| 14 | +
- i,+ #' ) |
|||
| 175 | -! | +|||
| 15 | +
- dataname_i,+ #' filter <- teal_slices( |
|||
| 176 | -! | +|||
| 16 | +
- toString(datanames)+ #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length"), |
|||
| 177 | +17 |
- )+ #' teal.slice::teal_slice(dataname = "iris", varname = "Species"), |
||
| 178 | +18 |
- )+ #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg"), |
||
| 179 | +19 |
- }+ #' teal.slice::teal_slice(dataname = "women", varname = "height"), |
||
| 180 | +20 |
- }+ #' mapping = list( |
||
| 181 | +21 |
-
+ #' module2 = c("mtcars mpg"),
|
||
| 182 | -32x | +|||
| 22 | +
- if (isTRUE(attr(filter, "module_specific"))) {
+ #' module3 = c("women height"),
|
|||
| 183 | -! | +|||
| 23 | +
- module_names <- unlist(c(module_labels(modules), "global_filters"))+ #' global_filters = "iris Species" |
|||
| 184 | -! | +|||
| 24 | +
- failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)+ #' ) |
|||
| 185 | -! | +|||
| 25 | +
- if (length(failed_mod_names)) {
+ #' ) |
|||
| 186 | -! | +|||
| 26 | +
- stop(+ #' |
|||
| 187 | -! | +|||
| 27 | +
- sprintf(+ #' app <- shinyApp( |
|||
| 188 | -! | +|||
| 28 | +
- "Some module names in the mapping arguments don't match module labels.\n %s not in %s",+ #' ui = fluidPage( |
|||
| 189 | -! | +|||
| 29 | +
- toString(failed_mod_names),+ #' teal:::filter_manager_modal_ui("manager")
|
|||
| 190 | -! | +|||
| 30 | +
- toString(unique(module_names))+ #' ), |
|||
| 191 | +31 |
- )+ #' server = function(input, output, session) {
|
||
| 192 | +32 |
- )+ #' teal:::filter_manager_modal_srv( |
||
| 193 | +33 |
- }+ #' "manager", |
||
| 194 | +34 |
-
+ #' filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3), |
||
| 195 | -! | +|||
| 35 | +
- if (anyDuplicated(module_names)) {
+ #' filter = filter |
|||
| 196 | +36 |
- # In teal we are able to set nested modules with duplicated label.+ #' ) |
||
| 197 | +37 |
- # Because mapping argument bases on the relationship between module-label and filter-id,+ #' } |
||
| 198 | +38 |
- # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)+ #' ) |
||
| 199 | -! | +|||
| 39 | +
- stop(+ #' if (interactive()) {
|
|||
| 200 | -! | +|||
| 40 | +
- sprintf(+ #' runApp(app) |
|||
| 201 | -! | +|||
| 41 | +
- "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",+ #' } |
|||
| 202 | -! | +|||
| 42 | +
- toString(module_names[duplicated(module_names)])+ #' |
|||
| 203 | +43 |
- )+ #' @keywords internal |
||
| 204 | +44 |
- )+ #' |
||
| 205 | +45 |
- }+ NULL |
||
| 206 | +46 |
- }+ |
||
| 207 | +47 |
-
+ #' @rdname module_filter_manager_modal |
||
| 208 | +48 |
- # Note regarding case `id = character(0)`:+ filter_manager_modal_ui <- function(id) {
+ |
+ ||
| 49 | +1x | +
+ ns <- NS(id)+ |
+ ||
| 50 | +1x | +
+ tags$button(+ |
+ ||
| 51 | +1x | +
+ id = ns("show"),
+ |
+ ||
| 52 | +1x | +
+ class = "btn action-button filter_manager_button",+ |
+ ||
| 53 | +1x | +
+ title = "Show filters manager modal",+ |
+ ||
| 54 | +1x | +
+ icon("gear")
|
||
| 209 | +55 |
- # rather than using `callModule` and creating a submodule of this module, we directly modify+ ) |
||
| 210 | +56 |
- # the `ui` and `server` with `id = character(0)` and calling the server function directly+ } |
||
| 211 | +57 |
- # rather than through `callModule`+ |
||
| 212 | -32x | +|||
| 58 | +
- res <- list(+ #' @rdname module_filter_manager_modal |
|||
| 213 | -32x | +|||
| 59 | +
- ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),+ filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
|
|||
| 214 | -32x | +60 | +4x |
- server = function(input, output, session) {
+ moduleServer(id, function(input, output, session) {
|
| 215 | -+ | |||
| 61 | +4x |
- # copy object so that load won't be shared between the session+ observeEvent(input$show, {
|
||
| 216 | +62 | ! |
- data <- data$copy(deep = TRUE)+ logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
|
|
| 217 | +63 | ! |
- filter <- deep_copy_filter(filter)+ showModal( |
|
| 218 | +64 | ! |
- srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)+ modalDialog( |
|
| 219 | -+ | |||
| 65 | +! |
- }+ filter_manager_ui(session$ns("filter_manager")),
|
||
| 220 | -+ | |||
| 66 | +! |
- )+ size = "l", |
||
| 221 | -32x | +|||
| 67 | +! |
- logger::log_trace("init teal app has been initialized.")
+ footer = NULL, |
||
| 222 | -32x | +|||
| 68 | +! |
- return(res)+ easyClose = TRUE |
||
| 223 | +69 |
- }+ ) |
| 1 | +70 |
- #' Send input validation messages to output.+ ) |
||
| 2 | +71 |
- #'+ }) |
||
| 3 | +72 |
- #' Captures messages from `InputValidator` objects and collates them+ |
||
| 4 | -+ | |||
| 73 | +4x |
- #' into one message passed to `validate`.+ filter_manager_srv("filter_manager", filtered_data_list, filter)
|
||
| 5 | +74 |
- #'+ }) |
||
| 6 | +75 |
- #' `shiny::validate` is used to withhold rendering of an output element until+ } |
||
| 7 | +76 |
- #' certain conditions are met and to print a validation message in place+ |
||
| 8 | +77 |
- #' of the output element.+ #' @rdname module_filter_manager |
||
| 9 | +78 |
- #' `shinyvalidate::InputValidator` allows to validate input elements+ filter_manager_ui <- function(id) {
|
||
| 10 | -+ | |||
| 79 | +! |
- #' and to display specific messages in their respective input widgets.+ ns <- NS(id) |
||
| 11 | -+ | |||
| 80 | +! |
- #' `validate_inputs` provides a hybrid solution.+ div( |
||
| 12 | -+ | |||
| 81 | +! |
- #' Given an `InputValidator` object, messages corresponding to inputs that fail validation+ class = "filter_manager_content",+ |
+ ||
| 82 | +! | +
+ tableOutput(ns("slices_table")),
+ |
+ ||
| 83 | +! | +
+ snapshot_manager_ui(ns("snapshot_manager"))
|
||
| 13 | +84 |
- #' are extracted and placed in one validation message that is passed to a `validate`/`need` call.+ ) |
||
| 14 | +85 |
- #' This way the input `validator` messages are repeated in the output.+ } |
||
| 15 | +86 |
- #'+ |
||
| 16 | +87 |
- #' The `...` argument accepts any number of `InputValidator` objects+ #' Manage multiple `FilteredData` objects |
||
| 17 | +88 |
- #' or a nested list of such objects.+ #' |
||
| 18 | +89 |
- #' If `validators` are passed directly, all their messages are printed together+ #' Oversee filter states in the whole application. |
||
| 19 | +90 |
- #' under one (optional) header message specified by `header`. If a list is passed,+ #' |
||
| 20 | +91 |
- #' messages are grouped by `validator`. The list's names are used as headers+ #' @rdname module_filter_manager |
||
| 21 | +92 |
- #' for their respective message groups.+ #' @details |
||
| 22 | +93 |
- #' If neither of the nested list elements is named, a header message is taken from `header`.+ #' This module observes the changes of the filters in each `FilteredData` object |
||
| 23 | +94 |
- #'+ #' and keeps track of all filters used. A mapping of filters to modules |
||
| 24 | +95 |
- #' @param ... either any number of `InputValidator` objects+ #' is kept in the `mapping_matrix` object (which is actually a `data.frame`) |
||
| 25 | +96 |
- #' or an optionally named, possibly nested `list` of `InputValidator`+ #' that tracks which filters (rows) are active in which modules (columns). |
||
| 26 | +97 |
- #' objects, see `Details`+ #' |
||
| 27 | +98 |
- #' @param header `character(1)` generic validation message; set to NULL to omit+ #' @param id (`character(1)`)\cr |
||
| 28 | +99 |
- #'+ #' `shiny` module id. |
||
| 29 | +100 |
- #' @return+ #' @param filtered_data_list (`named list`)\cr |
||
| 30 | +101 |
- #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails.+ #' A list, possibly nested, of `FilteredData` objects. |
||
| 31 | +102 |
- #'+ #' Each `FilteredData` will be served to one module in the `teal` application. |
||
| 32 | +103 |
- #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`]+ #' The structure of the list must reflect the nesting of modules in tabs |
||
| 33 | +104 |
- #'+ #' and names of the list must be the same as labels of their respective modules. |
||
| 34 | +105 |
- #' @examples+ #' @inheritParams init |
||
| 35 | +106 |
- #' library(shiny)+ #' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`. |
||
| 36 | +107 |
- #' library(shinyvalidate)+ #' @keywords internal |
||
| 37 | +108 |
#' |
||
| 38 | +109 |
- #' ui <- fluidPage(+ filter_manager_srv <- function(id, filtered_data_list, filter) {
|
||
| 39 | -+ | |||
| 110 | +6x |
- #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
+ moduleServer(id, function(input, output, session) {
|
||
| 40 | -+ | |||
| 111 | +6x |
- #' sidebarLayout(+ logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
|
||
| 41 | +112 |
- #' sidebarPanel(+ |
||
| 42 | -+ | |||
| 113 | +6x |
- #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
||
| 43 | +114 |
- #' selectInput("number", "select a number:", 1:6),
+
|
||
| 44 | +115 |
- #' br(),+ # Create global list of slices. |
||
| 45 | +116 |
- #' selectInput("color", "select a color:",
+ # Contains all available teal_slice objects available to all modules. |
||
| 46 | +117 |
- #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
+ # Passed whole to instances of FilteredData used for individual modules. |
||
| 47 | +118 |
- #' multiple = TRUE+ # Down there a subset that pertains to the data sets used in that module is applied and displayed. |
||
| 48 | -+ | |||
| 119 | +6x |
- #' ),+ slices_global <- reactiveVal(filter) |
||
| 49 | +120 |
- #' sliderInput("size", "select point size:",
+
|
||
| 50 | -+ | |||
| 121 | +6x |
- #' min = 0.1, max = 4, value = 0.25+ filtered_data_list <- |
||
| 51 | -+ | |||
| 122 | +6x |
- #' )+ if (!is_module_specific) {
|
||
| 52 | +123 |
- #' ),+ # Retrieve the first FilteredData from potentially nested list. |
||
| 53 | +124 |
- #' mainPanel(plotOutput("plot"))
+ # List of length one is named "global_filters" because that name is forbidden for a module label. |
||
| 54 | -+ | |||
| 125 | +5x |
- #' )+ list(global_filters = unlist(filtered_data_list)[[1]]) |
||
| 55 | +126 |
- #' )+ } else {
|
||
| 56 | +127 |
- #'+ # Flatten potentially nested list of FilteredData objects while maintaining useful names. |
||
| 57 | +128 |
- #' server <- function(input, output) {
+ # Simply using `unlist` would result in concatenated names. |
||
| 58 | -+ | |||
| 129 | +1x |
- #' # set up input validation+ flatten_nested <- function(x, name = NULL) {
|
||
| 59 | -+ | |||
| 130 | +5x |
- #' iv <- InputValidator$new()+ if (inherits(x, "FilteredData")) {
|
||
| 60 | -+ | |||
| 131 | +3x |
- #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
+ setNames(list(x), name) |
||
| 61 | +132 |
- #' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
+ } else {
|
||
| 62 | -+ | |||
| 133 | +2x |
- #' iv$enable()+ unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name))) |
||
| 63 | +134 |
- #' # more input validation+ } |
||
| 64 | +135 |
- #' iv_par <- InputValidator$new()+ } |
||
| 65 | -+ | |||
| 136 | +1x |
- #' iv_par$add_rule("color", sv_required(message = "choose a color"))
+ flatten_nested(filtered_data_list) |
||
| 66 | +137 |
- #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color")
+ } |
||
| 67 | +138 |
- #' iv_par$add_rule(+ |
||
| 68 | +139 |
- #' "size",+ # Create mapping fo filters to modules in matrix form (presented as data.frame). |
||
| 69 | +140 |
- #' sv_between(+ # Modules get NAs for filteres that cannot be set for them. |
||
| 70 | -+ | |||
| 141 | +6x |
- #' left = 0.5, right = 3,+ mapping_matrix <- reactive({
|
||
| 71 | -+ | |||
| 142 | +6x |
- #' message_fmt = "choose a value between {left} and {right}"
+ state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id") |
||
| 72 | -+ | |||
| 143 | +6x |
- #' )+ mapping_smooth <- lapply(filtered_data_list, function(x) {
|
||
| 73 | -+ | |||
| 144 | +8x |
- #' )+ state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id") |
||
| 74 | -+ | |||
| 145 | +8x |
- #' iv_par$enable()+ state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id") |
||
| 75 | -+ | |||
| 146 | +8x |
- #'+ states_active <- state_ids_global %in% state_ids_local |
||
| 76 | -+ | |||
| 147 | +8x |
- #' output$plot <- renderPlot({
+ ifelse(state_ids_global %in% state_ids_allowed, states_active, NA) |
||
| 77 | +148 |
- #' # validate output+ }) |
||
| 78 | +149 |
- #' switch(input[["method"]],+ |
||
| 79 | -+ | |||
| 150 | +6x |
- #' "sequential" = {
+ as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE) |
||
| 80 | +151 |
- #' validate_inputs(iv)+ }) |
||
| 81 | +152 |
- #' validate_inputs(iv_par, header = "Set proper graphical parameters")+ |
||
| 82 | -+ | |||
| 153 | +6x |
- #' },+ output$slices_table <- renderTable( |
||
| 83 | -+ | |||
| 154 | +6x |
- #' "combined" = validate_inputs(iv, iv_par),+ expr = {
|
||
| 84 | +155 |
- #' "grouped" = validate_inputs(list(+ # Display logical values as UTF characters. |
||
| 85 | -+ | |||
| 156 | +3x |
- #' "Some inputs require attention" = iv,+ mm <- mapping_matrix() |
||
| 86 | -+ | |||
| 157 | +3x |
- #' "Set proper graphical parameters" = iv_par+ mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060)) |
||
| 87 | -+ | |||
| 158 | +3x |
- #' ))+ mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x)) |
||
| 88 | -+ | |||
| 159 | +3x |
- #' )+ if (!is_module_specific) colnames(mm) <- "Global Filters" |
||
| 89 | +160 |
- #'+ |
||
| 90 | +161 |
- #' plot(eruptions ~ waiting, faithful,+ # Display placeholder if no filters defined. |
||
| 91 | -+ | |||
| 162 | +3x |
- #' las = 1, pch = 16,+ if (nrow(mm) == 0L) {
|
||
| 92 | -+ | |||
| 163 | +3x |
- #' col = input[["color"]], cex = input[["size"]]+ mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE) |
||
| 93 | -+ | |||
| 164 | +3x |
- #' )+ rownames(mm) <- "" |
||
| 94 | +165 |
- #' })+ } |
||
| 95 | +166 |
- #' }+ |
||
| 96 | +167 |
- #'+ # Report Previewer will not be displayed. |
||
| 97 | -+ | |||
| 168 | +3x |
- #' if (interactive()) {
+ mm[names(mm) != "Report previewer"] |
||
| 98 | +169 |
- #' shinyApp(ui, server)+ }, |
||
| 99 | -+ | |||
| 170 | +6x |
- #' }+ align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
|
||
| 100 | -+ | |||
| 171 | +6x |
- #'+ rownames = TRUE |
||
| 101 | +172 |
- #' @export+ ) |
||
| 102 | +173 |
- #'+ |
||
| 103 | +174 |
- validate_inputs <- function(..., header = "Some inputs require attention") {
+ # Create list of module calls. |
||
| 104 | -36x | +175 | +6x |
- dots <- list(...)+ modules_out <- lapply(names(filtered_data_list), function(module_name) {
|
| 105 | -2x | -
- if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
- |
- ||
| 106 | -+ | 176 | +8x |
-
+ filter_manager_module_srv( |
| 107 | -34x | +177 | +8x |
- messages <- extract_validator(dots, header)+ id = module_name, |
| 108 | -34x | +178 | +8x |
- failings <- if (!any_names(dots)) {
+ module_fd = filtered_data_list[[module_name]], |
| 109 | -29x | +179 | +8x |
- add_header(messages, header)+ slices_global = slices_global |
| 110 | +180 |
- } else {
+ ) |
||
| 111 | -5x | +|||
| 181 | +
- unlist(messages)+ }) |
|||
| 112 | +182 |
- }+ |
||
| 113 | +183 |
-
+ # Call snapshot manager. |
||
| 114 | -34x | +184 | +6x |
- shiny::validate(shiny::need(is.null(failings), failings))+ snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
|
| 115 | +185 |
- }+ + |
+ ||
| 186 | +6x | +
+ modules_out # returned for testing purpose |
||
| 116 | +187 |
-
+ }) |
||
| 117 | +188 |
- ### internal functions+ } |
||
| 118 | +189 | |||
| 119 | +190 |
- #' @keywords internal+ #' Module specific filter manager |
||
| 120 | +191 |
- # recursive object type test+ #' |
||
| 121 | +192 |
- # returns logical of length 1+ #' Track filter states in single module. |
||
| 122 | +193 |
- is_validators <- function(x) {
+ #' |
||
| 123 | -118x | +|||
| 194 | +
- all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))+ #' This module tracks the state of a single `FilteredData` object and global `teal_slices` |
|||
| 124 | +195 |
- }+ #' and updates both objects as necessary. Filter states added in different modules |
||
| 125 | +196 |
-
+ #' Filter states added any individual module are added to global `teal_slices` |
||
| 126 | +197 |
- #' @keywords internal+ #' and from there become available in other modules |
||
| 127 | +198 |
- # test if an InputValidator object is enabled+ #' by setting `private$available_teal_slices` in each `FilteredData`. |
||
| 128 | +199 |
- # returns logical of length 1+ #' |
||
| 129 | +200 |
- # official method requested at https://github.com/rstudio/shinyvalidate/issues/64+ #' @param id (`character(1)`)\cr |
||
| 130 | +201 |
- validator_enabled <- function(x) {
+ #' `shiny` module id. |
||
| 131 | -49x | +|||
| 202 | +
- x$.__enclos_env__$private$enabled+ #' @param module_fd (`FilteredData`)\cr |
|||
| 132 | +203 |
- }+ #' object to filter data in the teal-module |
||
| 133 | +204 |
-
+ #' @param slices_global (`reactiveVal`)\cr |
||
| 134 | +205 |
- #' @keywords internal+ #' stores `teal_slices` with all available filters; allows the following actions: |
||
| 135 | +206 |
- # recursively extract messages from validator list+ #' - to disable/enable a specific filter in a module |
||
| 136 | +207 |
- # returns character vector or a list of character vectors, possibly nested and named+ #' - to restore saved filter settings |
||
| 137 | +208 |
- extract_validator <- function(iv, header) {
+ #' - to save current filter panel settings |
||
| 138 | -113x | +|||
| 209 | +
- if (inherits(iv, "InputValidator")) {
+ #' @return A `reactive` expression containing the slices active in this module. |
|||
| 139 | -49x | +|||
| 210 | +
- add_header(gather_messages(iv), header)+ #' @keywords internal |
|||
| 140 | +211 |
- } else {
+ #' |
||
| 141 | -58x | +|||
| 212 | +
- if (is.null(names(iv))) names(iv) <- rep("", length(iv))
+ filter_manager_module_srv <- function(id, module_fd, slices_global) {
|
|||
| 142 | -64x | +213 | +8x |
- mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)+ moduleServer(id, function(input, output, session) {
|
| 143 | +214 |
- }+ # Only operate on slices that refer to data sets present in this module. |
||
| 144 | -+ | |||
| 215 | +8x |
- }+ module_fd$set_available_teal_slices(reactive(slices_global())) |
||
| 145 | +216 | |||
| 146 | +217 |
- #' @keywords internal+ # Track filter state of this module. |
||
| 147 | -+ | |||
| 218 | +8x |
- # collate failing messages from validator+ slices_module <- reactive(module_fd$get_filter_state()) |
||
| 148 | +219 |
- # returns list+ |
||
| 149 | +220 |
- gather_messages <- function(iv) {
+ # Reactive values for comparing states. |
||
| 150 | -49x | +221 | +8x |
- if (validator_enabled(iv)) {
+ previous_slices <- reactiveVal(isolate(slices_module())) |
| 151 | -46x | +222 | +8x |
- status <- iv$validate()+ slices_added <- reactiveVal(NULL) |
| 152 | -46x | +|||
| 223 | +
- failing_inputs <- Filter(Negate(is.null), status)+ |
|||
| 153 | -46x | +|||
| 224 | +
- unique(lapply(failing_inputs, function(x) x[["message"]]))+ # Observe changes in module filter state and trigger appropriate actions. |
|||
| 154 | -+ | |||
| 225 | +8x |
- } else {
+ observeEvent(slices_module(), ignoreNULL = FALSE, {
|
||
| 155 | +226 | 3x |
- logger::log_warn("Validator is disabled and will be omitted.")
+ logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
|
|
| 156 | +227 | 3x |
- list()+ added <- setdiff_teal_slices(slices_module(), slices_global()) |
|
| 157 | -+ | |||
| 228 | +! |
- }+ if (length(added)) slices_added(added) |
||
| 158 | -+ | |||
| 229 | +3x |
- }+ previous_slices(slices_module()) |
||
| 159 | +230 |
-
+ }) |
||
| 160 | +231 |
- #' @keywords internal+ |
||
| 161 | -+ | |||
| 232 | +8x |
- # add optional header to failing messages+ observeEvent(slices_added(), ignoreNULL = TRUE, {
|
||
| 162 | -+ | |||
| 233 | +! |
- add_header <- function(messages, header = "") {
+ logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
|
||
| 163 | -78x | +|||
| 234 | +
- ans <- unlist(messages)+ # In case the new state has the same id as an existing state, add a suffix to it. |
|||
| 164 | -78x | +|||
| 235 | +! |
- if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
+ global_ids <- vapply(slices_global(), `[[`, character(1L), "id") |
||
| 165 | -31x | +|||
| 236 | +! |
- ans <- c(paste0(header, "\n"), ans, "\n")+ lapply( |
||
| 166 | -+ | |||
| 237 | +! |
- }+ slices_added(), |
||
| 167 | -78x | +|||
| 238 | +! |
- ans+ function(slice) {
|
||
| 168 | -+ | |||
| 239 | +! |
- }+ if (slice$id %in% global_ids) {
|
||
| 169 | -+ | |||
| 240 | +! |
-
+ slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1) |
||
| 170 | +241 |
- #' @keywords internal+ } |
||
| 171 | +242 |
- # recursively check if the object contains a named list+ } |
||
| 172 | +243 |
- any_names <- function(x) {
+ ) |
||
| 173 | -103x | +|||
| 244 | +! |
- any(+ slices_global_new <- c(slices_global(), slices_added()) |
||
| 174 | -103x | +|||
| 245 | +! |
- if (is.list(x)) {
+ slices_global(slices_global_new) |
||
| 175 | -58x | +|||
| 246 | +! |
- if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))+ slices_added(NULL) |
||
| 176 | +247 |
- } else {
+ }) |
||
| 177 | -40x | +|||
| 248 | +
- FALSE+ |
|||
| 178 | -+ | |||
| 249 | +8x |
- }+ slices_module # returned for testing purpose |
||
| 179 | +250 |
- )+ }) |
||
| 180 | +251 |
}@@ -18683,1864 +19327,1886 @@ teal coverage - 72.73% |
| 1 |
- #' Get dummy `CDISC` data+ # This file contains Shiny modules useful for debugging and developing teal. |
||
| 2 |
- #'+ # We do not export the functions in this file. They are for |
||
| 3 |
- #' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`.+ # developers only and can be accessed via `:::`. |
||
| 4 |
- #' Some NAs are also introduced to stress test.+ |
||
| 5 |
- #'+ #' Dummy module to show the filter calls generated by the right encoding panel |
||
| 6 |
- #' @return `cdisc_data`+ #' |
||
| 7 |
- #' @keywords internal+ #' |
||
| 8 |
- example_cdisc_data <- function() { # nolint
+ #' Please do not remove, this is useful for debugging teal without |
||
| 9 | -! | +
- ADSL <- data.frame( # nolint+ #' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
|
|
| 10 | -! | +
- STUDYID = "study",+ #' and avoids session restarts! |
|
| 11 | -! | +
- USUBJID = 1:10,+ #' |
|
| 12 | -! | +
- SEX = sample(c("F", "M"), 10, replace = TRUE),
+ #' @param label `character` label of module |
|
| 13 | -! | +
- AGE = stats::rpois(10, 40)+ #' @keywords internal |
|
| 14 |
- )+ #' |
||
| 15 | -! | +
- ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint+ #' @examples |
|
| 16 | -! | +
- ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
+ #' app <- init( |
|
| 17 | -! | +
- ADTTE$AVAL <- c( # nolint+ #' data = list(iris = iris, mtcars = mtcars), |
|
| 18 | -! | +
- stats::rnorm(10, mean = 700, sd = 200), # dummy OS level+ #' modules = teal:::filter_calls_module(), |
|
| 19 | -! | +
- stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level+ #' header = "Simple teal app" |
|
| 20 | -! | +
- stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level+ #' ) |
|
| 21 |
- )+ #' if (interactive()) {
|
||
| 22 |
-
+ #' runApp(app) |
||
| 23 | -! | +
- ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint+ #' } |
|
| 24 | -! | +
- ADSL$SEX[c(2, 5)] <- NA # nolint+ filter_calls_module <- function(label = "Filter Calls Module") { # nolint
|
|
| 25 | -+ | ! |
-
+ checkmate::assert_string(label) |
| 26 | -! | +
- cdisc_data_obj <- teal.data::cdisc_data(+ |
|
| 27 | ! |
- cdisc_dataset(dataname = "ADSL", x = ADSL),+ module( |
|
| 28 | ! |
- cdisc_dataset(dataname = "ADTTE", x = ADTTE)+ label = label, |
|
| 29 | -+ | ! |
- )+ server = function(input, output, session, data) {
|
| 30 | -+ | ! |
-
+ checkmate::assert_class(data, "tdata") |
| 31 | -! | +
- res <- teal.data::cdisc_data(+ |
|
| 32 | ! |
- teal.data::cdisc_dataset(dataname = "ADSL", x = ADSL),+ output$filter_calls <- renderText({
|
|
| 33 | ! |
- teal.data::cdisc_dataset(dataname = "ADTTE", x = ADTTE),+ get_code_tdata(data) |
|
| 34 | -! | +
- code = '+ }) |
|
| 35 | -! | +
- ADSL <- data.frame(+ }, |
|
| 36 | ! |
- STUDYID = "study",+ ui = function(id, ...) {
|
|
| 37 | ! |
- USUBJID = 1:10,+ ns <- NS(id) |
|
| 38 | ! |
- SEX = sample(c("F", "M"), 10, replace = TRUE),
+ div( |
|
| 39 | ! |
- AGE = rpois(10, 40)+ h2("The following filter calls are generated:"),
|
|
| 40 | -+ | ! |
- )+ verbatimTextOutput(ns("filter_calls"))
|
| 41 | -! | +
- ADTTE <- rbind(ADSL, ADSL, ADSL)+ ) |
|
| 42 | -! | +
- ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
+ }, |
|
| 43 | ! |
- ADTTE$AVAL <- c(+ datanames = "all" |
|
| 44 | -! | +
- rnorm(10, mean = 700, sd = 200),+ ) |
|
| 45 | -! | ++ |
+ }+ |
+
| 1 | ++ |
+ # This is the main function from teal to be used by the end-users. Although it delegates+ |
+ |
| 2 | +
- rnorm(10, mean = 400, sd = 100),+ # directly to `module_teal_with_splash.R`, we keep it in a separate file because its doc is quite large |
||
| 46 | -! | +||
| 3 | +
- rnorm(10, mean = 450, sd = 200)+ # and it is very end-user oriented. It may also perform more argument checking with more informative |
||
| 47 | +4 |
- )+ # error messages. |
|
| 48 | +5 | ||
| 49 | -! | +||
| 6 | +
- ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE)+ |
||
| 50 | -! | +||
| 7 | +
- ADSL$SEX[c(2, 5)] <- NA+ #' Create the Server and UI Function For the Shiny App |
||
| 51 | +8 |
- '+ #' |
|
| 52 | +9 |
- )+ #' @description `r lifecycle::badge("stable")`
|
|
| 53 | -! | +||
| 10 | +
- return(res)+ #' End-users: This is the most important function for you to start a |
||
| 54 | +11 |
- }+ #' teal app that is composed out of teal modules. |
|
| 55 | +12 |
-
+ #' |
|
| 56 | +13 |
- #' Get datasets to go with example modules.+ #' **Notes for developers**: |
|
| 57 | +14 |
- #'+ #' This is a wrapper function around the `module_teal.R` functions. Unless you are |
|
| 58 | +15 |
- #' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`.+ #' an end-user, don't use this function, but instead this module. |
|
| 59 | +16 |
- #' Each list leaf is the same `FilteredData` object.+ #' |
|
| 60 | +17 |
- #'+ #' @param data (`TealData` or `TealDataset` or `TealDatasetConnector` or `list` or `data.frame` |
|
| 61 | +18 |
- #' @return named list of `FilteredData` objects, each with `ADSL` set.+ #' or `MultiAssayExperiment`)\cr |
|
| 62 | +19 |
- #' @keywords internal+ #' `R6` object as returned by [teal.data::cdisc_data()], [teal.data::teal_data()], |
|
| 63 | +20 |
- example_datasets <- function() { # nolint
+ #' [teal.data::cdisc_dataset()], [teal.data::dataset()], [teal.data::dataset_connector()] or |
|
| 64 | -! | +||
| 21 | +
- dummy_cdisc_data <- example_cdisc_data()+ #' [teal.data::cdisc_dataset_connector()] or a single `data.frame` or a `MultiAssayExperiment` |
||
| 65 | -! | +||
| 22 | +
- datasets <- teal.slice::init_filtered_data(dummy_cdisc_data)+ #' or a list of the previous objects or function returning a named list. |
||
| 66 | -! | +||
| 23 | +
- list(+ #' NOTE: teal does not guarantee reproducibility of the code when names of the list elements |
||
| 67 | -! | +||
| 24 | +
- "d2" = list(+ #' do not match the original object names. To ensure reproducibility please use [teal.data::teal_data()] |
||
| 68 | -! | +||
| 25 | +
- "d3" = list(+ #' or [teal.data::cdisc_data()] with `check = TRUE` enabled. |
||
| 69 | -! | +||
| 26 | +
- "aaa1" = datasets,+ #' @param modules (`list`, `teal_modules` or `teal_module`)\cr |
||
| 70 | -! | +||
| 27 | +
- "aaa2" = datasets,+ #' nested list of `teal_modules` or `teal_module` objects or a single |
||
| 71 | -! | +||
| 28 | +
- "aaa3" = datasets+ #' `teal_modules` or `teal_module` object. These are the specific output modules which |
||
| 72 | +29 |
- ),+ #' will be displayed in the teal application. See [modules()] and [module()] for |
|
| 73 | -! | +||
| 30 | +
- "bbb" = datasets+ #' more details. |
||
| 74 | +31 |
- ),+ #' @param title (`NULL` or `character`)\cr |
|
| 75 | -! | +||
| 32 | +
- "ccc" = datasets+ #' The browser window title (defaults to the host URL of the page). |
||
| 76 | +33 |
- )+ #' @param filter (`teal_slices`)\cr |
|
| 77 | +34 |
- }+ #' Specification of initial filter. Filters can be specified using [teal::teal_slices()]. |
|
| 78 | +35 |
-
+ #' Old way of specifying filters through a list is deprecated and will be removed in the |
|
| 79 | +36 |
- #' An example `teal` module+ #' next release. Please fix your applications to use [teal::teal_slices()]. |
|
| 80 | +37 |
- #'+ #' @param header (`shiny.tag` or `character`) \cr |
|
| 81 | +38 |
- #' @description `r lifecycle::badge("experimental")`
+ #' the header of the app. Note shiny code placed here (and in the footer |
|
| 82 | +39 |
- #' @inheritParams module+ #' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function |
|
| 83 | +40 |
- #' @return A `teal` module which can be included in the `modules` argument to [teal::init()].+ #' (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here. |
|
| 84 | +41 |
- #' @examples+ #' @param footer (`shiny.tag` or `character`)\cr |
|
| 85 | +42 |
- #' app <- init(+ #' the footer of the app |
|
| 86 | +43 |
- #' data = teal_data(+ #' @param id (`character`)\cr |
|
| 87 | +44 |
- #' dataset("IRIS", iris),
+ #' module id to embed it, if provided, |
|
| 88 | +45 |
- #' dataset("MTCARS", mtcars)
+ #' the server function must be called with [shiny::moduleServer()]; |
|
| 89 | +46 |
- #' ),+ #' See the vignette for an example. However, [ui_teal_with_splash()] |
|
| 90 | +47 |
- #' modules = example_module()+ #' is then preferred to this function. |
|
| 91 | +48 |
- #' )+ #' |
|
| 92 | +49 |
- #' if (interactive()) {
+ #' @return named list with `server` and `ui` function |
|
| 93 | +50 |
- #' shinyApp(app$ui, app$server)+ #' |
|
| 94 | +51 |
- #' }+ #' @export |
|
| 95 | +52 |
- #' @export+ #' |
|
| 96 | +53 |
- example_module <- function(label = "example teal module", datanames = "all") {
+ #' @include modules.R |
|
| 97 | -15x | +||
| 54 | +
- checkmate::assert_string(label)+ #' |
||
| 98 | -15x | +||
| 55 | +
- module(+ #' @examples |
||
| 99 | -15x | +||
| 56 | +
- label,+ #' new_iris <- transform(iris, id = seq_len(nrow(iris))) |
||
| 100 | -15x | +||
| 57 | +
- server = function(id, data) {
+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars))) |
||
| 101 | -! | +||
| 58 | +
- checkmate::assert_class(data, "tdata")+ #' |
||
| 102 | -! | +||
| 59 | +
- moduleServer(id, function(input, output, session) {
+ #' app <- init( |
||
| 103 | -! | +||
| 60 | +
- output$text <- renderPrint(data[[input$dataname]]())+ #' data = teal_data( |
||
| 104 | +61 |
- })+ #' dataset("new_iris", new_iris),
|
|
| 105 | +62 |
- },+ #' dataset("new_mtcars", new_mtcars),
|
|
| 106 | -15x | +||
| 63 | +
- ui = function(id, data) {
+ #' code = " |
||
| 107 | -! | +||
| 64 | +
- ns <- NS(id)+ #' new_iris <- transform(iris, id = seq_len(nrow(iris))) |
||
| 108 | -! | +||
| 65 | +
- teal.widgets::standard_layout(+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars))) |
||
| 109 | -! | +||
| 66 | +
- output = verbatimTextOutput(ns("text")),
+ #' " |
||
| 110 | -! | +||
| 67 | +
- encoding = selectInput(ns("dataname"), "Choose a dataset", choices = names(data))
+ #' ), |
||
| 111 | +68 |
- )+ #' modules = modules( |
|
| 112 | +69 |
- },+ #' module( |
|
| 113 | -15x | +||
| 70 | +
- datanames = datanames+ #' label = "data source", |
||
| 114 | +71 |
- )+ #' server = function(input, output, session, data) {},
|
|
| 115 | +72 |
- }+ #' ui = function(id, ...) div(p("information about data source")),
|
|
| 116 | +73 |
-
+ #' datanames = "all" |
|
| 117 | +74 |
-
+ #' ), |
|
| 118 | +75 |
- #' Get example modules.+ #' example_module(label = "example teal module"), |
|
| 119 | +76 |
- #'+ #' module( |
|
| 120 | +77 |
- #' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created.+ #' "Iris Sepal.Length histogram", |
|
| 121 | +78 |
- #' @param datanames (`character`)\cr+ #' server = function(input, output, session, data) {
|
|
| 122 | +79 |
- #' names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`.+ #' output$hist <- renderPlot( |
|
| 123 | +80 |
- #' @return `teal_modules`+ #' hist(data[["new_iris"]]()$Sepal.Length) |
|
| 124 | +81 |
- #' @keywords internal+ #' ) |
|
| 125 | +82 |
- example_modules <- function(datanames = c("ADSL", "ADTTE")) {
+ #' }, |
|
| 126 | -2x | +||
| 83 | +
- checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
+ #' ui = function(id, ...) {
|
||
| 127 | -2x | +||
| 84 | +
- mods <- modules(+ #' ns <- NS(id) |
||
| 128 | -2x | +||
| 85 | +
- label = "d1",+ #' plotOutput(ns("hist"))
|
||
| 129 | -2x | +||
| 86 | +
- modules(+ #' }, |
||
| 130 | -2x | +||
| 87 | +
- label = "d2",+ #' datanames = "new_iris" |
||
| 131 | -2x | +||
| 88 | +
- modules(+ #' ) |
||
| 132 | -2x | +||
| 89 | +
- label = "d3",+ #' ), |
||
| 133 | -2x | +||
| 90 | +
- example_module(label = "aaa1", datanames = datanames),+ #' title = "App title", |
||
| 134 | -2x | +||
| 91 | +
- example_module(label = "aaa2", datanames = datanames),+ #' filter = teal_slices( |
||
| 135 | -2x | +||
| 92 | +
- example_module(label = "aaa3", datanames = datanames)+ #' teal_slice(dataname = "new_iris", varname = "Species"), |
||
| 136 | +93 |
- ),+ #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"), |
|
| 137 | -2x | +||
| 94 | +
- example_module(label = "bbb", datanames = datanames)+ #' teal_slice(dataname = "new_mtcars", varname = "cyl"), |
||
| 138 | +95 |
- ),+ #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
|
|
| 139 | -2x | +||
| 96 | +
- example_module(label = "ccc", datanames = datanames)+ #' mapping = list( |
||
| 140 | +97 |
- )+ #' `example teal module` = "new_iris Species", |
|
| 141 | -2x | +||
| 98 | +
- return(mods)+ #' `Iris Sepal.Length histogram` = "new_iris Species", |
||
| 142 | +99 |
- }+ #' global_filters = "new_mtcars cyl" |
| 1 | +100 |
- #' Generates library calls from current session info+ #' ) |
||
| 2 | +101 |
- #'+ #' ), |
||
| 3 | +102 |
- #' Function to create multiple library calls out of current session info to make reproducible code works.+ #' header = tags$h1("Sample App"),
|
||
| 4 | +103 |
- #'+ #' footer = tags$p("Copyright 2017 - 2023")
|
||
| 5 | +104 |
- #' @return Character object contain code+ #' ) |
||
| 6 | +105 |
- #' @keywords internal+ #' if (interactive()) {
|
||
| 7 | +106 |
- get_rcode_libraries <- function() {
+ #' shinyApp(app$ui, app$server) |
||
| 8 | -14x | +|||
| 107 | +
- vapply(+ #' } |
|||
| 9 | -14x | +|||
| 108 | +
- utils::sessionInfo()$otherPkgs,+ #' |
|||
| 10 | -14x | +|||
| 109 | +
- function(x) {
+ init <- function(data, |
|||
| 11 | -238x | +|||
| 110 | +
- paste0("library(", x$Package, ")")
+ modules, |
|||
| 12 | +111 |
- },+ title = NULL, |
||
| 13 | -14x | +|||
| 112 | +
- character(1)+ filter = teal_slices(), |
|||
| 14 | +113 |
- ) %>%+ header = tags$p(), |
||
| 15 | +114 |
- # put it into reverse order to correctly simulate executed code+ footer = tags$p(), |
||
| 16 | -14x | +|||
| 115 | +
- rev() %>%+ id = character(0)) {
|
|||
| 17 | -14x | +116 | +38x |
- paste0(sep = "\n") %>%+ logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
|
| 18 | -14x | +117 | +38x |
- paste0(collapse = "")+ data <- teal.data::to_relational_data(data = data) |
| 19 | +118 |
- }+ |
||
| 20 | -+ | |||
| 119 | +33x |
-
+ checkmate::assert_class(data, "TealData") |
||
| 21 | -+ | |||
| 120 | +33x |
-
+ checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
|
||
| 22 | -+ | |||
| 121 | +33x |
-
+ checkmate::assert_string(title, null.ok = TRUE) |
||
| 23 | -+ | |||
| 122 | +33x |
- get_rcode_str_install <- function() {
+ checkmate::assert( |
||
| 24 | -18x | +123 | +33x |
- code_string <- getOption("teal.load_nest_code")
+ checkmate::check_class(filter, "teal_slices"),+ |
+
| 124 | +33x | +
+ checkmate::check_list(filter, names = "named") |
||
| 25 | +125 |
-
+ ) |
||
| 26 | -18x | +126 | +32x |
- if (!is.null(code_string) && is.character(code_string)) {
+ checkmate::assert_multi_class(header, c("shiny.tag", "character"))
|
| 27 | -2x | +127 | +32x |
- return(code_string)+ checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
|
| 28 | -+ | |||
| 128 | +32x |
- }+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
||
| 29 | +129 | |||
| 30 | -16x | +130 | +32x |
- return("# Add any code to install/load your NEST environment here\n")
+ teal.logger::log_system_info() |
| 31 | +131 |
- }+ |
||
| 32 | -+ | |||
| 132 | +32x |
-
+ if (inherits(modules, "teal_module")) {
|
||
| 33 | -+ | |||
| 133 | +1x |
- #' Get datasets code+ modules <- list(modules) |
||
| 34 | +134 |
- #'+ }+ |
+ ||
| 135 | +32x | +
+ if (inherits(modules, "list")) {
|
||
| 35 | -+ | |||
| 136 | +2x |
- #' Get combined code from `FilteredData` and from `CodeClass` object.+ modules <- do.call(teal::modules, modules) |
||
| 36 | +137 |
- #'+ } |
||
| 37 | +138 |
- #' @param datanames (`character`) names of datasets to extract code from+ |
||
| 38 | +139 |
- #' @param datasets (`FilteredData`) object+ # resolve modules datanames |
||
| 39 | -+ | |||
| 140 | +32x |
- #' @param hashes named (`list`) of hashes per dataset+ datanames <- teal.data::get_dataname(data) |
||
| 40 | -+ | |||
| 141 | +32x |
- #'+ join_keys <- data$get_join_keys() |
||
| 41 | -+ | |||
| 142 | +32x |
- #' @return `character(3)` containing following elements:+ resolve_modules_datanames <- function(modules) {
|
||
| 42 | -+ | |||
| 143 | +240x |
- #' - code from `CodeClass` (data loading code)+ if (inherits(modules, "teal_modules")) {
|
||
| 43 | -+ | |||
| 144 | +90x |
- #' - hash check of loaded objects+ modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE) |
||
| 44 | -+ | |||
| 145 | +90x |
- #'+ modules |
||
| 45 | +146 |
- #' @keywords internal+ } else {
|
||
| 46 | -+ | |||
| 147 | +150x |
- get_datasets_code <- function(datanames, datasets, hashes) {
+ modules$datanames <- if (identical(modules$datanames, "all")) {
|
||
| 47 | -14x | +148 | +5x |
- str_code <- datasets$get_code(datanames)+ datanames |
| 48 | -14x | +149 | +150x |
- if (length(str_code) == 0 || (length(str_code) == 1 && str_code == "")) {
+ } else if (is.character(modules$datanames)) {
|
| 49 | -! | +|||
| 150 | +145x |
- str_code <- "message('Preprocessing is empty')"
+ datanames_adjusted <- intersect(modules$datanames, datanames) |
||
| 50 | -14x | +151 | +145x |
- } else if (length(str_code) > 0) {
+ include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)+ |
+
| 152 | ++ |
+ } |
||
| 51 | -14x | +153 | +150x |
- str_code <- paste0(str_code, "\n\n")+ modules |
| 52 | +154 |
- }+ } |
||
| 53 | +155 |
-
+ } |
||
| 54 | -14x | +156 | +32x |
- if (!datasets$get_check()) {
+ modules <- resolve_modules_datanames(modules = modules) |
| 55 | -10x | +|||
| 157 | +
- check_note_string <- paste0(+ |
|||
| 56 | -10x | +158 | +32x |
- c(+ if (!inherits(filter, "teal_slices")) {
|
| 57 | -10x | +159 | +1x |
- "message(paste(\"Reproducibility of data import and preprocessing was not explicitly checked\",",+ checkmate::assert_subset(names(filter), choices = datanames) |
| 58 | -10x | +|||
| 160 | +
- " \" ('check = FALSE' is set). Contact app developer if this is an issue.\n\"))"
+ # list_to_teal_slices is lifted from teal.slice package, see zzz.R |
|||
| 59 | +161 |
- ),+ # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0). |
||
| 60 | -10x | +162 | +1x |
- collapse = "\n"+ filter <- list_to_teal_slices(filter) |
| 61 | +163 |
- )+ }+ |
+ ||
| 164 | ++ |
+ # convert teal.slice::teal_slices to teal::teal_slices |
||
| 62 | -10x | +165 | +32x |
- str_code <- paste0(str_code, "\n\n", check_note_string)+ filter <- as.teal_slices(as.list(filter)) |
| 63 | +166 |
- }+ |
||
| 64 | +167 |
-
+ # check teal_slices |
||
| 65 | -14x | +168 | +32x |
- str_hash <- paste(+ for (i in seq_along(filter)) {
|
| 66 | -14x | +169 | +2x |
- paste0(+ dataname_i <- shiny::isolate(filter[[i]]$dataname) |
| 67 | -14x | +170 | +2x |
- vapply(+ if (!dataname_i %in% datanames) {
|
| 68 | -14x | +|||
| 171 | +! |
- datanames,+ stop( |
||
| 69 | -14x | +|||
| 172 | +! |
- function(dataname) {
+ sprintf( |
||
| 70 | -17x | +|||
| 173 | +! |
- sprintf(+ "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s", |
||
| 71 | -17x | +|||
| 174 | +! |
- "stopifnot(%s == %s)",+ i, |
||
| 72 | -17x | +|||
| 175 | +! |
- deparse1(bquote(rlang::hash(.(as.name(dataname))))),+ dataname_i, |
||
| 73 | -17x | +|||
| 176 | +! |
- deparse1(hashes[[dataname]])+ toString(datanames) |
||
| 74 | +177 |
- )+ ) |
||
| 75 | +178 |
- },- |
- ||
| 76 | -14x | -
- character(1)+ ) |
||
| 77 | +179 |
- ),+ } |
||
| 78 | -14x | +|||
| 180 | +
- collapse = "\n"+ } |
|||
| 79 | +181 |
- ),+ |
||
| 80 | -14x | +182 | +32x |
- "\n\n"+ if (isTRUE(attr(filter, "module_specific"))) {
|
| 81 | -+ | |||
| 183 | +! |
- )+ module_names <- unlist(c(module_labels(modules), "global_filters")) |
||
| 82 | -+ | |||
| 184 | +! |
-
+ failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names) |
||
| 83 | -14x | +|||
| 185 | +! |
- c(str_code, str_hash)+ if (length(failed_mod_names)) {
|
||
| 84 | -+ | |||
| 186 | +! |
- }+ stop( |
| 1 | -+ | |||
| 187 | +! |
- #' Create a `teal` module for previewing a report+ sprintf( |
||
| 2 | -+ | |||
| 188 | +! |
- #'+ "Some module names in the mapping arguments don't match module labels.\n %s not in %s", |
||
| 3 | -+ | |||
| 189 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ toString(failed_mod_names), |
||
| 4 | -+ | |||
| 190 | +! |
- #' This function wraps [teal.reporter::reporter_previewer_ui()] and+ toString(unique(module_names)) |
||
| 5 | +191 |
- #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be+ ) |
||
| 6 | +192 |
- #' used in `teal` applications.+ ) |
||
| 7 | +193 |
- #'+ } |
||
| 8 | +194 |
- #' If you are creating a `teal` application using [teal::init()] then this+ |
||
| 9 | -+ | |||
| 195 | +! |
- #' module will be added to your application automatically if any of your `teal modules`+ if (anyDuplicated(module_names)) {
|
||
| 10 | +196 |
- #' support report generation+ # In teal we are able to set nested modules with duplicated label. |
||
| 11 | +197 |
- #'+ # Because mapping argument bases on the relationship between module-label and filter-id, |
||
| 12 | +198 |
- #' @inheritParams module+ # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label) |
||
| 13 | -+ | |||
| 199 | +! |
- #' @param server_args (`named list`)\cr+ stop( |
||
| 14 | -+ | |||
| 200 | +! |
- #' Arguments passed to [teal.reporter::reporter_previewer_srv()].+ sprintf( |
||
| 15 | -+ | |||
| 201 | +! |
- #' @return `teal_module` containing the `teal.reporter` previewer functionality+ "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ", |
||
| 16 | -+ | |||
| 202 | +! |
- #' @export+ toString(module_names[duplicated(module_names)]) |
||
| 17 | +203 |
- reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
+ ) |
||
| 18 | -4x | +|||
| 204 | +
- checkmate::assert_string(label)+ ) |
|||
| 19 | -2x | +|||
| 205 | +
- checkmate::assert_list(server_args, names = "named")+ } |
|||
| 20 | -2x | +|||
| 206 | +
- checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))+ } |
|||
| 21 | +207 | |||
| 22 | -2x | +|||
| 208 | +
- srv <- function(id, reporter, ...) {
+ # Note regarding case `id = character(0)`: |
|||
| 23 | -! | +|||
| 209 | +
- teal.reporter::reporter_previewer_srv(id, reporter, ...)+ # rather than using `callModule` and creating a submodule of this module, we directly modify |
|||
| 24 | +210 |
- }+ # the `ui` and `server` with `id = character(0)` and calling the server function directly |
||
| 25 | +211 |
-
+ # rather than through `callModule` |
||
| 26 | -2x | +212 | +32x |
- ui <- function(id, ...) {
+ res <- list( |
| 27 | -! | +|||
| 213 | +32x |
- teal.reporter::reporter_previewer_ui(id, ...)+ ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer), |
||
| 28 | -+ | |||
| 214 | +32x |
- }+ server = function(input, output, session) {
|
||
| 29 | +215 |
-
+ # copy object so that load won't be shared between the session |
||
| 30 | -2x | +|||
| 216 | +! |
- module <- module(+ data <- data$copy(deep = TRUE) |
||
| 31 | -2x | +|||
| 217 | +! |
- label = "temporary label",+ filter <- deep_copy_filter(filter) |
||
| 32 | -2x | +|||
| 218 | +! |
- server = srv, ui = ui,+ srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter) |
||
| 33 | -2x | +|||
| 219 | +
- server_args = server_args, ui_args = list(), datanames = NULL+ } |
|||
| 34 | +220 |
) |
||
| 35 | -2x | -
- class(module) <- c("teal_module_previewer", class(module))
- |
- ||
| 36 | -2x | +221 | +32x |
- module$label <- label+ logger::log_trace("init teal app has been initialized.")
|
| 37 | -2x | +222 | +32x |
- module+ return(res) |
| 38 | +223 |
}@@ -20549,1168 +21215,1014 @@ teal coverage - 72.73% |
| 1 |
- #' @title `TealReportCard`+ #' Get dummy `CDISC` data |
|||
| 2 |
- #' @description `r lifecycle::badge("experimental")`
+ #' |
|||
| 3 |
- #' A child of [`ReportCard`] that is used for teal specific applications.+ #' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`. |
|||
| 4 |
- #' In addition to the parent methods, it supports rendering teal specific elements such as+ #' Some NAs are also introduced to stress test. |
|||
| 5 |
- #' the source code, the encodings panel content and the filter panel content as part of the+ #' |
|||
| 6 |
- #' meta data.+ #' @return `cdisc_data` |
|||
| 7 |
- #' @export+ #' @keywords internal |
|||
| 8 |
- #'+ example_cdisc_data <- function() { # nolint
|
|||
| 9 | -+ | ! |
- TealReportCard <- R6::R6Class( # nolint: object_name_linter.+ ADSL <- data.frame( # nolint |
|
| 10 | -+ | ! |
- classname = "TealReportCard",+ STUDYID = "study", |
|
| 11 | -+ | ! |
- inherit = teal.reporter::ReportCard,+ USUBJID = 1:10, |
|
| 12 | -+ | ! |
- public = list(+ SEX = sample(c("F", "M"), 10, replace = TRUE),
|
|
| 13 | -+ | ! |
- #' @description Appends the source code to the `content` meta data of this `TealReportCard`.+ AGE = stats::rpois(10, 40) |
|
| 14 |
- #'+ ) |
|||
| 15 | -+ | ! |
- #' @param src (`character(1)`) code as text.+ ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint |
|
| 16 | -+ | ! |
- #' @param ... any `rmarkdown` R chunk parameter and its value.+ ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
|
|
| 17 | -+ | ! |
- #' But `eval` parameter is always set to `FALSE`.+ ADTTE$AVAL <- c( # nolint |
|
| 18 | -+ | ! |
- #' @return invisibly self+ stats::rnorm(10, mean = 700, sd = 200), # dummy OS level |
|
| 19 | -+ | ! |
- #' @examples+ stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level |
|
| 20 | -+ | ! |
- #' card <- TealReportCard$new()$append_src(+ stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level |
|
| 21 |
- #' "plot(iris)"+ ) |
|||
| 22 |
- #' )+ |
|||
| 23 | -+ | ! |
- #' card$get_content()[[1]]$get_content()+ ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint |
|
| 24 | -+ | ! |
- append_src = function(src, ...) {
+ ADSL$SEX[c(2, 5)] <- NA # nolint |
|
| 25 | -4x | +
- checkmate::assert_character(src, min.len = 0, max.len = 1)+ |
||
| 26 | -4x | +! |
- params <- list(...)+ cdisc_data_obj <- teal.data::cdisc_data( |
|
| 27 | -4x | +! |
- params$eval <- FALSE+ cdisc_dataset(dataname = "ADSL", x = ADSL), |
|
| 28 | -4x | +! |
- rblock <- RcodeBlock$new(src)+ cdisc_dataset(dataname = "ADTTE", x = ADTTE) |
|
| 29 | -4x | +
- rblock$set_params(params)+ ) |
||
| 30 | -4x | +
- self$append_content(rblock)+ |
||
| 31 | -4x | +! |
- self$append_metadata("SRC", src)
+ res <- teal.data::cdisc_data( |
|
| 32 | -4x | +! |
- invisible(self)+ teal.data::cdisc_dataset(dataname = "ADSL", x = ADSL), |
|
| 33 | -+ | ! |
- },+ teal.data::cdisc_dataset(dataname = "ADTTE", x = ADTTE), |
|
| 34 | -+ | ! |
- #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.+ code = ' |
|
| 35 | -+ | ! |
- #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses+ ADSL <- data.frame( |
|
| 36 | -+ | ! |
- #' the default `yaml::as.yaml` to format the list.+ STUDYID = "study", |
|
| 37 | -+ | ! |
- #' If the filter state list is empty, nothing is appended to the `content`.+ USUBJID = 1:10, |
|
| 38 | -+ | ! |
- #'+ SEX = sample(c("F", "M"), 10, replace = TRUE),
|
|
| 39 | -+ | ! |
- #' @param fs (`teal_slices`) object returned from [teal_slices()] function.+ AGE = rpois(10, 40) |
|
| 40 |
- #' @return invisibly self+ ) |
|||
| 41 | -+ | ! |
- append_fs = function(fs) {
+ ADTTE <- rbind(ADSL, ADSL, ADSL) |
|
| 42 | -5x | +! |
- checkmate::assert_class(fs, "teal_slices")+ ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
|
|
| 43 | -4x | +! |
- self$append_text("Filter State", "header3")
+ ADTTE$AVAL <- c( |
|
| 44 | -4x | +! |
- self$append_content(TealSlicesBlock$new(fs))+ rnorm(10, mean = 700, sd = 200), |
|
| 45 | -4x | +! |
- invisible(self)+ rnorm(10, mean = 400, sd = 100), |
|
| 46 | -+ | ! |
- },+ rnorm(10, mean = 450, sd = 200) |
|
| 47 |
- #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.+ ) |
|||
| 48 |
- #'+ |
|||
| 49 | -+ | ! |
- #' @param encodings (`list`) list of encodings selections of the teal app.+ ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) |
|
| 50 | -+ | ! |
- #' @return invisibly self+ ADSL$SEX[c(2, 5)] <- NA |
|
| 51 |
- #' @examples+ ' |
|||
| 52 |
- #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))+ ) |
|||
| 53 | -+ | ! |
- #' card$get_content()[[1]]$get_content()+ return(res) |
|
| 54 |
- #'+ } |
|||
| 55 |
- append_encodings = function(encodings) {
+
|
|||
| 56 | -4x | +
- checkmate::assert_list(encodings)+ #' Get datasets to go with example modules. |
||
| 57 | -4x | +
- self$append_text("Selected Options", "header3")
+ #' |
||
| 58 | -4x | +
- if (requireNamespace("yaml", quietly = TRUE)) {
+ #' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`. |
||
| 59 | -4x | +
- self$append_text(yaml::as.yaml(encodings, handlers = list(+ #' Each list leaf is the same `FilteredData` object. |
||
| 60 | -4x | +
- POSIXct = function(x) format(x, "%Y-%m-%d"),+ #' |
||
| 61 | -4x | +
- POSIXlt = function(x) format(x, "%Y-%m-%d"),+ #' @return named list of `FilteredData` objects, each with `ADSL` set. |
||
| 62 | -4x | +
- Date = function(x) format(x, "%Y-%m-%d")+ #' @keywords internal |
||
| 63 | -4x | +
- )), "verbatim")+ example_datasets <- function() { # nolint
|
||
| 64 | -+ | ! |
- } else {
+ dummy_cdisc_data <- example_cdisc_data() |
|
| 65 | ! |
- stop("yaml package is required to format the encodings list")
+ datasets <- teal.slice::init_filtered_data(dummy_cdisc_data) |
||
| 66 | -+ | ! |
- }+ list( |
|
| 67 | -4x | +! |
- self$append_metadata("Encodings", encodings)
+ "d2" = list( |
|
| 68 | -4x | +! |
- invisible(self)+ "d3" = list( |
|
| 69 | -+ | ! |
- }+ "aaa1" = datasets, |
|
| 70 | -+ | ! |
- ),+ "aaa2" = datasets, |
|
| 71 | -+ | ! |
- private = list()+ "aaa3" = datasets |
|
| 72 |
- )+ ), |
|||
| 73 | -- | - - | -||
| 74 | -- |
- #' @title `RcodeBlock`- |
- ||
| 75 | -- |
- #' @keywords internal- |
- ||
| 76 | -- |
- TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter.- |
- ||
| 77 | -- |
- classname = "TealSlicesBlock",- |
- ||
| 78 | -- |
- inherit = teal.reporter:::TextBlock,- |
- ||
| 79 | -- |
- public = list(- |
- ||
| 80 | -- |
- #' @description Returns a `TealSlicesBlock` object.- |
- ||
| 81 | -- |
- #'- |
- ||
| 82 | -- |
- #' @details Returns a `TealSlicesBlock` object with no content and no parameters.- |
- ||
| 83 | -- |
- #'- |
- ||
| 84 | -- |
- #' @param content (`teal_slices`) object returned from [teal_slices()] function.- |
- ||
| 85 | -- |
- #' @param style (`character(1)`) string specifying style to apply.- |
- ||
| 86 | -+ | ! |
- #'+ "bbb" = datasets |
|
| 87 | +74 |
- #' @return `TealSlicesBlock`+ ), |
||
| 88 | -+ | |||
| 75 | +! |
- #' @examples+ "ccc" = datasets |
||
| 89 | +76 |
- #' block <- teal:::TealSlicesBlock$new()+ ) |
||
| 90 | +77 |
- #'+ } |
||
| 91 | +78 |
- initialize = function(content = teal_slices(), style = "verbatim") {
- |
- ||
| 92 | -10x | -
- self$set_content(content)+ |
||
| 93 | -9x | +|||
| 79 | +
- self$set_style(style)+ #' An example `teal` module |
|||
| 94 | -9x | +|||
| 80 | +
- invisible(self)+ #' |
|||
| 95 | +81 |
- },+ #' @description `r lifecycle::badge("experimental")`
|
||
| 96 | +82 |
-
+ #' @inheritParams module |
||
| 97 | +83 |
- #' @description Sets content of this `TealSlicesBlock`.+ #' @return A `teal` module which can be included in the `modules` argument to [teal::init()]. |
||
| 98 | +84 |
- #' Sets content as `YAML` text which represents a list generated from `teal_slices`.+ #' @examples |
||
| 99 | +85 |
- #' The list displays limited number of fields from `teal_slice` objects, but this list is+ #' app <- init( |
||
| 100 | +86 |
- #' sufficient to conclude which filters were applied.+ #' data = teal_data( |
||
| 101 | +87 |
- #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"+ #' dataset("IRIS", iris),
|
||
| 102 | +88 |
- #'+ #' dataset("MTCARS", mtcars)
|
||
| 103 | +89 |
- #'+ #' ), |
||
| 104 | +90 |
- #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ #' modules = example_module() |
||
| 105 | +91 |
- #' @return invisibly self+ #' ) |
||
| 106 | +92 |
- set_content = function(content) {
+ #' if (interactive()) {
|
||
| 107 | -11x | +|||
| 93 | +
- checkmate::assert_class(content, "teal_slices")+ #' shinyApp(app$ui, app$server) |
|||
| 108 | -10x | +|||
| 94 | +
- if (length(content) != 0) {
+ #' } |
|||
| 109 | -7x | +|||
| 95 | +
- states_list <- lapply(content, function(x) {
+ #' @export |
|||
| 110 | -7x | +|||
| 96 | +
- x_list <- shiny::isolate(as.list(x))+ example_module <- function(label = "example teal module", datanames = "all") {
|
|||
| 111 | -7x | +97 | +15x |
- if (+ checkmate::assert_string(label) |
| 112 | -7x | +98 | +15x |
- inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
+ module( |
| 113 | -7x | +99 | +15x |
- length(x_list$choices) == 2 &&+ label, |
| 114 | -7x | -
- length(x_list$selected) == 2- |
- ||
| 115 | -+ | 100 | +15x |
- ) {
+ server = function(id, data) {
|
| 116 | +101 | ! |
- x_list$range <- paste(x_list$selected, collapse = " - ")+ checkmate::assert_class(data, "tdata") |
|
| 117 | +102 | ! |
- x_list["selected"] <- NULL- |
- |
| 118 | -- |
- }- |
- ||
| 119 | -7x | -
- if (!is.null(x_list$arg)) {
+ moduleServer(id, function(input, output, session) {
|
||
| 120 | +103 | ! |
- x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"- |
- |
| 121 | -- |
- }+ output$text <- renderPrint(data[[input$dataname]]()) |
||
| 122 | +104 | - - | -||
| 123 | -7x | -
- x_list <- x_list[- |
- ||
| 124 | -7x | -
- c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
+ }) |
||
| 125 | +105 |
- ]- |
- ||
| 126 | -7x | -
- names(x_list) <- c(+ }, |
||
| 127 | -7x | +106 | +15x |
- "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",+ ui = function(id, data) {
|
| 128 | -7x | +|||
| 107 | +! |
- "Selected Values", "Selected range", "Include NA values", "Include Inf values"+ ns <- NS(id) |
||
| 129 | -+ | |||
| 108 | +! |
- )+ teal.widgets::standard_layout( |
||
| 130 | -+ | |||
| 109 | +! |
-
+ output = verbatimTextOutput(ns("text")),
|
||
| 131 | -7x | +|||
| 110 | +! |
- Filter(Negate(is.null), x_list)+ encoding = selectInput(ns("dataname"), "Choose a dataset", choices = names(data))
|
||
| 132 | +111 |
- })+ ) |
||
| 133 | +112 | - - | -||
| 134 | -7x | -
- if (requireNamespace("yaml", quietly = TRUE)) {
+ }, |
||
| 135 | -7x | +113 | +15x |
- super$set_content(yaml::as.yaml(states_list))+ datanames = datanames |
| 136 | +114 |
- } else {
+ ) |
||
| 137 | -! | +|||
| 115 | +
- stop("yaml package is required to format the filter state list")
+ } |
|||
| 138 | +116 |
- }+ |
||
| 139 | +117 |
- }+ |
||
| 140 | -10x | +|||
| 118 | +
- private$teal_slices <- content+ #' Get example modules. |
|||
| 141 | -10x | +|||
| 119 | +
- invisible(self)+ #' |
|||
| 142 | +120 |
- },+ #' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created. |
||
| 143 | +121 |
- #' @description Create the `RcodeBlock` from a list.+ #' @param datanames (`character`)\cr |
||
| 144 | +122 |
- #' @param x `named list` with two fields `c("text", "params")`.
+ #' names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`. |
||
| 145 | +123 |
- #' Use the `get_available_params` method to get all possible parameters.+ #' @return `teal_modules` |
||
| 146 | +124 |
- #' @return invisibly self+ #' @keywords internal |
||
| 147 | +125 |
- from_list = function(x) {
+ example_modules <- function(datanames = c("ADSL", "ADTTE")) {
|
||
| 148 | -1x | +126 | +2x |
- checkmate::assert_list(x)+ checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
|
| 149 | -1x | +127 | +2x |
- checkmate::assert_names(names(x), must.include = c("teal_slices"))
+ mods <- modules( |
| 150 | -1x | +128 | +2x |
- self$set_content(x$teal_slices)+ label = "d1", |
| 151 | -1x | +129 | +2x |
- invisible(self)+ modules( |
| 152 | -+ | |||
| 130 | +2x |
- },+ label = "d2", |
||
| 153 | -+ | |||
| 131 | +2x |
- #' @description Convert the `RcodeBlock` to a list.+ modules( |
||
| 154 | -+ | |||
| 132 | +2x |
- #' @return `named list` with a text and `params`.+ label = "d3", |
||
| 155 | -+ | |||
| 133 | +2x |
-
+ example_module(label = "aaa1", datanames = datanames), |
||
| 156 | -+ | |||
| 134 | +2x |
- to_list = function() {
+ example_module(label = "aaa2", datanames = datanames), |
||
| 157 | +135 | 2x |
- list(teal_slices = private$teal_slices)+ example_module(label = "aaa3", datanames = datanames) |
|
| 158 | +136 |
- }+ ), |
||
| 159 | -+ | |||
| 137 | +2x |
- ),+ example_module(label = "bbb", datanames = datanames) |
||
| 160 | +138 |
- private = list(+ ), |
||
| 161 | -+ | |||
| 139 | +2x |
- style = "verbatim",+ example_module(label = "ccc", datanames = datanames) |
||
| 162 | +140 |
- teal_slices = NULL # teal_slices+ ) |
||
| 163 | -+ | |||
| 141 | +2x |
- )+ return(mods) |
||
| 164 | +142 |
- )+ } |
| 1 |
- #' Validate that dataset has a minimum number of observations+ #' Generates library calls from current session info |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' Function to create multiple library calls out of current session info to make reproducible code works. |
||
| 4 |
- #' @param x a data.frame+ #' |
||
| 5 |
- #' @param min_nrow minimum number of rows in \code{x}
+ #' @return Character object contain code |
||
| 6 |
- #' @param complete \code{logical} default \code{FALSE} when set to \code{TRUE} then complete cases are checked.
+ #' @keywords internal |
||
| 7 |
- #' @param allow_inf \code{logical} default \code{TRUE} when set to \code{FALSE} then error thrown if any values are
+ get_rcode_libraries <- function() {
|
||
| 8 | -+ | 14x |
- #' infinite.+ vapply( |
| 9 | -+ | 14x |
- #' @param msg (`character(1)`) additional message to display alongside the default message.+ utils::sessionInfo()$otherPkgs, |
| 10 | -+ | 14x |
- #'+ function(x) {
|
| 11 | -+ | 238x |
- #' @details This function is a wrapper for `shiny::validate`.+ paste0("library(", x$Package, ")")
|
| 12 |
- #'+ }, |
||
| 13 | -+ | 14x |
- #' @export+ character(1) |
| 14 |
- #'+ ) %>% |
||
| 15 |
- #' @examples+ # put it into reverse order to correctly simulate executed code |
||
| 16 | -+ | 14x |
- #' library(teal)+ rev() %>% |
| 17 | -+ | 14x |
- #' ui <- fluidPage(+ paste0(sep = "\n") %>% |
| 18 | -+ | 14x |
- #' sliderInput("len", "Max Length of Sepal",
+ paste0(collapse = "") |
| 19 |
- #' min = 4.3, max = 7.9, value = 5+ } |
||
| 20 |
- #' ),+ |
||
| 21 |
- #' plotOutput("plot")
+
|
||
| 22 |
- #' )+ |
||
| 23 |
- #'+ get_rcode_str_install <- function() {
|
||
| 24 | -+ | 18x |
- #' server <- function(input, output) {
+ code_string <- getOption("teal.load_nest_code")
|
| 25 |
- #' output$plot <- renderPlot({
+
|
||
| 26 | -+ | 18x |
- #' df <- iris[iris$Sepal.Length <= input$len, ]+ if (!is.null(code_string) && is.character(code_string)) {
|
| 27 | -+ | 2x |
- #' validate_has_data(+ return(code_string) |
| 28 |
- #' iris_f,+ } |
||
| 29 |
- #' min_nrow = 10,+ |
||
| 30 | -+ | 16x |
- #' complete = FALSE,+ return("# Add any code to install/load your NEST environment here\n")
|
| 31 |
- #' msg = "Please adjust Max Length of Sepal"+ } |
||
| 32 |
- #' )+ |
||
| 33 |
- #'+ #' Get datasets code |
||
| 34 |
- #' hist(iris_f$Sepal.Length, breaks = 5)+ #' |
||
| 35 |
- #' })+ #' Get combined code from `FilteredData` and from `CodeClass` object. |
||
| 36 |
- #' }+ #' |
||
| 37 |
- #' if (interactive()) {
+ #' @param datanames (`character`) names of datasets to extract code from |
||
| 38 |
- #' shinyApp(ui, server)+ #' @param datasets (`FilteredData`) object |
||
| 39 |
- #' }+ #' @param hashes named (`list`) of hashes per dataset |
||
| 41 |
- validate_has_data <- function(x,+ #' @return `character(3)` containing following elements: |
||
| 42 |
- min_nrow = NULL,+ #' - code from `CodeClass` (data loading code) |
||
| 43 |
- complete = FALSE,+ #' - hash check of loaded objects |
||
| 44 |
- allow_inf = TRUE,+ #' |
||
| 45 |
- msg = NULL) {
+ #' @keywords internal |
||
| 46 | -17x | +
- stopifnot(+ get_datasets_code <- function(datanames, datasets, hashes) {
|
|
| 47 | -17x | +14x |
- "Please provide a character vector in msg argument of validate_has_data." = is.character(msg) || is.null(msg)+ str_code <- datasets$get_code(datanames) |
| 48 | -+ | 14x |
- )+ if (length(str_code) == 0 || (length(str_code) == 1 && str_code == "")) {
|
| 49 | -15x | +! |
- validate(need(!is.null(x) && is.data.frame(x), "No data left."))+ str_code <- "message('Preprocessing is empty')"
|
| 50 | -15x | +14x |
- if (!is.null(min_nrow)) {
+ } else if (length(str_code) > 0) {
|
| 51 | -15x | +14x |
- if (complete) {
+ str_code <- paste0(str_code, "\n\n") |
| 52 | -5x | +
- complete_index <- stats::complete.cases(x)+ } |
|
| 53 | -5x | +
- validate(need(+ |
|
| 54 | -5x | +14x |
- sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,+ if (!datasets$get_check()) {
|
| 55 | -5x | +10x |
- paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
+ check_note_string <- paste0( |
| 56 | -+ | 10x |
- ))+ c( |
| 57 | -+ | 10x |
- } else {
+ "message(paste(\"Reproducibility of data import and preprocessing was not explicitly checked\",", |
| 58 | 10x |
- validate(need(+ " \" ('check = FALSE' is set). Contact app developer if this is an issue.\n\"))"
|
|
| 59 | -10x | +
- nrow(x) >= min_nrow,+ ), |
|
| 60 | 10x |
- paste(+ collapse = "\n" |
|
| 61 | -10x | +
- c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
+ ) |
|
| 62 | 10x |
- collapse = "\n"+ str_code <- paste0(str_code, "\n\n", check_note_string) |
|
| 63 |
- )+ } |
||
| 64 |
- ))+ |
||
| 65 | -+ | 14x |
- }+ str_hash <- paste( |
| 66 | -+ | 14x |
-
+ paste0( |
| 67 | -10x | +14x |
- if (!allow_inf) {
+ vapply( |
| 68 | -6x | +14x |
- validate(need(+ datanames, |
| 69 | -6x | +14x |
- all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))),+ function(dataname) {
|
| 70 | -6x | +17x |
- "Dataframe contains Inf values which is not allowed."+ sprintf( |
| 71 | -+ | 17x |
- ))+ "stopifnot(%s == %s)", |
| 72 | -+ | 17x |
- }+ deparse1(bquote(rlang::hash(.(as.name(dataname))))), |
| 73 | -+ | 17x |
- }+ deparse1(hashes[[dataname]]) |
| 74 |
- }+ ) |
||
| 75 |
-
+ }, |
||
| 76 | -+ | 14x |
- #' Validate that dataset has unique rows for key variables+ character(1) |
| 77 |
- #'+ ), |
||
| 78 | -+ | 14x |
- #' @description `r lifecycle::badge("stable")`
+ collapse = "\n" |
| 79 |
- #' @param x a data.frame+ ), |
||
| 80 | -+ | 14x |
- #' @param key a vector of ID variables from \code{x} that identify unique records
+ "\n\n" |
| 81 |
- #'+ ) |
||
| 82 |
- #' @details This function is a wrapper for `shiny::validate`.+ |
||
| 83 | -+ | 14x |
- #'+ c(str_code, str_hash) |
| 84 |
- #' @export+ } |
| 85 | +1 |
- #'+ #' Create a `teal` module for previewing a report |
|
| 86 | +2 |
- #' @examples+ #' |
|
| 87 | +3 |
- #' iris$id <- rep(1:50, times = 3)+ #' @description `r lifecycle::badge("experimental")`
|
|
| 88 | +4 |
- #' ui <- fluidPage(+ #' This function wraps [teal.reporter::reporter_previewer_ui()] and |
|
| 89 | +5 |
- #' selectInput(+ #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be |
|
| 90 | +6 |
- #' inputId = "species",+ #' used in `teal` applications. |
|
| 91 | +7 |
- #' label = "Select species",+ #' |
|
| 92 | +8 |
- #' choices = c("setosa", "versicolor", "virginica"),
+ #' If you are creating a `teal` application using [teal::init()] then this |
|
| 93 | +9 |
- #' selected = "setosa",+ #' module will be added to your application automatically if any of your `teal modules` |
|
| 94 | +10 |
- #' multiple = TRUE+ #' support report generation |
|
| 95 | +11 |
- #' ),+ #' |
|
| 96 | +12 |
- #' plotOutput("plot")
+ #' @inheritParams module |
|
| 97 | +13 |
- #' )+ #' @param server_args (`named list`)\cr |
|
| 98 | +14 |
- #' server <- function(input, output) {
+ #' Arguments passed to [teal.reporter::reporter_previewer_srv()]. |
|
| 99 | +15 |
- #' output$plot <- renderPlot({
+ #' @return `teal_module` containing the `teal.reporter` previewer functionality |
|
| 100 | +16 |
- #' iris_f <- iris[iris$Species %in% input$species, ]+ #' @export |
|
| 101 | +17 |
- #' validate_one_row_per_id(iris_f, key = c("id"))
+ reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
|
|
| 102 | -+ | ||
| 18 | +4x |
- #'+ checkmate::assert_string(label) |
|
| 103 | -+ | ||
| 19 | +2x |
- #' hist(iris_f$Sepal.Length, breaks = 5)+ checkmate::assert_list(server_args, names = "named") |
|
| 104 | -+ | ||
| 20 | +2x |
- #' })+ checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv)))) |
|
| 105 | +21 |
- #' }+ |
|
| 106 | -+ | ||
| 22 | +2x |
- #' if (interactive()) {
+ srv <- function(id, reporter, ...) {
|
|
| 107 | -+ | ||
| 23 | +! |
- #' shinyApp(ui, server)+ teal.reporter::reporter_previewer_srv(id, reporter, ...) |
|
| 108 | +24 |
- #' }+ } |
|
| 109 | +25 |
- #'+ |
|
| 110 | -+ | ||
| 26 | +2x |
- validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
+ ui <- function(id, ...) {
|
|
| 111 | +27 | ! |
- validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
+ teal.reporter::reporter_previewer_ui(id, ...) |
| 112 | +28 |
- }+ } |
|
| 113 | +29 | ||
| 114 | -+ | ||
| 30 | +2x |
- #' Validates that vector includes all expected values+ module <- module( |
|
| 115 | -+ | ||
| 31 | +2x |
- #'+ label = "temporary label", |
|
| 116 | -+ | ||
| 32 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ server = srv, ui = ui, |
|
| 117 | -+ | ||
| 33 | +2x |
- #' @param x values to test. All must be in \code{choices}
+ server_args = server_args, ui_args = list(), datanames = NULL |
|
| 118 | +34 |
- #' @param choices a vector to test for values of \code{x}
+ ) |
|
| 119 | -+ | ||
| 35 | +2x |
- #' @param msg warning message to display+ class(module) <- c("teal_module_previewer", class(module))
|
|
| 120 | -+ | ||
| 36 | +2x |
- #'+ module$label <- label+ |
+ |
| 37 | +2x | +
+ module |
|
| 121 | +38 |
- #' @details This function is a wrapper for `shiny::validate`.+ } |
| 122 | +1 |
- #'+ #' @title `TealReportCard` |
|
| 123 | +2 |
- #' @export+ #' @description `r lifecycle::badge("experimental")`
|
|
| 124 | +3 |
- #'+ #' A child of [`ReportCard`] that is used for teal specific applications. |
|
| 125 | +4 |
- #' @examples+ #' In addition to the parent methods, it supports rendering teal specific elements such as |
|
| 126 | +5 |
- #' ui <- fluidPage(+ #' the source code, the encodings panel content and the filter panel content as part of the |
|
| 127 | +6 |
- #' selectInput(+ #' meta data. |
|
| 128 | +7 |
- #' "species",+ #' @export |
|
| 129 | +8 |
- #' "Select species",+ #' |
|
| 130 | +9 |
- #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
+ TealReportCard <- R6::R6Class( # nolint: object_name_linter. |
|
| 131 | +10 |
- #' selected = "setosa",+ classname = "TealReportCard", |
|
| 132 | +11 |
- #' multiple = FALSE+ inherit = teal.reporter::ReportCard, |
|
| 133 | +12 |
- #' ),+ public = list( |
|
| 134 | +13 |
- #' verbatimTextOutput("summary")
+ #' @description Appends the source code to the `content` meta data of this `TealReportCard`. |
|
| 135 | +14 |
- #' )+ #' |
|
| 136 | +15 |
- #'+ #' @param src (`character(1)`) code as text. |
|
| 137 | +16 |
- #' server <- function(input, output) {
+ #' @param ... any `rmarkdown` R chunk parameter and its value. |
|
| 138 | +17 |
- #' output$summary <- renderPrint({
+ #' But `eval` parameter is always set to `FALSE`. |
|
| 139 | +18 |
- #' validate_in(input$species, iris$Species, "Species does not exist.")+ #' @return invisibly self |
|
| 140 | +19 |
- #' nrow(iris[iris$Species == input$species, ])+ #' @examples |
|
| 141 | +20 |
- #' })+ #' card <- TealReportCard$new()$append_src( |
|
| 142 | +21 |
- #' }+ #' "plot(iris)" |
|
| 143 | +22 |
- #' if (interactive()) {
+ #' ) |
|
| 144 | +23 |
- #' shinyApp(ui, server)+ #' card$get_content()[[1]]$get_content() |
|
| 145 | +24 |
- #' }+ append_src = function(src, ...) {
|
|
| 146 | -+ | ||
| 25 | +4x |
- #'+ checkmate::assert_character(src, min.len = 0, max.len = 1) |
|
| 147 | -+ | ||
| 26 | +4x |
- validate_in <- function(x, choices, msg) {
+ params <- list(...) |
|
| 148 | -! | +||
| 27 | +4x |
- validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg))+ params$eval <- FALSE |
|
| 149 | -+ | ||
| 28 | +4x |
- }+ rblock <- RcodeBlock$new(src) |
|
| 150 | -+ | ||
| 29 | +4x |
-
+ rblock$set_params(params) |
|
| 151 | -+ | ||
| 30 | +4x |
- #' Validates that vector has length greater than 0+ self$append_content(rblock) |
|
| 152 | -+ | ||
| 31 | +4x |
- #'+ self$append_metadata("SRC", src)
|
|
| 153 | -+ | ||
| 32 | +4x |
- #' @description `r lifecycle::badge("stable")`
+ invisible(self) |
|
| 154 | +33 |
- #' @param x vector+ }, |
|
| 155 | +34 |
- #' @param msg message to display+ #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`. |
|
| 156 | +35 |
- #'+ #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses |
|
| 157 | +36 |
- #' @details This function is a wrapper for `shiny::validate`.+ #' the default `yaml::as.yaml` to format the list. |
|
| 158 | +37 |
- #'+ #' If the filter state list is empty, nothing is appended to the `content`. |
|
| 159 | +38 |
- #' @export+ #' |
|
| 160 | +39 |
- #'+ #' @param fs (`teal_slices`) object returned from [teal_slices()] function. |
|
| 161 | +40 |
- #' @examples+ #' @return invisibly self |
|
| 162 | +41 |
- #' data <- data.frame(+ append_fs = function(fs) {
|
|
| 163 | -+ | ||
| 42 | +5x |
- #' id = c(1:10, 11:20, 1:10),+ checkmate::assert_class(fs, "teal_slices") |
|
| 164 | -+ | ||
| 43 | +4x |
- #' strata = rep(c("A", "B"), each = 15)
+ self$append_text("Filter State", "header3")
|
|
| 165 | -+ | ||
| 44 | +4x |
- #' )+ self$append_content(TealSlicesBlock$new(fs)) |
|
| 166 | -+ | ||
| 45 | +4x |
- #' ui <- fluidPage(+ invisible(self) |
|
| 167 | +46 |
- #' selectInput("ref1", "Select strata1 to compare",
+ }, |
|
| 168 | +47 |
- #' choices = c("A", "B", "C"), selected = "A"
+ #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`. |
|
| 169 | +48 |
- #' ),+ #' |
|
| 170 | +49 |
- #' selectInput("ref2", "Select strata2 to compare",
+ #' @param encodings (`list`) list of encodings selections of the teal app. |
|
| 171 | +50 |
- #' choices = c("A", "B", "C"), selected = "B"
+ #' @return invisibly self |
|
| 172 | +51 |
- #' ),+ #' @examples |
|
| 173 | +52 |
- #' verbatimTextOutput("arm_summary")
+ #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X")) |
|
| 174 | +53 |
- #' )+ #' card$get_content()[[1]]$get_content() |
|
| 175 | +54 |
- #'+ #' |
|
| 176 | +55 |
- #' server <- function(input, output) {
+ append_encodings = function(encodings) {
|
|
| 177 | -+ | ||
| 56 | +4x |
- #' output$arm_summary <- renderText({
+ checkmate::assert_list(encodings) |
|
| 178 | -+ | ||
| 57 | +4x |
- #' sample_1 <- data$id[data$strata == input$ref1]+ self$append_text("Selected Options", "header3")
|
|
| 179 | -+ | ||
| 58 | +4x |
- #' sample_2 <- data$id[data$strata == input$ref2]+ if (requireNamespace("yaml", quietly = TRUE)) {
|
|
| 180 | -+ | ||
| 59 | +4x |
- #'+ self$append_text(yaml::as.yaml(encodings, handlers = list( |
|
| 181 | -+ | ||
| 60 | +4x |
- #' validate_has_elements(sample_1, "No subjects in strata1.")+ POSIXct = function(x) format(x, "%Y-%m-%d"), |
|
| 182 | -+ | ||
| 61 | +4x |
- #' validate_has_elements(sample_2, "No subjects in strata2.")+ POSIXlt = function(x) format(x, "%Y-%m-%d"), |
|
| 183 | -+ | ||
| 62 | +4x |
- #'+ Date = function(x) format(x, "%Y-%m-%d") |
|
| 184 | -+ | ||
| 63 | +4x |
- #' paste0(+ )), "verbatim") |
|
| 185 | +64 |
- #' "Number of samples in: strata1=", length(sample_1),+ } else {
|
|
| 186 | -+ | ||
| 65 | +! |
- #' " comparions strata2=", length(sample_2)+ stop("yaml package is required to format the encodings list")
|
|
| 187 | +66 |
- #' )+ } |
|
| 188 | -+ | ||
| 67 | +4x |
- #' })+ self$append_metadata("Encodings", encodings)
|
|
| 189 | -+ | ||
| 68 | +4x |
- #' }+ invisible(self) |
|
| 190 | +69 |
- #' if (interactive()) {
+ } |
|
| 191 | +70 |
- #' shinyApp(ui, server)+ ), |
|
| 192 | +71 |
- #' }+ private = list() |
|
| 193 | +72 |
- validate_has_elements <- function(x, msg) {
- |
- |
| 194 | -! | -
- validate(need(length(x) > 0, msg))+ ) |
|
| 195 | +73 |
- }+ |
|
| 196 | +74 |
-
+ #' @title `RcodeBlock` |
|
| 197 | +75 |
- #' Validates no intersection between two vectors+ #' @keywords internal |
|
| 198 | +76 |
- #'+ TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter. |
|
| 199 | +77 |
- #' @description `r lifecycle::badge("stable")`
+ classname = "TealSlicesBlock", |
|
| 200 | +78 |
- #' @param x vector+ inherit = teal.reporter:::TextBlock, |
|
| 201 | +79 |
- #' @param y vector+ public = list( |
|
| 202 | +80 |
- #' @param msg message to display if \code{x} and \code{y} intersect
+ #' @description Returns a `TealSlicesBlock` object. |
|
| 203 | +81 |
- #'+ #' |
|
| 204 | +82 |
- #' @details This function is a wrapper for `shiny::validate`.+ #' @details Returns a `TealSlicesBlock` object with no content and no parameters. |
|
| 205 | +83 |
- #'+ #' |
|
| 206 | +84 |
- #' @export+ #' @param content (`teal_slices`) object returned from [teal_slices()] function. |
|
| 207 | +85 |
- #'+ #' @param style (`character(1)`) string specifying style to apply. |
|
| 208 | +86 |
- #' @examples+ #' |
|
| 209 | +87 |
- #' data <- data.frame(+ #' @return `TealSlicesBlock` |
|
| 210 | +88 |
- #' id = c(1:10, 11:20, 1:10),+ #' @examples |
|
| 211 | +89 |
- #' strata = rep(c("A", "B", "C"), each = 10)
+ #' block <- teal:::TealSlicesBlock$new() |
|
| 212 | +90 |
- #' )+ #' |
|
| 213 | +91 |
- #'+ initialize = function(content = teal_slices(), style = "verbatim") {
|
|
| 214 | -+ | ||
| 92 | +10x |
- #' ui <- fluidPage(+ self$set_content(content) |
|
| 215 | -+ | ||
| 93 | +9x |
- #' selectInput("ref1", "Select strata1 to compare",
+ self$set_style(style) |
|
| 216 | -+ | ||
| 94 | +9x |
- #' choices = c("A", "B", "C"),
+ invisible(self) |
|
| 217 | +95 |
- #' selected = "A"+ }, |
|
| 218 | +96 |
- #' ),+ |
|
| 219 | +97 |
- #' selectInput("ref2", "Select strata2 to compare",
+ #' @description Sets content of this `TealSlicesBlock`. |
|
| 220 | +98 |
- #' choices = c("A", "B", "C"),
+ #' Sets content as `YAML` text which represents a list generated from `teal_slices`. |
|
| 221 | +99 |
- #' selected = "B"+ #' The list displays limited number of fields from `teal_slice` objects, but this list is |
|
| 222 | +100 |
- #' ),+ #' sufficient to conclude which filters were applied. |
|
| 223 | +101 |
- #' verbatimTextOutput("summary")
+ #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min" |
|
| 224 | +102 |
- #' )+ #' |
|
| 225 | +103 |
- #'+ #' |
|
| 226 | +104 |
- #' server <- function(input, output) {
+ #' @param content (`teal_slices`) object returned from [teal_slices()] function. |
|
| 227 | +105 |
- #' output$summary <- renderText({
+ #' @return invisibly self |
|
| 228 | +106 |
- #' sample_1 <- data$id[data$strata == input$ref1]+ set_content = function(content) {
|
|
| 229 | -+ | ||
| 107 | +11x |
- #' sample_2 <- data$id[data$strata == input$ref2]+ checkmate::assert_class(content, "teal_slices") |
|
| 230 | -+ | ||
| 108 | +10x |
- #'+ if (length(content) != 0) {
|
|
| 231 | -+ | ||
| 109 | +7x |
- #' validate_no_intersection(+ states_list <- lapply(content, function(x) {
|
|
| 232 | -+ | ||
| 110 | +7x |
- #' sample_1, sample_2,+ x_list <- shiny::isolate(as.list(x)) |
|
| 233 | -+ | ||
| 111 | +7x |
- #' "subjects within strata1 and strata2 cannot overlap"+ if ( |
|
| 234 | -+ | ||
| 112 | +7x |
- #' )+ inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
|
|
| 235 | -+ | ||
| 113 | +7x |
- #' paste0(+ length(x_list$choices) == 2 && |
|
| 236 | -+ | ||
| 114 | +7x |
- #' "Number of subject in: reference treatment=", length(sample_1),+ length(x_list$selected) == 2 |
|
| 237 | +115 |
- #' " comparions treatment=", length(sample_2)+ ) {
|
|
| 238 | -+ | ||
| 116 | +! |
- #' )+ x_list$range <- paste(x_list$selected, collapse = " - ") |
|
| 239 | -+ | ||
| 117 | +! |
- #' })+ x_list["selected"] <- NULL |
|
| 240 | +118 |
- #' }+ } |
|
| 241 | -+ | ||
| 119 | +7x |
- #' if (interactive()) {
+ if (!is.null(x_list$arg)) {
|
|
| 242 | -+ | ||
| 120 | +! |
- #' shinyApp(ui, server)+ x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples" |
|
| 243 | +121 |
- #' }+ } |
|
| 244 | +122 |
- #'+ |
|
| 245 | -+ | ||
| 123 | +7x |
- validate_no_intersection <- function(x, y, msg) {
+ x_list <- x_list[ |
|
| 246 | -! | +||
| 124 | +7x |
- validate(need(length(intersect(x, y)) == 0, msg))+ c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
|
|
| 247 | +125 |
- }+ ] |
|
| 248 | -+ | ||
| 126 | +7x |
-
+ names(x_list) <- c( |
|
| 249 | -+ | ||
| 127 | +7x |
-
+ "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression", |
|
| 250 | -+ | ||
| 128 | +7x |
- #' Validates that dataset contains specific variable+ "Selected Values", "Selected range", "Include NA values", "Include Inf values" |
|
| 251 | +129 |
- #'+ ) |
|
| 252 | +130 |
- #' @description `r lifecycle::badge("stable")`
+
|
|
| 253 | -+ | ||
| 131 | +7x |
- #' @param data a data.frame+ Filter(Negate(is.null), x_list) |
|
| 254 | +132 |
- #' @param varname name of variable in \code{data}
+ }) |
|
| 255 | +133 |
- #' @param msg message to display if \code{data} does not include \code{varname}
+
|
|
| 256 | -+ | ||
| 134 | +7x |
- #'+ if (requireNamespace("yaml", quietly = TRUE)) {
|
|
| 257 | -+ | ||
| 135 | +7x |
- #' @details This function is a wrapper for `shiny::validate`.+ super$set_content(yaml::as.yaml(states_list)) |
|
| 258 | +136 |
- #'+ } else {
|
|
| 259 | -+ | ||
| 137 | +! |
- #' @export+ stop("yaml package is required to format the filter state list")
|
|
| 260 | +138 |
- #'+ } |
|
| 261 | +139 |
- #' @examples+ } |
|
| 262 | -+ | ||
| 140 | +10x |
- #' data <- data.frame(+ private$teal_slices <- content |
|
| 263 | -+ | ||
| 141 | +10x |
- #' one = rep("a", length.out = 20),
+ invisible(self) |
|
| 264 | +142 |
- #' two = rep(c("a", "b"), length.out = 20)
+ }, |
|
| 265 | +143 |
- #' )+ #' @description Create the `RcodeBlock` from a list. |
|
| 266 | +144 |
- #' ui <- fluidPage(+ #' @param x `named list` with two fields `c("text", "params")`.
|
|
| 267 | +145 |
- #' selectInput(+ #' Use the `get_available_params` method to get all possible parameters. |
|
| 268 | +146 |
- #' "var",+ #' @return invisibly self |
|
| 269 | +147 |
- #' "Select variable",+ from_list = function(x) {
|
|
| 270 | -+ | ||
| 148 | +1x |
- #' choices = c("one", "two", "three", "four"),
+ checkmate::assert_list(x) |
|
| 271 | -+ | ||
| 149 | +1x |
- #' selected = "one"+ checkmate::assert_names(names(x), must.include = c("teal_slices"))
|
|
| 272 | -+ | ||
| 150 | +1x |
- #' ),+ self$set_content(x$teal_slices) |
|
| 273 | -+ | ||
| 151 | +1x |
- #' verbatimTextOutput("summary")
+ invisible(self) |
|
| 274 | +152 |
- #' )+ }, |
|
| 275 | +153 |
- #'+ #' @description Convert the `RcodeBlock` to a list. |
|
| 276 | +154 |
- #' server <- function(input, output) {
+ #' @return `named list` with a text and `params`. |
|
| 277 | +155 |
- #' output$summary <- renderText({
+
|
|
| 278 | +156 |
- #' validate_has_variable(data, input$var)+ to_list = function() {
+ |
+ |
| 157 | +2x | +
+ list(teal_slices = private$teal_slices) |
|
| 279 | +158 |
- #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
+ } |
|
| 280 | +159 |
- #' })+ ), |
|
| 281 | +160 |
- #' }+ private = list( |
|
| 282 | +161 |
- #' if (interactive()) {
+ style = "verbatim", |
|
| 283 | +162 |
- #' shinyApp(ui, server)+ teal_slices = NULL # teal_slices |
|
| 284 | +163 |
- #' }+ ) |
|
| 285 | +164 |
- validate_has_variable <- function(data, varname, msg) {
+ ) |
|
| 286 | -! | +
| 1 | +
- if (length(varname) != 0) {
+ #' Send input validation messages to output. |
||
| 287 | -! | +||
| 2 | +
- has_vars <- varname %in% names(data)+ #' |
||
| 288 | +3 |
-
+ #' Captures messages from `InputValidator` objects and collates them |
|
| 289 | -! | +||
| 4 | +
- if (!all(has_vars)) {
+ #' into one message passed to `validate`. |
||
| 290 | -! | +||
| 5 | +
- if (missing(msg)) {
+ #' |
||
| 291 | -! | +||
| 6 | +
- msg <- sprintf(+ #' `shiny::validate` is used to withhold rendering of an output element until |
||
| 292 | -! | +||
| 7 | +
- "%s does not have the required variables: %s.",+ #' certain conditions are met and to print a validation message in place |
||
| 293 | -! | +||
| 8 | +
- deparse(substitute(data)),+ #' of the output element. |
||
| 294 | -! | +||
| 9 | +
- toString(varname[!has_vars])+ #' `shinyvalidate::InputValidator` allows to validate input elements |
||
| 295 | +10 |
- )+ #' and to display specific messages in their respective input widgets. |
|
| 296 | +11 |
- }+ #' `validate_inputs` provides a hybrid solution. |
|
| 297 | -! | +||
| 12 | +
- validate(need(FALSE, msg))+ #' Given an `InputValidator` object, messages corresponding to inputs that fail validation |
||
| 298 | +13 |
- }+ #' are extracted and placed in one validation message that is passed to a `validate`/`need` call. |
|
| 299 | +14 |
- }+ #' This way the input `validator` messages are repeated in the output. |
|
| 300 | +15 |
- }+ #' |
|
| 301 | +16 |
-
+ #' The `...` argument accepts any number of `InputValidator` objects |
|
| 302 | +17 |
- #' Validate that variables has expected number of levels+ #' or a nested list of such objects. |
|
| 303 | +18 |
- #'+ #' If `validators` are passed directly, all their messages are printed together |
|
| 304 | +19 |
- #' @description `r lifecycle::badge("stable")`
+ #' under one (optional) header message specified by `header`. If a list is passed, |
|
| 305 | +20 |
- #' @param x variable name. If \code{x} is not a factor, the unique values
+ #' messages are grouped by `validator`. The list's names are used as headers |
|
| 306 | +21 |
- #' are treated as levels.+ #' for their respective message groups. |
|
| 307 | +22 |
- #' @param min_levels cutoff for minimum number of levels of \code{x}
+ #' If neither of the nested list elements is named, a header message is taken from `header`. |
|
| 308 | +23 |
- #' @param max_levels cutoff for maximum number of levels of \code{x}
+ #' |
|
| 309 | +24 |
- #' @param var_name name of variable being validated for use in+ #' @param ... either any number of `InputValidator` objects |
|
| 310 | +25 |
- #' validation message+ #' or an optionally named, possibly nested `list` of `InputValidator` |
|
| 311 | +26 |
- #'+ #' objects, see `Details` |
|
| 312 | +27 |
- #' @details If the number of levels of \code{x} is less than \code{min_levels}
+ #' @param header `character(1)` generic validation message; set to NULL to omit |
|
| 313 | +28 |
- #' or greater than \code{max_levels} the validation will fail.
+ #' |
|
| 314 | +29 |
- #' This function is a wrapper for `shiny::validate`.+ #' @return |
|
| 315 | +30 |
- #'+ #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. |
|
| 316 | +31 |
- #' @export+ #' |
|
| 317 | +32 |
- #' @examples+ #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`] |
|
| 318 | +33 |
- #' data <- data.frame(+ #' |
|
| 319 | +34 |
- #' one = rep("a", length.out = 20),
+ #' @examples |
|
| 320 | +35 |
- #' two = rep(c("a", "b"), length.out = 20),
+ #' library(shiny) |
|
| 321 | +36 |
- #' three = rep(c("a", "b", "c"), length.out = 20),
+ #' library(shinyvalidate) |
|
| 322 | +37 |
- #' four = rep(c("a", "b", "c", "d"), length.out = 20),
+ #' |
|
| 323 | +38 |
- #' stringsAsFactors = TRUE+ #' ui <- fluidPage( |
|
| 324 | +39 |
- #' )+ #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
|
|
| 325 | +40 |
- #' ui <- fluidPage(+ #' sidebarLayout( |
|
| 326 | +41 |
- #' selectInput(+ #' sidebarPanel( |
|
| 327 | +42 |
- #' "var",+ #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
|
|
| 328 | +43 |
- #' "Select variable",+ #' selectInput("number", "select a number:", 1:6),
|
|
| 329 | +44 |
- #' choices = c("one", "two", "three", "four"),
+ #' br(), |
|
| 330 | +45 |
- #' selected = "one"+ #' selectInput("color", "select a color:",
|
|
| 331 | +46 |
- #' ),+ #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
|
|
| 332 | +47 |
- #' verbatimTextOutput("summary")
+ #' multiple = TRUE |
|
| 333 | +48 |
- #' )+ #' ), |
|
| 334 | +49 |
- #'+ #' sliderInput("size", "select point size:",
|
|
| 335 | +50 |
- #' server <- function(input, output) {
+ #' min = 0.1, max = 4, value = 0.25 |
|
| 336 | +51 |
- #' output$summary <- renderText({
+ #' ) |
|
| 337 | +52 |
- #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var)+ #' ), |
|
| 338 | +53 |
- #' paste0(+ #' mainPanel(plotOutput("plot"))
|
|
| 339 | +54 |
- #' "Levels of selected treatment variable: ",+ #' ) |
|
| 340 | +55 |
- #' paste(levels(data[[input$var]]),+ #' ) |
|
| 341 | +56 |
- #' collapse = ", "+ #' |
|
| 342 | +57 |
- #' )+ #' server <- function(input, output) {
|
|
| 343 | +58 |
- #' )+ #' # set up input validation |
|
| 344 | +59 |
- #' })+ #' iv <- InputValidator$new() |
|
| 345 | +60 |
- #' }+ #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
|
|
| 346 | +61 |
- #' if (interactive()) {
+ #' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
|
|
| 347 | +62 |
- #' shinyApp(ui, server)+ #' iv$enable() |
|
| 348 | +63 |
- #' }+ #' # more input validation |
|
| 349 | +64 |
- validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
+ #' iv_par <- InputValidator$new() |
|
| 350 | -! | +||
| 65 | +
- x_levels <- if (is.factor(x)) {
+ #' iv_par$add_rule("color", sv_required(message = "choose a color"))
|
||
| 351 | -! | +||
| 66 | +
- levels(x)+ #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color")
|
||
| 352 | +67 |
- } else {
+ #' iv_par$add_rule( |
|
| 353 | -! | +||
| 68 | +
- unique(x)+ #' "size", |
||
| 354 | +69 |
- }+ #' sv_between( |
|
| 355 | +70 |
-
+ #' left = 0.5, right = 3, |
|
| 356 | -! | +||
| 71 | +
- if (!is.null(min_levels) && !(is.null(max_levels))) {
+ #' message_fmt = "choose a value between {left} and {right}"
|
||
| 357 | -! | +||
| 72 | +
- validate(need(+ #' ) |
||
| 358 | -! | +||
| 73 | +
- length(x_levels) >= min_levels && length(x_levels) <= max_levels,+ #' ) |
||
| 359 | -! | +||
| 74 | +
- sprintf(+ #' iv_par$enable() |
||
| 360 | -! | +||
| 75 | +
- "%s variable needs minimum %s level(s) and maximum %s level(s).",+ #' |
||
| 361 | -! | +||
| 76 | +
- var_name, min_levels, max_levels+ #' output$plot <- renderPlot({
|
||
| 362 | +77 |
- )+ #' # validate output |
|
| 363 | +78 |
- ))+ #' switch(input[["method"]], |
|
| 364 | -! | +||
| 79 | +
- } else if (!is.null(min_levels)) {
+ #' "sequential" = {
|
||
| 365 | -! | +||
| 80 | +
- validate(need(+ #' validate_inputs(iv) |
||
| 366 | -! | +||
| 81 | +
- length(x_levels) >= min_levels,+ #' validate_inputs(iv_par, header = "Set proper graphical parameters") |
||
| 367 | -! | +||
| 82 | +
- sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
+ #' }, |
||
| 368 | +83 |
- ))+ #' "combined" = validate_inputs(iv, iv_par), |
|
| 369 | -! | +||
| 84 | +
- } else if (!is.null(max_levels)) {
+ #' "grouped" = validate_inputs(list( |
||
| 370 | -! | +||
| 85 | +
- validate(need(+ #' "Some inputs require attention" = iv, |
||
| 371 | -! | +||
| 86 | +
- length(x_levels) <= max_levels,+ #' "Set proper graphical parameters" = iv_par |
||
| 372 | -! | +||
| 87 | +
- sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
+ #' )) |
||
| 373 | +88 |
- ))+ #' ) |
|
| 374 | +89 |
- }+ #' |
|
| 375 | +90 |
- }+ #' plot(eruptions ~ waiting, faithful, |
| 1 | +91 |
- #' Get Client Timezone+ #' las = 1, pch = 16, |
||
| 2 | +92 |
- #'+ #' col = input[["color"]], cex = input[["size"]] |
||
| 3 | +93 |
- #' Local timezone in the browser may differ from the system timezone from the server.+ #' ) |
||
| 4 | +94 |
- #' This script can be run to register a shiny input which contains information about+ #' }) |
||
| 5 | +95 |
- #' the timezone in the browser.+ #' } |
||
| 6 | +96 |
#' |
||
| 7 | +97 |
- #' @param ns (`function`) namespace function passed from the `session` object in the+ #' if (interactive()) {
|
||
| 8 | +98 |
- #' Shiny server. For Shiny modules this will allow for proper name spacing of the+ #' shinyApp(ui, server) |
||
| 9 | +99 |
- #' registered input.+ #' } |
||
| 10 | +100 |
#' |
||
| 11 | +101 |
- #' @return (`Shiny`) input variable accessible with `input$tz` which is a (`character`)+ #' @export |
||
| 12 | +102 |
- #' string containing the timezone of the browser/client.+ #' |
||
| 13 | +103 |
- #' @keywords internal+ validate_inputs <- function(..., header = "Some inputs require attention") {
+ |
+ ||
| 104 | +36x | +
+ dots <- list(...)+ |
+ ||
| 105 | +2x | +
+ if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
|
||
| 14 | +106 |
- get_client_timezone <- function(ns) {
+
|
||
| 15 | -8x | +107 | +34x |
- script <- sprintf(+ messages <- extract_validator(dots, header) |
| 16 | -8x | +108 | +34x |
- "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",+ failings <- if (!any_names(dots)) {
|
| 17 | -8x | +109 | +29x |
- ns("timezone")
+ add_header(messages, header) |
| 18 | +110 |
- )+ } else {
|
||
| 19 | -8x | +111 | +5x |
- shinyjs::runjs(script) # function does not return anything+ unlist(messages)+ |
+
| 112 | ++ |
+ }+ |
+ ||
| 113 | ++ | + | ||
| 20 | -8x | +114 | +34x |
- return(invisible(NULL))+ shiny::validate(shiny::need(is.null(failings), failings)) |
| 21 | +115 |
} |
||
| 22 | +116 | |||
| 23 | +117 |
- #' Resolve the expected bootstrap theme+ ### internal functions |
||
| 24 | +118 | ++ | + + | +|
| 119 |
#' @keywords internal |
|||
| 25 | +120 |
- get_teal_bs_theme <- function() {
+ # recursive object type test |
||
| 26 | -36x | +|||
| 121 | +
- bs_theme <- getOption("teal.bs_theme")
+ # returns logical of length 1 |
|||
| 27 | -36x | +|||
| 122 | +
- if (is.null(bs_theme)) {
+ is_validators <- function(x) {
|
|||
| 28 | -33x | +123 | +118x |
- NULL+ all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator")) |
| 29 | -3x | +|||
| 124 | +
- } else if (!inherits(bs_theme, "bs_theme")) {
+ } |
|||
| 30 | -2x | +|||
| 125 | +
- warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
+
|
|||
| 31 | -2x | +|||
| 126 | +
- NULL+ #' @keywords internal |
|||
| 32 | +127 |
- } else {
+ # test if an InputValidator object is enabled |
||
| 33 | -1x | +|||
| 128 | +
- bs_theme+ # returns logical of length 1 |
|||
| 34 | +129 |
- }+ # official method requested at https://github.com/rstudio/shinyvalidate/issues/64 |
||
| 35 | +130 | ++ |
+ validator_enabled <- function(x) {
+ |
+ |
| 131 | +49x | +
+ x$.__enclos_env__$private$enabled+ |
+ ||
| 132 |
} |
|||
| 36 | +133 | |||
| 37 | +134 |
- include_parent_datanames <- function(dataname, join_keys) {
+ #' @keywords internal |
||
| 38 | -145x | +|||
| 135 | +
- parents <- character(0)+ # recursively extract messages from validator list+ |
+ |||
| 136 | ++ |
+ # returns character vector or a list of character vectors, possibly nested and named+ |
+ ||
| 137 | ++ |
+ extract_validator <- function(iv, header) {
|
||
| 39 | -145x | +138 | +113x |
- for (i in dataname) {
+ if (inherits(iv, "InputValidator")) {
|
| 40 | -25x | +139 | +49x |
- while (length(i) > 0) {
+ add_header(gather_messages(iv), header) |
| 41 | -25x | +|||
| 140 | +
- parent_i <- join_keys$get_parent(i)+ } else {
|
|||
| 42 | -25x | +141 | +58x |
- parents <- c(parent_i, parents)+ if (is.null(names(iv))) names(iv) <- rep("", length(iv))
|
| 43 | -25x | +142 | +64x |
- i <- parent_i+ mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE) |
| 44 | +143 |
- }+ } |
||
| 45 | +144 |
- }+ } |
||
| 46 | +145 | |||
| 47 | -145x | -
- return(unique(c(parents, dataname)))- |
- ||
| 48 | +146 |
- }+ #' @keywords internal |
||
| 49 | +147 |
-
+ # collate failing messages from validator |
||
| 50 | +148 |
- #' Template Function for `TealReportCard` Creation and Customization+ # returns list |
||
| 51 | +149 |
- #'+ gather_messages <- function(iv) {
|
||
| 52 | -+ | |||
| 150 | +49x |
- #' This function generates a report card with a title,+ if (validator_enabled(iv)) {
|
||
| 53 | -+ | |||
| 151 | +46x |
- #' an optional description, and the option to append the filter state list.+ status <- iv$validate() |
||
| 54 | -+ | |||
| 152 | +46x |
- #'+ failing_inputs <- Filter(Negate(is.null), status) |
||
| 55 | -+ | |||
| 153 | +46x |
- #' @param title (`character(1)`) title of the card (unless overwritten by label)+ unique(lapply(failing_inputs, function(x) x[["message"]])) |
||
| 56 | +154 |
- #' @param label (`character(1)`) label provided by the user when adding the card+ } else {
|
||
| 57 | -+ | |||
| 155 | +3x |
- #' @param description (`character(1)`) optional additional description+ logger::log_warn("Validator is disabled and will be omitted.")
|
||
| 58 | -+ | |||
| 156 | +3x |
- #' @param with_filter (`logical(1)`) flag indicating to add filter state+ list() |
||
| 59 | +157 |
- #' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation+ } |
||
| 60 | +158 |
- #' of the filter state in the report+ } |
||
| 61 | +159 |
- #'+ |
||
| 62 | +160 |
- #' @return (`TealReportCard`) populated with a title, description and filter state+ #' @keywords internal |
||
| 63 | +161 |
- #'+ # add optional header to failing messages |
||
| 64 | +162 |
- #' @export+ add_header <- function(messages, header = "") {
|
||
| 65 | -+ | |||
| 163 | +78x |
- report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
+ ans <- unlist(messages) |
||
| 66 | -2x | +164 | +78x |
- checkmate::assert_string(title)+ if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
|
| 67 | -2x | +165 | +31x |
- checkmate::assert_string(label)+ ans <- c(paste0(header, "\n"), ans, "\n") |
| 68 | -2x | +|||
| 166 | +
- checkmate::assert_string(description, null.ok = TRUE)+ } |
|||
| 69 | -2x | +167 | +78x |
- checkmate::assert_flag(with_filter)+ ans |
| 70 | -2x | +|||
| 168 | +
- checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")+ } |
|||
| 71 | +169 | |||
| 72 | -2x | +|||
| 170 | +
- card <- teal::TealReportCard$new()+ #' @keywords internal |
|||
| 73 | -2x | +|||
| 171 | +
- title <- if (label == "") title else label+ # recursively check if the object contains a named list |
|||
| 74 | -2x | +|||
| 172 | +
- card$set_name(title)+ any_names <- function(x) {
|
|||
| 75 | -2x | +173 | +103x |
- card$append_text(title, "header2")+ any( |
| 76 | -1x | +174 | +103x |
- if (!is.null(description)) card$append_text(description, "header3")+ if (is.list(x)) {
|
| 77 | -1x | +175 | +58x |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))+ |
+
| 176 | ++ |
+ } else {
|
||
| 78 | -2x | +177 | +40x |
- card+ FALSE |
| 79 | +178 | ++ |
+ }+ |
+ |
| 179 | ++ |
+ )+ |
+ ||
| 180 |
} |