| 1 |
- #' Create a UI of nested tabs of `teal_modules`+ #' Filter settings for teal applications |
||
| 3 |
- #' @section `ui_nested_tabs`:+ #' Filter settings for teal applications |
||
| 4 |
- #' Each `teal_modules` is translated to a `tabsetPanel` and each+ #' |
||
| 5 |
- #' of its children is another tab-module called recursively. The UI of a+ #' @inheritParams teal.slice::teal_slices |
||
| 6 |
- #' `teal_module` is obtained by calling the `ui` function on it.+ #' |
||
| 7 |
- #'+ #' @param module_specific (`logical(1)`)\cr |
||
| 8 |
- #' The `datasets` argument is required to resolve the teal arguments in an+ #' - `TRUE` when filter panel should be module-specific. All modules can have different set |
||
| 9 |
- #' isolated context (with respect to reactivity)+ #' of filters specified - see `mapping` argument. |
||
| 10 |
- #'+ #' - `FALSE` when one filter panel needed to all modules. All filters will be shared |
||
| 11 |
- #' @section `srv_nested_tabs`:+ #' by all modules. |
||
| 12 |
- #' This module calls recursively all elements of the `modules` returns one which+ #' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
|
||
| 13 |
- #' is currently active.+ #' (`named list`)\cr |
||
| 14 |
- #' - `teal_module` returns self as a active module.+ #' Specifies which filters will be active in which modules on app start. |
||
| 15 |
- #' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.+ #' Elements should contain character vector of `teal_slice` `id`s (see [teal.slice::teal_slice()]). |
||
| 16 |
- #'+ #' Names of the list should correspond to `teal_module` `label` set in [module()] function. |
||
| 17 |
- #' @name module_nested_tabs+ #' `id`s listed under `"global_filters` will be active in all modules. |
||
| 18 |
- #'+ #' If missing, all filters will be applied to all modules. |
||
| 19 |
- #' @inheritParams module_tabs_with_filters+ #' If empty list, all filters will be available to all modules but will start inactive. |
||
| 20 |
- #'+ #' If `module_specific` is `FALSE`, only `global_filters` will be active on start. |
||
| 21 |
- #' @param depth (`integer(1)`)\cr+ #' |
||
| 22 |
- #' number which helps to determine depth of the modules nesting.+ #' @param x (`list`) of lists to convert to `teal_slices` |
||
| 23 |
- #' @param is_module_specific (`logical(1)`)\cr+ #' |
||
| 24 |
- #' flag determining if the filter panel is global or module-specific.+ #' @examples |
||
| 25 |
- #' When set to `TRUE`, a filter panel is called inside of each module tab.+ #' filter <- teal_slices( |
||
| 26 |
- #' @return depending on class of `modules`, `ui_nested_tabs` returns:+ #' teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"), |
||
| 27 |
- #' - `teal_module`: instantiated UI of the module+ #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"), |
||
| 28 |
- #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively+ #' teal.slice::teal_slice( |
||
| 29 |
- #' calling this function on it.\cr+ #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5" |
||
| 30 |
- #' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.+ #' ), |
||
| 31 |
- #'+ #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"), |
||
| 32 |
- #' @examples+ #' mapping = list( |
||
| 33 |
- #' mods <- teal:::example_modules()+ #' module1 = c("species", "sepal_length"),
|
||
| 34 |
- #' datasets <- teal:::example_datasets()+ #' module2 = c("mtcars_mpg"),
|
||
| 35 |
- #' app <- shinyApp(+ #' global_filters = "long_petals" |
||
| 36 |
- #' ui = function() {
+ #' ) |
||
| 37 |
- #' tagList(+ #' ) |
||
| 38 |
- #' teal:::include_teal_css_js(),+ #' |
||
| 39 |
- #' textOutput("info"),
+ #' app <- teal::init( |
||
| 40 |
- #' fluidPage( # needed for nice tabs+ #' modules = list( |
||
| 41 |
- #' teal:::ui_nested_tabs("dummy", modules = mods, datasets = datasets)
+ #' module("module1"),
|
||
| 42 |
- #' )+ #' module("module2")
|
||
| 43 |
- #' )+ #' ), |
||
| 44 |
- #' },+ #' data = list(iris, mtcars), |
||
| 45 |
- #' server = function(input, output, session) {
+ #' filter = filter |
||
| 46 |
- #' active_module <- teal:::srv_nested_tabs(+ #' ) |
||
| 47 |
- #' "dummy",+ #' |
||
| 48 |
- #' datasets = datasets,+ #' if (interactive()) {
|
||
| 49 |
- #' modules = mods+ #' shiny::runApp(app) |
||
| 50 |
- #' )+ #' } |
||
| 51 |
- #' output$info <- renderText({
+ #' |
||
| 52 |
- #' paste0("The currently active tab name is ", active_module()$label)
+ #' @export |
||
| 53 |
- #' })+ teal_slices <- function(..., |
||
| 54 |
- #' }+ exclude_varnames = NULL, |
||
| 55 |
- #' )+ include_varnames = NULL, |
||
| 56 |
- #' if (interactive()) {
+ count_type = NULL, |
||
| 57 |
- #' runApp(app)+ allow_add = TRUE, |
||
| 58 |
- #' }+ module_specific = FALSE, |
||
| 59 |
- #' @keywords internal+ mapping) {
|
||
| 60 | -+ | 91x |
- NULL+ shiny::isolate({
|
| 61 | -+ | 91x |
-
+ checkmate::assert_flag(allow_add) |
| 62 | -+ | 91x |
- #' @rdname module_nested_tabs+ checkmate::assert_flag(module_specific) |
| 63 | -+ | 45x |
- ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
|
| 64 | -2x | +
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+
|
|
| 65 | -2x | +88x |
- checkmate::assert_count(depth)+ slices <- list(...) |
| 66 | -2x | +88x |
- UseMethod("ui_nested_tabs", modules)
+ all_slice_id <- vapply(slices, `[[`, character(1L), "id") |
| 67 |
- }+ |
||
| 68 | -+ | 88x |
-
+ if (missing(mapping)) {
|
| 69 | -+ | 46x |
- #' @rdname module_nested_tabs+ mapping <- list(global_filters = all_slice_id) |
| 70 |
- #' @export+ } |
||
| 71 | -+ | 88x |
- ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ if (!module_specific) {
|
| 72 | -! | +84x |
- stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ mapping[setdiff(names(mapping), "global_filters")] <- NULL |
| 73 |
- }+ } |
||
| 75 | -+ | 88x |
- #' @rdname module_nested_tabs+ failed_slice_id <- setdiff(unlist(mapping), all_slice_id) |
| 76 | -+ | 88x |
- #' @export+ if (length(failed_slice_id)) {
|
| 77 | -+ | 1x |
- ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ stop(sprintf( |
| 78 | 1x |
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ "Filters in mapping don't match any available filter.\n %s not in %s", |
|
| 79 | 1x |
- ns <- NS(id)+ toString(failed_slice_id), |
|
| 80 | 1x |
- do.call(+ toString(all_slice_id) |
|
| 81 | -1x | +
- tabsetPanel,+ )) |
|
| 82 | -1x | +
- c(+ } |
|
| 83 |
- # by giving an id, we can reactively respond to tab changes+ |
||
| 84 | -1x | +87x |
- list(+ tss <- teal.slice::teal_slices( |
| 85 | -1x | +
- id = ns("active_tab"),
+ ..., |
|
| 86 | -1x | +87x |
- type = if (modules$label == "root") "pills" else "tabs"+ exclude_varnames = exclude_varnames, |
| 87 | -+ | 87x |
- ),+ include_varnames = include_varnames, |
| 88 | -1x | +87x |
- lapply(+ count_type = count_type, |
| 89 | -1x | +87x |
- names(modules$children),+ allow_add = allow_add |
| 90 | -1x | +
- function(module_id) {
+ ) |
|
| 91 | -1x | +87x |
- module_label <- modules$children[[module_id]]$label+ attr(tss, "mapping") <- mapping |
| 92 | -1x | +87x |
- tabPanel(+ attr(tss, "module_specific") <- module_specific |
| 93 | -1x | +87x |
- title = module_label,+ class(tss) <- c("modules_teal_slices", class(tss))
|
| 94 | -1x | +87x |
- value = module_id, # when clicked this tab value changes input$<tabset panel id>+ tss |
| 95 | -1x | +
- ui_nested_tabs(+ }) |
|
| 96 | -1x | +
- id = ns(module_id),+ } |
|
| 97 | -1x | +
- modules = modules$children[[module_id]],+ |
|
| 98 | -1x | +
- datasets = datasets[[module_label]],+ |
|
| 99 | -1x | +
- depth = depth + 1L,+ #' @rdname teal_slices |
|
| 100 | -1x | +
- is_module_specific = is_module_specific+ #' @export |
|
| 101 |
- )+ #' @keywords internal |
||
| 102 |
- )+ #' |
||
| 103 |
- }+ as.teal_slices <- function(x) { # nolint
|
||
| 104 | -+ | 33x |
- )+ checkmate::assert_list(x) |
| 105 | -+ | 33x |
- )+ lapply(x, checkmate::assert_list, names = "named", .var.name = "list element") |
| 106 |
- )+ |
||
| 107 | -+ | 33x |
- }+ attrs <- attributes(unclass(x)) |
| 108 | -+ | 33x |
-
+ ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x)) |
| 109 | -+ | 33x |
- #' @rdname module_nested_tabs+ do.call(teal_slices, c(ans, attrs)) |
| 110 |
- #' @export+ } |
||
| 111 |
- ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+
|
||
| 112 | -1x | +
- checkmate::assert_class(datasets, class = "FilteredData")+ |
|
| 113 | -1x | +
- ns <- NS(id)+ #' @rdname teal_slices |
|
| 114 |
-
+ #' @export |
||
| 115 | -1x | +
- args <- isolate(teal.transform::resolve_delayed(modules$ui_args, datasets))+ #' @keywords internal |
|
| 116 | -1x | +
- args <- c(list(id = ns("module")), args)
+ #' |
|
| 117 |
-
+ c.teal_slices <- function(...) {
|
||
| 118 | -1x | +! |
- if (is_arg_used(modules$ui, "datasets")) {
+ x <- list(...) |
| 119 | ! |
- args <- c(args, datasets = datasets)+ checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices") |
|
| 120 |
- }+ |
||
| 121 | -+ | ! |
-
+ all_attributes <- lapply(x, attributes) |
| 122 | -1x | +! |
- if (is_arg_used(modules$ui, "data")) {
+ all_attributes <- coalesce_r(all_attributes) |
| 123 | ! |
- data <- .datasets_to_data(modules, datasets)+ all_attributes <- all_attributes[names(all_attributes) != "class"] |
|
| 124 | -! | +
- args <- c(args, data = list(data))+ |
|
| 125 | -+ | ! |
- }+ do.call( |
| 126 | -+ | ! |
-
+ teal_slices, |
| 127 | -1x | +! |
- teal_ui <- tags$div(+ c( |
| 128 | -1x | +! |
- id = id,+ unique(unlist(x, recursive = FALSE)), |
| 129 | -1x | +! |
- class = "teal_module",+ all_attributes |
| 130 | -1x | +
- uiOutput(ns("data_reactive"), inline = TRUE),
+ ) |
|
| 131 | -1x | +
- tagList(+ ) |
|
| 132 | -1x | +
- if (depth >= 2L) div(style = "mt-6"),+ } |
|
| 133 | -1x | +
- do.call(modules$ui, args)+ |
|
| 134 |
- )+ |
||
| 135 |
- )+ #' Deep copy `teal_slices` |
||
| 136 |
-
+ #' |
||
| 137 | -1x | +
- if (!is.null(modules$datanames) && is_module_specific) {
+ #' it's important to create a new copy of `teal_slices` when |
|
| 138 | -! | +
- fluidRow(+ #' starting a new `shiny` session. Otherwise, object will be shared |
|
| 139 | -! | +
- column(width = 9, teal_ui, class = "teal_primary_col"),+ #' by multiple users as it is created in global environment before |
|
| 140 | -! | +
- column(+ #' `shiny` session starts. |
|
| 141 | -! | +
- width = 3,+ #' @param filter (`teal_slices`) |
|
| 142 | -! | +
- datasets$ui_filter_panel(ns("module_filter_panel")),
+ #' @return `teal_slices` |
|
| 143 | -! | +
- class = "teal_secondary_col"+ #' @keywords internal |
|
| 144 |
- )+ deep_copy_filter <- function(filter) {
|
||
| 145 | -+ | 1x |
- )+ checkmate::assert_class(filter, "teal_slices") |
| 146 | -+ | 1x |
- } else {
+ shiny::isolate({
|
| 147 | 1x |
- teal_ui+ filter_copy <- lapply(filter, function(slice) {
|
|
| 148 | -+ | 2x |
- }+ teal.slice::as.teal_slice(as.list(slice)) |
| 149 |
- }+ }) |
||
| 150 | -+ | 1x |
-
+ attributes(filter_copy) <- attributes(filter) |
| 151 | -+ | 1x |
- #' @rdname module_nested_tabs+ filter_copy |
| 152 |
- srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,+ }) |
||
| 153 |
- reporter = teal.reporter::Reporter$new()) {
+ } |
||
| 154 | -54x | +
| 1 | +
- checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ # This module is the main teal module that puts everything together. |
|||
| 155 | -54x | +|||
| 2 | +
- checkmate::assert_class(reporter, "Reporter")+ |
|||
| 156 | -53x | +|||
| 3 | +
- UseMethod("srv_nested_tabs", modules)
+ #' teal main app module |
|||
| 157 | +4 |
- }+ #' |
||
| 158 | +5 |
-
+ #' This is the main teal app that puts everything together. |
||
| 159 | +6 |
- #' @rdname module_nested_tabs+ #' |
||
| 160 | +7 |
- #' @export+ #' It displays the splash UI which is used to fetch the data, possibly |
||
| 161 | +8 |
- srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,+ #' prompting for a password input to fetch the data. Once the data is ready, |
||
| 162 | +9 |
- reporter = teal.reporter::Reporter$new()) {
+ #' the splash screen is replaced by the actual teal UI that is tabsetted and |
||
| 163 | -! | +|||
| 10 | +
- stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ #' has a filter panel with `datanames` that are relevant for the current tab. |
|||
| 164 | +11 |
- }+ #' Nested tabs are possible, but we limit it to two nesting levels for reasons |
||
| 165 | +12 |
-
+ #' of clarity of the UI. |
||
| 166 | +13 |
- #' @rdname module_nested_tabs+ #' |
||
| 167 | +14 |
- #' @export+ #' The splash screen functionality can also be used |
||
| 168 | +15 |
- srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,+ #' for non-delayed data which takes time to load into memory, avoiding |
||
| 169 | +16 |
- reporter = teal.reporter::Reporter$new()) {
+ #' Shiny session timeouts. |
||
| 170 | -24x | +|||
| 17 | +
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ #' |
|||
| 171 | +18 |
-
+ #' Server evaluates the `raw_data` (delayed data mechanism) and creates the |
||
| 172 | -24x | +|||
| 19 | +
- moduleServer(id = id, module = function(input, output, session) {
+ #' `datasets` object that is shared across modules. |
|||
| 173 | -24x | +|||
| 20 | +
- logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
+ #' Once it is ready and non-`NULL`, the splash screen is replaced by the |
|||
| 174 | +21 |
-
+ #' main teal UI that depends on the data. |
||
| 175 | -24x | +|||
| 22 | +
- labels <- vapply(modules$children, `[[`, character(1), "label")+ #' The currently active tab is tracked and the right filter panel |
|||
| 176 | -24x | +|||
| 23 | +
- modules_reactive <- sapply(+ #' updates the displayed datasets to filter for according to the active `datanames` |
|||
| 177 | -24x | +|||
| 24 | +
- names(modules$children),+ #' of the tab. |
|||
| 178 | -24x | +|||
| 25 | +
- function(module_id) {
+ #' |
|||
| 179 | -35x | +|||
| 26 | +
- srv_nested_tabs(+ #' It is written as a Shiny module so it can be added into other apps as well. |
|||
| 180 | -35x | +|||
| 27 | +
- id = module_id,+ #' |
|||
| 181 | -35x | +|||
| 28 | +
- datasets = datasets[[labels[module_id]]],+ #' @name module_teal |
|||
| 182 | -35x | +|||
| 29 | +
- modules = modules$children[[module_id]],+ #' |
|||
| 183 | -35x | +|||
| 30 | +
- is_module_specific = is_module_specific,+ #' @inheritParams ui_teal_with_splash |
|||
| 184 | -35x | +|||
| 31 | +
- reporter = reporter+ #' |
|||
| 185 | +32 |
- )+ #' @param splash_ui (`shiny.tag`)\cr UI to display initially, |
||
| 186 | +33 |
- },+ #' can be a splash screen or a Shiny module UI. For the latter, see |
||
| 187 | -24x | +|||
| 34 | +
- simplify = FALSE+ #' [init()] about how to call the corresponding server function. |
|||
| 188 | +35 |
- )+ #' |
||
| 189 | +36 |
-
+ #' @param raw_data (`reactive`)\cr |
||
| 190 | +37 |
- # when not ready input$active_tab would return NULL - this would fail next reactive- |
- ||
| 191 | -24x | -
- input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)- |
- ||
| 192 | -24x | -
- get_active_module <- reactive({
- |
- ||
| 193 | -13x | -
- if (length(modules$children) == 1L) {
+ #' returns the `TealData`, only evaluated once, `NULL` value is ignored |
||
| 194 | +38 |
- # single tab is active by default+ #' |
||
| 195 | -2x | +|||
| 39 | +
- modules_reactive[[1]]()+ #' @return |
|||
| 196 | +40 |
- } else {
+ #' `ui_teal` returns `HTML` for Shiny module UI. |
||
| 197 | +41 |
- # switch to active tab+ #' `srv_teal` returns `reactive` which returns the currently active module. |
||
| 198 | -11x | +|||
| 42 | +
- modules_reactive[[input_validated()]]()+ #' |
|||
| 199 | +43 |
- }+ #' @keywords internal |
||
| 200 | +44 |
- })+ #' |
||
| 201 | +45 |
-
+ #' @examples |
||
| 202 | -24x | +|||
| 46 | +
- get_active_module+ #' mods <- teal:::example_modules() |
|||
| 203 | +47 |
- })+ #' raw_data <- reactive(teal:::example_cdisc_data()) |
||
| 204 | +48 |
- }+ #' app <- shinyApp( |
||
| 205 | +49 |
-
+ #' ui = function() {
|
||
| 206 | +50 |
- #' @rdname module_nested_tabs+ #' teal:::ui_teal("dummy")
|
||
| 207 | +51 |
- #' @export+ #' }, |
||
| 208 | +52 |
- srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,+ #' server = function(input, output, session) {
|
||
| 209 | +53 |
- reporter = teal.reporter::Reporter$new()) {
+ #' active_module <- teal:::srv_teal(id = "dummy", modules = mods, raw_data = raw_data) |
||
| 210 | -29x | +|||
| 54 | +
- checkmate::assert_class(datasets, "FilteredData")+ #' } |
|||
| 211 | -29x | +|||
| 55 | +
- logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
+ #' ) |
|||
| 212 | +56 |
-
+ #' if (interactive()) {
|
||
| 213 | -29x | +|||
| 57 | +
- moduleServer(id = id, module = function(input, output, session) {
+ #' runApp(app) |
|||
| 214 | -29x | +|||
| 58 | +
- modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets)+ #' } |
|||
| 215 | -29x | +|||
| 59 | +
- if (!is.null(modules$datanames) && is_module_specific) {
+ NULL |
|||
| 216 | -! | +|||
| 60 | +
- datasets$srv_filter_panel("module_filter_panel", active_datanames = reactive(modules$datanames))
+
|
|||
| 217 | +61 |
- }+ #' @rdname module_teal |
||
| 218 | +62 |
-
+ ui_teal <- function(id, |
||
| 219 | +63 |
- # Create two triggers to limit reactivity between filter-panel and modules.+ splash_ui = tags$h2("Starting the Teal App"),
|
||
| 220 | +64 |
- # We want to recalculate only visible modules+ title = NULL, |
||
| 221 | +65 |
- # - trigger the data when the tab is selected+ header = tags$p(""),
|
||
| 222 | +66 |
- # - trigger module to be called when the tab is selected for the first time+ footer = tags$p("")) {
|
||
| 223 | -29x | +67 | +32x |
- trigger_data <- reactiveVal(1L)+ if (checkmate::test_string(header)) {
|
| 224 | -29x | +|||
| 68 | +! |
- trigger_module <- reactiveVal(NULL)+ header <- tags$h1(header) |
||
| 225 | -29x | +|||
| 69 | +
- output$data_reactive <- renderUI({
+ } |
|||
| 226 | -18x | +70 | +32x |
- lapply(datasets$datanames(), function(x) {
+ if (checkmate::test_string(footer)) {
|
| 227 | -22x | +|||
| 71 | +! |
- datasets$get_data(x, filtered = TRUE)+ footer <- tags$p(footer) |
||
| 228 | +72 |
- })+ } |
||
| 229 | -18x | +73 | +32x |
- isolate(trigger_data(trigger_data() + 1))+ checkmate::assert( |
| 230 | -18x | +74 | +32x |
- isolate(trigger_module(TRUE))+ checkmate::check_class(splash_ui, "shiny.tag"), |
| 231 | -+ | |||
| 75 | +32x |
-
+ checkmate::check_class(splash_ui, "shiny.tag.list"), |
||
| 232 | -18x | +76 | +32x |
- NULL+ checkmate::check_class(splash_ui, "html") |
| 233 | +77 |
- })+ ) |
||
| 234 | -+ | |||
| 78 | +32x |
-
+ checkmate::assert( |
||
| 235 | -+ | |||
| 79 | +32x |
- # collect arguments to run teal_module+ checkmate::check_class(header, "shiny.tag"), |
||
| 236 | -29x | +80 | +32x |
- args <- c(list(id = "module"), modules$server_args)+ checkmate::check_class(header, "shiny.tag.list"), |
| 237 | -29x | +81 | +32x |
- if (is_arg_used(modules$server, "reporter")) {
+ checkmate::check_class(header, "html") |
| 238 | -! | +|||
| 82 | +
- args <- c(args, list(reporter = reporter))+ ) |
|||
| 239 | -+ | |||
| 83 | +32x |
- }+ checkmate::assert( |
||
| 240 | -+ | |||
| 84 | +32x |
-
+ checkmate::check_class(footer, "shiny.tag"), |
||
| 241 | -29x | +85 | +32x |
- if (is_arg_used(modules$server, "datasets")) {
+ checkmate::check_class(footer, "shiny.tag.list"), |
| 242 | -2x | +86 | +32x |
- args <- c(args, datasets = datasets)+ checkmate::check_class(footer, "html") |
| 243 | +87 |
- }+ ) |
||
| 244 | +88 | |||
| 245 | -29x | +89 | +32x |
- if (is_arg_used(modules$server, "data")) {
+ ns <- NS(id)+ |
+
| 90 | ++ |
+ # Once the data is loaded, we will remove this element and add the real teal UI instead |
||
| 246 | -8x | +91 | +32x |
- data <- .datasets_to_data(modules, datasets, trigger_data)+ splash_ui <- div(+ |
+
| 92 | ++ |
+ # id so we can remove the splash screen once ready, which is the first child of this container |
||
| 247 | -8x | +93 | +32x |
- args <- c(args, data = list(data))+ id = ns("main_ui_container"),
|
| 248 | +94 |
- }+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not |
||
| 249 | +95 |
-
+ # just the first item of the tagList) |
||
| 250 | -29x | +96 | +32x |
- if (is_arg_used(modules$server, "filter_panel_api")) {
+ div(splash_ui) |
| 251 | -2x | +|||
| 97 | +
- filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)+ ) |
|||
| 252 | -2x | +|||
| 98 | +
- args <- c(args, filter_panel_api = filter_panel_api)+ |
|||
| 253 | +99 |
- }+ # show busy icon when shiny session is busy computing stuff |
||
| 254 | +100 |
-
+ # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 #nolint |
||
| 255 | -29x | +101 | +32x |
- if (is_arg_used(modules$server, "datasets") && is_arg_used(modules$server, "data")) {
+ shiny_busy_message_panel <- conditionalPanel( |
| 256 | -1x | +102 | +32x |
- warning(+ condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
|
| 257 | -1x | +103 | +32x |
- "Module '", modules$label, "' has `data` and `datasets` arguments in the formals.",+ div( |
| 258 | -1x | +104 | +32x |
- "\nIt's recommended to use `data` to work with filtered objects."+ icon("arrows-rotate", "spin fa-spin"),
+ |
+
| 105 | +32x | +
+ "Computing ...", |
||
| 259 | +106 |
- )+ # CSS defined in `custom.css`+ |
+ ||
| 107 | +32x | +
+ class = "shinybusymessage" |
||
| 260 | +108 |
- }+ ) |
||
| 261 | +109 |
-
+ ) |
||
| 262 | +110 |
- # observe the trigger_module above to induce the module once the renderUI is triggered+ |
||
| 263 | -29x | +111 | +32x |
- observeEvent(+ res <- fluidPage( |
| 264 | -29x | +112 | +32x |
- ignoreNULL = TRUE,+ title = title, |
| 265 | -29x | +113 | +32x |
- once = TRUE,+ theme = get_teal_bs_theme(), |
| 266 | -29x | +114 | +32x |
- eventExpr = trigger_module(),+ include_teal_css_js(), |
| 267 | -29x | +115 | +32x |
- handlerExpr = {
+ tags$header(header), |
| 268 | -18x | +116 | +32x |
- module_output <- if (is_arg_used(modules$server, "id")) {
+ tags$hr(class = "my-2"), |
| 269 | -18x | +117 | +32x |
- do.call(modules$server, args)+ shiny_busy_message_panel, |
| 270 | -+ | |||
| 118 | +32x |
- } else {
+ splash_ui, |
||
| 271 | -! | +|||
| 119 | +32x |
- do.call(callModule, c(args, list(module = modules$server)))+ tags$hr(), |
||
| 272 | -+ | |||
| 120 | +32x |
- }+ tags$footer( |
||
| 273 | -+ | |||
| 121 | +32x |
- }+ div( |
||
| 274 | -+ | |||
| 122 | +32x |
- )+ footer, |
||
| 275 | -+ | |||
| 123 | +32x |
-
+ teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
|
||
| 276 | -29x | +124 | +32x |
- reactive(modules)+ textOutput(ns("identifier"))
|
| 277 | +125 |
- })+ ) |
||
| 278 | +126 |
- }+ ) |
||
| 279 | +127 |
-
+ ) |
||
| 280 | -+ | |||
| 128 | +32x |
- #' Convert `FilteredData` to reactive list of datasets of the `tdata` type.+ return(res) |
||
| 281 | +129 |
- #'+ } |
||
| 282 | +130 |
- #' Converts `FilteredData` object to `tdata` object containing datasets needed for a specific module.+ |
||
| 283 | +131 |
- #' Please note that if module needs dataset which has a parent, then parent will be also returned.+ |
||
| 284 | +132 |
- #' A hash per `dataset` is calculated internally and returned in the code.+ #' @rdname module_teal |
||
| 285 | +133 |
- #'+ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
|
||
| 286 | -+ | |||
| 134 | +9x |
- #' @param module (`teal_module`) module where needed filters are taken from+ stopifnot(is.reactive(raw_data)) |
||
| 287 | -+ | |||
| 135 | +8x |
- #' @param datasets (`FilteredData`) object where needed data are taken from+ moduleServer(id, function(input, output, session) {
|
||
| 288 | -+ | |||
| 136 | +8x |
- #' @param trigger_data (`reactiveVal`) to trigger getting the filtered data+ logger::log_trace("srv_teal initializing the module.")
|
||
| 289 | +137 |
- #' @return list of reactive datasets with following attributes:+ |
||
| 290 | -+ | |||
| 138 | +8x |
- #' - `code` (`character`) containing datasets reproducible code.+ output$identifier <- renderText( |
||
| 291 | -+ | |||
| 139 | +8x |
- #' - `join_keys` (`JoinKeys`) containing relationships between datasets.+ paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
|
||
| 292 | +140 |
- #' - `metadata` (`list`) containing metadata of datasets.+ ) |
||
| 293 | +141 |
- #'+ |
||
| 294 | -+ | |||
| 142 | +8x |
- #' @keywords internal+ teal.widgets::verbatim_popup_srv( |
||
| 295 | -+ | |||
| 143 | +8x |
- .datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) {
+ "sessionInfo", |
||
| 296 | -13x | +144 | +8x |
- checkmate::assert_class(module, "teal_module")+ verbatim_content = utils::capture.output(utils::sessionInfo()), |
| 297 | -13x | +145 | +8x |
- checkmate::assert_class(datasets, "FilteredData")+ title = "SessionInfo" |
| 298 | -13x | +|||
| 146 | +
- checkmate::assert_class(trigger_data, "reactiveVal")+ ) |
|||
| 299 | +147 | |||
| 148 | ++ |
+ # `JavaScript` code+ |
+ ||
| 300 | -12x | +149 | +8x |
- datanames <- if (is.null(module$datanames)) datasets$datanames() else module$datanames+ run_js_files(files = "init.js") # `JavaScript` code to make the clipboard accessible |
| 301 | +150 |
-
+ # set timezone in shiny app |
||
| 302 | +151 |
- # list of reactive filtered data+ # timezone is set in the early beginning so it will be available also+ |
+ ||
| 152 | ++ |
+ # for `DDL` and all shiny modules |
||
| 303 | -12x | +153 | +8x |
- data <- sapply(+ get_client_timezone(session$ns) |
| 304 | -12x | +154 | +8x |
- datanames,+ observeEvent( |
| 305 | -12x | +155 | +8x |
- function(x) eventReactive(trigger_data(), datasets$get_data(x, filtered = TRUE)),+ eventExpr = input$timezone, |
| 306 | -12x | +156 | +8x |
- simplify = FALSE+ once = TRUE, |
| 307 | -+ | |||
| 157 | +8x |
- )+ handlerExpr = {
|
||
| 308 | -+ | |||
| 158 | +! |
-
+ session$userData$timezone <- input$timezone |
||
| 309 | -12x | +|||
| 159 | +! |
- hashes <- calculate_hashes(datanames, datasets)+ logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
|
||
| 310 | -12x | +|||
| 160 | +
- metadata <- lapply(datanames, datasets$get_metadata)+ } |
|||
| 311 | -12x | +|||
| 161 | +
- names(metadata) <- datanames+ ) |
|||
| 312 | +162 | |||
| 313 | -12x | -
- new_tdata(- |
- ||
| 314 | -12x | +|||
| 163 | +
- data,+ # loading the data ----- |
|||
| 315 | -12x | +164 | +8x |
- eventReactive(+ env <- environment() |
| 316 | -12x | +165 | +8x |
- trigger_data(),+ datasets_reactive <- reactive({
|
| 317 | -12x | +166 | +6x |
- c(+ if (is.null(raw_data())) {
|
| 318 | -12x | +167 | +1x |
- get_rcode_str_install(),+ return(NULL) |
| 319 | -12x | +|||
| 168 | +
- get_rcode_libraries(),+ } |
|||
| 320 | -12x | +169 | +5x |
- get_datasets_code(datanames, datasets, hashes),+ env$progress <- shiny::Progress$new(session) |
| 321 | -12x | +170 | +5x |
- teal.slice::get_filter_expr(datasets, datanames)+ env$progress$set(0.25, message = "Setting data") |
| 322 | +171 |
- )+ |
||
| 323 | +172 |
- ),+ # create a list of data following structure of the nested modules list structure. |
||
| 324 | -12x | +|||
| 173 | +
- datasets$get_join_keys(),+ # Because it's easier to unpack modules and datasets when they follow the same nested structure. |
|||
| 325 | -12x | +174 | +5x |
- metadata+ datasets_singleton <- teal.slice::init_filtered_data(raw_data()) |
| 326 | +175 |
- )+ # Singleton starts with only global filters active. |
||
| 327 | -+ | |||
| 176 | +5x |
- }+ filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter) |
||
| 328 | -+ | |||
| 177 | +5x |
-
+ datasets_singleton$set_filter_state(filter_global) |
||
| 329 | -+ | |||
| 178 | +5x |
- #' Get the hash of a dataset+ module_datasets <- function(modules) {
|
||
| 330 | -+ | |||
| 179 | +19x |
- #'+ if (inherits(modules, "teal_modules")) {
|
||
| 331 | -+ | |||
| 180 | +8x |
- #' @param datanames (`character`) names of datasets+ datasets <- lapply(modules$children, module_datasets) |
||
| 332 | -+ | |||
| 181 | +8x |
- #' @param datasets (`FilteredData`) object holding the data+ labels <- vapply(modules$children, `[[`, character(1), "label") |
||
| 333 | -+ | |||
| 182 | +8x |
- #'+ names(datasets) <- labels |
||
| 334 | -+ | |||
| 183 | +8x |
- #' @return A list of hashes per dataset+ datasets |
||
| 335 | -+ | |||
| 184 | +11x |
- #' @keywords internal+ } else if (isTRUE(attr(filter, "module_specific"))) {
|
||
| 336 | +185 |
- #'+ # we should create FilteredData even if modules$datanames is null |
||
| 337 | +186 |
- calculate_hashes <- function(datanames, datasets) {
+ # null controls a display of filter panel but data should be still passed |
||
| 338 | -16x | +187 | +3x |
- sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)+ datanames <- if (is.null(modules$datanames)) raw_data()$get_datanames() else modules$datanames |
| 339 | -+ | |||
| 188 | +3x |
- }+ data_objects <- sapply( |
| 1 | -+ | |||
| 189 | +3x |
- # This module is the main teal module that puts everything together.+ datanames, |
||
| 2 | -+ | |||
| 190 | +3x |
-
+ function(dataname) {
|
||
| 3 | -+ | |||
| 191 | +6x |
- #' teal main app module+ dataset <- raw_data()$get_dataset(dataname) |
||
| 4 | -+ | |||
| 192 | +6x |
- #'+ list( |
||
| 5 | -+ | |||
| 193 | +6x |
- #' This is the main teal app that puts everything together.+ dataset = dataset$get_raw_data(), |
||
| 6 | -+ | |||
| 194 | +6x |
- #'+ metadata = dataset$get_metadata(), |
||
| 7 | -+ | |||
| 195 | +6x |
- #' It displays the splash UI which is used to fetch the data, possibly+ label = dataset$get_dataset_label() |
||
| 8 | +196 |
- #' prompting for a password input to fetch the data. Once the data is ready,+ ) |
||
| 9 | +197 |
- #' the splash screen is replaced by the actual teal UI that is tabsetted and+ }, |
||
| 10 | -+ | |||
| 198 | +3x |
- #' has a filter panel with `datanames` that are relevant for the current tab.+ simplify = FALSE |
||
| 11 | +199 |
- #' Nested tabs are possible, but we limit it to two nesting levels for reasons+ ) |
||
| 12 | -+ | |||
| 200 | +3x |
- #' of clarity of the UI.+ datasets_module <- teal.slice::init_filtered_data( |
||
| 13 | -+ | |||
| 201 | +3x |
- #'+ data_objects, |
||
| 14 | -+ | |||
| 202 | +3x |
- #' The splash screen functionality can also be used+ join_keys = raw_data()$get_join_keys(), |
||
| 15 | -+ | |||
| 203 | +3x |
- #' for non-delayed data which takes time to load into memory, avoiding+ code = raw_data()$get_code_class(), |
||
| 16 | -+ | |||
| 204 | +3x |
- #' Shiny session timeouts.+ check = raw_data()$get_check() |
||
| 17 | +205 |
- #'+ ) |
||
| 18 | +206 |
- #' Server evaluates the `raw_data` (delayed data mechanism) and creates the+ |
||
| 19 | +207 |
- #' `datasets` object that is shared across modules.+ # set initial filters |
||
| 20 | -+ | |||
| 208 | +3x |
- #' Once it is ready and non-`NULL`, the splash screen is replaced by the+ slices <- Filter(x = filter, f = function(x) {
|
||
| 21 | -+ | |||
| 209 | +! |
- #' main teal UI that depends on the data.+ x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) && |
||
| 22 | -+ | |||
| 210 | +! |
- #' The currently active tab is tracked and the right filter panel+ x$dataname %in% datanames |
||
| 23 | +211 |
- #' updates the displayed datasets to filter for according to the active `datanames`+ }) |
||
| 24 | -+ | |||
| 212 | +3x |
- #' of the tab.+ include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames] |
||
| 25 | -+ | |||
| 213 | +3x |
- #'+ exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames] |
||
| 26 | -+ | |||
| 214 | +3x |
- #' It is written as a Shiny module so it can be added into other apps as well.+ slices$include_varnames <- include_varnames |
||
| 27 | -+ | |||
| 215 | +3x |
- #'+ slices$exclude_varnames <- exclude_varnames |
||
| 28 | -+ | |||
| 216 | +3x |
- #' @name module_teal+ datasets_module$set_filter_state(slices) |
||
| 29 | -+ | |||
| 217 | +3x |
- #'+ datasets_module |
||
| 30 | +218 |
- #' @inheritParams ui_teal_with_splash+ } else {
|
||
| 31 | -+ | |||
| 219 | +8x |
- #'+ datasets_singleton |
||
| 32 | +220 |
- #' @param splash_ui (`shiny.tag`)\cr UI to display initially,+ } |
||
| 33 | +221 |
- #' can be a splash screen or a Shiny module UI. For the latter, see+ } |
||
| 34 | -+ | |||
| 222 | +5x |
- #' [init()] about how to call the corresponding server function.+ datasets <- module_datasets(modules) |
||
| 35 | +223 |
- #'+ |
||
| 36 | -+ | |||
| 224 | +5x |
- #' @param raw_data (`reactive`)\cr+ logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
|
||
| 37 | -+ | |||
| 225 | +5x |
- #' returns the `TealData`, only evaluated once, `NULL` value is ignored+ datasets |
||
| 38 | +226 |
- #'+ }) |
||
| 39 | +227 |
- #' @return+ |
||
| 40 | -+ | |||
| 228 | +8x |
- #' `ui_teal` returns `HTML` for Shiny module UI.+ reporter <- teal.reporter::Reporter$new() |
||
| 41 | -+ | |||
| 229 | +8x |
- #' `srv_teal` returns `reactive` which returns the currently active module.+ is_any_previewer <- function(modules) {
|
||
| 42 | -+ | |||
| 230 | +! |
- #'+ if (inherits(modules, "teal_modules")) {
|
||
| 43 | -+ | |||
| 231 | +! |
- #' @keywords internal+ any(unlist(lapply(modules$children, is_any_previewer), use.names = FALSE)) |
||
| 44 | -+ | |||
| 232 | +! |
- #'+ } else if (inherits(modules, "teal_module_previewer")) {
|
||
| 45 | -+ | |||
| 233 | +! |
- #' @examples+ TRUE |
||
| 46 | +234 |
- #' mods <- teal:::example_modules()+ } else {
|
||
| 47 | -+ | |||
| 235 | +! |
- #' raw_data <- reactive(teal:::example_cdisc_data())+ FALSE |
||
| 48 | +236 |
- #' app <- shinyApp(+ } |
||
| 49 | +237 |
- #' ui = function() {
+ } |
||
| 50 | -+ | |||
| 238 | +8x |
- #' teal:::ui_teal("dummy")
+ if (is_arg_used(modules, "reporter") && !is_any_previewer(modules)) {
|
||
| 51 | -+ | |||
| 239 | +! |
- #' },+ modules <- append_module(modules, reporter_previewer_module()) |
||
| 52 | +240 |
- #' server = function(input, output, session) {
+ } |
||
| 53 | +241 |
- #' active_module <- teal:::srv_teal(id = "dummy", modules = mods, raw_data = raw_data)+ |
||
| 54 | +242 |
- #' }+ # Replace splash / welcome screen once data is loaded ---- |
||
| 55 | +243 |
- #' )+ # ignoreNULL to not trigger at the beginning when data is NULL |
||
| 56 | +244 |
- #' if (interactive()) {
+ # just handle it once because data obtained through delayed loading should |
||
| 57 | +245 |
- #' runApp(app)+ # usually not change afterwards |
||
| 58 | +246 |
- #' }+ # if restored from bookmarked state, `filter` is ignored |
||
| 59 | -+ | |||
| 247 | +8x |
- NULL+ observeEvent(datasets_reactive(), ignoreNULL = TRUE, once = TRUE, {
|
||
| 60 | -+ | |||
| 248 | +1x |
-
+ logger::log_trace("srv_teal@5 setting main ui after data was pulled")
|
||
| 61 | -+ | |||
| 249 | +1x |
- #' @rdname module_teal+ env$progress$set(0.5, message = "Setting up main UI") |
||
| 62 | -+ | |||
| 250 | +1x |
- ui_teal <- function(id,+ on.exit(env$progress$close()) |
||
| 63 | +251 |
- splash_ui = tags$h2("Starting the Teal App"),
+ # main_ui_container contains splash screen first and we remove it and replace it by the real UI |
||
| 64 | +252 |
- title = NULL,+ |
||
| 65 | -+ | |||
| 253 | +1x |
- header = tags$p(""),
+ removeUI(sprintf("#%s:first-child", session$ns("main_ui_container")))
|
||
| 66 | -+ | |||
| 254 | +1x |
- footer = tags$p("")) {
+ insertUI( |
||
| 67 | -32x | +255 | +1x |
- if (checkmate::test_string(header)) {
+ selector = paste0("#", session$ns("main_ui_container")),
|
| 68 | -! | +|||
| 256 | +1x |
- header <- tags$h1(header)+ where = "beforeEnd", |
||
| 69 | +257 |
- }+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not |
||
| 70 | -32x | +|||
| 258 | +
- if (checkmate::test_string(footer)) {
+ # just the first item of the tagList) |
|||
| 71 | -! | +|||
| 259 | +1x |
- footer <- tags$p(footer)+ ui = div(ui_tabs_with_filters( |
||
| 72 | -+ | |||
| 260 | +1x |
- }+ session$ns("main_ui"),
|
||
| 73 | -32x | +261 | +1x |
- checkmate::assert(+ modules = modules, |
| 74 | -32x | +262 | +1x |
- checkmate::check_class(splash_ui, "shiny.tag"),+ datasets = datasets_reactive(), |
| 75 | -32x | +263 | +1x |
- checkmate::check_class(splash_ui, "shiny.tag.list"),+ filter = filter |
| 76 | -32x | +|||
| 264 | +
- checkmate::check_class(splash_ui, "html")+ )), |
|||
| 77 | +265 |
- )+ # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not |
||
| 78 | -32x | +|||
| 266 | +
- checkmate::assert(+ # have any effect as they are ignored when not present |
|||
| 79 | -32x | +267 | +1x |
- checkmate::check_class(header, "shiny.tag"),+ immediate = TRUE |
| 80 | -32x | +|||
| 268 | +
- checkmate::check_class(header, "shiny.tag.list"),+ ) |
|||
| 81 | -32x | +|||
| 269 | +
- checkmate::check_class(header, "html")+ |
|||
| 82 | +270 |
- )+ # must make sure that this is only executed once as modules assume their observers are only |
||
| 83 | -32x | +|||
| 271 | +
- checkmate::assert(+ # registered once (calling server functions twice would trigger observers twice each time) |
|||
| 84 | -32x | +272 | +1x |
- checkmate::check_class(footer, "shiny.tag"),+ active_module <- srv_tabs_with_filters( |
| 85 | -32x | +273 | +1x |
- checkmate::check_class(footer, "shiny.tag.list"),+ id = "main_ui", |
| 86 | -32x | +274 | +1x |
- checkmate::check_class(footer, "html")+ datasets = datasets_reactive(), |
| 87 | -+ | |||
| 275 | +1x |
- )+ modules = modules, |
||
| 88 | -+ | |||
| 276 | +1x |
-
+ reporter = reporter, |
||
| 89 | -32x | +277 | +1x |
- ns <- NS(id)+ filter = filter |
| 90 | +278 |
- # Once the data is loaded, we will remove this element and add the real teal UI instead+ ) |
||
| 91 | -32x | +279 | +1x |
- splash_ui <- div(+ return(active_module) |
| 92 | +280 |
- # id so we can remove the splash screen once ready, which is the first child of this container+ }) |
||
| 93 | -32x | +|||
| 281 | +
- id = ns("main_ui_container"),
+ }) |
|||
| 94 | +282 |
- # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ } |
| 95 | +1 |
- # just the first item of the tagList)+ #' Send input validation messages to output. |
||
| 96 | -32x | +|||
| 2 | +
- div(splash_ui)+ #' |
|||
| 97 | +3 |
- )+ #' Captures messages from `InputValidator` objects and collates them |
||
| 98 | +4 |
-
+ #' into one message passed to `validate`. |
||
| 99 | +5 |
- # show busy icon when shiny session is busy computing stuff+ #' |
||
| 100 | +6 |
- # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 #nolint+ #' `shiny::validate` is used to withhold rendering of an output element until |
||
| 101 | -32x | +|||
| 7 | +
- shiny_busy_message_panel <- conditionalPanel(+ #' certain conditions are met and to print a validation message in place |
|||
| 102 | -32x | +|||
| 8 | +
- condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
+ #' of the output element. |
|||
| 103 | -32x | +|||
| 9 | +
- div(+ #' `shinyvalidate::InputValidator` allows to validate input elements |
|||
| 104 | -32x | +|||
| 10 | +
- icon("arrows-rotate", "spin fa-spin"),
+ #' and to display specific messages in their respective input widgets. |
|||
| 105 | -32x | +|||
| 11 | +
- "Computing ...",+ #' `validate_inputs` provides a hybrid solution. |
|||
| 106 | +12 |
- # CSS defined in `custom.css`+ #' Given an `InputValidator` object, messages corresponding to inputs that fail validation |
||
| 107 | -32x | +|||
| 13 | +
- class = "shinybusymessage"+ #' are extracted and placed in one validation message that is passed to a `validate`/`need` call. |
|||
| 108 | +14 |
- )+ #' This way the input `validator` messages are repeated in the output. |
||
| 109 | +15 |
- )+ #' |
||
| 110 | +16 |
-
+ #' The `...` argument accepts any number of `InputValidator` objects |
||
| 111 | -32x | +|||
| 17 | +
- res <- fluidPage(+ #' or a nested list of such objects. |
|||
| 112 | -32x | +|||
| 18 | +
- title = title,+ #' If `validators` are passed directly, all their messages are printed together |
|||
| 113 | -32x | +|||
| 19 | +
- theme = get_teal_bs_theme(),+ #' under one (optional) header message specified by `header`. If a list is passed, |
|||
| 114 | -32x | +|||
| 20 | +
- include_teal_css_js(),+ #' messages are grouped by `validator`. The list's names are used as headers |
|||
| 115 | -32x | +|||
| 21 | +
- tags$header(header),+ #' for their respective message groups. |
|||
| 116 | -32x | +|||
| 22 | +
- tags$hr(class = "my-2"),+ #' If neither of the nested list elements is named, a header message is taken from `header`. |
|||
| 117 | -32x | +|||
| 23 | +
- shiny_busy_message_panel,+ #' |
|||
| 118 | -32x | +|||
| 24 | +
- splash_ui,+ #' @param ... either any number of `InputValidator` objects |
|||
| 119 | -32x | +|||
| 25 | +
- tags$hr(),+ #' or an optionally named, possibly nested `list` of `InputValidator` |
|||
| 120 | -32x | +|||
| 26 | +
- tags$footer(+ #' objects, see `Details` |
|||
| 121 | -32x | +|||
| 27 | +
- div(+ #' @param header `character(1)` generic validation message; set to NULL to omit |
|||
| 122 | -32x | +|||
| 28 | +
- footer,+ #' |
|||
| 123 | -32x | +|||
| 29 | +
- teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
+ #' @return |
|||
| 124 | -32x | +|||
| 30 | +
- textOutput(ns("identifier"))
+ #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails. |
|||
| 125 | +31 |
- )+ #' |
||
| 126 | +32 |
- )+ #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`] |
||
| 127 | +33 |
- )+ #' |
||
| 128 | -32x | +|||
| 34 | +
- return(res)+ #' @examples |
|||
| 129 | +35 |
- }+ #' library(shiny) |
||
| 130 | +36 |
-
+ #' library(shinyvalidate) |
||
| 131 | +37 |
-
+ #' |
||
| 132 | +38 |
- #' @rdname module_teal+ #' ui <- fluidPage( |
||
| 133 | +39 |
- srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
+ #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
|
||
| 134 | -9x | +|||
| 40 | +
- stopifnot(is.reactive(raw_data))+ #' sidebarLayout( |
|||
| 135 | -8x | +|||
| 41 | +
- moduleServer(id, function(input, output, session) {
+ #' sidebarPanel( |
|||
| 136 | -8x | +|||
| 42 | +
- logger::log_trace("srv_teal initializing the module.")
+ #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
|
|||
| 137 | +43 |
-
+ #' selectInput("number", "select a number:", 1:6),
|
||
| 138 | -8x | +|||
| 44 | +
- output$identifier <- renderText(+ #' br(), |
|||
| 139 | -8x | +|||
| 45 | +
- paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
+ #' selectInput("color", "select a color:",
|
|||
| 140 | +46 |
- )+ #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
|
||
| 141 | +47 |
-
+ #' multiple = TRUE |
||
| 142 | -8x | +|||
| 48 | +
- teal.widgets::verbatim_popup_srv(+ #' ), |
|||
| 143 | -8x | +|||
| 49 | +
- "sessionInfo",+ #' sliderInput("size", "select point size:",
|
|||
| 144 | -8x | +|||
| 50 | +
- verbatim_content = utils::capture.output(utils::sessionInfo()),+ #' min = 0.1, max = 4, value = 0.25 |
|||
| 145 | -8x | +|||
| 51 | +
- title = "SessionInfo"+ #' ) |
|||
| 146 | +52 |
- )+ #' ), |
||
| 147 | +53 |
-
+ #' mainPanel(plotOutput("plot"))
|
||
| 148 | +54 |
- # `JavaScript` code+ #' ) |
||
| 149 | -8x | +|||
| 55 | +
- run_js_files(files = "init.js") # `JavaScript` code to make the clipboard accessible+ #' ) |
|||
| 150 | +56 |
- # set timezone in shiny app+ #' |
||
| 151 | +57 |
- # timezone is set in the early beginning so it will be available also+ #' server <- function(input, output) {
|
||
| 152 | +58 |
- # for `DDL` and all shiny modules+ #' # set up input validation |
||
| 153 | -8x | +|||
| 59 | +
- get_client_timezone(session$ns)+ #' iv <- InputValidator$new() |
|||
| 154 | -8x | +|||
| 60 | +
- observeEvent(+ #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
|
|||
| 155 | -8x | +|||
| 61 | +
- eventExpr = input$timezone,+ #' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
|
|||
| 156 | -8x | +|||
| 62 | +
- once = TRUE,+ #' iv$enable() |
|||
| 157 | -8x | +|||
| 63 | +
- handlerExpr = {
+ #' # more input validation |
|||
| 158 | -! | +|||
| 64 | +
- session$userData$timezone <- input$timezone+ #' iv_par <- InputValidator$new() |
|||
| 159 | -! | +|||
| 65 | +
- logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
+ #' iv_par$add_rule("color", sv_required(message = "choose a color"))
|
|||
| 160 | +66 |
- }+ #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color")
|
||
| 161 | +67 |
- )+ #' iv_par$add_rule( |
||
| 162 | +68 |
-
+ #' "size", |
||
| 163 | +69 |
- # loading the data -----+ #' sv_between( |
||
| 164 | -8x | +|||
| 70 | +
- env <- environment()+ #' left = 0.5, right = 3, |
|||
| 165 | -8x | +|||
| 71 | +
- datasets_reactive <- reactive({
+ #' message_fmt = "choose a value between {left} and {right}"
|
|||
| 166 | -6x | +|||
| 72 | +
- if (is.null(raw_data())) {
+ #' ) |
|||
| 167 | -1x | +|||
| 73 | +
- return(NULL)+ #' ) |
|||
| 168 | +74 |
- }+ #' iv_par$enable() |
||
| 169 | -5x | +|||
| 75 | +
- env$progress <- shiny::Progress$new(session)+ #' |
|||
| 170 | -5x | +|||
| 76 | +
- env$progress$set(0.25, message = "Setting data")+ #' output$plot <- renderPlot({
|
|||
| 171 | +77 |
-
+ #' # validate output |
||
| 172 | +78 |
- # create a list of data following structure of the nested modules list structure.+ #' switch(input[["method"]], |
||
| 173 | +79 |
- # Because it's easier to unpack modules and datasets when they follow the same nested structure.+ #' "sequential" = {
|
||
| 174 | -5x | +|||
| 80 | +
- datasets_singleton <- teal.slice::init_filtered_data(raw_data())+ #' validate_inputs(iv) |
|||
| 175 | +81 |
- # Singleton starts with only global filters active.+ #' validate_inputs(iv_par, header = "Set proper graphical parameters") |
||
| 176 | -5x | +|||
| 82 | +
- filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)+ #' }, |
|||
| 177 | -5x | +|||
| 83 | +
- datasets_singleton$set_filter_state(filter_global)+ #' "combined" = validate_inputs(iv, iv_par), |
|||
| 178 | -5x | +|||
| 84 | +
- module_datasets <- function(modules) {
+ #' "grouped" = validate_inputs(list( |
|||
| 179 | -19x | +|||
| 85 | +
- if (inherits(modules, "teal_modules")) {
+ #' "Some inputs require attention" = iv, |
|||
| 180 | -8x | +|||
| 86 | +
- datasets <- lapply(modules$children, module_datasets)+ #' "Set proper graphical parameters" = iv_par |
|||
| 181 | -8x | +|||
| 87 | +
- labels <- vapply(modules$children, `[[`, character(1), "label")+ #' )) |
|||
| 182 | -8x | +|||
| 88 | +
- names(datasets) <- labels+ #' ) |
|||
| 183 | -8x | +|||
| 89 | +
- datasets+ #' |
|||
| 184 | -11x | +|||
| 90 | +
- } else if (isTRUE(attr(filter, "module_specific"))) {
+ #' plot(eruptions ~ waiting, faithful, |
|||
| 185 | +91 |
- # we should create FilteredData even if modules$datanames is null+ #' las = 1, pch = 16, |
||
| 186 | +92 |
- # null controls a display of filter panel but data should be still passed+ #' col = input[["color"]], cex = input[["size"]] |
||
| 187 | -3x | +|||
| 93 | +
- datanames <- if (is.null(modules$datanames)) raw_data()$get_datanames() else modules$datanames+ #' ) |
|||
| 188 | -3x | +|||
| 94 | +
- data_objects <- sapply(+ #' }) |
|||
| 189 | -3x | +|||
| 95 | +
- datanames,+ #' } |
|||
| 190 | -3x | +|||
| 96 | +
- function(dataname) {
+ #' |
|||
| 191 | -6x | +|||
| 97 | +
- dataset <- raw_data()$get_dataset(dataname)+ #' if (interactive()) {
|
|||
| 192 | -6x | +|||
| 98 | +
- list(+ #' shinyApp(ui, server) |
|||
| 193 | -6x | +|||
| 99 | +
- dataset = dataset$get_raw_data(),+ #' } |
|||
| 194 | -6x | +|||
| 100 | +
- metadata = dataset$get_metadata(),+ #' |
|||
| 195 | -6x | +|||
| 101 | +
- label = dataset$get_dataset_label()+ #' @export |
|||
| 196 | +102 |
- )+ #' |
||
| 197 | +103 |
- },+ validate_inputs <- function(..., header = "Some inputs require attention") {
|
||
| 198 | -3x | +104 | +36x |
- simplify = FALSE+ dots <- list(...)+ |
+
| 105 | +2x | +
+ if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
|
||
| 199 | +106 |
- )+ |
||
| 200 | -3x | +107 | +34x |
- datasets_module <- teal.slice::init_filtered_data(+ messages <- extract_validator(dots, header) |
| 201 | -3x | +108 | +34x |
- data_objects,+ failings <- if (!any_names(dots)) {
|
| 202 | -3x | +109 | +29x |
- join_keys = raw_data()$get_join_keys(),+ add_header(messages, header) |
| 203 | -3x | +|||
| 110 | +
- code = raw_data()$get_code_class(),+ } else {
|
|||
| 204 | -3x | +111 | +5x |
- check = raw_data()$get_check()+ unlist(messages) |
| 205 | +112 |
- )+ } |
||
| 206 | +113 | |||
| 114 | +34x | +
+ shiny::validate(shiny::need(is.null(failings), failings))+ |
+ ||
| 207 | +115 |
- # set initial filters+ } |
||
| 208 | -3x | -
- slices <- Filter(x = filter, f = function(x) {
- |
- ||
| 209 | -! | -
- x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&- |
- ||
| 210 | -! | +|||
| 116 | +
- x$dataname %in% datanames+ |
|||
| 211 | +117 |
- })+ ### internal functions |
||
| 212 | -3x | +|||
| 118 | +
- include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]+ |
|||
| 213 | -3x | +|||
| 119 | +
- exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]+ #' @keywords internal |
|||
| 214 | -3x | +|||
| 120 | +
- slices$include_varnames <- include_varnames+ # recursive object type test |
|||
| 215 | -3x | +|||
| 121 | +
- slices$exclude_varnames <- exclude_varnames+ # returns logical of length 1 |
|||
| 216 | -3x | +|||
| 122 | +
- datasets_module$set_filter_state(slices)+ is_validators <- function(x) {
|
|||
| 217 | -3x | +123 | +118x |
- datasets_module+ all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator")) |
| 218 | +124 |
- } else {
+ } |
||
| 219 | -8x | +|||
| 125 | +
- datasets_singleton+ |
|||
| 220 | +126 |
- }+ #' @keywords internal |
||
| 221 | +127 |
- }+ # test if an InputValidator object is enabled |
||
| 222 | -5x | +|||
| 128 | +
- datasets <- module_datasets(modules)+ # returns logical of length 1 |
|||
| 223 | +129 |
-
+ # official method requested at https://github.com/rstudio/shinyvalidate/issues/64 |
||
| 224 | -5x | +|||
| 130 | +
- logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
+ validator_enabled <- function(x) {
|
|||
| 225 | -5x | +131 | +49x |
- datasets+ x$.__enclos_env__$private$enabled |
| 226 | +132 |
- })+ } |
||
| 227 | +133 | |||
| 228 | -8x | -
- reporter <- teal.reporter::Reporter$new()- |
- ||
| 229 | -8x | -
- is_any_previewer <- function(modules) {
- |
- ||
| 230 | -! | -
- if (inherits(modules, "teal_modules")) {
- |
- ||
| 231 | -! | +|||
| 134 | +
- any(unlist(lapply(modules$children, is_any_previewer), use.names = FALSE))+ #' @keywords internal |
|||
| 232 | -! | +|||
| 135 | +
- } else if (inherits(modules, "teal_module_previewer")) {
+ # recursively extract messages from validator list |
|||
| 233 | -! | +|||
| 136 | +
- TRUE+ # returns character vector or a list of character vectors, possibly nested and named |
|||
| 234 | +137 |
- } else {
+ extract_validator <- function(iv, header) {
|
||
| 235 | -! | +|||
| 138 | +113x |
- FALSE+ if (inherits(iv, "InputValidator")) {
|
||
| 236 | -+ | |||
| 139 | +49x |
- }+ add_header(gather_messages(iv), header) |
||
| 237 | +140 |
- }+ } else {
|
||
| 238 | -8x | +141 | +58x |
- if (is_arg_used(modules, "reporter") && !is_any_previewer(modules)) {
+ if (is.null(names(iv))) names(iv) <- rep("", length(iv))
|
| 239 | -! | +|||
| 142 | +64x |
- modules <- append_module(modules, reporter_previewer_module())+ mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE) |
||
| 240 | +143 |
- }+ } |
||
| 241 | +144 |
-
+ } |
||
| 242 | +145 |
- # Replace splash / welcome screen once data is loaded ----+ |
||
| 243 | +146 |
- # ignoreNULL to not trigger at the beginning when data is NULL+ #' @keywords internal |
||
| 244 | +147 |
- # just handle it once because data obtained through delayed loading should+ # collate failing messages from validator |
||
| 245 | +148 |
- # usually not change afterwards+ # returns list |
||
| 246 | +149 |
- # if restored from bookmarked state, `filter` is ignored+ gather_messages <- function(iv) {
|
||
| 247 | -8x | +150 | +49x |
- observeEvent(datasets_reactive(), ignoreNULL = TRUE, once = TRUE, {
+ if (validator_enabled(iv)) {
|
| 248 | -1x | +151 | +46x |
- logger::log_trace("srv_teal@5 setting main ui after data was pulled")
+ status <- iv$validate() |
| 249 | -1x | +152 | +46x |
- env$progress$set(0.5, message = "Setting up main UI")+ failing_inputs <- Filter(Negate(is.null), status) |
| 250 | -1x | +153 | +46x |
- on.exit(env$progress$close())+ unique(lapply(failing_inputs, function(x) x[["message"]])) |
| 251 | -- |
- # main_ui_container contains splash screen first and we remove it and replace it by the real UI- |
- ||
| 252 | +154 |
-
+ } else {
|
||
| 253 | -1x | +155 | +3x |
- removeUI(sprintf("#%s:first-child", session$ns("main_ui_container")))
+ logger::log_warn("Validator is disabled and will be omitted.")
|
| 254 | -1x | +156 | +3x |
- insertUI(+ list() |
| 255 | -1x | +|||
| 157 | +
- selector = paste0("#", session$ns("main_ui_container")),
+ } |
|||
| 256 | -1x | +|||
| 158 | +
- where = "beforeEnd",+ } |
|||
| 257 | +159 |
- # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ |
||
| 258 | +160 |
- # just the first item of the tagList)+ #' @keywords internal |
||
| 259 | -1x | +|||
| 161 | +
- ui = div(ui_tabs_with_filters(+ # add optional header to failing messages |
|||
| 260 | -1x | +|||
| 162 | +
- session$ns("main_ui"),
+ add_header <- function(messages, header = "") {
|
|||
| 261 | -1x | +163 | +78x |
- modules = modules,+ ans <- unlist(messages) |
| 262 | -1x | +164 | +78x |
- datasets = datasets_reactive(),+ if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
|
| 263 | -1x | -
- filter = filter- |
- ||
| 264 | -- |
- )),- |
- ||
| 265 | -+ | 165 | +31x |
- # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not+ ans <- c(paste0(header, "\n"), ans, "\n") |
| 266 | +166 |
- # have any effect as they are ignored when not present+ } |
||
| 267 | -1x | +167 | +78x |
- immediate = TRUE+ ans |
| 268 | +168 |
- )+ } |
||
| 269 | +169 | |||
| 270 | +170 |
- # must make sure that this is only executed once as modules assume their observers are only+ #' @keywords internal |
||
| 271 | +171 |
- # registered once (calling server functions twice would trigger observers twice each time)- |
- ||
| 272 | -1x | -
- active_module <- srv_tabs_with_filters(- |
- ||
| 273 | -1x | -
- id = "main_ui",+ # recursively check if the object contains a named list |
||
| 274 | -1x | +|||
| 172 | +
- datasets = datasets_reactive(),+ any_names <- function(x) {
|
|||
| 275 | -1x | +173 | +103x |
- modules = modules,+ any( |
| 276 | -1x | +174 | +103x |
- reporter = reporter,+ if (is.list(x)) {
|
| 277 | -1x | +175 | +58x |
- filter = filter+ if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names)) |
| 278 | +176 |
- )+ } else {
|
||
| 279 | -1x | +177 | +40x |
- return(active_module)+ FALSE |
| 280 | +178 |
- })+ } |
||
| 281 | +179 |
- })+ ) |
||
| 282 | +180 |
}@@ -5687,56 +5651,56 @@ teal coverage - 72.64% |
| 1 |
- #' @title `TealReportCard`+ #' Include `CSS` files from `/inst/css/` package directory to application header |
||
| 2 |
- #' @description `r lifecycle::badge("experimental")`
+ #' |
||
| 3 |
- #' A child of [`ReportCard`] that is used for teal specific applications.+ #' `system.file` should not be used to access files in other packages, it does |
||
| 4 |
- #' In addition to the parent methods, it supports rendering teal specific elements such as+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 5 |
- #' the source code, the encodings panel content and the filter panel content as part of the+ #' as needed. Thus, we do not export this method |
||
| 6 |
- #' meta data.+ #' |
||
| 7 |
- #' @export+ #' @param pattern (`character`) pattern of files to be included |
||
| 9 |
- TealReportCard <- R6::R6Class( # nolint: object_name_linter.+ #' @return HTML code that includes `CSS` files |
||
| 10 |
- classname = "TealReportCard",+ #' @keywords internal |
||
| 11 |
- inherit = teal.reporter::ReportCard,+ include_css_files <- function(pattern = "*") {
|
||
| 12 | -+ | 32x |
- public = list(+ css_files <- list.files( |
| 13 | -+ | 32x |
- #' @description Appends the source code to the `content` meta data of this `TealReportCard`.+ system.file("css", package = "teal", mustWork = TRUE),
|
| 14 | -+ | 32x |
- #'+ pattern = pattern, full.names = TRUE |
| 15 |
- #' @param src (`character(1)`) code as text.+ ) |
||
| 16 | -+ | 32x |
- #' @param ... any `rmarkdown` R chunk parameter and its value.+ return( |
| 17 | -+ | 32x |
- #' But `eval` parameter is always set to `FALSE`.+ shiny::singleton( |
| 18 | -+ | 32x |
- #' @return invisibly self+ shiny::tags$head(lapply(css_files, shiny::includeCSS)) |
| 19 |
- #' @examples+ ) |
||
| 20 |
- #' card <- TealReportCard$new()$append_src(+ ) |
||
| 21 |
- #' "plot(iris)"+ } |
||
| 22 |
- #' )+ |
||
| 23 |
- #' card$get_content()[[1]]$get_content()+ #' Include `JS` files from `/inst/js/` package directory to application header |
||
| 24 |
- append_src = function(src, ...) {
+ #' |
||
| 25 | -4x | +
- checkmate::assert_character(src, min.len = 0, max.len = 1)+ #' `system.file` should not be used to access files in other packages, it does |
|
| 26 | -4x | +
- params <- list(...)+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 27 | -4x | +
- params$eval <- FALSE+ #' as needed. Thus, we do not export this method |
|
| 28 | -4x | +
- rblock <- RcodeBlock$new(src)+ #' |
|
| 29 | -4x | +
- rblock$set_params(params)+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file` |
|
| 30 | -4x | +
- self$append_content(rblock)+ #' @param except (`character`) vector of basename filenames to be excluded |
|
| 31 | -4x | +
- self$append_metadata("SRC", src)
+ #' |
|
| 32 | -4x | +
- invisible(self)+ #' @return HTML code that includes `JS` files |
|
| 33 |
- },+ #' @keywords internal |
||
| 34 |
- #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.+ include_js_files <- function(pattern = NULL, except = NULL) {
|
||
| 35 | -+ | 32x |
- #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses+ checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE) |
| 36 | -+ | 32x |
- #' the default `yaml::as.yaml` to format the list.+ js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
|
| 37 | -+ | 32x |
- #' If the filter state list is empty, nothing is appended to the `content`.+ js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL |
| 38 |
- #'+ |
||
| 39 | -+ | 32x |
- #' @param fs (`teal_slices`) object returned from [teal_slices()] function.+ return(singleton(lapply(js_files, includeScript))) |
| 40 |
- #' @return invisibly self+ } |
||
| 41 |
- append_fs = function(fs) {
+
|
||
| 42 | -4x | +
- checkmate::assert_class(fs, "teal_slices")+ #' Run `JS` file from `/inst/js/` package directory |
|
| 43 | -3x | +
- self$append_text("Filter State", "header3")
+ #' |
|
| 44 | -3x | +
- self$append_content(TealSlicesBlock$new(fs))+ #' This is triggered from the server to execute on the client |
|
| 45 | -3x | +
- invisible(self)+ #' rather than triggered directly on the client. |
|
| 46 |
- },+ #' Unlike `include_js_files` which includes `JavaScript` functions, |
||
| 47 |
- #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.+ #' the `run_js` actually executes `JavaScript` functions. |
||
| 48 |
- #'+ #' |
||
| 49 |
- #' @param encodings (`list`) list of encodings selections of the teal app.+ #' `system.file` should not be used to access files in other packages, it does |
||
| 50 |
- #' @return invisibly self+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 51 |
- #' @examples+ #' as needed. Thus, we do not export this method |
||
| 52 |
- #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))+ #' |
||
| 53 |
- #' card$get_content()[[1]]$get_content()+ #' @param files (`character`) vector of filenames |
||
| 54 |
- #'+ #' @keywords internal |
||
| 55 |
- append_encodings = function(encodings) {
+ run_js_files <- function(files) {
|
||
| 56 | -4x | +8x |
- checkmate::assert_list(encodings)+ checkmate::assert_character(files, min.len = 1, any.missing = FALSE) |
| 57 | -4x | +8x |
- self$append_text("Selected Options", "header3")
+ lapply(files, function(file) {
|
| 58 | -4x | +8x |
- if (requireNamespace("yaml", quietly = TRUE)) {
+ shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
|
| 59 | -4x | +
- self$append_text(yaml::as.yaml(encodings, handlers = list(+ }) |
|
| 60 | -4x | +8x |
- POSIXct = function(x) format(x, "%Y-%m-%d"),+ return(invisible(NULL)) |
| 61 | -4x | +
- POSIXlt = function(x) format(x, "%Y-%m-%d"),+ } |
|
| 62 | -4x | +
- Date = function(x) format(x, "%Y-%m-%d")+ |
|
| 63 | -4x | +
- )), "verbatim")+ #' Code to include teal `CSS` and `JavaScript` files |
|
| 64 |
- } else {
+ #' |
||
| 65 | -! | +
- stop("yaml package is required to format the encodings list")
+ #' This is useful when you want to use the same `JavaScript` and `CSS` files that are |
|
| 66 |
- }+ #' used with the teal application. |
||
| 67 | -4x | +
- self$append_metadata("Encodings", encodings)
+ #' This is also useful for running standalone modules in teal with the correct |
|
| 68 | -4x | +
- invisible(self)+ #' styles. |
|
| 69 |
- }+ #' Also initializes `shinyjs` so you can use it. |
||
| 70 |
- ),+ #' |
||
| 71 |
- private = list()+ #' @return HTML code to include |
||
| 72 |
- )+ #' @examples |
||
| 73 |
-
+ #' shiny_ui <- tagList( |
||
| 74 |
- #' @title `RcodeBlock`+ #' teal:::include_teal_css_js(), |
||
| 75 |
- #' @keywords internal+ #' p("Hello")
|
||
| 76 |
- TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter.+ #' ) |
||
| 77 |
- classname = "TealSlicesBlock",+ #' @keywords internal |
||
| 78 |
- inherit = teal.reporter:::TextBlock,+ include_teal_css_js <- function() {
|
||
| 79 | -+ | 32x |
- public = list(+ tagList( |
| 80 | -+ | 32x |
- #' @description Returns a `TealSlicesBlock` object.+ shinyjs::useShinyjs(), |
| 81 | -+ | 32x |
- #'+ include_css_files(), |
| 82 |
- #' @details Returns a `TealSlicesBlock` object with no content and no parameters.+ # init.js is executed from the server |
||
| 83 | -+ | 32x |
- #'+ include_js_files(except = "init.js"), |
| 84 | -+ | 32x |
- #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
|
| 85 |
- #' @param style (`character(1)`) string specifying style to apply.+ ) |
||
| 86 |
- #'+ } |
| 87 | +1 |
- #' @return `TealSlicesBlock`+ # This file adds a splash screen for delayed data loading on top of teal |
||
| 88 | +2 |
- #' @examples+ |
||
| 89 | +3 |
- #' block <- teal:::TealSlicesBlock$new()+ #' UI to show a splash screen in the beginning, then delegate to [srv_teal()] |
||
| 90 | +4 |
- #'+ #' |
||
| 91 | +5 |
- initialize = function(content = teal_slices(), style = "verbatim") {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 92 | -9x | +|||
| 6 | +
- self$set_content(content)+ #' The splash screen could be used to query for a password to fetch the data. |
|||
| 93 | -8x | +|||
| 7 | +
- self$set_style(style)+ #' [init()] is a very thin wrapper around this module useful for end-users which |
|||
| 94 | -8x | +|||
| 8 | +
- invisible(self)+ #' assumes that it is a top-level module and cannot be embedded. |
|||
| 95 | +9 |
- },+ #' This function instead adheres to the Shiny module conventions. |
||
| 96 | +10 |
-
+ #' |
||
| 97 | +11 |
- #' @description Sets content of this `TealSlicesBlock`.+ #' If data is obtained through delayed loading, its splash screen is used. Otherwise, |
||
| 98 | +12 |
- #' Sets content as `YAML` text which represents a list generated from `teal_slices`.+ #' a default splash screen is shown. |
||
| 99 | +13 |
- #' The list displays limited number of fields from `teal_slice` objects, but this list is+ #' |
||
| 100 | +14 |
- #' sufficient to conclude which filters were applied.+ #' Please also refer to the doc of [init()]. |
||
| 101 | +15 |
- #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"+ #' |
||
| 102 | +16 |
- #'+ #' @param id (`character(1)`)\cr |
||
| 103 | +17 |
- #'+ #' module id |
||
| 104 | +18 |
- #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ #' @inheritParams init |
||
| 105 | +19 |
- #' @return invisibly self+ #' @export |
||
| 106 | +20 |
- set_content = function(content) {
+ ui_teal_with_splash <- function(id, |
||
| 107 | -10x | +|||
| 21 | +
- checkmate::assert_class(content, "teal_slices")+ data, |
|||
| 108 | -9x | +|||
| 22 | +
- if (length(content) != 0) {
+ title, |
|||
| 109 | -7x | +|||
| 23 | +
- states_list <- lapply(content, function(x) {
+ header = tags$p("Add Title Here"),
|
|||
| 110 | -7x | +|||
| 24 | +
- x_list <- shiny::isolate(as.list(x))+ footer = tags$p("Add Footer Here")) {
|
|||
| 111 | -7x | +25 | +32x |
- if (+ checkmate::assert_class(data, "TealDataAbstract") |
| 112 | -7x | +26 | +32x |
- inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
+ is_pulled_data <- teal.data::is_pulled(data) |
| 113 | -7x | +27 | +32x |
- length(x_list$choices) == 2 &&+ ns <- NS(id) |
| 114 | -7x | +|||
| 28 | +
- length(x_list$selected) == 2+ |
|||
| 115 | +29 |
- ) {
+ # Startup splash screen for delayed loading |
||
| 116 | -! | +|||
| 30 | +
- x_list$range <- paste(x_list$selected, collapse = " - ")+ # We use delayed loading in all cases, even when the data does not need to be fetched. |
|||
| 117 | -! | +|||
| 31 | +
- x_list["selected"] <- NULL+ # This has the benefit that when filtering the data takes a lot of time initially, the |
|||
| 118 | +32 |
- }+ # Shiny app does not time out. |
||
| 119 | -7x | +33 | +32x |
- if (!is.null(x_list$arg)) {
+ splash_ui <- if (is_pulled_data) {
|
| 120 | -! | +|||
| 34 | +
- x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"+ # blank ui if data is already pulled |
|||
| 121 | -+ | |||
| 35 | +28x |
- }+ div() |
||
| 122 | +36 |
-
+ } else {
|
||
| 123 | -7x | +37 | +4x |
- x_list <- x_list[+ message("App was initialized with delayed data loading.")
|
| 124 | -7x | +38 | +4x |
- c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
+ data$get_ui(ns("startapp_module"))
|
| 125 | +39 |
- ]- |
- ||
| 126 | -7x | -
- names(x_list) <- c(+ } |
||
| 127 | -7x | +|||
| 40 | +
- "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",+ |
|||
| 128 | -7x | +41 | +32x |
- "Selected Values", "Selected range", "Include NA values", "Include Inf values"+ ui_teal(id = ns("teal"), splash_ui = splash_ui, title = title, header = header, footer = footer)
|
| 129 | +42 |
- )+ } |
||
| 130 | +43 | |||
| 131 | -7x | +|||
| 44 | +
- Filter(Negate(is.null), x_list)+ #' Server function that loads the data through reactive loading and then delegates |
|||
| 132 | +45 |
- })+ #' to [srv_teal()]. |
||
| 133 | +46 |
-
+ #' |
||
| 134 | -7x | +|||
| 47 | +
- if (requireNamespace("yaml", quietly = TRUE)) {
- |
- |||
| 135 | -7x | -
- super$set_content(yaml::as.yaml(states_list))+ #' @description `r lifecycle::badge("stable")`
|
||
| 136 | +48 |
- } else {
- |
- ||
| 137 | -! | -
- stop("yaml package is required to format the filter state list")
+ #' Please also refer to the doc of [init()]. |
||
| 138 | +49 |
- }+ #' |
||
| 139 | +50 |
- }- |
- ||
| 140 | -9x | -
- private$teal_slices <- content+ #' @inheritParams init |
||
| 141 | -9x | +|||
| 51 | +
- invisible(self)+ #' @param modules `teal_modules` object containing the output modules which |
|||
| 142 | +52 |
- },+ #' will be displayed in the teal application. See [modules()] and [module()] for |
||
| 143 | +53 |
- #' @description Create the `RcodeBlock` from a list.+ #' more details. |
||
| 144 | +54 |
- #' @param x `named list` with two fields `c("text", "params")`.
+ #' @inheritParams shiny::moduleServer |
||
| 145 | +55 |
- #' Use the `get_available_params` method to get all possible parameters.+ #' @return `reactive`, return value of [srv_teal()] |
||
| 146 | +56 |
- #' @return invisibly self+ #' @export |
||
| 147 | +57 |
- from_list = function(x) {
+ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
|
||
| 148 | -1x | +58 | +4x |
- checkmate::assert_list(x)+ checkmate::assert_class(data, "TealDataAbstract") |
| 149 | -1x | +59 | +4x |
- checkmate::assert_names(names(x), must.include = c("teal_slices"))
+ moduleServer(id, function(input, output, session) {
|
| 150 | -1x | +60 | +4x |
- self$set_content(x$teal_slices)+ logger::log_trace( |
| 151 | -1x | +61 | +4x |
- invisible(self)+ "srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
|
| 152 | +62 |
- },+ ) |
||
| 153 | +63 |
- #' @description Convert the `RcodeBlock` to a list.+ + |
+ ||
| 64 | +4x | +
+ if (getOption("teal.show_js_log", default = FALSE)) {
+ |
+ ||
| 65 | +! | +
+ shinyjs::showLog() |
||
| 154 | +66 |
- #' @return `named list` with a text and `params`.+ } |
||
| 155 | +67 | |||
| 68 | +4x | +
+ is_pulled_data <- teal.data::is_pulled(data)+ |
+ ||
| 156 | +69 |
- to_list = function() {
+ # raw_data contains TealDataAbstract, i.e. R6 object and container for data+ |
+ ||
| 70 | ++ |
+ # reactive to get data through delayed loading+ |
+ ||
| 71 | ++ |
+ # we must leave it inside the server because of callModule which needs to pick up the right session |
||
| 157 | +72 | +4x | +
+ if (is_pulled_data) {
+ |
+ |
| 73 | 2x |
- list(teal_slices = private$teal_slices)+ raw_data <- reactiveVal(data) # will trigger by setting it |
||
| 158 | +74 |
- }+ } else {
+ |
+ ||
| 75 | +2x | +
+ raw_data <- data$get_server()(id = "startapp_module")+ |
+ ||
| 76 | +2x | +
+ if (!is.reactive(raw_data)) {
+ |
+ ||
| 77 | +! | +
+ stop("The delayed loading module has to return a reactive object.")
|
||
| 159 | +78 |
- ),+ } |
||
| 160 | +79 |
- private = list(+ } |
||
| 161 | +80 |
- style = "verbatim",+ + |
+ ||
| 81 | +4x | +
+ res <- srv_teal(id = "teal", modules = modules, raw_data = raw_data, filter = filter)+ |
+ ||
| 82 | +4x | +
+ logger::log_trace(+ |
+ ||
| 83 | +4x | +
+ "srv_teal_with_splash initialized the module with data { paste(data$get_datanames(), collapse = ' ') }."
|
||
| 162 | +84 |
- teal_slices = NULL # teal_slices+ )+ |
+ ||
| 85 | +4x | +
+ return(res) |
||
| 163 | +86 |
- )+ }) |
||
| 164 | +87 |
- )+ } |
| 1 |
- #' Filter state snapshot management.+ #' Validate that dataset has a minimum number of observations |
||
| 3 |
- #' Capture and restore snapshots of the global (app) filter state.+ #' @description `r lifecycle::badge("stable")`
|
||
| 4 |
- #'+ #' @param x a data.frame |
||
| 5 |
- #' This module introduces snapshots: stored descriptions of the filter state of the entire application.+ #' @param min_nrow minimum number of rows in \code{x}
|
||
| 6 |
- #' Snapshots allow the user to save the current filter state of the application for later use in the session,+ #' @param complete \code{logical} default \code{FALSE} when set to \code{TRUE} then complete cases are checked.
|
||
| 7 |
- #' as well as to save it to file in order to share it with an app developer or other users.+ #' @param allow_inf \code{logical} default \code{TRUE} when set to \code{FALSE} then error thrown if any values are
|
||
| 8 |
- #'+ #' infinite. |
||
| 9 |
- #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner.+ #' @param msg (`character(1)`) additional message to display alongside the default message. |
||
| 10 |
- #' At the beginning of a session it presents two icons: a camera and an circular arrow.+ #' |
||
| 11 |
- #' Clicking the camera captures a snapshot and clicking the arrow resets initial application state.+ #' @details This function is a wrapper for `shiny::validate`. |
||
| 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.+ #' |
||
| 13 |
- #'+ #' @export |
||
| 14 |
- #' @section Server logic:+ #' |
||
| 15 |
- #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance+ #' @examples |
||
| 16 |
- #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`+ #' library(teal) |
||
| 17 |
- #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation+ #' ui <- fluidPage( |
||
| 18 |
- #' (attributes are maintained).+ #' sliderInput("len", "Max Length of Sepal",
|
||
| 19 |
- #'+ #' min = 4.3, max = 7.9, value = 5 |
||
| 20 |
- #' Snapshots are stored in a `reactiveVal` as a named list.+ #' ), |
||
| 21 |
- #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.+ #' plotOutput("plot")
|
||
| 22 |
- #'+ #' ) |
||
| 23 |
- #' For every snapshot except the initial one, a piece of UI is generated that contains+ #' |
||
| 24 |
- #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.+ #' server <- function(input, output) {
|
||
| 25 |
- #' The initial snapshot is restored by a separate "reset" button.+ #' output$plot <- renderPlot({
|
||
| 26 |
- #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.+ #' df <- iris[iris$Sepal.Length <= input$len, ] |
||
| 27 |
- #'+ #' validate_has_data( |
||
| 28 |
- #' @section Snapshot mechanics:+ #' iris_f, |
||
| 29 |
- #' When a snapshot is captured, the user is prompted to name it.+ #' min_nrow = 10, |
||
| 30 |
- #' Names are displayed as is but since they are used to create button ids,+ #' complete = FALSE, |
||
| 31 |
- #' under the hood they are converted to syntactically valid strings.+ #' msg = "Please adjust Max Length of Sepal" |
||
| 32 |
- #' New snapshot names are validated so that their valid versions are unique.+ #' ) |
||
| 33 |
- #' Leading and trailing white space is trimmed.+ #' |
||
| 34 |
- #'+ #' hist(iris_f$Sepal.Length, breaks = 5) |
||
| 35 |
- #' The module can read the global state of the application from `slices_global` and `mapping_matrix`.+ #' }) |
||
| 36 |
- #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.+ #' } |
||
| 37 |
- #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.+ #' if (interactive()) {
|
||
| 38 |
- #' The snapshot contains the `mapping` attribute of the initial application state+ #' shinyApp(ui, server) |
||
| 39 |
- #' (or one that has been restored), which may not reflect the current one,+ #' } |
||
| 40 |
- #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,+ #' |
||
| 41 |
- #' when passed to the `mapping` argument of [`teal::teal_slices`], would result in the current mapping.+ validate_has_data <- function(x, |
||
| 42 |
- #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.+ min_nrow = NULL, |
||
| 43 |
- #'+ complete = FALSE, |
||
| 44 |
- #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.+ allow_inf = TRUE, |
||
| 45 |
- #' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared+ msg = NULL) {
|
||
| 46 | -+ | 17x |
- #' and set anew according to the `mapping` attribute of the snapshot.+ stopifnot( |
| 47 | -+ | 17x |
- #' The snapshot is then set as the current content of `slices_global`.+ "Please provide a character vector in msg argument of validate_has_data." = is.character(msg) || is.null(msg) |
| 48 |
- #'+ ) |
||
| 49 | -+ | 15x |
- #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,+ validate(need(!is.null(x) && is.data.frame(x), "No data left.")) |
| 50 | -+ | 15x |
- #' and then saved to file with [`teal.slice::slices_store`].+ if (!is.null(min_nrow)) {
|
| 51 | -+ | 15x |
- #'+ if (complete) {
|
| 52 | -+ | 5x |
- #' @param id (`character(1)`) `shiny` module id+ complete_index <- stats::complete.cases(x) |
| 53 | -+ | 5x |
- #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object+ validate(need( |
| 54 | -+ | 5x |
- #' containing all `teal_slice`s existing in the app, both active and inactive+ sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow, |
| 55 | -+ | 5x |
- #' @param mapping_matrix (`reactive`) that contains a `data.frame` representation+ paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
|
| 56 |
- #' of the mapping of filter state ids (rows) to modules labels (columns);+ )) |
||
| 57 |
- #' all columns are `logical` vectors+ } else {
|
||
| 58 | -+ | 10x |
- #' @param filtered_data_list non-nested (`named list`) that contains `FilteredData` objects+ validate(need( |
| 59 | -+ | 10x |
- #'+ nrow(x) >= min_nrow, |
| 60 | -+ | 10x |
- #' @return Nothing is returned.+ paste( |
| 61 | -+ | 10x |
- #'+ c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
|
| 62 | -+ | 10x |
- #' @name snapshot_manager_module+ collapse = "\n" |
| 63 |
- #' @aliases snapshot snapshot_manager+ ) |
||
| 64 |
- #'+ )) |
||
| 65 |
- #' @author Aleksander Chlebowski+ } |
||
| 66 |
- #'+ |
||
| 67 | -+ | 10x |
- #' @rdname snapshot_manager_module+ if (!allow_inf) {
|
| 68 | -+ | 6x |
- #' @keywords internal+ validate(need( |
| 69 | -+ | 6x |
- #'+ all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))), |
| 70 | -+ | 6x |
- snapshot_manager_ui <- function(id) {
+ "Dataframe contains Inf values which is not allowed." |
| 71 | -! | +
- ns <- NS(id)+ )) |
|
| 72 | -! | +
- div(+ } |
|
| 73 | -! | +
- class = "snapshot_manager_content",+ } |
|
| 74 | -! | +
- div(+ } |
|
| 75 | -! | +
- class = "snapshot_table_row",+ |
|
| 76 | -! | +
- span(tags$b("Snapshot manager")),
+ #' Validate that dataset has unique rows for key variables |
|
| 77 | -! | +
- actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
+ #' |
|
| 78 | -! | +
- actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
+ #' @description `r lifecycle::badge("stable")`
|
|
| 79 | -! | +
- NULL+ #' @param x a data.frame |
|
| 80 |
- ),+ #' @param key a vector of ID variables from \code{x} that identify unique records
|
||
| 81 | -! | +
- uiOutput(ns("snapshot_list"))
+ #' |
|
| 82 |
- )+ #' @details This function is a wrapper for `shiny::validate`. |
||
| 83 |
- }+ #' |
||
| 84 |
-
+ #' @export |
||
| 85 |
- #' @rdname snapshot_manager_module+ #' |
||
| 86 |
- #' @keywords internal+ #' @examples |
||
| 87 |
- #'+ #' iris$id <- rep(1:50, times = 3) |
||
| 88 |
- snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
+ #' ui <- fluidPage( |
||
| 89 | -7x | +
- checkmate::assert_character(id)+ #' selectInput( |
|
| 90 | -7x | +
- checkmate::assert_true(is.reactive(slices_global))+ #' inputId = "species", |
|
| 91 | -7x | +
- checkmate::assert_class(isolate(slices_global()), "teal_slices")+ #' label = "Select species", |
|
| 92 | -7x | +
- checkmate::assert_true(is.reactive(mapping_matrix))+ #' choices = c("setosa", "versicolor", "virginica"),
|
|
| 93 | -7x | +
- checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)+ #' selected = "setosa", |
|
| 94 | -7x | +
- checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named")+ #' multiple = TRUE |
|
| 95 |
-
+ #' ), |
||
| 96 | -7x | +
- moduleServer(id, function(input, output, session) {
+ #' plotOutput("plot")
|
|
| 97 | -7x | +
- ns <- session$ns+ #' ) |
|
| 98 |
-
+ #' server <- function(input, output) {
|
||
| 99 |
- # Store global filter states.+ #' output$plot <- renderPlot({
|
||
| 100 | -7x | +
- filter <- isolate(slices_global())+ #' iris_f <- iris[iris$Species %in% input$species, ] |
|
| 101 | -7x | +
- snapshot_history <- reactiveVal({
+ #' validate_one_row_per_id(iris_f, key = c("id"))
|
|
| 102 | -7x | +
- list(+ #' |
|
| 103 | -7x | +
- "Initial application state" = as.list(filter, recursive = TRUE)+ #' hist(iris_f$Sepal.Length, breaks = 5) |
|
| 104 |
- )+ #' }) |
||
| 105 |
- })+ #' } |
||
| 106 |
-
+ #' if (interactive()) {
|
||
| 107 |
- # Snapshot current application state - name snaphsot.+ #' shinyApp(ui, server) |
||
| 108 | -7x | +
- observeEvent(input$snapshot_add, {
+ #' } |
|
| 109 | -! | +
- showModal(+ #' |
|
| 110 | -! | +
- modalDialog(+ validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
|
|
| 111 | ! |
- textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
+ validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
|
|
| 112 | -! | +
- footer = tagList(+ } |
|
| 113 | -! | +
- actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
+
|
|
| 114 | -! | +
- modalButton(label = "Cancel", icon = icon("thumbs-down"))
+ #' Validates that vector includes all expected values |
|
| 115 |
- ),+ #' |
||
| 116 | -! | +
- size = "s"+ #' @description `r lifecycle::badge("stable")`
|
|
| 117 |
- )+ #' @param x values to test. All must be in \code{choices}
|
||
| 118 |
- )+ #' @param choices a vector to test for values of \code{x}
|
||
| 119 |
- })+ #' @param msg warning message to display |
||
| 120 |
- # Snapshot current application state - store snaphsot.+ #' |
||
| 121 | -7x | +
- observeEvent(input$snapshot_name_accept, {
+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 122 | -! | +
- snapshot_name <- trimws(input$snapshot_name)+ #' |
|
| 123 | -! | +
- if (identical(snapshot_name, "")) {
+ #' @export |
|
| 124 | -! | +
- showNotification(+ #' |
|
| 125 | -! | +
- "Please name the snapshot.",+ #' @examples |
|
| 126 | -! | +
- type = "message"+ #' ui <- fluidPage( |
|
| 127 |
- )+ #' selectInput( |
||
| 128 | -! | +
- updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ #' "species", |
|
| 129 | -! | +
- } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ #' "Select species", |
|
| 130 | -! | +
- showNotification(+ #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
|
|
| 131 | -! | +
- "This name is in conflict with other snapshot names. Please choose a different one.",+ #' selected = "setosa", |
|
| 132 | -! | +
- type = "message"+ #' multiple = FALSE |
|
| 133 |
- )+ #' ), |
||
| 134 | -! | +
- updateTextInput(inputId = "snapshot_name", value = , placeholder = "Meaningful, unique name")+ #' verbatimTextOutput("summary")
|
|
| 135 |
- } else {
+ #' ) |
||
| 136 | -! | +
- snapshot <- as.list(slices_global(), recursive = TRUE)+ #' |
|
| 137 | -! | +
- attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())+ #' server <- function(input, output) {
|
|
| 138 | -! | +
- snapshot_update <- c(snapshot_history(), list(snapshot))+ #' output$summary <- renderPrint({
|
|
| 139 | -! | +
- names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ #' validate_in(input$species, iris$Species, "Species does not exist.") |
|
| 140 | -! | +
- snapshot_history(snapshot_update)+ #' nrow(iris[iris$Species == input$species, ]) |
|
| 141 | -! | +
- removeModal()+ #' }) |
|
| 142 |
- # Reopen filter manager modal by clicking button in the main application.+ #' } |
||
| 143 | -! | +
- shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE)+ #' if (interactive()) {
|
|
| 144 |
- }+ #' shinyApp(ui, server) |
||
| 145 |
- })+ #' } |
||
| 146 |
-
+ #' |
||
| 147 |
- # Restore initial state.+ validate_in <- function(x, choices, msg) {
|
||
| 148 | -7x | +! |
- observeEvent(input$snapshot_reset, {
+ validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg)) |
| 149 | -! | +
- s <- "Initial application state"+ } |
|
| 150 |
- ### Begin restore procedure. ###+ |
||
| 151 | -! | +
- snapshot <- snapshot_history()[[s]]+ #' Validates that vector has length greater than 0 |
|
| 152 | -! | +
- snapshot_state <- as.teal_slices(snapshot)+ #' |
|
| 153 | -! | +
- mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ #' @description `r lifecycle::badge("stable")`
|
|
| 154 | -! | +
- mapply(+ #' @param x vector |
|
| 155 | -! | +
- function(filtered_data, filter_ids) {
+ #' @param msg message to display |
|
| 156 | -! | +
- filtered_data$clear_filter_states(force = TRUE)+ #' |
|
| 157 | -! | +
- slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 158 | -! | +
- filtered_data$set_filter_state(slices)+ #' |
|
| 159 |
- },+ #' @export |
||
| 160 | -! | +
- filtered_data = filtered_data_list,+ #' |
|
| 161 | -! | +
- filter_ids = mapping_unfolded+ #' @examples |
|
| 162 |
- )+ #' data <- data.frame( |
||
| 163 | -! | +
- slices_global(snapshot_state)+ #' id = c(1:10, 11:20, 1:10), |
|
| 164 | -! | +
- removeModal()+ #' strata = rep(c("A", "B"), each = 15)
|
|
| 165 |
- ### End restore procedure. ###+ #' ) |
||
| 166 |
- })+ #' ui <- fluidPage( |
||
| 167 |
-
+ #' selectInput("ref1", "Select strata1 to compare",
|
||
| 168 |
- # Create UI elements and server logic for the snapshot table.+ #' choices = c("A", "B", "C"), selected = "A"
|
||
| 169 |
- # Observers must be tracked to avoid duplication and excess reactivity.+ #' ), |
||
| 170 |
- # Remaining elements are tracked likewise for consistency and a slight speed margin.+ #' selectInput("ref2", "Select strata2 to compare",
|
||
| 171 | -7x | +
- observers <- reactiveValues()+ #' choices = c("A", "B", "C"), selected = "B"
|
|
| 172 | -7x | +
- handlers <- reactiveValues()+ #' ), |
|
| 173 | -7x | +
- divs <- reactiveValues()+ #' verbatimTextOutput("arm_summary")
|
|
| 174 |
-
+ #' ) |
||
| 175 | -7x | +
- observeEvent(snapshot_history(), {
+ #' |
|
| 176 | -3x | +
- lapply(names(snapshot_history())[-1L], function(s) {
+ #' server <- function(input, output) {
|
|
| 177 | -! | +
- id_pickme <- sprintf("pickme_%s", make.names(s))
+ #' output$arm_summary <- renderText({
|
|
| 178 | -! | +
- id_saveme <- sprintf("saveme_%s", make.names(s))
+ #' sample_1 <- data$id[data$strata == input$ref1] |
|
| 179 | -! | +
- id_rowme <- sprintf("rowme_%s", make.names(s))
+ #' sample_2 <- data$id[data$strata == input$ref2] |
|
| 180 |
-
+ #' |
||
| 181 |
- # Observer for restoring snapshot.+ #' validate_has_elements(sample_1, "No subjects in strata1.") |
||
| 182 | -! | +
- if (!is.element(id_pickme, names(observers))) {
+ #' validate_has_elements(sample_2, "No subjects in strata2.") |
|
| 183 | -! | +
- observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
+ #' |
|
| 184 |
- ### Begin restore procedure. ###+ #' paste0( |
||
| 185 | -! | +
- snapshot <- snapshot_history()[[s]]+ #' "Number of samples in: strata1=", length(sample_1), |
|
| 186 | -! | +
- snapshot_state <- as.teal_slices(snapshot)+ #' " comparions strata2=", length(sample_2) |
|
| 187 | -! | +
- mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ #' ) |
|
| 188 | -! | +
- mapply(+ #' }) |
|
| 189 | -! | +
- function(filtered_data, filter_ids) {
+ #' } |
|
| 190 | -! | +
- filtered_data$clear_filter_states(force = TRUE)+ #' if (interactive()) {
|
|
| 191 | -! | +
- slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ #' shinyApp(ui, server) |
|
| 192 | -! | +
- filtered_data$set_filter_state(slices)+ #' } |
|
| 193 |
- },+ validate_has_elements <- function(x, msg) {
|
||
| 194 | ! |
- filtered_data = filtered_data_list,+ validate(need(length(x) > 0, msg)) |
|
| 195 | -! | +
- filter_ids = mapping_unfolded+ } |
|
| 196 |
- )+ |
||
| 197 | -! | +
- slices_global(snapshot_state)+ #' Validates no intersection between two vectors |
|
| 198 | -! | +
- removeModal()+ #' |
|
| 199 |
- ### End restore procedure. ###+ #' @description `r lifecycle::badge("stable")`
|
||
| 200 |
- })+ #' @param x vector |
||
| 201 |
- }+ #' @param y vector |
||
| 202 |
- # Create handler for downloading snapshot.+ #' @param msg message to display if \code{x} and \code{y} intersect
|
||
| 203 | -! | +
- if (!is.element(id_saveme, names(handlers))) {
+ #' |
|
| 204 | -! | +
- output[[id_saveme]] <- downloadHandler(+ #' @details This function is a wrapper for `shiny::validate`. |
|
| 205 | -! | +
- filename = function() {
+ #' |
|
| 206 | -! | +
- sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
+ #' @export |
|
| 207 |
- },+ #' |
||
| 208 | -! | +
- content = function(file) {
+ #' @examples |
|
| 209 | -! | +
- snapshot <- snapshot_history()[[s]]+ #' data <- data.frame( |
|
| 210 | -! | +
- snapshot_state <- as.teal_slices(snapshot)+ #' id = c(1:10, 11:20, 1:10), |
|
| 211 | -! | +
- teal.slice::slices_store(tss = snapshot_state, file = file)+ #' strata = rep(c("A", "B", "C"), each = 10)
|
|
| 212 |
- }+ #' ) |
||
| 213 |
- )+ #' |
||
| 214 | -! | +
- handlers[[id_saveme]] <- id_saveme+ #' ui <- fluidPage( |
|
| 215 |
- }+ #' selectInput("ref1", "Select strata1 to compare",
|
||
| 216 |
- # Create a row for the snapshot table.+ #' choices = c("A", "B", "C"),
|
||
| 217 | -! | +
- if (!is.element(id_rowme, names(divs))) {
+ #' selected = "A" |
|
| 218 | -! | +
- divs[[id_rowme]] <- div(+ #' ), |
|
| 219 | -! | +
- class = "snapshot_table_row",+ #' selectInput("ref2", "Select strata2 to compare",
|
|
| 220 | -! | +
- span(h5(s)),+ #' choices = c("A", "B", "C"),
|
|
| 221 | -! | +
- actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
+ #' selected = "B" |
|
| 222 | -! | +
- downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
+ #' ), |
|
| 223 |
- )+ #' verbatimTextOutput("summary")
|
||
| 224 |
- }+ #' ) |
||
| 225 |
- })+ #' |
||
| 226 |
- })+ #' server <- function(input, output) {
|
||
| 227 |
-
+ #' output$summary <- renderText({
|
||
| 228 |
- # Create table to display list of snapshots and their actions.+ #' sample_1 <- data$id[data$strata == input$ref1] |
||
| 229 | -7x | +
- output$snapshot_list <- renderUI({
+ #' sample_2 <- data$id[data$strata == input$ref2] |
|
| 230 | -3x | +
- rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d)+ #' |
|
| 231 | -3x | +
- if (length(rows) == 0L) {
+ #' validate_no_intersection( |
|
| 232 | -3x | +
- div(+ #' sample_1, sample_2, |
|
| 233 | -3x | +
- class = "snapshot_manager_placeholder",+ #' "subjects within strata1 and strata2 cannot overlap" |
|
| 234 | -3x | +
- "Snapshots will appear here."+ #' ) |
|
| 235 |
- )+ #' paste0( |
||
| 236 |
- } else {
+ #' "Number of subject in: reference treatment=", length(sample_1), |
||
| 237 | -! | +
- rows+ #' " comparions treatment=", length(sample_2) |
|
| 238 |
- }+ #' ) |
||
| 239 |
- })+ #' }) |
||
| 240 |
- })+ #' } |
||
| 241 |
- }+ #' if (interactive()) {
|
||
| 242 |
-
+ #' shinyApp(ui, server) |
||
| 243 |
-
+ #' } |
||
| 244 |
-
+ #' |
||
| 245 |
-
+ validate_no_intersection <- function(x, y, msg) {
|
||
| 246 | -+ | ! |
- ### utility functions ----+ validate(need(length(intersect(x, y)) == 0, msg)) |
| 247 |
-
+ } |
||
| 248 |
- #' Explicitly enumerate global filters.+ |
||
| 249 |
- #'+ |
||
| 250 |
- #' Transform module mapping such that global filters are explicitly specified for every module.+ #' Validates that dataset contains specific variable |
||
| 252 |
- #' @param mapping (`named list`) as stored in mapping parameter of `teal_slices`+ #' @description `r lifecycle::badge("stable")`
|
||
| 253 |
- #' @param module_names (`character`) vector containing names of all modules in the app+ #' @param data a data.frame |
||
| 254 |
- #' @return A `named_list` with one element per module, each element containing all filters applied to that module.+ #' @param varname name of variable in \code{data}
|
||
| 255 |
- #' @keywords internal+ #' @param msg message to display if \code{data} does not include \code{varname}
|
||
| 257 |
- unfold_mapping <- function(mapping, module_names) {
+ #' @details This function is a wrapper for `shiny::validate`. |
||
| 258 | -! | +
- module_names <- structure(module_names, names = module_names)+ #' |
|
| 259 | -! | +
- lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))+ #' @export |
|
| 260 |
- }+ #' |
||
| 261 |
-
+ #' @examples |
||
| 262 |
- #' Convert mapping matrix to filter mapping specification.+ #' data <- data.frame( |
||
| 263 |
- #'+ #' one = rep("a", length.out = 20),
|
||
| 264 |
- #' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,+ #' two = rep(c("a", "b"), length.out = 20)
|
||
| 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.+ #' ui <- fluidPage( |
||
| 267 |
- #' If a module has no active filters but the global ones, it will not be mentioned in the output.+ #' selectInput( |
||
| 268 |
- #'+ #' "var", |
||
| 269 |
- #' @param mapping_matrix (`data.frame`) of logical vectors where+ #' "Select variable", |
||
| 270 |
- #' columns represent modules and row represent `teal_slice`s+ #' choices = c("one", "two", "three", "four"),
|
||
| 271 |
- #' @return `named list` like that in the `mapping` attribute of a `teal_slices` object.+ #' selected = "one" |
||
| 272 |
- #' @keywords internal+ #' ), |
||
| 273 |
- #'+ #' verbatimTextOutput("summary")
|
||
| 274 |
- matrix_to_mapping <- function(mapping_matrix) {
+ #' ) |
||
| 275 | -! | +
- mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x))+ #' |
|
| 276 | -! | +
- global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))+ #' server <- function(input, output) {
|
|
| 277 | -! | +
- global_filters <- names(global[global])+ #' output$summary <- renderText({
|
|
| 278 | -! | +
- local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]+ #' validate_has_variable(data, input$var) |
|
| 279 |
-
+ #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
|
||
| 280 | -! | +
- mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))+ #' }) |
|
| 281 | -! | +
- Filter(function(x) length(x) != 0L, mapping)+ #' } |
|
| 282 |
- }+ #' if (interactive()) {
|
| 1 | +283 |
- #' Creates a `teal_modules` object.+ #' shinyApp(ui, server) |
|
| 2 | +284 |
- #'+ #' } |
|
| 3 | +285 |
- #' @description `r lifecycle::badge("stable")`
+ validate_has_variable <- function(data, varname, msg) {
|
|
| 4 | -+ | ||
| 286 | +! |
- #' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object+ if (length(varname) != 0) {
|
|
| 5 | -+ | ||
| 287 | +! |
- #' containing the passed objects.+ has_vars <- varname %in% names(data) |
|
| 6 | +288 |
- #'+ |
|
| 7 | -+ | ||
| 289 | +! |
- #' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules`+ if (!all(has_vars)) {
|
|
| 8 | -+ | ||
| 290 | +! |
- #' shapes the navigation panel of a `teal` application.+ if (missing(msg)) {
|
|
| 9 | -+ | ||
| 291 | +! |
- #'+ msg <- sprintf( |
|
| 10 | -+ | ||
| 292 | +! |
- #' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details+ "%s does not have the required variables: %s.", |
|
| 11 | -+ | ||
| 293 | +! |
- #' @param label (`character(1)`) label of modules collection (default `"root"`).+ deparse(substitute(data)), |
|
| 12 | -+ | ||
| 294 | +! |
- #' If using the `label` argument then it must be explicitly named.+ toString(varname[!has_vars]) |
|
| 13 | +295 |
- #' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
+ ) |
|
| 14 | +296 |
- #'+ } |
|
| 15 | -+ | ||
| 297 | +! |
- #' @export+ validate(need(FALSE, msg)) |
|
| 16 | +298 |
- #'+ } |
|
| 17 | +299 |
- #' @return object of class \code{teal_modules}. Object contains following fields
+ } |
|
| 18 | +300 |
- #' - `label`: taken from the `label` argument+ } |
|
| 19 | +301 |
- #' - `children`: a list containing objects passed in `...`. List elements are named after+ |
|
| 20 | +302 |
- #' their `label` attribute converted to a valid `shiny` id.+ #' Validate that variables has expected number of levels |
|
| 21 | +303 |
- #' @examples+ #' |
|
| 22 | +304 |
- #' library(shiny)+ #' @description `r lifecycle::badge("stable")`
|
|
| 23 | +305 |
- #'+ #' @param x variable name. If \code{x} is not a factor, the unique values
|
|
| 24 | +306 |
- #' app <- init(+ #' are treated as levels. |
|
| 25 | +307 |
- #' data = teal_data(dataset("iris", iris)),
+ #' @param min_levels cutoff for minimum number of levels of \code{x}
|
|
| 26 | +308 |
- #' modules = modules(+ #' @param max_levels cutoff for maximum number of levels of \code{x}
|
|
| 27 | +309 |
- #' label = "Modules",+ #' @param var_name name of variable being validated for use in |
|
| 28 | +310 |
- #' modules(+ #' validation message |
|
| 29 | +311 |
- #' label = "Module",+ #' |
|
| 30 | +312 |
- #' module(+ #' @details If the number of levels of \code{x} is less than \code{min_levels}
|
|
| 31 | +313 |
- #' label = "Inner module",+ #' or greater than \code{max_levels} the validation will fail.
|
|
| 32 | +314 |
- #' server = function(id, data) {
+ #' This function is a wrapper for `shiny::validate`. |
|
| 33 | +315 |
- #' moduleServer(+ #' |
|
| 34 | +316 |
- #' id,+ #' @export |
|
| 35 | +317 |
- #' module = function(input, output, session) {
+ #' @examples |
|
| 36 | +318 |
- #' output$data <- renderDataTable(data[["iris"]]())+ #' data <- data.frame( |
|
| 37 | +319 |
- #' }+ #' one = rep("a", length.out = 20),
|
|
| 38 | +320 |
- #' )+ #' two = rep(c("a", "b"), length.out = 20),
|
|
| 39 | +321 |
- #' },+ #' three = rep(c("a", "b", "c"), length.out = 20),
|
|
| 40 | +322 |
- #' ui = function(id) {
+ #' four = rep(c("a", "b", "c", "d"), length.out = 20),
|
|
| 41 | +323 |
- #' ns <- NS(id)+ #' stringsAsFactors = TRUE |
|
| 42 | +324 |
- #' tagList(dataTableOutput(ns("data")))
+ #' ) |
|
| 43 | +325 |
- #' },+ #' ui <- fluidPage( |
|
| 44 | +326 |
- #' datanames = "all"+ #' selectInput( |
|
| 45 | -- |
- #' )- |
- |
| 46 | +327 |
- #' ),+ #' "var", |
|
| 47 | +328 |
- #' module(+ #' "Select variable", |
|
| 48 | +329 |
- #' label = "Another module",+ #' choices = c("one", "two", "three", "four"),
|
|
| 49 | +330 |
- #' server = function(id) {
+ #' selected = "one" |
|
| 50 | +331 |
- #' moduleServer(+ #' ), |
|
| 51 | +332 |
- #' id,+ #' verbatimTextOutput("summary")
|
|
| 52 | +333 |
- #' module = function(input, output, session) {
+ #' ) |
|
| 53 | +334 |
- #' output$text <- renderText("Another module")
+ #' |
|
| 54 | +335 |
- #' }+ #' server <- function(input, output) {
|
|
| 55 | +336 |
- #' )+ #' output$summary <- renderText({
|
|
| 56 | +337 |
- #' },+ #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var) |
|
| 57 | +338 |
- #' ui = function(id) {
+ #' paste0( |
|
| 58 | +339 |
- #' ns <- NS(id)+ #' "Levels of selected treatment variable: ", |
|
| 59 | +340 |
- #' tagList(textOutput(ns("text")))
+ #' paste(levels(data[[input$var]]), |
|
| 60 | +341 |
- #' },+ #' collapse = ", " |
|
| 61 | +342 |
- #' datanames = NULL+ #' ) |
|
| 62 | +343 |
#' ) |
|
| 63 | +344 |
- #' )+ #' }) |
|
| 64 | +345 |
- #' )+ #' } |
|
| 65 | +346 |
#' if (interactive()) {
|
|
| 66 | +347 |
- #' runApp(app)+ #' shinyApp(ui, server) |
|
| 67 | +348 |
#' } |
|
| 68 | +349 |
- modules <- function(..., label = "root") {
- |
- |
| 69 | -79x | -
- checkmate::assert_string(label)- |
- |
| 70 | -77x | -
- submodules <- list(...)- |
- |
| 71 | -77x | -
- if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
+ validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
|
|
| 72 | -2x | +||
| 350 | +! |
- stop(+ x_levels <- if (is.factor(x)) {
|
|
| 73 | -2x | +||
| 351 | +! |
- "The only character argument to modules() must be 'label' and it must be named, ",+ levels(x) |
|
| 74 | -2x | +||
| 352 | +
- "change modules('lab', ...) to modules(label = 'lab', ...)"
+ } else {
|
||
| 75 | -+ | ||
| 353 | +! |
- )+ unique(x) |
|
| 76 | +354 |
} |
|
| 77 | +355 | ||
| 78 | -75x | +||
| 356 | +! |
- checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+ if (!is.null(min_levels) && !(is.null(max_levels))) {
|
|
| 79 | -+ | ||
| 357 | +! |
- # name them so we can more easily access the children+ validate(need( |
|
| 80 | -+ | ||
| 358 | +! |
- # beware however that the label of the submodules should not be changed as it must be kept synced+ length(x_levels) >= min_levels && length(x_levels) <= max_levels, |
|
| 81 | -72x | +||
| 359 | +! |
- labels <- vapply(submodules, function(submodule) submodule$label, character(1))+ sprintf( |
|
| 82 | -72x | +||
| 360 | +! |
- names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
+ "%s variable needs minimum %s level(s) and maximum %s level(s).", |
|
| 83 | -72x | +||
| 361 | +! |
- structure(+ var_name, min_levels, max_levels |
|
| 84 | -72x | +||
| 362 | +
- list(+ ) |
||
| 85 | -72x | +||
| 363 | +
- label = label,+ )) |
||
| 86 | -72x | +||
| 364 | +! |
- children = submodules+ } else if (!is.null(min_levels)) {
|
|
| 87 | -+ | ||
| 365 | +! |
- ),+ validate(need( |
|
| 88 | -72x | +||
| 366 | +! |
- class = "teal_modules"+ length(x_levels) >= min_levels, |
|
| 89 | -+ | ||
| 367 | +! |
- )+ sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
|
|
| 90 | +368 |
- }+ )) |
|
| 91 | -+ | ||
| 369 | +! |
-
+ } else if (!is.null(max_levels)) {
|
|
| 92 | -+ | ||
| 370 | +! |
- #' Function which appends a teal_module onto the children of a teal_modules object+ validate(need( |
|
| 93 | -+ | ||
| 371 | +! |
- #' @keywords internal+ length(x_levels) <= max_levels, |
|
| 94 | -+ | ||
| 372 | +! |
- #' @param modules `teal_modules`+ sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
|
|
| 95 | +373 |
- #' @param module `teal_module` object to be appended onto the children of `modules`+ )) |
|
| 96 | +374 |
- #' @return `teal_modules` object with `module` appended+ } |
|
| 97 | +375 |
- append_module <- function(modules, module) {
+ } |
|
| 98 | -7x | +
| 1 | +
- checkmate::assert_class(modules, "teal_modules")+ #' Filter state snapshot management. |
|||
| 99 | -5x | +|||
| 2 | +
- checkmate::assert_class(module, "teal_module")+ #' |
|||
| 100 | -3x | +|||
| 3 | +
- modules$children <- c(modules$children, list(module))+ #' Capture and restore snapshots of the global (app) filter state. |
|||
| 101 | -3x | +|||
| 4 | +
- labels <- vapply(modules$children, function(submodule) submodule$label, character(1))+ #' |
|||
| 102 | -3x | +|||
| 5 | +
- names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
+ #' This module introduces snapshots: stored descriptions of the filter state of the entire application. |
|||
| 103 | -3x | +|||
| 6 | +
- modules+ #' Snapshots allow the user to save the current filter state of the application for later use in the session, |
|||
| 104 | +7 |
- }+ #' as well as to save it to file in order to share it with an app developer or other users. |
||
| 105 | +8 |
-
+ #' |
||
| 106 | +9 |
- #' Does the object make use of the `arg`+ #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner. |
||
| 107 | +10 |
- #'+ #' At the beginning of a session it presents two icons: a camera and an circular arrow. |
||
| 108 | +11 |
- #' @param modules (`teal_module` or `teal_modules`) object+ #' Clicking the camera captures a snapshot and clicking the arrow resets initial application state. |
||
| 109 | +12 |
- #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.+ #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button. |
||
| 110 | +13 |
- #' @return `logical` whether the object makes use of `arg`+ #' |
||
| 111 | +14 |
- #' @rdname is_arg_used+ #' @section Server logic: |
||
| 112 | +15 |
- #' @keywords internal+ #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance |
||
| 113 | +16 |
- is_arg_used <- function(modules, arg) {
+ #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices` |
||
| 114 | -285x | +|||
| 17 | +
- checkmate::assert_string(arg)+ #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation |
|||
| 115 | -282x | +|||
| 18 | +
- if (inherits(modules, "teal_modules")) {
+ #' (attributes are maintained). |
|||
| 116 | -19x | +|||
| 19 | +
- any(unlist(lapply(modules$children, is_arg_used, arg)))+ #' |
|||
| 117 | -263x | +|||
| 20 | +
- } else if (inherits(modules, "teal_module")) {
+ #' Snapshots are stored in a `reactiveVal` as a named list. |
|||
| 118 | -32x | +|||
| 21 | +
- is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg)+ #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit. |
|||
| 119 | -231x | +|||
| 22 | +
- } else if (is.function(modules)) {
+ #' |
|||
| 120 | -229x | +|||
| 23 | +
- isTRUE(arg %in% names(formals(modules)))+ #' For every snapshot except the initial one, a piece of UI is generated that contains |
|||
| 121 | +24 |
- } else {
+ #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file. |
||
| 122 | -2x | +|||
| 25 | +
- stop("is_arg_used function not implemented for this object")
+ #' The initial snapshot is restored by a separate "reset" button. |
|||
| 123 | +26 |
- }+ #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that. |
||
| 124 | +27 |
- }+ #' |
||
| 125 | +28 |
-
+ #' @section Snapshot mechanics: |
||
| 126 | +29 |
-
+ #' When a snapshot is captured, the user is prompted to name it. |
||
| 127 | +30 |
- #' Creates a `teal_module` object.+ #' Names are displayed as is but since they are used to create button ids, |
||
| 128 | +31 |
- #'+ #' under the hood they are converted to syntactically valid strings. |
||
| 129 | +32 |
- #' @description `r lifecycle::badge("stable")`
+ #' New snapshot names are validated so that their valid versions are unique. |
||
| 130 | +33 |
- #' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module.+ #' Leading and trailing white space is trimmed. |
||
| 131 | +34 |
#' |
||
| 132 | +35 |
- #' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except+ #' The module can read the global state of the application from `slices_global` and `mapping_matrix`. |
||
| 133 | +36 |
- #' `"global_filters"` - read more in `mapping` argument of [teal::teal_slices].+ #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module. |
||
| 134 | +37 |
- #' @param server (`function`) `shiny` module with following arguments:+ #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot. |
||
| 135 | +38 |
- #' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]).+ #' The snapshot contains the `mapping` attribute of the initial application state |
||
| 136 | +39 |
- #' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module.+ #' (or one that has been restored), which may not reflect the current one, |
||
| 137 | +40 |
- #' - `data` (optional) module will receive a `tdata` object, a list of reactive (filtered) data specified in+ #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that, |
||
| 138 | +41 |
- #' the `filters` argument.+ #' when passed to the `mapping` argument of [`teal::teal_slices`], would result in the current mapping. |
||
| 139 | +42 |
- #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list. |
||
| 140 | +43 |
- #' - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]).+ #' |
||
| 141 | +44 |
- # - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).+ #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object. |
||
| 142 | +45 |
- #' - `...` (optional) `server_args` elements will be passed to the module named argument or to the `...`.+ #' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared |
||
| 143 | +46 |
- #' @param ui (`function`) Shiny `ui` module function with following arguments:+ #' and set anew according to the `mapping` attribute of the snapshot. |
||
| 144 | +47 |
- #' - `id` - teal will set proper shiny namespace for this module.+ #' The snapshot is then set as the current content of `slices_global`. |
||
| 145 | +48 |
- #' - `data` (optional) module will receive list of reactive (filtered) data specified in the `filters` argument.+ #' |
||
| 146 | +49 |
- #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring, |
||
| 147 | +50 |
- #' - `...` (optional) `ui_args` elements will be passed to the module named argument or to the `...`.+ #' and then saved to file with [`teal.slice::slices_store`]. |
||
| 148 | +51 |
- #' @param filters (`character`) Deprecated. Use `datanames` instead.+ #' |
||
| 149 | +52 |
- #' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The+ #' @param id (`character(1)`) `shiny` module id |
||
| 150 | +53 |
- #' filter panel will automatically update the shown filters to include only+ #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object |
||
| 151 | +54 |
- #' filters in the listed datasets. `NULL` will hide the filter panel,+ #' containing all `teal_slice`s existing in the app, both active and inactive |
||
| 152 | +55 |
- #' and the keyword `'all'` will show filters of all datasets. `datanames` also determines+ #' @param mapping_matrix (`reactive`) that contains a `data.frame` representation |
||
| 153 | +56 |
- #' a subset of datasets which are appended to the `data` argument in `server` function.+ #' of the mapping of filter state ids (rows) to modules labels (columns); |
||
| 154 | +57 |
- #' @param server_args (named `list`) with additional arguments passed on to the+ #' all columns are `logical` vectors |
||
| 155 | +58 |
- #' `server` function.+ #' @param filtered_data_list non-nested (`named list`) that contains `FilteredData` objects |
||
| 156 | +59 |
- #' @param ui_args (named `list`) with additional arguments passed on to the+ #' |
||
| 157 | +60 |
- #' `ui` function.+ #' @return Nothing is returned. |
||
| 158 | +61 |
#' |
||
| 159 | +62 |
- #' @return object of class `teal_module`.+ #' @name snapshot_manager_module |
||
| 160 | +63 |
- #' @export+ #' @aliases snapshot snapshot_manager |
||
| 161 | +64 |
- #' @examples+ #' |
||
| 162 | +65 |
- #' library(shiny)+ #' @author Aleksander Chlebowski |
||
| 163 | +66 |
#' |
||
| 164 | +67 |
- #' app <- init(+ #' @rdname snapshot_manager_module |
||
| 165 | +68 |
- #' data = teal_data(dataset("iris", iris)),
+ #' @keywords internal |
||
| 166 | +69 |
- #' modules = list(+ #' |
||
| 167 | +70 |
- #' module(+ snapshot_manager_ui <- function(id) {
|
||
| 168 | -+ | |||
| 71 | +! |
- #' label = "Module",+ ns <- NS(id) |
||
| 169 | -+ | |||
| 72 | +! |
- #' server = function(id, data) {
+ div( |
||
| 170 | -+ | |||
| 73 | +! |
- #' moduleServer(+ class = "snapshot_manager_content", |
||
| 171 | -+ | |||
| 74 | +! |
- #' id,+ div( |
||
| 172 | -+ | |||
| 75 | +! |
- #' module = function(input, output, session) {
+ class = "snapshot_table_row", |
||
| 173 | -+ | |||
| 76 | +! |
- #' output$data <- renderDataTable(data[["iris"]]())+ span(tags$b("Snapshot manager")),
|
||
| 174 | -+ | |||
| 77 | +! |
- #' }+ actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
|
||
| 175 | -+ | |||
| 78 | +! |
- #' )+ actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
|
||
| 176 | -+ | |||
| 79 | +! |
- #' },+ NULL |
||
| 177 | +80 |
- #' ui = function(id) {
+ ), |
||
| 178 | -+ | |||
| 81 | +! |
- #' ns <- NS(id)+ uiOutput(ns("snapshot_list"))
|
||
| 179 | +82 |
- #' tagList(dataTableOutput(ns("data")))
+ ) |
||
| 180 | +83 |
- #' }+ } |
||
| 181 | +84 |
- #' )+ |
||
| 182 | +85 |
- #' )+ #' @rdname snapshot_manager_module |
||
| 183 | +86 |
- #' )+ #' @keywords internal |
||
| 184 | +87 |
- #' if (interactive()) {
+ #' |
||
| 185 | +88 |
- #' runApp(app)+ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
|
||
| 186 | -+ | |||
| 89 | +7x |
- #' }+ checkmate::assert_character(id) |
||
| 187 | -+ | |||
| 90 | +7x |
- module <- function(label = "module",+ checkmate::assert_true(is.reactive(slices_global)) |
||
| 188 | -+ | |||
| 91 | +7x |
- server = function(id, ...) {
+ checkmate::assert_class(isolate(slices_global()), "teal_slices") |
||
| 189 | -1x | -
- moduleServer(id, function(input, output, session) {}) # nolint
- |
- ||
| 190 | -+ | 92 | +7x |
- },+ checkmate::assert_true(is.reactive(mapping_matrix)) |
| 191 | -+ | |||
| 93 | +7x |
- ui = function(id, ...) {
+ checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE) |
||
| 192 | -1x | +94 | +7x |
- tags$p(paste0("This module has no UI (id: ", id, " )"))
+ checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named") |
| 193 | +95 |
- },+ |
||
| 194 | -+ | |||
| 96 | +7x |
- filters,+ moduleServer(id, function(input, output, session) {
|
||
| 195 | -+ | |||
| 97 | +7x |
- datanames = "all",+ ns <- session$ns |
||
| 196 | +98 |
- server_args = NULL,+ |
||
| 197 | +99 |
- ui_args = NULL) {
+ # Store global filter states. |
||
| 198 | -109x | +100 | +7x |
- checkmate::assert_string(label)+ filter <- isolate(slices_global()) |
| 199 | -106x | +101 | +7x |
- checkmate::assert_function(server)+ snapshot_history <- reactiveVal({
|
| 200 | -106x | +102 | +7x |
- checkmate::assert_function(ui)+ list( |
| 201 | -106x | +103 | +7x |
- checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ "Initial application state" = as.list(filter, recursive = TRUE) |
| 202 | -105x | +|||
| 104 | +
- checkmate::assert_list(server_args, null.ok = TRUE, names = "named")+ ) |
|||
| 203 | -103x | +|||
| 105 | +
- checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")+ }) |
|||
| 204 | +106 | |||
| 107 | ++ |
+ # Snapshot current application state - name snaphsot.+ |
+ ||
| 205 | -101x | +108 | +7x |
- if (!missing(filters)) {
+ observeEvent(input$snapshot_add, {
|
| 206 | +109 | ! |
- checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ showModal( |
|
| 207 | +110 | ! |
- datanames <- filters+ modalDialog( |
|
| 208 | +111 | ! |
- msg <-+ textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
|
|
| 209 | +112 | ! |
- "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."+ footer = tagList( |
|
| 210 | +113 | ! |
- logger::log_warn(msg)+ actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
|
|
| 211 | +114 | ! |
- warning(msg)+ modalButton(label = "Cancel", icon = icon("thumbs-down"))
|
|
| 212 | +115 |
- }+ ), |
||
| 213 | -+ | |||
| 116 | +! |
-
+ size = "s" |
||
| 214 | -101x | +|||
| 117 | +
- if (label == "global_filters") {
+ ) |
|||
| 215 | -1x | +|||
| 118 | +
- stop("Label 'global_filters' is reserved in teal. Please change to something else.")
+ ) |
|||
| 216 | +119 |
- }+ }) |
||
| 217 | -100x | +|||
| 120 | +
- server_formals <- names(formals(server))+ # Snapshot current application state - store snaphsot. |
|||
| 218 | -100x | +121 | +7x |
- if (!(+ observeEvent(input$snapshot_name_accept, {
|
| 219 | -100x | +|||
| 122 | +! |
- "id" %in% server_formals ||+ snapshot_name <- trimws(input$snapshot_name) |
||
| 220 | -100x | +|||
| 123 | +! |
- all(c("input", "output", "session") %in% server_formals)
+ if (identical(snapshot_name, "")) {
|
||
| 221 | -+ | |||
| 124 | +! |
- )) {
+ showNotification( |
||
| 222 | -2x | +|||
| 125 | +! |
- stop(+ "Please name the snapshot.", |
||
| 223 | -2x | +|||
| 126 | +! |
- "\nmodule() `server` argument requires a function with following arguments:",+ type = "message" |
||
| 224 | -2x | +|||
| 127 | +
- "\n - id - teal will set proper shiny namespace for this module.",+ ) |
|||
| 225 | -2x | +|||
| 128 | +! |
- "\n - input, output, session (not recommended) - then shiny::callModule will be used to call a module.",+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name") |
||
| 226 | -2x | +|||
| 129 | +! |
- "\n\nFollowing arguments can be used optionaly:",+ } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
|
||
| 227 | -2x | +|||
| 130 | +! |
- "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",+ showNotification( |
||
| 228 | -2x | +|||
| 131 | +! |
- "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ "This name is in conflict with other snapshot names. Please choose a different one.", |
||
| 229 | -2x | +|||
| 132 | +! |
- "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",+ type = "message" |
||
| 230 | -2x | +|||
| 133 | +
- "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",+ ) |
|||
| 231 | -2x | +|||
| 134 | +! |
- "\n - `...` server_args elements will be passed to the module named argument or to the `...`"+ updateTextInput(inputId = "snapshot_name", value = , placeholder = "Meaningful, unique name") |
||
| 232 | +135 |
- )+ } else {
|
||
| 233 | -+ | |||
| 136 | +! |
- }+ snapshot <- as.list(slices_global(), recursive = TRUE) |
||
| 234 | -+ | |||
| 137 | +! |
-
+ attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix()) |
||
| 235 | -98x | +|||
| 138 | +! |
- if (!is.element("data", server_formals) && !is.null(datanames)) {
+ snapshot_update <- c(snapshot_history(), list(snapshot)) |
||
| 236 | -64x | +|||
| 139 | +! |
- message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name |
||
| 237 | -64x | +|||
| 140 | +! |
- datanames <- NULL+ snapshot_history(snapshot_update) |
||
| 238 | -+ | |||
| 141 | +! |
- }+ removeModal() |
||
| 239 | +142 |
-
+ # Reopen filter manager modal by clicking button in the main application. |
||
| 240 | -98x | +|||
| 143 | +! |
- srv_extra_args <- setdiff(names(server_args), server_formals)+ shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE) |
||
| 241 | -98x | +|||
| 144 | +
- if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
+ } |
|||
| 242 | -1x | +|||
| 145 | +
- stop(+ }) |
|||
| 243 | -1x | +|||
| 146 | +
- "\nFollowing `server_args` elements have no equivalent in the formals of the `server`:\n",+ |
|||
| 244 | -1x | +|||
| 147 | +
- paste(paste(" -", srv_extra_args), collapse = "\n"),
+ # Restore initial state. |
|||
| 245 | -1x | +148 | +7x |
- "\n\nUpdate the `server` arguments by including above or add `...`"+ observeEvent(input$snapshot_reset, {
|
| 246 | -+ | |||
| 149 | +! |
- )+ s <- "Initial application state" |
||
| 247 | +150 |
- }+ ### Begin restore procedure. ### |
||
| 248 | -+ | |||
| 151 | +! |
-
+ snapshot <- snapshot_history()[[s]] |
||
| 249 | -97x | +|||
| 152 | +! |
- ui_formals <- names(formals(ui))+ snapshot_state <- as.teal_slices(snapshot) |
||
| 250 | -97x | +|||
| 153 | +! |
- if (!"id" %in% ui_formals) {
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list)) |
||
| 251 | -1x | +|||
| 154 | +! |
- stop(+ mapply( |
||
| 252 | -1x | +|||
| 155 | +! |
- "\nmodule() `ui` argument requires a function with following arguments:",+ function(filtered_data, filter_ids) {
|
||
| 253 | -1x | +|||
| 156 | +! |
- "\n - id - teal will set proper shiny namespace for this module.",+ filtered_data$clear_filter_states(force = TRUE) |
||
| 254 | -1x | +|||
| 157 | +! |
- "\n\nFollowing arguments can be used optionaly:",+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state) |
||
| 255 | -1x | +|||
| 158 | +! |
- "\n - `data` - module will receive list of reactive (filtered) data specied in the `filters` argument",+ filtered_data$set_filter_state(slices) |
||
| 256 | -1x | +|||
| 159 | +
- "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ }, |
|||
| 257 | -1x | +|||
| 160 | +! |
- "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"+ filtered_data = filtered_data_list, |
||
| 258 | -+ | |||
| 161 | +! |
- )+ filter_ids = mapping_unfolded |
||
| 259 | +162 |
- }+ ) |
||
| 260 | -+ | |||
| 163 | +! |
-
+ slices_global(snapshot_state) |
||
| 261 | -96x | +|||
| 164 | +! |
- ui_extra_args <- setdiff(names(ui_args), ui_formals)+ removeModal() |
||
| 262 | -96x | +|||
| 165 | +
- if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
+ ### End restore procedure. ### |
|||
| 263 | -1x | +|||
| 166 | +
- stop(+ })+ |
+ |||
| 167 | ++ | + + | +||
| 168 | ++ |
+ # Create UI elements and server logic for the snapshot table.+ |
+ ||
| 169 | ++ |
+ # Observers must be tracked to avoid duplication and excess reactivity.+ |
+ ||
| 170 | ++ |
+ # Remaining elements are tracked likewise for consistency and a slight speed margin. |
||
| 264 | -1x | +171 | +7x | +
+ observers <- reactiveValues()+ |
+
| 172 | +7x | +
+ handlers <- reactiveValues()+ |
+ ||
| 173 | +7x | +
+ divs <- reactiveValues()+ |
+ ||
| 174 | ++ | + + | +||
| 175 | +7x | +
+ observeEvent(snapshot_history(), {
+ |
+ ||
| 176 | +3x | +
+ 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))
+ |
+ ||
| 180 | ++ | + + | +||
| 181 | ++ |
+ # Observer for restoring snapshot.+ |
+ ||
| 182 | +! | +
+ if (!is.element(id_pickme, names(observers))) {
+ |
+ ||
| 183 | +! | +
+ observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
+ |
+ ||
| 184 | ++ |
+ ### Begin restore procedure. ###+ |
+ ||
| 185 | +! | +
+ snapshot <- snapshot_history()[[s]]+ |
+ ||
| 186 | +! | +
+ snapshot_state <- as.teal_slices(snapshot)+ |
+ ||
| 187 | +! | +
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ |
+ ||
| 188 | +! | +
+ mapply(+ |
+ ||
| 189 | +! | +
+ function(filtered_data, filter_ids) {
+ |
+ ||
| 190 | +! | +
+ filtered_data$clear_filter_states(force = TRUE)+ |
+ ||
| 191 | +! | +
+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ |
+ ||
| 192 | +! | +
+ filtered_data$set_filter_state(slices)+ |
+ ||
| 193 | ++ |
+ },+ |
+ ||
| 194 | +! | +
+ filtered_data = filtered_data_list,+ |
+ ||
| 195 | +! | +
+ filter_ids = mapping_unfolded+ |
+ ||
| 196 | ++ |
+ )+ |
+ ||
| 197 | +! | +
+ slices_global(snapshot_state)+ |
+ ||
| 198 | +! | +
+ removeModal()+ |
+ ||
| 199 | ++ |
+ ### End restore procedure. ###+ |
+ ||
| 200 | ++ |
+ })+ |
+ ||
| 201 | ++ |
+ }+ |
+ ||
| 202 | ++ |
+ # Create handler for downloading snapshot.+ |
+ ||
| 203 | +! | +
+ if (!is.element(id_saveme, names(handlers))) {
+ |
+ ||
| 204 | +! | +
+ output[[id_saveme]] <- downloadHandler(+ |
+ ||
| 205 | +! | +
+ filename = function() {
+ |
+ ||
| 206 | +! | +
+ sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
+ |
+ ||
| 207 | ++ |
+ },+ |
+ ||
| 208 | +! | +
+ content = function(file) {
+ |
+ ||
| 209 | +! | +
+ snapshot <- snapshot_history()[[s]]+ |
+ ||
| 210 | +! | +
+ snapshot_state <- as.teal_slices(snapshot)+ |
+ ||
| 211 | +! | +
+ teal.slice::slices_store(tss = snapshot_state, file = file)+ |
+ ||
| 212 | ++ |
+ }+ |
+ ||
| 213 | ++ |
+ )+ |
+ ||
| 214 | +! | +
+ handlers[[id_saveme]] <- id_saveme+ |
+ ||
| 215 | ++ |
+ }+ |
+ ||
| 216 | ++ |
+ # Create a row for the snapshot table.+ |
+ ||
| 217 | +! | +
+ if (!is.element(id_rowme, names(divs))) {
+ |
+ ||
| 218 | +! | +
+ divs[[id_rowme]] <- div(+ |
+ ||
| 219 | +! | +
+ class = "snapshot_table_row",+ |
+ ||
| 220 | +! | +
+ span(h5(s)),+ |
+ ||
| 221 | +! | +
+ actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
+ |
+ ||
| 222 | +! |
- "\nFollowing `ui_args` elements have no equivalent in the formals of `ui`:\n",+ downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
|
||
| 265 | -1x | +|||
| 223 | +
- paste(paste(" -", ui_extra_args), collapse = "\n"),
+ ) |
|||
| 266 | -1x | +|||
| 224 | +
- "\n\nUpdate the `ui` arguments by including above or add `...`"+ } |
|||
| 267 | +225 |
- )+ }) |
||
| 268 | +226 |
- }+ }) |
||
| 269 | +227 | |||
| 270 | -95x | +|||
| 228 | +
- structure(+ # Create table to display list of snapshots and their actions. |
|||
| 271 | -95x | +229 | +7x |
- list(+ output$snapshot_list <- renderUI({
|
| 272 | -95x | +230 | +3x |
- label = label,+ rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d) |
| 273 | -95x | +231 | +3x |
- server = server, ui = ui, datanames = datanames,+ if (length(rows) == 0L) {
|
| 274 | -95x | +232 | +3x |
- server_args = server_args, ui_args = ui_args+ div( |
| 275 | -+ | |||
| 233 | +3x |
- ),+ class = "snapshot_manager_placeholder", |
||
| 276 | -95x | +234 | +3x |
- class = "teal_module"+ "Snapshots will appear here." |
| 277 | +235 |
- )+ ) |
||
| 278 | +236 |
- }+ } else {
|
||
| 279 | -+ | |||
| 237 | +! |
-
+ rows |
||
| 280 | +238 |
-
+ } |
||
| 281 | +239 |
- #' Get module depth+ }) |
||
| 282 | +240 |
- #'+ }) |
||
| 283 | +241 |
- #' Depth starts at 0, so a single `teal.module` has depth 0.+ } |
||
| 284 | +242 |
- #' Nesting it increases overall depth by 1.+ |
||
| 285 | +243 |
- #'+ |
||
| 286 | +244 |
- #' @inheritParams init+ |
||
| 287 | +245 |
- #' @param depth optional, integer determining current depth level+ |
||
| 288 | +246 |
- #'+ ### utility functions ---- |
||
| 289 | +247 |
- #' @return depth level for given module+ |
||
| 290 | +248 |
- #' @keywords internal+ #' Explicitly enumerate global filters. |
||
| 291 | +249 |
#' |
||
| 292 | -- |
- #' @examples- |
- ||
| 293 | +250 |
- #' mods <- modules(+ #' Transform module mapping such that global filters are explicitly specified for every module. |
||
| 294 | +251 |
- #' label = "d1",+ #' |
||
| 295 | +252 |
- #' modules(+ #' @param mapping (`named list`) as stored in mapping parameter of `teal_slices` |
||
| 296 | +253 |
- #' label = "d2",+ #' @param module_names (`character`) vector containing names of all modules in the app |
||
| 297 | +254 |
- #' modules(+ #' @return A `named_list` with one element per module, each element containing all filters applied to that module. |
||
| 298 | +255 |
- #' label = "d3",+ #' @keywords internal |
||
| 299 | +256 |
- #' module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3")+ #' |
||
| 300 | +257 |
- #' ),+ unfold_mapping <- function(mapping, module_names) {
|
||
| 301 | -+ | |||
| 258 | +! |
- #' module(label = "bbb")+ module_names <- structure(module_names, names = module_names) |
||
| 302 | -+ | |||
| 259 | +! |
- #' ),+ lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]])) |
||
| 303 | +260 |
- #' module(label = "ccc")+ } |
||
| 304 | +261 |
- #' )+ |
||
| 305 | +262 |
- #' stopifnot(teal:::modules_depth(mods) == 3L)+ #' Convert mapping matrix to filter mapping specification. |
||
| 306 | +263 |
#' |
||
| 307 | +264 |
- #' mods <- modules(+ #' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module, |
||
| 308 | +265 |
- #' label = "a",+ #' to a list specification like the one used in the `mapping` attribute of `teal_slices`. |
||
| 309 | +266 |
- #' modules(+ #' Global filters are gathered in one list element. |
||
| 310 | +267 |
- #' label = "b1", module(label = "c")+ #' If a module has no active filters but the global ones, it will not be mentioned in the output. |
||
| 311 | +268 |
- #' ),+ #' |
||
| 312 | +269 |
- #' module(label = "b2")+ #' @param mapping_matrix (`data.frame`) of logical vectors where |
||
| 313 | +270 |
- #' )+ #' columns represent modules and row represent `teal_slice`s |
||
| 314 | +271 |
- #' stopifnot(teal:::modules_depth(mods) == 2L)+ #' @return `named list` like that in the `mapping` attribute of a `teal_slices` object. |
||
| 315 | -- |
- modules_depth <- function(modules, depth = 0L) {
- |
- ||
| 316 | -12x | -
- checkmate::assert(- |
- ||
| 317 | -12x | +272 | +
- checkmate::check_class(modules, "teal_module"),+ #' @keywords internal |
|
| 318 | -12x | +|||
| 273 | +
- checkmate::check_class(modules, "teal_modules")+ #' |
|||
| 319 | +274 |
- )+ matrix_to_mapping <- function(mapping_matrix) {
|
||
| 320 | -12x | +|||
| 275 | +! |
- checkmate::assert_int(depth, lower = 0)+ mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x)) |
||
| 321 | -11x | +|||
| 276 | +! |
- if (inherits(modules, "teal_modules")) {
+ global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L)) |
||
| 322 | -4x | +|||
| 277 | +! |
- max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))+ global_filters <- names(global[global])+ |
+ ||
| 278 | +! | +
+ local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ] |
||
| 323 | +279 |
- } else {
+
|
||
| 324 | -7x | +|||
| 280 | +! |
- depth+ mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters)) |
||
| 325 | -+ | |||
| 281 | +! |
- }+ Filter(function(x) length(x) != 0L, mapping) |
||
| 326 | +282 |
} |
| 327 | +1 |
-
+ #' Create a UI of nested tabs of `teal_modules` |
|
| 328 | +2 |
-
+ #' |
|
| 329 | +3 |
- module_labels <- function(modules) {
- |
- |
| 330 | -! | -
- if (inherits(modules, "teal_modules")) {
- |
- |
| 331 | -! | -
- lapply(modules$children, module_labels)+ #' @section `ui_nested_tabs`: |
|
| 332 | +4 |
- } else {
+ #' Each `teal_modules` is translated to a `tabsetPanel` and each |
|
| 333 | -! | +||
| 5 | +
- modules$label+ #' of its children is another tab-module called recursively. The UI of a |
||
| 334 | +6 |
- }+ #' `teal_module` is obtained by calling the `ui` function on it. |
|
| 335 | +7 |
- }+ #' |
|
| 336 | +8 |
-
+ #' The `datasets` argument is required to resolve the teal arguments in an |
|
| 337 | +9 |
- #' Converts `teal_modules` to a string+ #' isolated context (with respect to reactivity) |
|
| 338 | +10 |
#' |
|
| 339 | +11 |
- #' @param x (`teal_modules`) to print+ #' @section `srv_nested_tabs`: |
|
| 340 | +12 |
- #' @param indent (`integer`) indent level;+ #' This module calls recursively all elements of the `modules` returns one which |
|
| 341 | +13 |
- #' each `submodule` is indented one level more+ #' is currently active. |
|
| 342 | +14 |
- #' @param ... (optional) additional parameters to pass to recursive calls of `toString`+ #' - `teal_module` returns self as a active module. |
|
| 343 | +15 |
- #' @return (`character`)+ #' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`. |
|
| 344 | +16 |
- #' @export+ #' |
|
| 345 | +17 |
- #' @rdname modules+ #' @name module_nested_tabs |
|
| 346 | +18 |
- toString.teal_modules <- function(x, indent = 0, ...) { # nolint
+ #' |
|
| 347 | +19 |
- # argument must be `x` to be consistent with base method- |
- |
| 348 | -! | -
- paste(c(+ #' @inheritParams module_tabs_with_filters |
|
| 349 | -! | +||
| 20 | +
- paste0(rep(" ", indent), "+ ", x$label),
+ #' |
||
| 350 | -! | +||
| 21 | +
- unlist(lapply(x$children, toString, indent = indent + 1, ...))+ #' @param depth (`integer(1)`)\cr |
||
| 351 | -! | +||
| 22 | +
- ), collapse = "\n")+ #' number which helps to determine depth of the modules nesting. |
||
| 352 | +23 |
- }+ #' @param is_module_specific (`logical(1)`)\cr |
|
| 353 | +24 |
-
+ #' flag determining if the filter panel is global or module-specific. |
|
| 354 | +25 |
- #' Converts `teal_module` to a string+ #' When set to `TRUE`, a filter panel is called inside of each module tab. |
|
| 355 | +26 |
- #'+ #' @return depending on class of `modules`, `ui_nested_tabs` returns: |
|
| 356 | +27 |
- #' @inheritParams toString.teal_modules+ #' - `teal_module`: instantiated UI of the module |
|
| 357 | +28 |
- #' @param x `teal_module`+ #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively |
|
| 358 | +29 |
- #' @param ... ignored+ #' calling this function on it.\cr |
|
| 359 | +30 |
- #' @export+ #' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab. |
|
| 360 | +31 |
- #' @rdname module+ #' |
|
| 361 | +32 |
- toString.teal_module <- function(x, indent = 0, ...) { # nolint
+ #' @examples |
|
| 362 | -! | +||
| 33 | +
- paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
+ #' mods <- teal:::example_modules() |
||
| 363 | +34 |
- }+ #' datasets <- teal:::example_datasets() |
|
| 364 | +35 |
-
+ #' app <- shinyApp( |
|
| 365 | +36 |
- #' Prints `teal_modules`+ #' ui = function() {
|
|
| 366 | +37 |
- #' @param x `teal_modules`+ #' tagList( |
|
| 367 | +38 |
- #' @param ... parameters passed to `toString`+ #' teal:::include_teal_css_js(), |
|
| 368 | +39 |
- #' @export+ #' textOutput("info"),
|
|
| 369 | +40 |
- #' @rdname modules+ #' fluidPage( # needed for nice tabs |
|
| 370 | +41 |
- print.teal_modules <- function(x, ...) {
+ #' teal:::ui_nested_tabs("dummy", modules = mods, datasets = datasets)
|
|
| 371 | -! | +||
| 42 | +
- s <- toString(x, ...)+ #' ) |
||
| 372 | -! | +||
| 43 | +
- cat(s)+ #' ) |
||
| 373 | -! | +||
| 44 | +
- return(invisible(s))+ #' }, |
||
| 374 | +45 |
- }+ #' server = function(input, output, session) {
|
|
| 375 | +46 |
-
+ #' active_module <- teal:::srv_nested_tabs( |
|
| 376 | +47 |
- #' Prints `teal_module`+ #' "dummy", |
|
| 377 | +48 |
- #' @param x `teal_module`+ #' datasets = datasets, |
|
| 378 | +49 |
- #' @param ... parameters passed to `toString`+ #' modules = mods |
|
| 379 | +50 |
- #' @export+ #' ) |
|
| 380 | +51 |
- #' @rdname module+ #' output$info <- renderText({
|
|
| 381 | +52 |
- print.teal_module <- print.teal_modules+ #' paste0("The currently active tab name is ", active_module()$label)
|
| 1 | +53 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ #' }) |
||
| 2 | +54 |
- #'+ #' } |
||
| 3 | +55 |
- #' `system.file` should not be used to access files in other packages, it does+ #' ) |
||
| 4 | +56 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' if (interactive()) {
|
||
| 5 | +57 |
- #' as needed. Thus, we do not export this method+ #' runApp(app) |
||
| 6 | +58 |
- #'+ #' } |
||
| 7 | +59 |
- #' @param pattern (`character`) pattern of files to be included+ #' @keywords internal |
||
| 8 | +60 |
- #'+ NULL |
||
| 9 | +61 |
- #' @return HTML code that includes `CSS` files+ |
||
| 10 | +62 |
- #' @keywords internal+ #' @rdname module_nested_tabs |
||
| 11 | +63 |
- include_css_files <- function(pattern = "*") {
+ ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 12 | -32x | +64 | +2x |
- css_files <- list.files(+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
| 13 | -32x | +65 | +2x |
- system.file("css", package = "teal", mustWork = TRUE),
+ checkmate::assert_count(depth) |
| 14 | -32x | +66 | +2x |
- pattern = pattern, full.names = TRUE+ UseMethod("ui_nested_tabs", modules)
|
| 15 | +67 |
- )+ } |
||
| 16 | -32x | +|||
| 68 | +
- return(+ |
|||
| 17 | -32x | +|||
| 69 | +
- shiny::singleton(+ #' @rdname module_nested_tabs |
|||
| 18 | -32x | +|||
| 70 | +
- shiny::tags$head(lapply(css_files, shiny::includeCSS))+ #' @export |
|||
| 19 | +71 |
- )+ ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 20 | -+ | |||
| 72 | +! |
- )+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
|
||
| 21 | +73 |
} |
||
| 22 | +74 | |||
| 23 | +75 |
- #' Include `JS` files from `/inst/js/` package directory to application header+ #' @rdname module_nested_tabs |
||
| 24 | +76 |
- #'+ #' @export |
||
| 25 | +77 |
- #' `system.file` should not be used to access files in other packages, it does+ ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 26 | -+ | |||
| 78 | +1x |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
||
| 27 | -+ | |||
| 79 | +1x |
- #' as needed. Thus, we do not export this method+ ns <- NS(id) |
||
| 28 | -+ | |||
| 80 | +1x |
- #'+ do.call( |
||
| 29 | -+ | |||
| 81 | +1x |
- #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ tabsetPanel, |
||
| 30 | -+ | |||
| 82 | +1x |
- #' @param except (`character`) vector of basename filenames to be excluded+ c( |
||
| 31 | +83 |
- #'+ # by giving an id, we can reactively respond to tab changes |
||
| 32 | -+ | |||
| 84 | +1x | +
+ list(+ |
+ ||
| 85 | +1x |
- #' @return HTML code that includes `JS` files+ id = ns("active_tab"),
|
||
| 33 | -+ | |||
| 86 | +1x |
- #' @keywords internal+ type = if (modules$label == "root") "pills" else "tabs" |
||
| 34 | +87 |
- include_js_files <- function(pattern = NULL, except = NULL) {
+ ), |
||
| 35 | -32x | +88 | +1x |
- checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)+ lapply( |
| 36 | -32x | +89 | +1x |
- js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
+ names(modules$children), |
| 37 | -32x | +90 | +1x |
- js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL+ function(module_id) {
|
| 38 | -+ | |||
| 91 | +1x |
-
+ module_label <- modules$children[[module_id]]$label |
||
| 39 | -32x | +92 | +1x |
- return(singleton(lapply(js_files, includeScript)))+ tabPanel( |
| 40 | -+ | |||
| 93 | +1x |
- }+ title = module_label, |
||
| 41 | -+ | |||
| 94 | +1x |
-
+ value = module_id, # when clicked this tab value changes input$<tabset panel id> |
||
| 42 | -+ | |||
| 95 | +1x |
- #' Run `JS` file from `/inst/js/` package directory+ ui_nested_tabs( |
||
| 43 | -+ | |||
| 96 | +1x |
- #'+ id = ns(module_id), |
||
| 44 | -+ | |||
| 97 | +1x |
- #' This is triggered from the server to execute on the client+ modules = modules$children[[module_id]], |
||
| 45 | -+ | |||
| 98 | +1x |
- #' rather than triggered directly on the client.+ datasets = datasets[[module_label]], |
||
| 46 | -+ | |||
| 99 | +1x |
- #' Unlike `include_js_files` which includes `JavaScript` functions,+ depth = depth + 1L, |
||
| 47 | -+ | |||
| 100 | +1x |
- #' the `run_js` actually executes `JavaScript` functions.+ is_module_specific = is_module_specific |
||
| 48 | +101 |
- #'+ ) |
||
| 49 | +102 |
- #' `system.file` should not be used to access files in other packages, it does+ ) |
||
| 50 | +103 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ } |
||
| 51 | +104 |
- #' as needed. Thus, we do not export this method+ ) |
||
| 52 | +105 |
- #'+ ) |
||
| 53 | +106 |
- #' @param files (`character`) vector of filenames+ ) |
||
| 54 | +107 |
- #' @keywords internal+ } |
||
| 55 | +108 |
- run_js_files <- function(files) {
- |
- ||
| 56 | -8x | -
- checkmate::assert_character(files, min.len = 1, any.missing = FALSE)- |
- ||
| 57 | -8x | -
- lapply(files, function(file) {
- |
- ||
| 58 | -8x | -
- shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
+
|
||
| 59 | +109 |
- })- |
- ||
| 60 | -8x | -
- return(invisible(NULL))+ #' @rdname module_nested_tabs |
||
| 61 | +110 |
- }+ #' @export |
||
| 62 | +111 |
-
+ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
|
||
| 63 | -+ | |||
| 112 | +1x |
- #' Code to include teal `CSS` and `JavaScript` files+ checkmate::assert_class(datasets, class = "FilteredData") |
||
| 64 | -+ | |||
| 113 | +1x |
- #'+ ns <- NS(id) |
||
| 65 | +114 |
- #' This is useful when you want to use the same `JavaScript` and `CSS` files that are+ |
||
| 66 | -+ | |||
| 115 | +1x |
- #' used with the teal application.+ args <- isolate(teal.transform::resolve_delayed(modules$ui_args, datasets)) |
||
| 67 | -+ | |||
| 116 | +1x |
- #' This is also useful for running standalone modules in teal with the correct+ args <- c(list(id = ns("module")), args)
|
||
| 68 | +117 |
- #' styles.+ |
||
| 69 | -+ | |||
| 118 | +1x |
- #' Also initializes `shinyjs` so you can use it.+ if (is_arg_used(modules$ui, "datasets")) {
|
||
| 70 | -+ | |||
| 119 | +! |
- #'+ args <- c(args, datasets = datasets) |
||
| 71 | +120 |
- #' @return HTML code to include+ } |
||
| 72 | +121 |
- #' @examples+ |
||
| 73 | -+ | |||
| 122 | +1x |
- #' shiny_ui <- tagList(+ if (is_arg_used(modules$ui, "data")) {
|
||
| 74 | -+ | |||
| 123 | +! |
- #' teal:::include_teal_css_js(),+ data <- .datasets_to_data(modules, datasets) |
||
| 75 | -+ | |||
| 124 | +! |
- #' p("Hello")
+ args <- c(args, data = list(data)) |
||
| 76 | +125 |
- #' )+ } |
||
| 77 | +126 |
- #' @keywords internal+ |
||
| 78 | -+ | |||
| 127 | +1x |
- include_teal_css_js <- function() {
+ teal_ui <- tags$div( |
||
| 79 | -32x | +128 | +1x |
- tagList(+ id = id, |
| 80 | -32x | +129 | +1x |
- shinyjs::useShinyjs(),+ class = "teal_module", |
| 81 | -32x | +130 | +1x |
- include_css_files(),+ uiOutput(ns("data_reactive"), inline = TRUE),
|
| 82 | -+ | |||
| 131 | +1x |
- # init.js is executed from the server+ tagList( |
||
| 83 | -32x | +132 | +1x |
- include_js_files(except = "init.js"),+ if (depth >= 2L) div(style = "mt-6"), |
| 84 | -32x | +133 | +1x |
- shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
+ do.call(modules$ui, args) |
| 85 | +134 |
- )+ ) |
||
| 86 | +135 |
- }+ ) |
| 1 | +136 |
- .onLoad <- function(libname, pkgname) { # nolint
+
|
||
| 2 | -+ | |||
| 137 | +1x |
- # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R+ if (!is.null(modules$datanames) && is_module_specific) {
|
||
| 3 | +138 | ! |
- teal_default_options <- list(teal.show_js_log = FALSE)+ fluidRow( |
|
| 4 | -+ | |||
| 139 | +! |
-
+ column(width = 9, teal_ui, class = "teal_primary_col"), |
||
| 5 | +140 | ! |
- op <- options()+ column( |
|
| 6 | +141 | ! |
- toset <- !(names(teal_default_options) %in% names(op))+ width = 3, |
|
| 7 | +142 | ! |
- if (any(toset)) options(teal_default_options[toset])+ datasets$ui_filter_panel(ns("module_filter_panel")),
+ |
+ |
| 143 | +! | +
+ class = "teal_secondary_col" |
||
| 8 | +144 |
-
+ ) |
||
| 9 | -! | +|||
| 145 | +
- options("shiny.sanitize.errors" = FALSE)
+ ) |
|||
| 10 | +146 |
-
+ } else {
+ |
+ ||
| 147 | +1x | +
+ teal_ui |
||
| 11 | +148 |
- # Set up the teal logger instance+ } |
||
| 12 | -! | +|||
| 149 | +
- teal.logger::register_logger("teal")
+ } |
|||
| 13 | +150 | |||
| 14 | -! | +|||
| 151 | +
- invisible()+ #' @rdname module_nested_tabs |
|||
| 15 | +152 |
- }+ srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE, |
||
| 16 | +153 |
-
+ reporter = teal.reporter::Reporter$new()) {
|
||
| 17 | -+ | |||
| 154 | +54x |
- .onAttach <- function(libname, pkgname) { # nolint
+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
|
||
| 18 | -2x | +155 | +54x |
- packageStartupMessage(+ checkmate::assert_class(reporter, "Reporter") |
| 19 | -2x | +156 | +53x |
- "\nYou are using teal version ",+ UseMethod("srv_nested_tabs", modules)
|
| 20 | +157 |
- # `system.file` uses the `shim` of `system.file` by `teal`+ } |
||
| 21 | +158 |
- # we avoid `desc` dependency here to get the version+ |
||
| 22 | -2x | +|||
| 159 | +
- read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
+ #' @rdname module_nested_tabs |
|||
| 23 | +160 |
- )+ #' @export |
||
| 24 | +161 | ++ |
+ srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,+ |
+ |
| 162 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+ ||
| 163 | +! | +
+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ |
+ ||
| 164 |
} |
|||
| 25 | +165 | |||
| 26 | +166 |
- # Use non-exported function(s) from teal.slice.+ #' @rdname module_nested_tabs+ |
+ ||
| 167 | ++ |
+ #' @export |
||
| 27 | +168 |
- # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).+ srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE, |
||
| 28 | +169 |
- list_to_teal_slices <- getFromNamespace("list_to_teal_slices", "teal.slice")
+ reporter = teal.reporter::Reporter$new()) {
|
||
| 29 | -+ | |||
| 170 | +24x |
- # This one is here because setdiff_teal_slice should not be exported from teal.slice.+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
||
| 30 | +171 |
- setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
+
|
||
| 31 | -+ | |||
| 172 | +24x |
- # This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice.+ moduleServer(id = id, module = function(input, output, session) {
|
||
| 32 | -+ | |||
| 173 | +24x |
- coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
+ logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
|
||
| 33 | +174 |
- # all *Block objects are private in teal.reporter+ |
||
| 34 | -+ | |||
| 175 | +24x |
- RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint
+ labels <- vapply(modules$children, `[[`, character(1), "label") |
| 1 | -+ | |||
| 176 | +24x |
- #' Filter settings for teal applications+ modules_reactive <- sapply( |
||
| 2 | -+ | |||
| 177 | +24x |
- #'+ names(modules$children), |
||
| 3 | -+ | |||
| 178 | +24x |
- #' Filter settings for teal applications+ function(module_id) {
|
||
| 4 | -+ | |||
| 179 | +35x |
- #'+ srv_nested_tabs( |
||
| 5 | -+ | |||
| 180 | +35x |
- #' @inheritParams teal.slice::teal_slices+ id = module_id, |
||
| 6 | -+ | |||
| 181 | +35x |
- #'+ datasets = datasets[[labels[module_id]]], |
||
| 7 | -+ | |||
| 182 | +35x |
- #' @param module_specific (`logical(1)`)\cr+ modules = modules$children[[module_id]], |
||
| 8 | -+ | |||
| 183 | +35x |
- #' - `TRUE` when filter panel should be module-specific. All modules can have different set+ is_module_specific = is_module_specific, |
||
| 9 | -+ | |||
| 184 | +35x |
- #' of filters specified - see `mapping` argument.+ reporter = reporter |
||
| 10 | +185 |
- #' - `FALSE` when one filter panel needed to all modules. All filters will be shared+ ) |
||
| 11 | +186 |
- #' by all modules.+ }, |
||
| 12 | -+ | |||
| 187 | +24x |
- #' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
+ simplify = FALSE |
||
| 13 | +188 |
- #' (`named list`)\cr+ ) |
||
| 14 | +189 |
- #' Specifies which filters will be active in which modules on app start.+ |
||
| 15 | +190 |
- #' Elements should contain character vector of `teal_slice` `id`s (see [teal.slice::teal_slice()]).+ # when not ready input$active_tab would return NULL - this would fail next reactive |
||
| 16 | -+ | |||
| 191 | +24x |
- #' Names of the list should correspond to `teal_module` `label` set in [module()] function.+ input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE) |
||
| 17 | -+ | |||
| 192 | +24x |
- #' `id`s listed under `"global_filters` will be active in all modules.+ get_active_module <- reactive({
|
||
| 18 | -+ | |||
| 193 | +13x |
- #' If missing, all filters will be applied to all modules.+ if (length(modules$children) == 1L) {
|
||
| 19 | +194 |
- #' If empty list, all filters will be available to all modules but will start inactive.+ # single tab is active by default |
||
| 20 | -+ | |||
| 195 | +2x |
- #' If `module_specific` is `FALSE`, only `global_filters` will be active on start.+ modules_reactive[[1]]() |
||
| 21 | +196 |
- #'+ } else {
|
||
| 22 | +197 |
- #' @param x (`list`) of lists to convert to `teal_slices`+ # switch to active tab |
||
| 23 | -+ | |||
| 198 | +11x |
- #'+ modules_reactive[[input_validated()]]() |
||
| 24 | +199 |
- #' @examples+ } |
||
| 25 | +200 |
- #' filter <- teal_slices(+ }) |
||
| 26 | +201 |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"),+ |
||
| 27 | -+ | |||
| 202 | +24x |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),+ get_active_module |
||
| 28 | +203 |
- #' teal.slice::teal_slice(+ }) |
||
| 29 | +204 |
- #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"+ } |
||
| 30 | +205 |
- #' ),+ |
||
| 31 | +206 |
- #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),+ #' @rdname module_nested_tabs |
||
| 32 | +207 |
- #' mapping = list(+ #' @export |
||
| 33 | +208 |
- #' module1 = c("species", "sepal_length"),
+ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE, |
||
| 34 | +209 |
- #' module2 = c("mtcars_mpg"),
+ reporter = teal.reporter::Reporter$new()) {
+ |
+ ||
| 210 | +29x | +
+ checkmate::assert_class(datasets, "FilteredData") |
||
| 35 | -+ | |||
| 211 | +29x |
- #' global_filters = "long_petals"+ logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
|
||
| 36 | +212 |
- #' )+ |
||
| 37 | -+ | |||
| 213 | +29x |
- #' )+ moduleServer(id = id, module = function(input, output, session) {
|
||
| 38 | -+ | |||
| 214 | +29x |
- #'+ modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets) |
||
| 39 | -+ | |||
| 215 | +29x |
- #' app <- teal::init(+ if (!is.null(modules$datanames) && is_module_specific) {
|
||
| 40 | -+ | |||
| 216 | +! |
- #' modules = list(+ datasets$srv_filter_panel("module_filter_panel", active_datanames = reactive(modules$datanames))
|
||
| 41 | +217 |
- #' module("module1"),
+ } |
||
| 42 | +218 |
- #' module("module2")
+
|
||
| 43 | +219 |
- #' ),+ # Create two triggers to limit reactivity between filter-panel and modules. |
||
| 44 | +220 |
- #' data = list(iris, mtcars),+ # We want to recalculate only visible modules |
||
| 45 | +221 |
- #' filter = filter+ # - trigger the data when the tab is selected |
||
| 46 | +222 |
- #' )+ # - trigger module to be called when the tab is selected for the first time |
||
| 47 | -+ | |||
| 223 | +29x |
- #'+ trigger_data <- reactiveVal(1L) |
||
| 48 | -+ | |||
| 224 | +29x |
- #' if (interactive()) {
+ trigger_module <- reactiveVal(NULL) |
||
| 49 | -+ | |||
| 225 | +29x |
- #' shiny::runApp(app)+ output$data_reactive <- renderUI({
|
||
| 50 | -+ | |||
| 226 | +18x |
- #' }+ lapply(datasets$datanames(), function(x) {
|
||
| 51 | -+ | |||
| 227 | +22x |
- #'+ datasets$get_data(x, filtered = TRUE) |
||
| 52 | +228 |
- #' @export+ }) |
||
| 53 | -+ | |||
| 229 | +18x |
- teal_slices <- function(...,+ isolate(trigger_data(trigger_data() + 1)) |
||
| 54 | -+ | |||
| 230 | +18x |
- exclude_varnames = NULL,+ isolate(trigger_module(TRUE)) |
||
| 55 | +231 |
- include_varnames = NULL,+ |
||
| 56 | -+ | |||
| 232 | +18x |
- count_type = NULL,+ NULL |
||
| 57 | +233 |
- allow_add = TRUE,+ }) |
||
| 58 | +234 |
- module_specific = FALSE,+ |
||
| 59 | +235 |
- mapping) {
+ # collect arguments to run teal_module |
||
| 60 | -91x | +236 | +29x |
- shiny::isolate({
+ args <- c(list(id = "module"), modules$server_args) |
| 61 | -91x | +237 | +29x |
- checkmate::assert_flag(allow_add)+ if (is_arg_used(modules$server, "reporter")) {
|
| 62 | -91x | +|||
| 238 | +! |
- checkmate::assert_flag(module_specific)+ args <- c(args, list(reporter = reporter)) |
||
| 63 | -45x | +|||
| 239 | +
- if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
+ } |
|||
| 64 | +240 | |||
| 65 | -88x | +241 | +29x |
- slices <- list(...)+ if (is_arg_used(modules$server, "datasets")) {
|
| 66 | -88x | +242 | +2x |
- all_slice_id <- vapply(slices, `[[`, character(1L), "id")+ args <- c(args, datasets = datasets) |
| 67 | +243 | ++ |
+ }+ |
+ |
| 244 | ||||
| 68 | -88x | +245 | +29x |
- if (missing(mapping)) {
+ if (is_arg_used(modules$server, "data")) {
|
| 69 | -46x | +246 | +8x |
- mapping <- list(global_filters = all_slice_id)+ data <- .datasets_to_data(modules, datasets, trigger_data)+ |
+
| 247 | +8x | +
+ args <- c(args, data = list(data)) |
||
| 70 | +248 |
} |
||
| 249 | ++ | + + | +||
| 71 | -88x | +250 | +29x |
- if (!module_specific) {
+ if (is_arg_used(modules$server, "filter_panel_api")) {
|
| 72 | -84x | +251 | +2x |
- mapping[setdiff(names(mapping), "global_filters")] <- NULL+ filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)+ |
+
| 252 | +2x | +
+ args <- c(args, filter_panel_api = filter_panel_api) |
||
| 73 | +253 |
} |
||
| 74 | +254 | |||
| 75 | -88x | -
- failed_slice_id <- setdiff(unlist(mapping), all_slice_id)- |
- ||
| 76 | -88x | +255 | +29x |
- if (length(failed_slice_id)) {
+ if (is_arg_used(modules$server, "datasets") && is_arg_used(modules$server, "data")) {
|
| 77 | +256 | 1x |
- stop(sprintf(+ warning( |
|
| 78 | +257 | 1x |
- "Filters in mapping don't match any available filter.\n %s not in %s",+ "Module '", modules$label, "' has `data` and `datasets` arguments in the formals.", |
|
| 79 | +258 | 1x |
- toString(failed_slice_id),+ "\nIt's recommended to use `data` to work with filtered objects." |
|
| 80 | -1x | +|||
| 259 | +
- toString(all_slice_id)+ ) |
|||
| 81 | +260 |
- ))+ } |
||
| 82 | +261 |
- }+ |
||
| 83 | +262 |
-
+ # observe the trigger_module above to induce the module once the renderUI is triggered |
||
| 84 | -87x | +263 | +29x |
- tss <- teal.slice::teal_slices(+ observeEvent( |
| 85 | -+ | |||
| 264 | +29x |
- ...,+ ignoreNULL = TRUE, |
||
| 86 | -87x | +265 | +29x |
- exclude_varnames = exclude_varnames,+ once = TRUE, |
| 87 | -87x | +266 | +29x |
- include_varnames = include_varnames,+ eventExpr = trigger_module(), |
| 88 | -87x | +267 | +29x |
- count_type = count_type,+ handlerExpr = {
|
| 89 | -87x | +268 | +18x |
- allow_add = allow_add+ module_output <- if (is_arg_used(modules$server, "id")) {
+ |
+
| 269 | +18x | +
+ do.call(modules$server, args) |
||
| 90 | +270 |
- )+ } else {
|
||
| 91 | -87x | +|||
| 271 | +! |
- attr(tss, "mapping") <- mapping+ do.call(callModule, c(args, list(module = modules$server))) |
||
| 92 | -87x | +|||
| 272 | +
- attr(tss, "module_specific") <- module_specific+ } |
|||
| 93 | -87x | +|||
| 273 | +
- class(tss) <- c("modules_teal_slices", class(tss))
+ }+ |
+ |||
| 274 | ++ |
+ )+ |
+ ||
| 275 | ++ | + | ||
| 94 | -87x | +276 | +29x |
- tss+ reactive(modules) |
| 95 | +277 |
}) |
||
| 96 | +278 |
} |
||
| 97 | +279 | |||
| 98 | +280 |
-
+ #' Convert `FilteredData` to reactive list of datasets of the `tdata` type. |
||
| 99 | +281 |
- #' @rdname teal_slices+ #' |
||
| 100 | +282 |
- #' @export+ #' Converts `FilteredData` object to `tdata` object containing datasets needed for a specific module. |
||
| 101 | +283 |
- #' @keywords internal+ #' Please note that if module needs dataset which has a parent, then parent will be also returned. |
||
| 102 | +284 | ++ |
+ #' A hash per `dataset` is calculated internally and returned in the code.+ |
+ |
| 285 |
#' |
|||
| 103 | +286 |
- as.teal_slices <- function(x) { # nolint
+ #' @param module (`teal_module`) module where needed filters are taken from |
||
| 104 | -33x | +|||
| 287 | +
- checkmate::assert_list(x)+ #' @param datasets (`FilteredData`) object where needed data are taken from |
|||
| 105 | -33x | +|||
| 288 | +
- lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")+ #' @param trigger_data (`reactiveVal`) to trigger getting the filtered data |
|||
| 106 | +289 |
-
+ #' @return list of reactive datasets with following attributes: |
||
| 107 | -33x | +|||
| 290 | +
- attrs <- attributes(unclass(x))+ #' - `code` (`character`) containing datasets reproducible code. |
|||
| 108 | -33x | +|||
| 291 | +
- ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))+ #' - `join_keys` (`JoinKeys`) containing relationships between datasets. |
|||
| 109 | -33x | +|||
| 292 | +
- do.call(teal_slices, c(ans, attrs))+ #' - `metadata` (`list`) containing metadata of datasets. |
|||
| 110 | +293 |
- }+ #' |
||
| 111 | +294 |
-
+ #' @keywords internal+ |
+ ||
| 295 | ++ |
+ .datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) {
+ |
+ ||
| 296 | +13x | +
+ checkmate::assert_class(module, "teal_module")+ |
+ ||
| 297 | +13x | +
+ checkmate::assert_class(datasets, "FilteredData")+ |
+ ||
| 298 | +13x | +
+ checkmate::assert_class(trigger_data, "reactiveVal") |
||
| 112 | +299 | |||
| 113 | -+ | |||
| 300 | +12x |
- #' @rdname teal_slices+ datanames <- if (is.null(module$datanames)) datasets$datanames() else module$datanames |
||
| 114 | +301 |
- #' @export+ |
||
| 115 | +302 |
- #' @keywords internal+ # list of reactive filtered data |
||
| 116 | -+ | |||
| 303 | +12x |
- #'+ data <- sapply( |
||
| 117 | -+ | |||
| 304 | +12x |
- c.teal_slices <- function(...) {
+ datanames, |
||
| 118 | -! | +|||
| 305 | +12x |
- x <- list(...)+ function(x) eventReactive(trigger_data(), datasets$get_data(x, filtered = TRUE)), |
||
| 119 | -! | +|||
| 306 | +12x |
- checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ simplify = FALSE |
||
| 120 | +307 | ++ |
+ )+ |
+ |
| 308 | ||||
| 121 | -! | +|||
| 309 | +12x |
- all_attributes <- lapply(x, attributes)+ hashes <- calculate_hashes(datanames, datasets) |
||
| 122 | -! | +|||
| 310 | +12x |
- all_attributes <- coalesce_r(all_attributes)+ metadata <- lapply(datanames, datasets$get_metadata) |
||
| 123 | -! | +|||
| 311 | +12x |
- all_attributes <- all_attributes[names(all_attributes) != "class"]+ names(metadata) <- datanames |
||
| 124 | +312 | |||
| 125 | -! | +|||
| 313 | +12x |
- do.call(+ new_tdata( |
||
| 126 | -! | +|||
| 314 | +12x |
- teal_slices,+ data, |
||
| 127 | -! | +|||
| 315 | +12x |
- c(+ eventReactive( |
||
| 128 | -! | +|||
| 316 | +12x |
- unique(unlist(x, recursive = FALSE)),+ trigger_data(), |
||
| 129 | -! | +|||
| 317 | +12x |
- all_attributes+ c( |
||
| 130 | -+ | |||
| 318 | +12x |
- )+ get_rcode_str_install(), |
||
| 131 | -+ | |||
| 319 | +12x |
- )+ get_rcode_libraries(), |
||
| 132 | -+ | |||
| 320 | +12x |
- }+ get_datasets_code(datanames, datasets, hashes), |
||
| 133 | -+ | |||
| 321 | +12x |
-
+ teal.slice::get_filter_expr(datasets, datanames) |
||
| 134 | +322 |
-
+ ) |
||
| 135 | +323 |
- #' Deep copy `teal_slices`+ ), |
||
| 136 | -+ | |||
| 324 | +12x |
- #'+ datasets$get_join_keys(), |
||
| 137 | -+ | |||
| 325 | +12x |
- #' it's important to create a new copy of `teal_slices` when+ metadata |
||
| 138 | +326 |
- #' starting a new `shiny` session. Otherwise, object will be shared+ ) |
||
| 139 | +327 |
- #' by multiple users as it is created in global environment before+ } |
||
| 140 | +328 |
- #' `shiny` session starts.+ |
||
| 141 | +329 |
- #' @param filter (`teal_slices`)+ #' Get the hash of a dataset |
||
| 142 | +330 |
- #' @return `teal_slices`+ #' |
||
| 143 | +331 |
- #' @keywords internal+ #' @param datanames (`character`) names of datasets |
||
| 144 | +332 |
- deep_copy_filter <- function(filter) {
- |
- ||
| 145 | -1x | -
- checkmate::assert_class(filter, "teal_slices")- |
- ||
| 146 | -1x | -
- shiny::isolate({
- |
- ||
| 147 | -1x | -
- filter_copy <- lapply(filter, function(slice) {
+ #' @param datasets (`FilteredData`) object holding the data |
||
| 148 | -2x | +|||
| 333 | +
- teal.slice::as.teal_slice(as.list(slice))+ #' |
|||
| 149 | +334 |
- })+ #' @return A list of hashes per dataset |
||
| 150 | -1x | +|||
| 335 | +
- attributes(filter_copy) <- attributes(filter)+ #' @keywords internal |
|||
| 151 | -1x | +|||
| 336 | +
- filter_copy+ #' |
|||
| 152 | +337 |
- })+ calculate_hashes <- function(datanames, datasets) {
+ |
+ ||
| 338 | +16x | +
+ sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE) |
||
| 153 | +339 |
}@@ -13423,14 +13864,14 @@ teal coverage - 72.64% |
| 1 |
- #' Filter manager modal+ #' Add right filter panel into each of the top-level `teal_modules` UIs. |
|||
| 3 |
- #' Opens modal containing the filter manager UI.+ #' The [ui_nested_tabs] function returns a nested tabbed UI corresponding |
|||
| 4 |
- #'+ #' to the nested modules. |
|||
| 5 |
- #' @name module_filter_manager_modal+ #' This function adds the right filter panel to each main tab. |
|||
| 6 |
- #' @inheritParams filter_manager_srv+ #' |
|||
| 7 |
- #' @examples+ #' The right filter panel's filter choices affect the `datasets` object. Therefore, |
|||
| 8 |
- #' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris)))+ #' all modules using the same `datasets` share the same filters. |
|||
| 9 |
- #' fd2 <- teal.slice::init_filtered_data(+ #' |
|||
| 10 |
- #' list(iris = list(dataset = iris), mtcars = list(dataset = mtcars))+ #' This works with nested modules of depth greater than 2, though the filter |
|||
| 11 |
- #' )+ #' panel is inserted at the right of the modules at depth 1 and not at the leaves. |
|||
| 12 |
- #' fd3 <- teal.slice::init_filtered_data(+ #' |
|||
| 13 |
- #' list(iris = list(dataset = iris), women = list(dataset = women))+ #' @name module_tabs_with_filters |
|||
| 14 |
- #' )+ #' |
|||
| 15 |
- #' filter <- teal_slices(+ #' @inheritParams module_teal |
|||
| 16 |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length"),+ #' |
|||
| 17 |
- #' teal.slice::teal_slice(dataname = "iris", varname = "Species"),+ #' @param datasets (`named list` of `FilteredData`)\cr |
|||
| 18 |
- #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg"),+ #' object to store filter state and filtered datasets, shared across modules. For more |
|||
| 19 |
- #' teal.slice::teal_slice(dataname = "women", varname = "height"),+ #' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure |
|||
| 20 |
- #' mapping = list(+ #' of the `modules` argument and list names must correspond to the labels in `modules`. |
|||
| 21 |
- #' module2 = c("mtcars mpg"),
+ #' When filter is not module-specific then list contains the same object in all elements. |
|||
| 22 |
- #' module3 = c("women height"),
+ #' @param reporter (`Reporter`) object from `teal.reporter` |
|||
| 23 |
- #' global_filters = "iris Species"+ #' |
|||
| 24 |
- #' )+ #' @return A `tagList` of The main menu, place holders for filters and |
|||
| 25 |
- #' )+ #' place holders for the teal modules |
|||
| 27 |
- #' app <- shinyApp(+ #' |
|||
| 28 |
- #' ui = fluidPage(+ #' @keywords internal |
|||
| 29 |
- #' teal:::filter_manager_modal_ui("manager")
+ #' |
|||
| 30 |
- #' ),+ #' @examples |
|||
| 31 |
- #' server = function(input, output, session) {
+ #' |
|||
| 32 |
- #' teal:::filter_manager_modal_srv(+ #' mods <- teal:::example_modules() |
|||
| 33 |
- #' "manager",+ #' datasets <- teal:::example_datasets() |
|||
| 34 |
- #' filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3),+ #' |
|||
| 35 |
- #' filter = filter+ #' app <- shinyApp( |
|||
| 36 |
- #' )+ #' ui = function() {
|
|||
| 37 |
- #' }+ #' tagList( |
|||
| 38 |
- #' )+ #' teal:::include_teal_css_js(), |
|||
| 39 |
- #' if (interactive()) {
+ #' textOutput("info"),
|
|||
| 40 |
- #' runApp(app)+ #' fluidPage( # needed for nice tabs |
|||
| 41 |
- #' }+ #' ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
|
|||
| 42 |
- #'+ #' ) |
|||
| 43 |
- #' @keywords internal+ #' ) |
|||
| 44 |
- #'+ #' }, |
|||
| 45 |
- NULL+ #' server = function(input, output, session) {
|
|||
| 46 |
-
+ #' output$info <- renderText({
|
|||
| 47 |
- #' @rdname module_filter_manager_modal+ #' paste0("The currently active tab name is ", active_module()$label)
|
|||
| 48 |
- filter_manager_modal_ui <- function(id) {
+ #' }) |
|||
| 49 | -1x | +
- ns <- NS(id)+ #' active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods) |
||
| 50 | -1x | +
- tags$button(+ #' } |
||
| 51 | -1x | +
- id = ns("show"),
+ #' ) |
||
| 52 | -1x | +
- class = "btn action-button filter_manager_button",+ #' if (interactive()) {
|
||
| 53 | -1x | +
- title = "Show filters manager modal",+ #' runApp(app) |
||
| 54 | -1x | +
- icon("gear")
+ #' } |
||
| 55 |
- )+ #' |
|||
| 56 |
- }+ NULL |
|||
| 58 |
- #' @rdname module_filter_manager_modal+ #' @rdname module_tabs_with_filters |
|||
| 59 |
- filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
+ ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
|
|||
| 60 | -4x | +1x |
- moduleServer(id, function(input, output, session) {
+ checkmate::assert_class(modules, "teal_modules") |
|
| 61 | -4x | +1x |
- observeEvent(input$show, {
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
|
| 62 | -! | +1x |
- logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
+ checkmate::assert_class(filter, "teal_slices") |
|
| 63 | -! | +
- showModal(+ |
||
| 64 | -! | +1x |
- modalDialog(+ ns <- NS(id) |
|
| 65 | -! | +1x |
- filter_manager_ui(session$ns("filter_manager")),
+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
|
| 66 | -! | +
- size = "l",+ |
||
| 67 | -! | +1x |
- footer = NULL,+ teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
|
|
| 68 | -! | +1x |
- easyClose = TRUE+ filter_panel_btns <- tags$li( |
|
| 69 | -+ | 1x |
- )+ class = "flex-grow", |
|
| 70 | -+ | 1x |
- )+ tags$button( |
|
| 71 | -+ | 1x |
- })+ class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger |
|
| 72 | -+ | 1x |
-
+ href = "javascript:void(0)", |
|
| 73 | -4x | +1x |
- filter_manager_srv("filter_manager", filtered_data_list, filter)
+ onclick = "toggleFilterPanel();", # see sidebar.js |
|
| 74 | -+ | 1x |
- })+ title = "Toggle filter panels", |
|
| 75 | -+ | 1x |
- }+ icon("fas fa-bars")
|
|
| 76 |
-
+ ), |
|||
| 77 | -+ | 1x |
- #' @rdname module_filter_manager+ filter_manager_modal_ui(ns("filter_manager"))
|
|
| 78 |
- filter_manager_ui <- function(id) {
+ ) |
|||
| 79 | -! | +1x |
- ns <- NS(id)+ teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns) |
|
| 80 | -! | +
- div(+ |
||
| 81 | -! | +1x |
- class = "filter_manager_content",+ if (!is_module_specific) {
|
|
| 82 | -! | +
- tableOutput(ns("slices_table")),
+ # need to rearrange html so that filter panel is within tabset |
||
| 83 | -! | +1x |
- snapshot_manager_ui(ns("snapshot_manager"))
+ tabset_bar <- teal_ui$children[[1]] |
|
| 84 | -+ | 1x |
- )+ teal_modules <- teal_ui$children[[2]] |
|
| 85 | -+ | 1x |
- }+ filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
|
|
| 86 | -+ | 1x |
-
+ list( |
|
| 87 | -+ | 1x |
- #' Manage multiple `FilteredData` objects+ tabset_bar, |
|
| 88 | -+ | 1x |
- #'+ tags$hr(class = "my-2"), |
|
| 89 | -+ | 1x |
- #' Oversee filter states in the whole application.+ fluidRow( |
|
| 90 | -+ | 1x |
- #'+ column(width = 9, teal_modules, class = "teal_primary_col"), |
|
| 91 | -+ | 1x |
- #' @rdname module_filter_manager+ column(width = 3, filter_ui, class = "teal_secondary_col") |
|
| 92 |
- #' @details+ ) |
|||
| 93 |
- #' This module observes the changes of the filters in each `FilteredData` object+ ) |
|||
| 94 |
- #' and keeps track of all filters used. A mapping of filters to modules+ } else {
|
|||
| 95 | -+ | ! |
- #' is kept in the `mapping_matrix` object (which is actually a `data.frame`)+ teal_ui |
|
| 96 |
- #' that tracks which filters (rows) are active in which modules (columns).+ } |
|||
| 97 |
- #'+ } |
|||
| 98 |
- #' @param id (`character(1)`)\cr+ |
|||
| 99 |
- #' `shiny` module id.+ #' @rdname module_tabs_with_filters |
|||
| 100 |
- #' @param filtered_data_list (`named list`)\cr+ srv_tabs_with_filters <- function(id, |
|||
| 101 |
- #' A list, possibly nested, of `FilteredData` objects.+ datasets, |
|||
| 102 |
- #' Each `FilteredData` will be served to one module in the `teal` application.+ modules, |
|||
| 103 |
- #' The structure of the list must reflect the nesting of modules in tabs+ reporter = teal.reporter::Reporter$new(), |
|||
| 104 |
- #' and names of the list must be the same as labels of their respective modules.- |
- |||
| 105 | -- |
- #' @inheritParams init- |
- ||
| 106 | -- |
- #' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.- |
- ||
| 107 | -- |
- #' @keywords internal- |
- ||
| 108 | -- |
- #'- |
- ||
| 109 | -- |
- filter_manager_srv <- function(id, filtered_data_list, filter) {
+ filter = teal_slices()) {
|
||
| 110 | +105 | 6x |
- moduleServer(id, function(input, output, session) {
+ checkmate::assert_class(modules, "teal_modules") |
|
| 111 | +106 | 6x |
- logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
- |
- |
| 112 | -- |
-
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
|
||
| 113 | +107 | 6x |
- is_module_specific <- isTRUE(attr(filter, "module_specific"))- |
- |
| 114 | -- | - - | -||
| 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 | -- |
- # Down there a subset that pertains to the data sets used in that module is applied and displayed.+ checkmate::assert_class(reporter, "Reporter") |
||
| 119 | -6x | +108 | +4x |
- slices_global <- reactiveVal(filter)+ checkmate::assert_class(filter, "teal_slices") |
| 120 | +109 | |||
| 121 | -6x | -
- filtered_data_list <-- |
- ||
| 122 | -6x | -
- if (!is_module_specific) {
- |
- ||
| 123 | -- |
- # Retrieve the first FilteredData from potentially nested list.- |
- ||
| 124 | -+ | 110 | +4x |
- # List of length one is named "global_filters" because that name is forbidden for a module label.+ moduleServer(id, function(input, output, session) {
|
| 125 | -5x | -
- list(global_filters = unlist(filtered_data_list)[[1]])- |
- ||
| 126 | -- |
- } else {
- |
- ||
| 127 | -- |
- # Flatten potentially nested list of FilteredData objects while maintaining useful names.- |
- ||
| 128 | -+ | 111 | +4x |
- # Simply using `unlist` would result in concatenated names.+ logger::log_trace("srv_tabs_with_filters initializing the module.")
|
| 129 | -1x | +|||
| 112 | +
- flatten_nested <- function(x, name = NULL) {
+
|
|||
| 130 | -5x | +113 | +4x |
- if (inherits(x, "FilteredData")) {
+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
| 131 | -3x | +114 | +4x |
- setNames(list(x), name)+ manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
|
| 132 | +115 |
- } else {
+
|
||
| 133 | -2x | +116 | +4x |
- unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))+ active_module <- srv_nested_tabs( |
| 134 | -+ | |||
| 117 | +4x |
- }+ id = "root", |
||
| 135 | -+ | |||
| 118 | +4x |
- }+ datasets = datasets, |
||
| 136 | -1x | +119 | +4x |
- flatten_nested(filtered_data_list)+ modules = modules, |
| 137 | -+ | |||
| 120 | +4x |
- }+ reporter = reporter, |
||
| 138 | -+ | |||
| 121 | +4x |
-
+ is_module_specific = is_module_specific |
||
| 139 | +122 |
- # Create mapping fo filters to modules in matrix form (presented as data.frame).+ ) |
||
| 140 | +123 |
- # Modules get NAs for filteres that cannot be set for them.+ |
||
| 141 | -6x | +124 | +4x |
- mapping_matrix <- reactive({
+ if (!is_module_specific) {
|
| 142 | -6x | +125 | +4x |
- state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")+ active_datanames <- reactive(active_module()$datanames) |
| 143 | -6x | +126 | +4x |
- mapping_smooth <- lapply(filtered_data_list, function(x) {
+ singleton <- unlist(datasets)[[1]] |
| 144 | -8x | +127 | +4x |
- state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")+ singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
+ |
+
| 128 | ++ | + | ||
| 145 | -8x | +129 | +4x |
- state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")+ observeEvent( |
| 146 | -8x | +130 | +4x |
- states_active <- state_ids_global %in% state_ids_local+ eventExpr = active_datanames(), |
| 147 | -8x | +131 | +4x |
- ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)+ handlerExpr = {
|
| 148 | -+ | |||
| 132 | +5x |
- })+ script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
|
||
| 149 | +133 |
-
+ # hide the filter panel and disable the burger button |
||
| 150 | -6x | +134 | +1x |
- as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)+ "handleNoActiveDatasets();" |
| 151 | +135 |
- })+ } else {
|
||
| 152 | +136 | - - | -||
| 153 | -6x | -
- output$slices_table <- renderTable(+ # show the filter panel and enable the burger button |
||
| 154 | -6x | +137 | +4x |
- expr = {
+ "handleActiveDatasetsPresent();" |
| 155 | +138 |
- # Display logical values as UTF characters.+ } |
||
| 156 | -3x | +139 | +5x |
- mm <- mapping_matrix()+ shinyjs::runjs(script) |
| 157 | -3x | +|||
| 140 | +
- mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))+ }, |
|||
| 158 | -3x | +141 | +4x |
- mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))+ ignoreNULL = FALSE |
| 159 | -3x | +|||
| 142 | +
- if (!is_module_specific) colnames(mm) <- "Global Filters"+ ) |
|||
| 160 | +143 |
-
+ } |
||
| 161 | +144 |
- # Display placeholder if no filters defined.+ |
||
| 162 | -3x | +145 | +4x |
- if (nrow(mm) == 0L) {
+ showNotification("Data loaded - App fully started up")
|
| 163 | -3x | +146 | +4x |
- mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)+ logger::log_trace("srv_tabs_with_filters initialized the module")
|
| 164 | -3x | -
- rownames(mm) <- ""- |
- ||
| 165 | -+ | 147 | +4x |
- }+ return(active_module) |
| 166 | +148 | - - | -||
| 167 | -3x | -
- mm+ }) |
||
| 168 | +149 |
- },- |
- ||
| 169 | -6x | -
- align = paste(c("l", rep("c", length(filtered_data_list))), collapse = ""),
+ } |
||
| 170 | -6x | +
| 1 | +
- rownames = TRUE+ #' Creates a `teal_modules` object. |
|||
| 171 | +2 |
- )+ #' |
||
| 172 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 173 | +4 |
- # Create list of module calls.+ #' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object |
||
| 174 | -6x | +|||
| 5 | +
- modules_out <- lapply(names(filtered_data_list), function(module_name) {
+ #' containing the passed objects. |
|||
| 175 | -8x | +|||
| 6 | +
- filter_manager_module_srv(+ #' |
|||
| 176 | -8x | +|||
| 7 | +
- id = module_name,+ #' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules` |
|||
| 177 | -8x | +|||
| 8 | +
- module_fd = filtered_data_list[[module_name]],+ #' shapes the navigation panel of a `teal` application. |
|||
| 178 | -8x | +|||
| 9 | +
- slices_global = slices_global+ #' |
|||
| 179 | +10 |
- )+ #' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details |
||
| 180 | +11 |
- })+ #' @param label (`character(1)`) label of modules collection (default `"root"`). |
||
| 181 | +12 |
-
+ #' If using the `label` argument then it must be explicitly named. |
||
| 182 | +13 |
- # Call snapshot manager.+ #' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
|
||
| 183 | -6x | +|||
| 14 | +
- snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
+ #' |
|||
| 184 | +15 |
-
+ #' @export |
||
| 185 | -6x | +|||
| 16 | +
- modules_out # returned for testing purpose+ #' |
|||
| 186 | +17 |
- })+ #' @return object of class \code{teal_modules}. Object contains following fields
|
||
| 187 | +18 |
- }+ #' - `label`: taken from the `label` argument |
||
| 188 | +19 |
-
+ #' - `children`: a list containing objects passed in `...`. List elements are named after |
||
| 189 | +20 |
- #' Module specific filter manager+ #' their `label` attribute converted to a valid `shiny` id. |
||
| 190 | +21 |
- #'+ #' @examples |
||
| 191 | +22 |
- #' Track filter states in single module.+ #' library(shiny) |
||
| 192 | +23 |
#' |
||
| 193 | +24 |
- #' This module tracks the state of a single `FilteredData` object and global `teal_slices`+ #' app <- init( |
||
| 194 | +25 |
- #' and updates both objects as necessary. Filter states added in different modules+ #' data = teal_data(dataset("iris", iris)),
|
||
| 195 | +26 |
- #' Filter states added any individual module are added to global `teal_slices`+ #' modules = modules( |
||
| 196 | +27 |
- #' and from there become available in other modules+ #' label = "Modules", |
||
| 197 | +28 |
- #' by setting `private$available_teal_slices` in each `FilteredData`.+ #' modules( |
||
| 198 | +29 |
- #'+ #' label = "Module", |
||
| 199 | +30 |
- #' @param id (`character(1)`)\cr+ #' module( |
||
| 200 | +31 |
- #' `shiny` module id.+ #' label = "Inner module", |
||
| 201 | +32 |
- #' @param module_fd (`FilteredData`)\cr+ #' server = function(id, data) {
|
||
| 202 | +33 |
- #' object to filter data in the teal-module+ #' moduleServer( |
||
| 203 | +34 |
- #' @param slices_global (`reactiveVal`)\cr+ #' id, |
||
| 204 | +35 |
- #' stores `teal_slices` with all available filters; allows the following actions:+ #' module = function(input, output, session) {
|
||
| 205 | +36 |
- #' - to disable/enable a specific filter in a module+ #' output$data <- renderDataTable(data[["iris"]]()) |
||
| 206 | +37 |
- #' - to restore saved filter settings+ #' } |
||
| 207 | +38 |
- #' - to save current filter panel settings+ #' ) |
||
| 208 | +39 |
- #' @return A `reactive` expression containing the slices active in this module.+ #' }, |
||
| 209 | +40 |
- #' @keywords internal+ #' ui = function(id) {
|
||
| 210 | +41 |
- #'+ #' ns <- NS(id) |
||
| 211 | +42 |
- filter_manager_module_srv <- function(id, module_fd, slices_global) {
- |
- ||
| 212 | -8x | -
- moduleServer(id, function(input, output, session) {
+ #' tagList(dataTableOutput(ns("data")))
|
||
| 213 | +43 |
- # Only operate on slices that refer to data sets present in this module.+ #' }, |
||
| 214 | -8x | +|||
| 44 | +
- module_fd$set_available_teal_slices(reactive(slices_global()))+ #' datanames = "all" |
|||
| 215 | +45 |
-
+ #' ) |
||
| 216 | +46 |
- # Track filter state of this module.+ #' ), |
||
| 217 | -8x | +|||
| 47 | +
- slices_module <- reactive(module_fd$get_filter_state())+ #' module( |
|||
| 218 | +48 |
-
+ #' label = "Another module", |
||
| 219 | +49 |
- # Reactive values for comparing states.+ #' server = function(id) {
|
||
| 220 | -8x | +|||
| 50 | +
- previous_slices <- reactiveVal(isolate(slices_module()))+ #' moduleServer( |
|||
| 221 | -8x | +|||
| 51 | +
- slices_added <- reactiveVal(NULL)+ #' id, |
|||
| 222 | +52 |
-
+ #' module = function(input, output, session) {
|
||
| 223 | +53 |
- # Observe changes in module filter state and trigger appropriate actions.+ #' output$text <- renderText("Another module")
|
||
| 224 | -8x | +|||
| 54 | +
- observeEvent(slices_module(), ignoreNULL = FALSE, {
+ #' } |
|||
| 225 | -3x | +|||
| 55 | +
- logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
+ #' ) |
|||
| 226 | -3x | +|||
| 56 | +
- added <- setdiff_teal_slices(slices_module(), slices_global())+ #' }, |
|||
| 227 | -! | +|||
| 57 | +
- if (length(added)) slices_added(added)+ #' ui = function(id) {
|
|||
| 228 | -3x | +|||
| 58 | +
- previous_slices(slices_module())+ #' ns <- NS(id) |
|||
| 229 | +59 |
- })+ #' tagList(textOutput(ns("text")))
|
||
| 230 | +60 |
-
+ #' }, |
||
| 231 | -8x | +|||
| 61 | +
- observeEvent(slices_added(), ignoreNULL = TRUE, {
+ #' datanames = NULL |
|||
| 232 | -! | +|||
| 62 | +
- logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
+ #' ) |
|||
| 233 | +63 |
- # In case the new state has the same id as an existing state, add a suffix to it.+ #' ) |
||
| 234 | -! | +|||
| 64 | +
- global_ids <- vapply(slices_global(), `[[`, character(1L), "id")+ #' ) |
|||
| 235 | -! | +|||
| 65 | +
- lapply(+ #' if (interactive()) {
|
|||
| 236 | -! | +|||
| 66 | +
- slices_added(),+ #' runApp(app) |
|||
| 237 | -! | +|||
| 67 | +
- function(slice) {
+ #' } |
|||
| 238 | -! | +|||
| 68 | +
- if (slice$id %in% global_ids) {
+ modules <- function(..., label = "root") {
|
|||
| 239 | -! | +|||
| 69 | +79x |
- slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)+ checkmate::assert_string(label) |
||
| 240 | -+ | |||
| 70 | +77x |
- }+ submodules <- list(...) |
||
| 241 | -+ | |||
| 71 | +77x |
- }+ if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
|
||
| 242 | -+ | |||
| 72 | +2x |
- )+ stop( |
||
| 243 | -! | +|||
| 73 | +2x |
- slices_global_new <- c(slices_global(), slices_added())+ "The only character argument to modules() must be 'label' and it must be named, ", |
||
| 244 | -! | +|||
| 74 | +2x |
- slices_global(slices_global_new)+ "change modules('lab', ...) to modules(label = 'lab', ...)"
|
||
| 245 | -! | +|||
| 75 | +
- slices_added(NULL)+ ) |
|||
| 246 | +76 |
- })+ } |
||
| 247 | +77 | |||
| 248 | -8x | +78 | +75x |
- slices_module # returned for testing purpose+ checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
|
| 249 | +79 |
- })+ # name them so we can more easily access the children |
||
| 250 | +80 |
- }+ # beware however that the label of the submodules should not be changed as it must be kept synced |
| 1 | -+ | |||
| 81 | +72x |
- # This is the main function from teal to be used by the end-users. Although it delegates+ labels <- vapply(submodules, function(submodule) submodule$label, character(1)) |
||
| 2 | -+ | |||
| 82 | +72x |
- # directly to `module_teal_with_splash.R`, we keep it in a separate file because its doc is quite large+ names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
|
||
| 3 | -+ | |||
| 83 | +72x |
- # and it is very end-user oriented. It may also perform more argument checking with more informative+ structure( |
||
| 4 | -+ | |||
| 84 | +72x |
- # error messages.+ list( |
||
| 5 | -+ | |||
| 85 | +72x |
-
+ label = label, |
||
| 6 | -+ | |||
| 86 | +72x |
-
+ children = submodules |
||
| 7 | +87 |
- #' Create the Server and UI Function For the Shiny App+ ), |
||
| 8 | -+ | |||
| 88 | +72x |
- #'+ class = "teal_modules" |
||
| 9 | +89 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 10 | +90 |
- #' End-users: This is the most important function for you to start a+ } |
||
| 11 | +91 |
- #' teal app that is composed out of teal modules.+ |
||
| 12 | +92 |
- #'+ #' Function which appends a teal_module onto the children of a teal_modules object |
||
| 13 | +93 |
- #' **Notes for developers**:+ #' @keywords internal |
||
| 14 | +94 |
- #' This is a wrapper function around the `module_teal.R` functions. Unless you are+ #' @param modules `teal_modules` |
||
| 15 | +95 |
- #' an end-user, don't use this function, but instead this module.+ #' @param module `teal_module` object to be appended onto the children of `modules` |
||
| 16 | +96 |
- #'+ #' @return `teal_modules` object with `module` appended |
||
| 17 | +97 |
- #' @param data (`TealData` or `TealDataset` or `TealDatasetConnector` or `list` or `data.frame`+ append_module <- function(modules, module) {
|
||
| 18 | -+ | |||
| 98 | +7x |
- #' or `MultiAssayExperiment`)\cr+ checkmate::assert_class(modules, "teal_modules") |
||
| 19 | -+ | |||
| 99 | +5x |
- #' `R6` object as returned by [teal.data::cdisc_data()], [teal.data::teal_data()],+ checkmate::assert_class(module, "teal_module") |
||
| 20 | -+ | |||
| 100 | +3x |
- #' [teal.data::cdisc_dataset()], [teal.data::dataset()], [teal.data::dataset_connector()] or+ modules$children <- c(modules$children, list(module)) |
||
| 21 | -+ | |||
| 101 | +3x |
- #' [teal.data::cdisc_dataset_connector()] or a single `data.frame` or a `MultiAssayExperiment`+ labels <- vapply(modules$children, function(submodule) submodule$label, character(1)) |
||
| 22 | -+ | |||
| 102 | +3x |
- #' or a list of the previous objects or function returning a named list.+ names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
|
||
| 23 | -+ | |||
| 103 | +3x |
- #' NOTE: teal does not guarantee reproducibility of the code when names of the list elements+ modules |
||
| 24 | +104 |
- #' do not match the original object names. To ensure reproducibility please use [teal.data::teal_data()]+ } |
||
| 25 | +105 |
- #' or [teal.data::cdisc_data()] with `check = TRUE` enabled.+ |
||
| 26 | +106 |
- #' @param modules (`list`, `teal_modules` or `teal_module`)\cr+ #' Does the object make use of the `arg` |
||
| 27 | +107 |
- #' nested list of `teal_modules` or `teal_module` objects or a single+ #' |
||
| 28 | +108 |
- #' `teal_modules` or `teal_module` object. These are the specific output modules which+ #' @param modules (`teal_module` or `teal_modules`) object |
||
| 29 | +109 |
- #' will be displayed in the teal application. See [modules()] and [module()] for+ #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules. |
||
| 30 | +110 |
- #' more details.+ #' @return `logical` whether the object makes use of `arg` |
||
| 31 | +111 |
- #' @param title (`NULL` or `character`)\cr+ #' @rdname is_arg_used |
||
| 32 | +112 |
- #' The browser window title (defaults to the host URL of the page).+ #' @keywords internal |
||
| 33 | +113 |
- #' @param filter (`teal_slices`)\cr+ is_arg_used <- function(modules, arg) {
|
||
| 34 | -+ | |||
| 114 | +285x |
- #' Specification of initial filter. Filters can be specified using [teal::teal_slices()].+ checkmate::assert_string(arg) |
||
| 35 | -+ | |||
| 115 | +282x |
- #' Old way of specifying filters through a list is deprecated and will be removed in the+ if (inherits(modules, "teal_modules")) {
|
||
| 36 | -+ | |||
| 116 | +19x |
- #' next release. Please fix your applications to use [teal::teal_slices()].+ any(unlist(lapply(modules$children, is_arg_used, arg))) |
||
| 37 | -+ | |||
| 117 | +263x |
- #' @param header (`shiny.tag` or `character`) \cr+ } else if (inherits(modules, "teal_module")) {
|
||
| 38 | -+ | |||
| 118 | +32x |
- #' the header of the app. Note shiny code placed here (and in the footer+ is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg) |
||
| 39 | -+ | |||
| 119 | +231x |
- #' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function+ } else if (is.function(modules)) {
|
||
| 40 | -+ | |||
| 120 | +229x |
- #' (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here.+ isTRUE(arg %in% names(formals(modules))) |
||
| 41 | +121 |
- #' @param footer (`shiny.tag` or `character`)\cr+ } else {
|
||
| 42 | -+ | |||
| 122 | +2x |
- #' the footer of the app+ stop("is_arg_used function not implemented for this object")
|
||
| 43 | +123 |
- #' @param id (`character`)\cr+ } |
||
| 44 | +124 |
- #' module id to embed it, if provided,+ } |
||
| 45 | +125 |
- #' the server function must be called with [shiny::moduleServer()];+ |
||
| 46 | +126 |
- #' See the vignette for an example. However, [ui_teal_with_splash()]+ |
||
| 47 | +127 |
- #' is then preferred to this function.+ #' Creates a `teal_module` object. |
||
| 48 | +128 |
#' |
||
| 49 | -- |
- #' @return named list with `server` and `ui` function- |
- ||
| 50 | +129 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 51 | +130 |
- #' @export+ #' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module. |
||
| 52 | +131 |
#' |
||
| 53 | +132 |
- #' @include modules.R+ #' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except |
||
| 54 | +133 |
- #'+ #' `"global_filters"` - read more in `mapping` argument of [teal::teal_slices]. |
||
| 55 | +134 |
- #' @examples+ #' @param server (`function`) `shiny` module with following arguments: |
||
| 56 | +135 |
- #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ #' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]). |
||
| 57 | +136 |
- #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ #' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module. |
||
| 58 | +137 |
- #'+ #' - `data` (optional) module will receive a `tdata` object, a list of reactive (filtered) data specified in |
||
| 59 | +138 |
- #' app <- init(+ #' the `filters` argument. |
||
| 60 | +139 |
- #' data = teal_data(+ #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`). |
||
| 61 | +140 |
- #' dataset("new_iris", new_iris),
+ #' - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]). |
||
| 62 | +141 |
- #' dataset("new_mtcars", new_mtcars),
+ # - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]). |
||
| 63 | +142 |
- #' code = "+ #' - `...` (optional) `server_args` elements will be passed to the module named argument or to the `...`. |
||
| 64 | +143 |
- #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ #' @param ui (`function`) Shiny `ui` module function with following arguments: |
||
| 65 | +144 |
- #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ #' - `id` - teal will set proper shiny namespace for this module. |
||
| 66 | +145 |
- #' "+ #' - `data` (optional) module will receive list of reactive (filtered) data specified in the `filters` argument. |
||
| 67 | +146 |
- #' ),+ #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`). |
||
| 68 | +147 |
- #' modules = modules(+ #' - `...` (optional) `ui_args` elements will be passed to the module named argument or to the `...`. |
||
| 69 | +148 |
- #' module(+ #' @param filters (`character`) Deprecated. Use `datanames` instead. |
||
| 70 | +149 |
- #' label = "data source",+ #' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The |
||
| 71 | +150 |
- #' server = function(input, output, session, data) {},
+ #' filter panel will automatically update the shown filters to include only |
||
| 72 | +151 |
- #' ui = function(id, ...) div(p("information about data source")),
+ #' filters in the listed datasets. `NULL` will hide the filter panel, |
||
| 73 | +152 |
- #' datanames = "all"+ #' and the keyword `'all'` will show filters of all datasets. `datanames` also determines |
||
| 74 | +153 |
- #' ),+ #' a subset of datasets which are appended to the `data` argument in `server` function. |
||
| 75 | +154 |
- #' example_module(label = "example teal module"),+ #' @param server_args (named `list`) with additional arguments passed on to the |
||
| 76 | +155 |
- #' module(+ #' `server` function. |
||
| 77 | +156 |
- #' "Iris Sepal.Length histogram",+ #' @param ui_args (named `list`) with additional arguments passed on to the |
||
| 78 | +157 |
- #' server = function(input, output, session, data) {
+ #' `ui` function. |
||
| 79 | +158 |
- #' output$hist <- renderPlot(+ #' |
||
| 80 | +159 |
- #' hist(data[["new_iris"]]()$Sepal.Length)+ #' @return object of class `teal_module`. |
||
| 81 | +160 |
- #' )+ #' @export |
||
| 82 | +161 |
- #' },+ #' @examples |
||
| 83 | +162 |
- #' ui = function(id, ...) {
+ #' library(shiny) |
||
| 84 | +163 |
- #' ns <- NS(id)+ #' |
||
| 85 | +164 |
- #' plotOutput(ns("hist"))
+ #' app <- init( |
||
| 86 | +165 |
- #' },+ #' data = teal_data(dataset("iris", iris)),
|
||
| 87 | +166 |
- #' datanames = "new_iris"+ #' modules = list( |
||
| 88 | +167 |
- #' )+ #' module( |
||
| 89 | +168 |
- #' ),+ #' label = "Module", |
||
| 90 | +169 |
- #' title = "App title",+ #' server = function(id, data) {
|
||
| 91 | +170 |
- #' filter = teal_slices(+ #' moduleServer( |
||
| 92 | +171 |
- #' teal_slice(dataname = "new_iris", varname = "Species"),+ #' id, |
||
| 93 | +172 |
- #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),+ #' module = function(input, output, session) {
|
||
| 94 | +173 |
- #' teal_slice(dataname = "new_mtcars", varname = "cyl"),+ #' output$data <- renderDataTable(data[["iris"]]()) |
||
| 95 | +174 |
- #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
+ #' } |
||
| 96 | +175 |
- #' mapping = list(+ #' ) |
||
| 97 | +176 |
- #' `example teal module` = "new_iris Species",+ #' }, |
||
| 98 | +177 |
- #' `Iris Sepal.Length histogram` = "new_iris Species",+ #' ui = function(id) {
|
||
| 99 | +178 |
- #' global_filters = "new_mtcars cyl"+ #' ns <- NS(id) |
||
| 100 | +179 |
- #' )+ #' tagList(dataTableOutput(ns("data")))
|
||
| 101 | +180 |
- #' ),+ #' } |
||
| 102 | +181 |
- #' header = tags$h1("Sample App"),
+ #' ) |
||
| 103 | +182 |
- #' footer = tags$p("Copyright 2017 - 2023")
+ #' ) |
||
| 104 | +183 |
#' ) |
||
| 105 | +184 |
#' if (interactive()) {
|
||
| 106 | +185 |
- #' shinyApp(app$ui, app$server)+ #' runApp(app) |
||
| 107 | +186 |
#' } |
||
| 108 | +187 |
- #'+ module <- function(label = "module", |
||
| 109 | +188 |
- init <- function(data,+ server = function(id, ...) {
|
||
| 110 | -+ | |||
| 189 | +1x |
- modules,+ moduleServer(id, function(input, output, session) {}) # nolint
|
||
| 111 | +190 |
- title = NULL,+ }, |
||
| 112 | +191 |
- filter = teal_slices(),+ ui = function(id, ...) {
|
||
| 113 | -+ | |||
| 192 | +1x |
- header = tags$p(),+ tags$p(paste0("This module has no UI (id: ", id, " )"))
|
||
| 114 | +193 |
- footer = tags$p(),+ }, |
||
| 115 | +194 |
- id = character(0)) {
+ filters, |
||
| 116 | -38x | +|||
| 195 | +
- logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
+ datanames = "all", |
|||
| 117 | -38x | +|||
| 196 | +
- data <- teal.data::to_relational_data(data = data)+ server_args = NULL, |
|||
| 118 | +197 |
-
+ ui_args = NULL) {
|
||
| 119 | -33x | +198 | +109x |
- checkmate::assert_class(data, "TealData")+ checkmate::assert_string(label) |
| 120 | -33x | +199 | +106x |
- checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
+ checkmate::assert_function(server) |
| 121 | -33x | +200 | +106x |
- checkmate::assert_string(title, null.ok = TRUE)+ checkmate::assert_function(ui) |
| 122 | -33x | +201 | +106x |
- checkmate::assert(+ checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
| 123 | -33x | +202 | +105x |
- checkmate::check_class(filter, "teal_slices"),+ checkmate::assert_list(server_args, null.ok = TRUE, names = "named") |
| 124 | -33x | +203 | +103x |
- checkmate::check_list(filter, names = "named")+ checkmate::assert_list(ui_args, null.ok = TRUE, names = "named") |
| 125 | +204 |
- )+ |
||
| 126 | -32x | +205 | +101x |
- checkmate::assert_multi_class(header, c("shiny.tag", "character"))
+ if (!missing(filters)) {
|
| 127 | -32x | +|||
| 206 | +! |
- checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
+ checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
||
| 128 | -32x | +|||
| 207 | +! |
- checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ datanames <- filters |
||
| 129 | -+ | |||
| 208 | +! |
-
+ msg <- |
||
| 130 | -32x | +|||
| 209 | +! |
- teal.logger::log_system_info()+ "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."+ |
+ ||
| 210 | +! | +
+ logger::log_warn(msg)+ |
+ ||
| 211 | +! | +
+ warning(msg) |
||
| 131 | +212 |
-
+ } |
||
| 132 | -32x | +|||
| 213 | +
- if (inherits(modules, "teal_module")) {
+
|
|||
| 133 | -1x | +214 | +101x |
- modules <- list(modules)+ if (label == "global_filters") {
|
| 134 | -+ | |||
| 215 | +1x |
- }+ stop( |
||
| 135 | -32x | +216 | +1x |
- if (inherits(modules, "list")) {
+ sprintf("module(label = \"%s\", ...\n ", label),
|
| 136 | -2x | +217 | +1x |
- modules <- do.call(teal::modules, modules)+ "Label 'global_filters' is reserved in teal. Please change to something else.", |
| 137 | -+ | |||
| 218 | +1x |
- }+ call. = FALSE |
||
| 138 | +219 |
-
+ ) |
||
| 139 | +220 |
- # resolve modules datanames+ } |
||
| 140 | -32x | +221 | +100x |
- datanames <- teal.data::get_dataname(data)+ if (label == "Report previewer") {
|
| 141 | -32x | +|||
| 222 | +! |
- join_keys <- data$get_join_keys()+ stop( |
||
| 142 | -32x | +|||
| 223 | +! |
- resolve_modules_datanames <- function(modules) {
+ sprintf("module(label = \"%s\", ...\n ", label),
|
||
| 143 | -240x | +|||
| 224 | +! |
- if (inherits(modules, "teal_modules")) {
+ "Label 'Report previewer' is reserved in teal.", |
||
| 144 | -90x | +|||
| 225 | +! |
- modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE)+ call. = FALSE |
||
| 145 | -90x | +|||
| 226 | +
- modules+ ) |
|||
| 146 | +227 |
- } else {
+ } |
||
| 147 | -150x | +228 | +100x |
- modules$datanames <- if (identical(modules$datanames, "all")) {
+ server_formals <- names(formals(server)) |
| 148 | -5x | +229 | +100x |
- datanames+ if (!( |
| 149 | -150x | +230 | +100x |
- } else if (is.character(modules$datanames)) {
+ "id" %in% server_formals || |
| 150 | -145x | +231 | +100x |
- datanames_adjusted <- intersect(modules$datanames, datanames)+ all(c("input", "output", "session") %in% server_formals)
+ |
+
| 232 | ++ |
+ )) {
|
||
| 151 | -145x | +233 | +2x |
- include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)+ stop( |
| 152 | -+ | |||
| 234 | +2x |
- }+ "\nmodule() `server` argument requires a function with following arguments:", |
||
| 153 | -150x | +235 | +2x |
- modules+ "\n - id - teal will set proper shiny namespace for this module.", |
| 154 | -+ | |||
| 236 | +2x |
- }+ "\n - input, output, session (not recommended) - then shiny::callModule will be used to call a module.", |
||
| 155 | -+ | |||
| 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", |
||
| 156 | -32x | +239 | +2x |
- modules <- resolve_modules_datanames(modules = modules)+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`", |
| 157 | -+ | |||
| 240 | +2x |
-
+ "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`", |
||
| 158 | -32x | +241 | +2x |
- if (!inherits(filter, "teal_slices")) {
+ "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).", |
| 159 | -1x | +242 | +2x |
- checkmate::assert_subset(names(filter), choices = datanames)+ "\n - `...` server_args elements will be passed to the module named argument or to the `...`" |
| 160 | +243 |
- # list_to_teal_slices is lifted from teal.slice package, see zzz.R+ ) |
||
| 161 | +244 |
- # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).+ } |
||
| 162 | -1x | +|||
| 245 | +
- filter <- list_to_teal_slices(filter)+ |
|||
| 163 | -+ | |||
| 246 | +98x |
- }+ if (!is.element("data", server_formals) && !is.null(datanames)) {
|
||
| 164 | -+ | |||
| 247 | +64x |
- # convert teal.slice::teal_slices to teal::teal_slices+ message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
|
||
| 165 | -32x | +248 | +64x |
- filter <- as.teal_slices(as.list(filter))+ datanames <- NULL |
| 166 | +249 |
-
+ } |
||
| 167 | +250 |
- # check teal_slices+ |
||
| 168 | -32x | +251 | +98x |
- for (i in seq_along(filter)) {
+ srv_extra_args <- setdiff(names(server_args), server_formals) |
| 169 | -2x | +252 | +98x |
- dataname_i <- shiny::isolate(filter[[i]]$dataname)+ if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
|
| 170 | -2x | +253 | +1x |
- if (!dataname_i %in% datanames) {
+ stop( |
| 171 | -! | +|||
| 254 | +1x |
- stop(+ "\nFollowing `server_args` elements have no equivalent in the formals of the `server`:\n", |
||
| 172 | -! | +|||
| 255 | +1x |
- sprintf(+ paste(paste(" -", srv_extra_args), collapse = "\n"),
|
||
| 173 | -! | +|||
| 256 | +1x |
- "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s",+ "\n\nUpdate the `server` arguments by including above or add `...`" |
||
| 174 | -! | +|||
| 257 | +
- i,+ ) |
|||
| 175 | -! | +|||
| 258 | +
- dataname_i,+ } |
|||
| 176 | -! | +|||
| 259 | +
- toString(datanames)+ |
|||
| 177 | -+ | |||
| 260 | +97x |
- )+ ui_formals <- names(formals(ui)) |
||
| 178 | -+ | |||
| 261 | +97x |
- )+ if (!"id" %in% ui_formals) {
|
||
| 179 | -+ | |||
| 262 | +1x |
- }+ stop( |
||
| 180 | -+ | |||
| 263 | +1x |
- }+ "\nmodule() `ui` argument requires a function with following arguments:", |
||
| 181 | -+ | |||
| 264 | +1x |
-
+ "\n - id - teal will set proper shiny namespace for this module.", |
||
| 182 | -32x | +265 | +1x |
- if (isTRUE(attr(filter, "module_specific"))) {
+ "\n\nFollowing arguments can be used optionaly:", |
| 183 | -! | +|||
| 266 | +1x |
- module_names <- unlist(c(module_labels(modules), "global_filters"))+ "\n - `data` - module will receive list of reactive (filtered) data specied in the `filters` argument", |
||
| 184 | -! | +|||
| 267 | +1x |
- failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`", |
||
| 185 | -! | +|||
| 268 | +1x |
- if (length(failed_mod_names)) {
+ "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`" |
||
| 186 | -! | +|||
| 269 | +
- stop(+ ) |
|||
| 187 | -! | +|||
| 270 | +
- sprintf(+ } |
|||
| 188 | -! | +|||
| 271 | +
- "Some module names in the mapping arguments don't match module labels.\n %s not in %s",+ |
|||
| 189 | -! | +|||
| 272 | +96x |
- toString(failed_mod_names),+ ui_extra_args <- setdiff(names(ui_args), ui_formals) |
||
| 190 | -! | +|||
| 273 | +96x |
- toString(unique(module_names))+ if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
|
||
| 191 | -+ | |||
| 274 | +1x |
- )+ stop( |
||
| 192 | -+ | |||
| 275 | +1x |
- )+ "\nFollowing `ui_args` elements have no equivalent in the formals of `ui`:\n", |
||
| 193 | -+ | |||
| 276 | +1x |
- }+ paste(paste(" -", ui_extra_args), collapse = "\n"),
|
||
| 194 | -+ | |||
| 277 | +1x |
-
+ "\n\nUpdate the `ui` arguments by including above or add `...`" |
||
| 195 | -! | +|||
| 278 | +
- if (anyDuplicated(module_names)) {
+ ) |
|||
| 196 | +279 |
- # In teal we are able to set nested modules with duplicated label.+ } |
||
| 197 | +280 |
- # Because mapping argument bases on the relationship between module-label and filter-id,+ |
||
| 198 | -+ | |||
| 281 | +95x |
- # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)+ structure( |
||
| 199 | -! | +|||
| 282 | +95x |
- stop(+ list( |
||
| 200 | -! | +|||
| 283 | +95x |
- sprintf(+ label = label, |
||
| 201 | -! | +|||
| 284 | +95x |
- "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",+ server = server, ui = ui, datanames = datanames, |
||
| 202 | -! | +|||
| 285 | +95x |
- toString(module_names[duplicated(module_names)])+ server_args = server_args, ui_args = ui_args |
||
| 203 | +286 |
- )+ ), |
||
| 204 | -+ | |||
| 287 | +95x |
- )+ class = "teal_module" |
||
| 205 | +288 |
- }+ ) |
||
| 206 | +289 |
- }+ } |
||
| 207 | +290 | |||
| 208 | +291 |
- # Note regarding case `id = character(0)`:+ |
||
| 209 | +292 |
- # rather than using `callModule` and creating a submodule of this module, we directly modify+ #' Get module depth |
||
| 210 | +293 |
- # the `ui` and `server` with `id = character(0)` and calling the server function directly+ #' |
||
| 211 | +294 |
- # rather than through `callModule`- |
- ||
| 212 | -32x | -
- res <- list(- |
- ||
| 213 | -32x | -
- ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),- |
- ||
| 214 | -32x | -
- server = function(input, output, session) {
+ #' Depth starts at 0, so a single `teal.module` has depth 0. |
||
| 215 | +295 |
- # copy object so that load won't be shared between the session- |
- ||
| 216 | -! | -
- data <- data$copy(deep = TRUE)+ #' Nesting it increases overall depth by 1. |
||
| 217 | -! | +|||
| 296 | +
- filter <- deep_copy_filter(filter)+ #' |
|||
| 218 | -! | +|||
| 297 | +
- srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)+ #' @inheritParams init |
|||
| 219 | +298 |
- }+ #' @param depth optional, integer determining current depth level |
||
| 220 | +299 |
- )+ #' |
||
| 221 | -32x | +|||
| 300 | +
- logger::log_trace("init teal app has been initialized.")
+ #' @return depth level for given module |
|||
| 222 | -32x | +|||
| 301 | +
- return(res)+ #' @keywords internal |
|||
| 223 | +302 |
- }+ #' |
| 1 | +303 |
- #' Validate that dataset has a minimum number of observations+ #' @examples |
|
| 2 | +304 |
- #'+ #' mods <- modules( |
|
| 3 | +305 |
- #' @description `r lifecycle::badge("stable")`
+ #' label = "d1", |
|
| 4 | +306 |
- #' @param x a data.frame+ #' modules( |
|
| 5 | +307 |
- #' @param min_nrow minimum number of rows in \code{x}
+ #' label = "d2", |
|
| 6 | +308 |
- #' @param complete \code{logical} default \code{FALSE} when set to \code{TRUE} then complete cases are checked.
+ #' modules( |
|
| 7 | +309 |
- #' @param allow_inf \code{logical} default \code{TRUE} when set to \code{FALSE} then error thrown if any values are
+ #' label = "d3", |
|
| 8 | +310 |
- #' infinite.+ #' module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3") |
|
| 9 | +311 |
- #' @param msg (`character(1)`) additional message to display alongside the default message.+ #' ), |
|
| 10 | +312 |
- #'+ #' module(label = "bbb") |
|
| 11 | +313 |
- #' @details This function is a wrapper for `shiny::validate`.+ #' ), |
|
| 12 | +314 |
- #'+ #' module(label = "ccc") |
|
| 13 | +315 |
- #' @export+ #' ) |
|
| 14 | +316 |
- #'+ #' stopifnot(teal:::modules_depth(mods) == 3L) |
|
| 15 | +317 |
- #' @examples+ #' |
|
| 16 | +318 |
- #' library(teal)+ #' mods <- modules( |
|
| 17 | +319 |
- #' ui <- fluidPage(+ #' label = "a", |
|
| 18 | +320 |
- #' sliderInput("len", "Max Length of Sepal",
+ #' modules( |
|
| 19 | +321 |
- #' min = 4.3, max = 7.9, value = 5+ #' label = "b1", module(label = "c") |
|
| 20 | +322 |
#' ), |
|
| 21 | +323 |
- #' plotOutput("plot")
+ #' module(label = "b2") |
|
| 22 | +324 |
#' ) |
|
| 23 | +325 |
- #'+ #' stopifnot(teal:::modules_depth(mods) == 2L) |
|
| 24 | +326 |
- #' server <- function(input, output) {
+ modules_depth <- function(modules, depth = 0L) {
|
|
| 25 | -+ | ||
| 327 | +12x |
- #' output$plot <- renderPlot({
+ checkmate::assert( |
|
| 26 | -+ | ||
| 328 | +12x |
- #' df <- iris[iris$Sepal.Length <= input$len, ]+ checkmate::check_class(modules, "teal_module"), |
|
| 27 | -+ | ||
| 329 | +12x |
- #' validate_has_data(+ checkmate::check_class(modules, "teal_modules") |
|
| 28 | +330 |
- #' iris_f,+ ) |
|
| 29 | -+ | ||
| 331 | +12x |
- #' min_nrow = 10,+ checkmate::assert_int(depth, lower = 0) |
|
| 30 | -+ | ||
| 332 | +11x |
- #' complete = FALSE,+ if (inherits(modules, "teal_modules")) {
|
|
| 31 | -+ | ||
| 333 | +4x |
- #' msg = "Please adjust Max Length of Sepal"+ max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L)) |
|
| 32 | +334 |
- #' )+ } else {
+ |
+ |
| 335 | +7x | +
+ depth |
|
| 33 | +336 |
- #'+ } |
|
| 34 | +337 |
- #' hist(iris_f$Sepal.Length, breaks = 5)+ } |
|
| 35 | +338 |
- #' })+ |
|
| 36 | +339 |
- #' }+ |
|
| 37 | +340 |
- #' if (interactive()) {
+ module_labels <- function(modules) {
+ |
+ |
| 341 | +! | +
+ if (inherits(modules, "teal_modules")) {
+ |
+ |
| 342 | +! | +
+ lapply(modules$children, module_labels) |
|
| 38 | +343 |
- #' shinyApp(ui, server)+ } else {
+ |
+ |
| 344 | +! | +
+ modules$label |
|
| 39 | +345 |
- #' }+ } |
|
| 40 | +346 |
- #'+ } |
|
| 41 | +347 |
- validate_has_data <- function(x,+ |
|
| 42 | +348 |
- min_nrow = NULL,+ #' Converts `teal_modules` to a string |
|
| 43 | +349 |
- complete = FALSE,+ #' |
|
| 44 | +350 |
- allow_inf = TRUE,+ #' @param x (`teal_modules`) to print |
|
| 45 | +351 |
- msg = NULL) {
+ #' @param indent (`integer`) indent level; |
|
| 46 | -17x | +||
| 352 | +
- stopifnot(+ #' each `submodule` is indented one level more |
||
| 47 | -17x | +||
| 353 | +
- "Please provide a character vector in msg argument of validate_has_data." = is.character(msg) || is.null(msg)+ #' @param ... (optional) additional parameters to pass to recursive calls of `toString` |
||
| 48 | +354 |
- )+ #' @return (`character`) |
|
| 49 | -15x | +||
| 355 | +
- validate(need(!is.null(x) && is.data.frame(x), "No data left."))+ #' @export |
||
| 50 | -15x | +||
| 356 | +
- if (!is.null(min_nrow)) {
+ #' @rdname modules |
||
| 51 | -15x | +||
| 357 | +
- if (complete) {
+ toString.teal_modules <- function(x, indent = 0, ...) { # nolint
|
||
| 52 | -5x | +||
| 358 | +
- complete_index <- stats::complete.cases(x)+ # argument must be `x` to be consistent with base method |
||
| 53 | -5x | +||
| 359 | +! |
- validate(need(+ paste(c( |
|
| 54 | -5x | +||
| 360 | +! |
- sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,+ paste0(rep(" ", indent), "+ ", x$label),
|
|
| 55 | -5x | +||
| 361 | +! |
- paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
+ unlist(lapply(x$children, toString, indent = indent + 1, ...)) |
|
| 56 | -+ | ||
| 362 | +! |
- ))+ ), collapse = "\n") |
|
| 57 | +363 |
- } else {
+ } |
|
| 58 | -10x | +||
| 364 | +
- validate(need(+ |
||
| 59 | -10x | +||
| 365 | +
- nrow(x) >= min_nrow,+ #' Converts `teal_module` to a string |
||
| 60 | -10x | +||
| 366 | +
- paste(+ #' |
||
| 61 | -10x | +||
| 367 | +
- c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
+ #' @inheritParams toString.teal_modules |
||
| 62 | -10x | +||
| 368 | +
- collapse = "\n"+ #' @param x `teal_module` |
||
| 63 | +369 |
- )+ #' @param ... ignored |
|
| 64 | +370 |
- ))+ #' @export |
|
| 65 | +371 |
- }+ #' @rdname module |
|
| 66 | +372 |
-
+ toString.teal_module <- function(x, indent = 0, ...) { # nolint
|
|
| 67 | -10x | +||
| 373 | +! |
- if (!allow_inf) {
+ paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
|
|
| 68 | -6x | +||
| 374 | +
- validate(need(+ } |
||
| 69 | -6x | +||
| 375 | +
- all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))),+ |
||
| 70 | -6x | +||
| 376 | +
- "Dataframe contains Inf values which is not allowed."+ #' Prints `teal_modules` |
||
| 71 | +377 |
- ))+ #' @param x `teal_modules` |
|
| 72 | +378 |
- }+ #' @param ... parameters passed to `toString` |
|
| 73 | +379 |
- }+ #' @export |
|
| 74 | +380 |
- }+ #' @rdname modules |
|
| 75 | +381 |
-
+ print.teal_modules <- function(x, ...) {
+ |
+ |
| 382 | +! | +
+ s <- toString(x, ...)+ |
+ |
| 383 | +! | +
+ cat(s)+ |
+ |
| 384 | +! | +
+ return(invisible(s)) |
|
| 76 | +385 |
- #' Validate that dataset has unique rows for key variables+ } |
|
| 77 | +386 |
- #'+ |
|
| 78 | +387 |
- #' @description `r lifecycle::badge("stable")`
+ #' Prints `teal_module` |
|
| 79 | +388 |
- #' @param x a data.frame+ #' @param x `teal_module` |
|
| 80 | +389 |
- #' @param key a vector of ID variables from \code{x} that identify unique records
+ #' @param ... parameters passed to `toString` |
|
| 81 | +390 |
- #'+ #' @export |
|
| 82 | +391 |
- #' @details This function is a wrapper for `shiny::validate`.+ #' @rdname module |
|
| 83 | +392 |
- #'+ print.teal_module <- print.teal_modules |
| 84 | +1 |
- #' @export+ #' Filter manager modal |
|
| 85 | +2 |
#' |
|
| 86 | +3 |
- #' @examples+ #' Opens modal containing the filter manager UI. |
|
| 87 | +4 |
- #' iris$id <- rep(1:50, times = 3)+ #' |
|
| 88 | +5 |
- #' ui <- fluidPage(+ #' @name module_filter_manager_modal |
|
| 89 | +6 |
- #' selectInput(+ #' @inheritParams filter_manager_srv |
|
| 90 | +7 |
- #' inputId = "species",+ #' @examples |
|
| 91 | +8 |
- #' label = "Select species",+ #' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris))) |
|
| 92 | +9 |
- #' choices = c("setosa", "versicolor", "virginica"),
+ #' fd2 <- teal.slice::init_filtered_data( |
|
| 93 | +10 |
- #' selected = "setosa",+ #' list(iris = list(dataset = iris), mtcars = list(dataset = mtcars)) |
|
| 94 | +11 |
- #' multiple = TRUE+ #' ) |
|
| 95 | +12 |
- #' ),+ #' fd3 <- teal.slice::init_filtered_data( |
|
| 96 | +13 |
- #' plotOutput("plot")
+ #' list(iris = list(dataset = iris), women = list(dataset = women)) |
|
| 97 | +14 |
#' ) |
|
| 98 | +15 |
- #' server <- function(input, output) {
+ #' filter <- teal_slices( |
|
| 99 | +16 |
- #' output$plot <- renderPlot({
+ #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length"), |
|
| 100 | +17 |
- #' iris_f <- iris[iris$Species %in% input$species, ]+ #' teal.slice::teal_slice(dataname = "iris", varname = "Species"), |
|
| 101 | +18 |
- #' validate_one_row_per_id(iris_f, key = c("id"))
+ #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg"), |
|
| 102 | +19 |
- #'+ #' teal.slice::teal_slice(dataname = "women", varname = "height"), |
|
| 103 | +20 |
- #' hist(iris_f$Sepal.Length, breaks = 5)+ #' mapping = list( |
|
| 104 | +21 |
- #' })+ #' module2 = c("mtcars mpg"),
|
|
| 105 | +22 |
- #' }+ #' module3 = c("women height"),
|
|
| 106 | +23 |
- #' if (interactive()) {
+ #' global_filters = "iris Species" |
|
| 107 | +24 |
- #' shinyApp(ui, server)+ #' ) |
|
| 108 | +25 |
- #' }+ #' ) |
|
| 109 | +26 |
#' |
|
| 110 | +27 |
- validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
+ #' app <- shinyApp( |
|
| 111 | -! | +||
| 28 | +
- validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
+ #' ui = fluidPage( |
||
| 112 | +29 |
- }+ #' teal:::filter_manager_modal_ui("manager")
|
|
| 113 | +30 |
-
+ #' ), |
|
| 114 | +31 |
- #' Validates that vector includes all expected values+ #' server = function(input, output, session) {
|
|
| 115 | +32 |
- #'+ #' teal:::filter_manager_modal_srv( |
|
| 116 | +33 |
- #' @description `r lifecycle::badge("stable")`
+ #' "manager", |
|
| 117 | +34 |
- #' @param x values to test. All must be in \code{choices}
+ #' filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3), |
|
| 118 | +35 |
- #' @param choices a vector to test for values of \code{x}
+ #' filter = filter |
|
| 119 | +36 |
- #' @param msg warning message to display+ #' ) |
|
| 120 | +37 |
- #'+ #' } |
|
| 121 | +38 |
- #' @details This function is a wrapper for `shiny::validate`.+ #' ) |
|
| 122 | +39 |
- #'+ #' if (interactive()) {
|
|
| 123 | +40 |
- #' @export+ #' runApp(app) |
|
| 124 | +41 |
- #'+ #' } |
|
| 125 | +42 |
- #' @examples+ #' |
|
| 126 | +43 |
- #' ui <- fluidPage(+ #' @keywords internal |
|
| 127 | +44 |
- #' selectInput(+ #' |
|
| 128 | +45 |
- #' "species",+ NULL |
|
| 129 | +46 |
- #' "Select species",+ |
|
| 130 | +47 |
- #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
+ #' @rdname module_filter_manager_modal |
|
| 131 | +48 |
- #' selected = "setosa",+ filter_manager_modal_ui <- function(id) {
|
|
| 132 | -+ | ||
| 49 | +1x |
- #' multiple = FALSE+ ns <- NS(id) |
|
| 133 | -+ | ||
| 50 | +1x |
- #' ),+ tags$button( |
|
| 134 | -+ | ||
| 51 | +1x |
- #' verbatimTextOutput("summary")
+ id = ns("show"),
|
|
| 135 | -+ | ||
| 52 | +1x |
- #' )+ class = "btn action-button filter_manager_button", |
|
| 136 | -+ | ||
| 53 | +1x |
- #'+ title = "Show filters manager modal", |
|
| 137 | -+ | ||
| 54 | +1x |
- #' server <- function(input, output) {
+ icon("gear")
|
|
| 138 | +55 |
- #' output$summary <- renderPrint({
+ ) |
|
| 139 | +56 |
- #' validate_in(input$species, iris$Species, "Species does not exist.")+ } |
|
| 140 | +57 |
- #' nrow(iris[iris$Species == input$species, ])+ |
|
| 141 | +58 |
- #' })+ #' @rdname module_filter_manager_modal |
|
| 142 | +59 |
- #' }+ filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
|
|
| 143 | -+ | ||
| 60 | +4x |
- #' if (interactive()) {
+ moduleServer(id, function(input, output, session) {
|
|
| 144 | -+ | ||
| 61 | +4x |
- #' shinyApp(ui, server)+ observeEvent(input$show, {
|
|
| 145 | -+ | ||
| 62 | +! |
- #' }+ logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
|
|
| 146 | -+ | ||
| 63 | +! |
- #'+ showModal( |
|
| 147 | -+ | ||
| 64 | +! |
- validate_in <- function(x, choices, msg) {
+ modalDialog( |
|
| 148 | +65 | ! |
- validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg))+ filter_manager_ui(session$ns("filter_manager")),
|
| 149 | -+ | ||
| 66 | +! |
- }+ size = "l", |
|
| 150 | -+ | ||
| 67 | +! |
-
+ footer = NULL, |
|
| 151 | -+ | ||
| 68 | +! |
- #' Validates that vector has length greater than 0+ easyClose = TRUE |
|
| 152 | +69 |
- #'+ ) |
|
| 153 | +70 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
|
| 154 | +71 |
- #' @param x vector+ }) |
|
| 155 | +72 |
- #' @param msg message to display+ |
|
| 156 | -+ | ||
| 73 | +4x |
- #'+ filter_manager_srv("filter_manager", filtered_data_list, filter)
|
|
| 157 | +74 |
- #' @details This function is a wrapper for `shiny::validate`.+ }) |
|
| 158 | +75 |
- #'+ } |
|
| 159 | +76 |
- #' @export+ |
|
| 160 | +77 |
- #'+ #' @rdname module_filter_manager |
|
| 161 | +78 |
- #' @examples+ filter_manager_ui <- function(id) {
|
|
| 162 | -+ | ||
| 79 | +! |
- #' data <- data.frame(+ ns <- NS(id) |
|
| 163 | -+ | ||
| 80 | +! |
- #' id = c(1:10, 11:20, 1:10),+ div( |
|
| 164 | -+ | ||
| 81 | +! |
- #' strata = rep(c("A", "B"), each = 15)
+ class = "filter_manager_content", |
|
| 165 | -+ | ||
| 82 | +! |
- #' )+ tableOutput(ns("slices_table")),
|
|
| 166 | -+ | ||
| 83 | +! |
- #' ui <- fluidPage(+ snapshot_manager_ui(ns("snapshot_manager"))
|
|
| 167 | +84 |
- #' selectInput("ref1", "Select strata1 to compare",
+ ) |
|
| 168 | +85 |
- #' choices = c("A", "B", "C"), selected = "A"
+ } |
|
| 169 | +86 |
- #' ),+ |
|
| 170 | +87 |
- #' selectInput("ref2", "Select strata2 to compare",
+ #' Manage multiple `FilteredData` objects |
|
| 171 | +88 |
- #' choices = c("A", "B", "C"), selected = "B"
+ #' |
|
| 172 | +89 |
- #' ),+ #' Oversee filter states in the whole application. |
|
| 173 | +90 |
- #' verbatimTextOutput("arm_summary")
+ #' |
|
| 174 | +91 |
- #' )+ #' @rdname module_filter_manager |
|
| 175 | +92 |
- #'+ #' @details |
|
| 176 | +93 |
- #' server <- function(input, output) {
+ #' This module observes the changes of the filters in each `FilteredData` object |
|
| 177 | +94 |
- #' output$arm_summary <- renderText({
+ #' and keeps track of all filters used. A mapping of filters to modules |
|
| 178 | +95 |
- #' sample_1 <- data$id[data$strata == input$ref1]+ #' is kept in the `mapping_matrix` object (which is actually a `data.frame`) |
|
| 179 | +96 |
- #' sample_2 <- data$id[data$strata == input$ref2]+ #' that tracks which filters (rows) are active in which modules (columns). |
|
| 180 | +97 |
#' |
|
| 181 | +98 |
- #' validate_has_elements(sample_1, "No subjects in strata1.")+ #' @param id (`character(1)`)\cr |
|
| 182 | +99 |
- #' validate_has_elements(sample_2, "No subjects in strata2.")+ #' `shiny` module id. |
|
| 183 | +100 |
- #'+ #' @param filtered_data_list (`named list`)\cr |
|
| 184 | +101 |
- #' paste0(+ #' A list, possibly nested, of `FilteredData` objects. |
|
| 185 | +102 |
- #' "Number of samples in: strata1=", length(sample_1),+ #' Each `FilteredData` will be served to one module in the `teal` application. |
|
| 186 | +103 |
- #' " comparions strata2=", length(sample_2)+ #' The structure of the list must reflect the nesting of modules in tabs |
|
| 187 | +104 |
- #' )+ #' and names of the list must be the same as labels of their respective modules. |
|
| 188 | +105 |
- #' })+ #' @inheritParams init |
|
| 189 | +106 |
- #' }+ #' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`. |
|
| 190 | +107 |
- #' if (interactive()) {
+ #' @keywords internal |
|
| 191 | +108 |
- #' shinyApp(ui, server)+ #' |
|
| 192 | +109 |
- #' }+ filter_manager_srv <- function(id, filtered_data_list, filter) {
+ |
+ |
| 110 | +6x | +
+ moduleServer(id, function(input, output, session) {
+ |
+ |
| 111 | +6x | +
+ logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
|
|
| 193 | +112 |
- validate_has_elements <- function(x, msg) {
+
|
|
| 194 | -! | +||
| 113 | +6x |
- validate(need(length(x) > 0, msg))+ is_module_specific <- isTRUE(attr(filter, "module_specific")) |
|
| 195 | +114 |
- }+ |
|
| 196 | +115 |
-
+ # Create global list of slices. |
|
| 197 | +116 |
- #' Validates no intersection between two vectors+ # Contains all available teal_slice objects available to all modules. |
|
| 198 | +117 |
- #'+ # Passed whole to instances of FilteredData used for individual modules. |
|
| 199 | +118 |
- #' @description `r lifecycle::badge("stable")`
+ # Down there a subset that pertains to the data sets used in that module is applied and displayed.+ |
+ |
| 119 | +6x | +
+ slices_global <- reactiveVal(filter) |
|
| 200 | +120 |
- #' @param x vector+ + |
+ |
| 121 | +6x | +
+ filtered_data_list <-+ |
+ |
| 122 | +6x | +
+ if (!is_module_specific) {
|
|
| 201 | +123 |
- #' @param y vector+ # Retrieve the first FilteredData from potentially nested list. |
|
| 202 | +124 |
- #' @param msg message to display if \code{x} and \code{y} intersect
+ # List of length one is named "global_filters" because that name is forbidden for a module label.+ |
+ |
| 125 | +5x | +
+ list(global_filters = unlist(filtered_data_list)[[1]]) |
|
| 203 | +126 |
- #'+ } else {
|
|
| 204 | +127 |
- #' @details This function is a wrapper for `shiny::validate`.+ # Flatten potentially nested list of FilteredData objects while maintaining useful names. |
|
| 205 | +128 |
- #'+ # Simply using `unlist` would result in concatenated names. |
|
| 206 | -+ | ||
| 129 | +1x |
- #' @export+ flatten_nested <- function(x, name = NULL) {
|
|
| 207 | -+ | ||
| 130 | +5x |
- #'+ if (inherits(x, "FilteredData")) {
|
|
| 208 | -+ | ||
| 131 | +3x |
- #' @examples+ setNames(list(x), name) |
|
| 209 | +132 |
- #' data <- data.frame(+ } else {
|
|
| 210 | -+ | ||
| 133 | +2x |
- #' id = c(1:10, 11:20, 1:10),+ unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name))) |
|
| 211 | +134 |
- #' strata = rep(c("A", "B", "C"), each = 10)
+ } |
|
| 212 | +135 |
- #' )+ } |
|
| 213 | -+ | ||
| 136 | +1x |
- #'+ flatten_nested(filtered_data_list) |
|
| 214 | +137 |
- #' ui <- fluidPage(+ } |
|
| 215 | +138 |
- #' selectInput("ref1", "Select strata1 to compare",
+
|
|
| 216 | +139 |
- #' choices = c("A", "B", "C"),
+ # Create mapping fo filters to modules in matrix form (presented as data.frame). |
|
| 217 | +140 |
- #' selected = "A"+ # Modules get NAs for filteres that cannot be set for them. |
|
| 218 | -+ | ||
| 141 | +6x |
- #' ),+ mapping_matrix <- reactive({
|
|
| 219 | -+ | ||
| 142 | +6x |
- #' selectInput("ref2", "Select strata2 to compare",
+ state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id") |
|
| 220 | -+ | ||
| 143 | +6x |
- #' choices = c("A", "B", "C"),
+ mapping_smooth <- lapply(filtered_data_list, function(x) {
|
|
| 221 | -+ | ||
| 144 | +8x |
- #' selected = "B"+ state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id") |
|
| 222 | -+ | ||
| 145 | +8x |
- #' ),+ state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id") |
|
| 223 | -+ | ||
| 146 | +8x |
- #' verbatimTextOutput("summary")
+ states_active <- state_ids_global %in% state_ids_local |
|
| 224 | -+ | ||
| 147 | +8x |
- #' )+ ifelse(state_ids_global %in% state_ids_allowed, states_active, NA) |
|
| 225 | +148 |
- #'+ }) |
|
| 226 | +149 |
- #' server <- function(input, output) {
+
|
|
| 227 | -+ | ||
| 150 | +6x |
- #' output$summary <- renderText({
+ as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE) |
|
| 228 | +151 |
- #' sample_1 <- data$id[data$strata == input$ref1]+ }) |
|
| 229 | +152 |
- #' sample_2 <- data$id[data$strata == input$ref2]+ |
|
| 230 | -+ | ||
| 153 | +6x |
- #'+ output$slices_table <- renderTable( |
|
| 231 | -+ | ||
| 154 | +6x |
- #' validate_no_intersection(+ expr = {
|
|
| 232 | +155 |
- #' sample_1, sample_2,+ # Display logical values as UTF characters. |
|
| 233 | -+ | ||
| 156 | +3x |
- #' "subjects within strata1 and strata2 cannot overlap"+ mm <- mapping_matrix() |
|
| 234 | -+ | ||
| 157 | +3x |
- #' )+ mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060)) |
|
| 235 | -+ | ||
| 158 | +3x |
- #' paste0(+ mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x)) |
|
| 236 | -+ | ||
| 159 | +3x |
- #' "Number of subject in: reference treatment=", length(sample_1),+ if (!is_module_specific) colnames(mm) <- "Global Filters" |
|
| 237 | +160 |
- #' " comparions treatment=", length(sample_2)+ |
|
| 238 | +161 |
- #' )+ # Display placeholder if no filters defined. |
|
| 239 | -+ | ||
| 162 | +3x |
- #' })+ if (nrow(mm) == 0L) {
|
|
| 240 | -+ | ||
| 163 | +3x |
- #' }+ mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE) |
|
| 241 | -+ | ||
| 164 | +3x |
- #' if (interactive()) {
+ rownames(mm) <- "" |
|
| 242 | +165 |
- #' shinyApp(ui, server)+ } |
|
| 243 | +166 |
- #' }+ |
|
| 244 | +167 |
- #'+ # Report Previewer will not be displayed.+ |
+ |
| 168 | +3x | +
+ mm[names(mm) != "Report previewer"] |
|
| 245 | +169 |
- validate_no_intersection <- function(x, y, msg) {
+ }, |
|
| 246 | -! | +||
| 170 | +6x |
- validate(need(length(intersect(x, y)) == 0, msg))+ align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
|
|
| 247 | -+ | ||
| 171 | +6x |
- }+ rownames = TRUE |
|
| 248 | +172 |
-
+ ) |
|
| 249 | +173 | ||
| 250 | +174 |
- #' Validates that dataset contains specific variable+ # Create list of module calls. |
|
| 251 | -+ | ||
| 175 | +6x |
- #'+ modules_out <- lapply(names(filtered_data_list), function(module_name) {
|
|
| 252 | -+ | ||
| 176 | +8x |
- #' @description `r lifecycle::badge("stable")`
+ filter_manager_module_srv( |
|
| 253 | -+ | ||
| 177 | +8x |
- #' @param data a data.frame+ id = module_name, |
|
| 254 | -+ | ||
| 178 | +8x |
- #' @param varname name of variable in \code{data}
+ module_fd = filtered_data_list[[module_name]], |
|
| 255 | -+ | ||
| 179 | +8x |
- #' @param msg message to display if \code{data} does not include \code{varname}
+ slices_global = slices_global |
|
| 256 | +180 |
- #'+ ) |
|
| 257 | +181 |
- #' @details This function is a wrapper for `shiny::validate`.+ }) |
|
| 258 | +182 |
- #'+ |
|
| 259 | +183 |
- #' @export+ # Call snapshot manager. |
|
| 260 | -+ | ||
| 184 | +6x |
- #'+ snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
|
|
| 261 | +185 |
- #' @examples+ |
|
| 262 | -+ | ||
| 186 | +6x |
- #' data <- data.frame(+ modules_out # returned for testing purpose |
|
| 263 | +187 |
- #' one = rep("a", length.out = 20),
+ }) |
|
| 264 | +188 |
- #' two = rep(c("a", "b"), length.out = 20)
+ } |
|
| 265 | +189 |
- #' )+ |
|
| 266 | +190 |
- #' ui <- fluidPage(+ #' Module specific filter manager |
|
| 267 | +191 |
- #' selectInput(+ #' |
|
| 268 | +192 |
- #' "var",+ #' Track filter states in single module. |
|
| 269 | +193 |
- #' "Select variable",+ #' |
|
| 270 | +194 |
- #' choices = c("one", "two", "three", "four"),
+ #' This module tracks the state of a single `FilteredData` object and global `teal_slices` |
|
| 271 | +195 |
- #' selected = "one"+ #' and updates both objects as necessary. Filter states added in different modules |
|
| 272 | +196 |
- #' ),+ #' Filter states added any individual module are added to global `teal_slices` |
|
| 273 | +197 |
- #' verbatimTextOutput("summary")
+ #' and from there become available in other modules |
|
| 274 | +198 |
- #' )+ #' by setting `private$available_teal_slices` in each `FilteredData`. |
|
| 275 | +199 |
#' |
|
| 276 | +200 |
- #' server <- function(input, output) {
+ #' @param id (`character(1)`)\cr |
|
| 277 | +201 |
- #' output$summary <- renderText({
+ #' `shiny` module id. |
|
| 278 | +202 |
- #' validate_has_variable(data, input$var)+ #' @param module_fd (`FilteredData`)\cr |
|
| 279 | +203 |
- #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
+ #' object to filter data in the teal-module |
|
| 280 | +204 |
- #' })+ #' @param slices_global (`reactiveVal`)\cr |
|
| 281 | +205 |
- #' }+ #' stores `teal_slices` with all available filters; allows the following actions: |
|
| 282 | +206 |
- #' if (interactive()) {
+ #' - to disable/enable a specific filter in a module |
|
| 283 | +207 |
- #' shinyApp(ui, server)+ #' - to restore saved filter settings |
|
| 284 | +208 |
- #' }+ #' - to save current filter panel settings |
|
| 285 | +209 |
- validate_has_variable <- function(data, varname, msg) {
+ #' @return A `reactive` expression containing the slices active in this module. |
|
| 286 | -! | +||
| 210 | +
- if (length(varname) != 0) {
+ #' @keywords internal |
||
| 287 | -! | +||
| 211 | +
- has_vars <- varname %in% names(data)+ #' |
||
| 288 | +212 |
-
+ filter_manager_module_srv <- function(id, module_fd, slices_global) {
|
|
| 289 | -! | +||
| 213 | +8x |
- if (!all(has_vars)) {
+ moduleServer(id, function(input, output, session) {
|
|
| 290 | -! | +||
| 214 | +
- if (missing(msg)) {
+ # Only operate on slices that refer to data sets present in this module. |
||
| 291 | -! | +||
| 215 | +8x |
- msg <- sprintf(+ module_fd$set_available_teal_slices(reactive(slices_global())) |
|
| 292 | -! | +||
| 216 | +
- "%s does not have the required variables: %s.",+ |
||
| 293 | -! | +||
| 217 | +
- deparse(substitute(data)),+ # Track filter state of this module. |
- ||
| 294 | -! | +||
| 218 | +8x |
- toString(varname[!has_vars])+ slices_module <- reactive(module_fd$get_filter_state()) |
|
| 295 | +219 |
- )+ |
|
| 296 | +220 |
- }+ # Reactive values for comparing states. |
|
| 297 | -! | +||
| 221 | +8x |
- validate(need(FALSE, msg))+ previous_slices <- reactiveVal(isolate(slices_module())) |
|
| 298 | -+ | ||
| 222 | +8x |
- }+ slices_added <- reactiveVal(NULL) |
|
| 299 | +223 |
- }+ |
|
| 300 | +224 |
- }+ # Observe changes in module filter state and trigger appropriate actions. |
|
| 301 | -+ | ||
| 225 | +8x |
-
+ observeEvent(slices_module(), ignoreNULL = FALSE, {
|
|
| 302 | -+ | ||
| 226 | +3x |
- #' Validate that variables has expected number of levels+ logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
|
|
| 303 | -+ | ||
| 227 | +3x |
- #'+ added <- setdiff_teal_slices(slices_module(), slices_global()) |
|
| 304 | -+ | ||
| 228 | +! |
- #' @description `r lifecycle::badge("stable")`
+ if (length(added)) slices_added(added) |
|
| 305 | -+ | ||
| 229 | +3x |
- #' @param x variable name. If \code{x} is not a factor, the unique values
+ previous_slices(slices_module()) |
|
| 306 | +230 |
- #' are treated as levels.+ }) |
|
| 307 | +231 |
- #' @param min_levels cutoff for minimum number of levels of \code{x}
+
|
|
| 308 | -+ | ||
| 232 | +8x |
- #' @param max_levels cutoff for maximum number of levels of \code{x}
+ observeEvent(slices_added(), ignoreNULL = TRUE, {
|
|
| 309 | -+ | ||
| 233 | +! |
- #' @param var_name name of variable being validated for use in+ logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
|
|
| 310 | +234 |
- #' validation message+ # In case the new state has the same id as an existing state, add a suffix to it. |
|
| 311 | -+ | ||
| 235 | +! |
- #'+ global_ids <- vapply(slices_global(), `[[`, character(1L), "id") |
|
| 312 | -+ | ||
| 236 | +! |
- #' @details If the number of levels of \code{x} is less than \code{min_levels}
+ lapply( |
|
| 313 | -+ | ||
| 237 | +! |
- #' or greater than \code{max_levels} the validation will fail.
+ slices_added(), |
|
| 314 | -+ | ||
| 238 | +! |
- #' This function is a wrapper for `shiny::validate`.+ function(slice) {
|
|
| 315 | -+ | ||
| 239 | +! |
- #'+ if (slice$id %in% global_ids) {
|
|
| 316 | -+ | ||
| 240 | +! |
- #' @export+ slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1) |
|
| 317 | +241 |
- #' @examples+ } |
|
| 318 | +242 |
- #' data <- data.frame(+ } |
|
| 319 | +243 |
- #' one = rep("a", length.out = 20),
+ ) |
|
| 320 | -+ | ||
| 244 | +! |
- #' two = rep(c("a", "b"), length.out = 20),
+ slices_global_new <- c(slices_global(), slices_added()) |
|
| 321 | -+ | ||
| 245 | +! |
- #' three = rep(c("a", "b", "c"), length.out = 20),
+ slices_global(slices_global_new)+ |
+ |
| 246 | +! | +
+ slices_added(NULL) |
|
| 322 | +247 |
- #' four = rep(c("a", "b", "c", "d"), length.out = 20),
+ }) |
|
| 323 | +248 |
- #' stringsAsFactors = TRUE+ + |
+ |
| 249 | +8x | +
+ slices_module # returned for testing purpose |
|
| 324 | +250 |
- #' )+ }) |
|
| 325 | +251 |
- #' ui <- fluidPage(+ } |
| 326 | +1 |
- #' selectInput(+ # This file contains Shiny modules useful for debugging and developing teal. |
|
| 327 | +2 |
- #' "var",+ # We do not export the functions in this file. They are for |
|
| 328 | +3 |
- #' "Select variable",+ # developers only and can be accessed via `:::`. |
|
| 329 | +4 |
- #' choices = c("one", "two", "three", "four"),
+
|
|
| 330 | +5 |
- #' selected = "one"+ #' Dummy module to show the filter calls generated by the right encoding panel |
|
| 331 | +6 |
- #' ),+ #' |
|
| 332 | +7 |
- #' verbatimTextOutput("summary")
+ #' |
|
| 333 | +8 |
- #' )+ #' Please do not remove, this is useful for debugging teal without |
|
| 334 | +9 |
- #'+ #' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
|
|
| 335 | +10 |
- #' server <- function(input, output) {
+ #' and avoids session restarts! |
|
| 336 | +11 |
- #' output$summary <- renderText({
+ #' |
|
| 337 | +12 |
- #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var)+ #' @param label `character` label of module |
|
| 338 | +13 |
- #' paste0(+ #' @keywords internal |
|
| 339 | +14 |
- #' "Levels of selected treatment variable: ",+ #' |
|
| 340 | +15 |
- #' paste(levels(data[[input$var]]),+ #' @examples |
|
| 341 | +16 |
- #' collapse = ", "+ #' app <- init( |
|
| 342 | +17 |
- #' )+ #' data = list(iris = iris, mtcars = mtcars), |
|
| 343 | +18 |
- #' )+ #' modules = teal:::filter_calls_module(), |
|
| 344 | +19 |
- #' })+ #' header = "Simple teal app" |
|
| 345 | +20 |
- #' }+ #' ) |
|
| 346 | +21 |
#' if (interactive()) {
|
|
| 347 | +22 |
- #' shinyApp(ui, server)+ #' runApp(app) |
|
| 348 | +23 |
#' } |
|
| 349 | +24 |
- validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
- |
- |
| 350 | -! | -
- x_levels <- if (is.factor(x)) {
+ filter_calls_module <- function(label = "Filter Calls Module") { # nolint
|
|
| 351 | +25 | ! |
- levels(x)+ checkmate::assert_string(label) |
| 352 | +26 |
- } else {
+
|
|
| 353 | +27 | ! |
- unique(x)- |
-
| 354 | -- |
- }- |
- |
| 355 | -- |
-
+ module( |
|
| 356 | +28 | ! |
- if (!is.null(min_levels) && !(is.null(max_levels))) {
+ label = label, |
| 357 | +29 | ! |
- validate(need(+ server = function(input, output, session, data) {
|
| 358 | +30 | ! |
- length(x_levels) >= min_levels && length(x_levels) <= max_levels,+ checkmate::assert_class(data, "tdata") |
| 359 | -! | +||
| 31 | +
- sprintf(+ |
||
| 360 | +32 | ! |
- "%s variable needs minimum %s level(s) and maximum %s level(s).",+ output$filter_calls <- renderText({
|
| 361 | +33 | ! |
- var_name, min_levels, max_levels+ get_code_tdata(data) |
| 362 | +34 |
- )+ }) |
|
| 363 | +35 |
- ))+ }, |
|
| 364 | +36 | ! |
- } else if (!is.null(min_levels)) {
+ ui = function(id, ...) {
|
| 365 | +37 | ! |
- validate(need(+ ns <- NS(id) |
| 366 | +38 | ! |
- length(x_levels) >= min_levels,+ div( |
| 367 | +39 | ! |
- sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
- |
-
| 368 | -- |
- ))+ h2("The following filter calls are generated:"),
|
|
| 369 | +40 | ! |
- } else if (!is.null(max_levels)) {
+ verbatimTextOutput(ns("filter_calls"))
|
| 370 | -! | +||
| 41 | +
- validate(need(+ ) |
||
| 371 | -! | +||
| 42 | +
- length(x_levels) <= max_levels,+ }, |
||
| 372 | +43 | ! |
- sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
- |
-
| 373 | -- |
- ))+ datanames = "all" |
|
| 374 | +44 |
- }+ ) |
|
| 375 | +45 |
}@@ -19377,84 +19747,84 @@ teal coverage - 72.64% |
| 1 |
- #' Add right filter panel into each of the top-level `teal_modules` UIs.+ # This is the main function from teal to be used by the end-users. Although it delegates |
|||
| 2 |
- #'+ # directly to `module_teal_with_splash.R`, we keep it in a separate file because its doc is quite large |
|||
| 3 |
- #' The [ui_nested_tabs] function returns a nested tabbed UI corresponding+ # and it is very end-user oriented. It may also perform more argument checking with more informative |
|||
| 4 |
- #' to the nested modules.+ # error messages. |
|||
| 5 |
- #' This function adds the right filter panel to each main tab.+ |
|||
| 6 |
- #'+ |
|||
| 7 |
- #' The right filter panel's filter choices affect the `datasets` object. Therefore,+ #' Create the Server and UI Function For the Shiny App |
|||
| 8 |
- #' all modules using the same `datasets` share the same filters.+ #' |
|||
| 9 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
|||
| 10 |
- #' This works with nested modules of depth greater than 2, though the filter+ #' End-users: This is the most important function for you to start a |
|||
| 11 |
- #' panel is inserted at the right of the modules at depth 1 and not at the leaves.+ #' teal app that is composed out of teal modules. |
|||
| 13 |
- #' @name module_tabs_with_filters+ #' **Notes for developers**: |
|||
| 14 |
- #'+ #' This is a wrapper function around the `module_teal.R` functions. Unless you are |
|||
| 15 |
- #' @inheritParams module_teal+ #' an end-user, don't use this function, but instead this module. |
|||
| 17 |
- #' @param datasets (`named list` of `FilteredData`)\cr+ #' @param data (`TealData` or `TealDataset` or `TealDatasetConnector` or `list` or `data.frame` |
|||
| 18 |
- #' object to store filter state and filtered datasets, shared across modules. For more+ #' or `MultiAssayExperiment`)\cr |
|||
| 19 |
- #' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure+ #' `R6` object as returned by [teal.data::cdisc_data()], [teal.data::teal_data()], |
|||
| 20 |
- #' of the `modules` argument and list names must correspond to the labels in `modules`.+ #' [teal.data::cdisc_dataset()], [teal.data::dataset()], [teal.data::dataset_connector()] or |
|||
| 21 |
- #' When filter is not module-specific then list contains the same object in all elements.+ #' [teal.data::cdisc_dataset_connector()] or a single `data.frame` or a `MultiAssayExperiment` |
|||
| 22 |
- #' @param reporter (`Reporter`) object from `teal.reporter`+ #' or a list of the previous objects or function returning a named list. |
|||
| 23 |
- #'+ #' NOTE: teal does not guarantee reproducibility of the code when names of the list elements |
|||
| 24 |
- #' @return A `tagList` of The main menu, place holders for filters and+ #' do not match the original object names. To ensure reproducibility please use [teal.data::teal_data()] |
|||
| 25 |
- #' place holders for the teal modules+ #' or [teal.data::cdisc_data()] with `check = TRUE` enabled. |
|||
| 26 |
- #'+ #' @param modules (`list`, `teal_modules` or `teal_module`)\cr |
|||
| 27 |
- #'+ #' nested list of `teal_modules` or `teal_module` objects or a single |
|||
| 28 |
- #' @keywords internal+ #' `teal_modules` or `teal_module` object. These are the specific output modules which |
|||
| 29 |
- #'+ #' will be displayed in the teal application. See [modules()] and [module()] for |
|||
| 30 |
- #' @examples+ #' more details. |
|||
| 31 |
- #'+ #' @param title (`NULL` or `character`)\cr |
|||
| 32 |
- #' mods <- teal:::example_modules()+ #' The browser window title (defaults to the host URL of the page). |
|||
| 33 |
- #' datasets <- teal:::example_datasets()+ #' @param filter (`teal_slices`)\cr |
|||
| 34 |
- #'+ #' Specification of initial filter. Filters can be specified using [teal::teal_slices()]. |
|||
| 35 |
- #' app <- shinyApp(+ #' Old way of specifying filters through a list is deprecated and will be removed in the |
|||
| 36 |
- #' ui = function() {
+ #' next release. Please fix your applications to use [teal::teal_slices()]. |
|||
| 37 |
- #' tagList(+ #' @param header (`shiny.tag` or `character`) \cr |
|||
| 38 |
- #' teal:::include_teal_css_js(),+ #' the header of the app. Note shiny code placed here (and in the footer |
|||
| 39 |
- #' textOutput("info"),
+ #' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function |
|||
| 40 |
- #' fluidPage( # needed for nice tabs+ #' (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here. |
|||
| 41 |
- #' ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
+ #' @param footer (`shiny.tag` or `character`)\cr |
|||
| 42 |
- #' )+ #' the footer of the app |
|||
| 43 |
- #' )+ #' @param id (`character`)\cr |
|||
| 44 |
- #' },+ #' module id to embed it, if provided, |
|||
| 45 |
- #' server = function(input, output, session) {
+ #' the server function must be called with [shiny::moduleServer()]; |
|||
| 46 |
- #' output$info <- renderText({
+ #' See the vignette for an example. However, [ui_teal_with_splash()] |
|||
| 47 |
- #' paste0("The currently active tab name is ", active_module()$label)
+ #' is then preferred to this function. |
|||
| 48 |
- #' })+ #' |
|||
| 49 |
- #' active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods)+ #' @return named list with `server` and `ui` function |
|||
| 50 |
- #' }+ #' |
|||
| 51 |
- #' )+ #' @export |
|||
| 52 |
- #' if (interactive()) {
+ #' |
|||
| 53 |
- #' runApp(app)+ #' @include modules.R |
|||
| 54 |
- #' }+ #' |
|||
| 55 |
- #'+ #' @examples |
|||
| 56 |
- NULL+ #' new_iris <- transform(iris, id = seq_len(nrow(iris))) |
|||
| 57 |
-
+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars))) |
|||
| 58 |
- #' @rdname module_tabs_with_filters+ #' |
|||
| 59 |
- ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
+ #' app <- init( |
|||
| 60 | -1x | +
- checkmate::assert_class(modules, "teal_modules")+ #' data = teal_data( |
||
| 61 | -1x | +
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ #' dataset("new_iris", new_iris),
|
||
| 62 | -1x | +
- checkmate::assert_class(filter, "teal_slices")+ #' dataset("new_mtcars", new_mtcars),
|
||
| 63 |
-
+ #' code = " |
|||
| 64 | -1x | +
- ns <- NS(id)+ #' new_iris <- transform(iris, id = seq_len(nrow(iris))) |
||
| 65 | -1x | +
- is_module_specific <- isTRUE(attr(filter, "module_specific"))+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars))) |
||
| 66 |
-
+ #' " |
|||
| 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",- |
- ||
| 70 | -1x | -
- tags$button(- |
- ||
| 71 | -1x | -
- class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger- |
- ||
| 72 | -1x | -
- href = "javascript:void(0)",- |
- ||
| 73 | -1x | -
- onclick = "toggleFilterPanel();", # see sidebar.js- |
- ||
| 74 | -1x | -
- title = "Toggle filter panels",- |
- ||
| 75 | -1x | +
- icon("fas fa-bars")
+ #' modules = modules( |
||
| 76 | +69 |
- ),- |
- ||
| 77 | -1x | -
- filter_manager_modal_ui(ns("filter_manager"))
+ #' module( |
||
| 78 | +70 |
- )- |
- ||
| 79 | -1x | -
- teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)+ #' label = "data source", |
||
| 80 | +71 | - - | -||
| 81 | -1x | -
- if (!is_module_specific) {
+ #' server = function(input, output, session, data) {},
|
||
| 82 | +72 |
- # need to rearrange html so that filter panel is within tabset- |
- ||
| 83 | -1x | -
- tabset_bar <- teal_ui$children[[1]]- |
- ||
| 84 | -1x | -
- teal_modules <- teal_ui$children[[2]]- |
- ||
| 85 | -1x | -
- filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
- |
- ||
| 86 | -1x | -
- list(- |
- ||
| 87 | -1x | -
- tabset_bar,- |
- ||
| 88 | -1x | -
- tags$hr(class = "my-2"),- |
- ||
| 89 | -1x | -
- fluidRow(- |
- ||
| 90 | -1x | -
- column(width = 9, teal_modules, class = "teal_primary_col"),- |
- ||
| 91 | -1x | -
- column(width = 3, filter_ui, class = "teal_secondary_col")+ #' ui = function(id, ...) div(p("information about data source")),
|
||
| 92 | +73 |
- )+ #' datanames = "all" |
||
| 93 | +74 |
- )+ #' ), |
||
| 94 | +75 |
- } else {
- |
- ||
| 95 | -! | -
- teal_ui+ #' example_module(label = "example teal module"), |
||
| 96 | +76 |
- }+ #' module( |
||
| 97 | +77 |
- }+ #' "Iris Sepal.Length histogram", |
||
| 98 | +78 |
-
+ #' server = function(input, output, session, data) {
|
||
| 99 | +79 |
- #' @rdname module_tabs_with_filters+ #' output$hist <- renderPlot( |
||
| 100 | +80 |
- srv_tabs_with_filters <- function(id,+ #' hist(data[["new_iris"]]()$Sepal.Length) |
||
| 101 | +81 |
- datasets,+ #' ) |
||
| 102 | +82 |
- modules,+ #' }, |
||
| 103 | +83 |
- reporter = teal.reporter::Reporter$new(),+ #' ui = function(id, ...) {
|
||
| 104 | +84 |
- filter = teal_slices()) {
+ #' ns <- NS(id) |
||
| 105 | -6x | +|||
| 85 | +
- checkmate::assert_class(modules, "teal_modules")+ #' plotOutput(ns("hist"))
|
|||
| 106 | -6x | +|||
| 86 | +
- checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ #' }, |
|||
| 107 | -6x | +|||
| 87 | +
- checkmate::assert_class(reporter, "Reporter")+ #' datanames = "new_iris" |
|||
| 108 | -4x | +|||
| 88 | +
- checkmate::assert_class(filter, "teal_slices")+ #' ) |
|||
| 109 | +89 |
-
+ #' ), |
||
| 110 | -4x | +|||
| 90 | +
- moduleServer(id, function(input, output, session) {
+ #' title = "App title", |
|||
| 111 | -4x | +|||
| 91 | +
- logger::log_trace("srv_tabs_with_filters initializing the module.")
+ #' filter = teal_slices( |
|||
| 112 | +92 |
-
+ #' teal_slice(dataname = "new_iris", varname = "Species"), |
||
| 113 | -4x | +|||
| 93 | +
- is_module_specific <- isTRUE(attr(filter, "module_specific"))+ #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"), |
|||
| 114 | -4x | +|||
| 94 | +
- manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
+ #' teal_slice(dataname = "new_mtcars", varname = "cyl"), |
|||
| 115 | +95 |
-
+ #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
|
||
| 116 | -4x | +|||
| 96 | +
- active_module <- srv_nested_tabs(+ #' mapping = list( |
|||
| 117 | -4x | +|||
| 97 | +
- id = "root",+ #' `example teal module` = "new_iris Species", |
|||
| 118 | -4x | +|||
| 98 | +
- datasets = datasets,+ #' `Iris Sepal.Length histogram` = "new_iris Species", |
|||
| 119 | -4x | +|||
| 99 | +
- modules = modules,+ #' global_filters = "new_mtcars cyl" |
|||
| 120 | -4x | +|||
| 100 | +
- reporter = reporter,+ #' ) |
|||
| 121 | -4x | +|||
| 101 | +
- is_module_specific = is_module_specific+ #' ), |
|||
| 122 | +102 |
- )+ #' header = tags$h1("Sample App"),
|
||
| 123 | +103 |
-
+ #' footer = tags$p("Copyright 2017 - 2023")
|
||
| 124 | -4x | +|||
| 104 | +
- if (!is_module_specific) {
+ #' ) |
|||
| 125 | -4x | +|||
| 105 | +
- active_datanames <- reactive(active_module()$datanames)+ #' if (interactive()) {
|
|||
| 126 | -4x | +|||
| 106 | +
- singleton <- unlist(datasets)[[1]]+ #' shinyApp(app$ui, app$server) |
|||
| 127 | -4x | +|||
| 107 | +
- singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
+ #' } |
|||
| 128 | +108 |
-
+ #' |
||
| 129 | -4x | +|||
| 109 | +
- observeEvent(+ init <- function(data, |
|||
| 130 | -4x | +|||
| 110 | +
- eventExpr = active_datanames(),+ modules, |
|||
| 131 | -4x | +|||
| 111 | +
- handlerExpr = {
+ title = NULL, |
|||
| 132 | -5x | +|||
| 112 | +
- script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
+ filter = teal_slices(), |
|||
| 133 | +113 |
- # hide the filter panel and disable the burger button+ header = tags$p(), |
||
| 134 | -1x | +|||
| 114 | +
- "handleNoActiveDatasets();"+ footer = tags$p(), |
|||
| 135 | +115 |
- } else {
+ id = character(0)) {
|
||
| 136 | -+ | |||
| 116 | +38x |
- # show the filter panel and enable the burger button+ logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
|
||
| 137 | -4x | +117 | +38x |
- "handleActiveDatasetsPresent();"+ data <- teal.data::to_relational_data(data = data) |
| 138 | +118 |
- }+ |
||
| 139 | -5x | +119 | +33x |
- shinyjs::runjs(script)+ checkmate::assert_class(data, "TealData") |
| 140 | -+ | |||
| 120 | +33x |
- },+ checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
|
||
| 141 | -4x | +121 | +33x |
- ignoreNULL = FALSE+ checkmate::assert_string(title, null.ok = TRUE) |
| 142 | -+ | |||
| 122 | +33x |
- )+ checkmate::assert( |
||
| 143 | -+ | |||
| 123 | +33x |
- }+ checkmate::check_class(filter, "teal_slices"), |
||
| 144 | -+ | |||
| 124 | +33x |
-
+ checkmate::check_list(filter, names = "named") |
||
| 145 | -4x | +|||
| 125 | +
- showNotification("Data loaded - App fully started up")
+ ) |
|||
| 146 | -4x | +126 | +32x |
- logger::log_trace("srv_tabs_with_filters initialized the module")
+ checkmate::assert_multi_class(header, c("shiny.tag", "character"))
|
| 147 | -4x | +127 | +32x |
- return(active_module)+ checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
|
| 148 | -+ | |||
| 128 | +32x |
- })+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE) |
||
| 149 | +129 |
- }+ |
| 1 | -+ | ||
| 130 | +32x |
- #' Send input validation messages to output.+ teal.logger::log_system_info() |
|
| 2 | +131 |
- #'+ |
|
| 3 | -+ | ||
| 132 | +32x |
- #' Captures messages from `InputValidator` objects and collates them+ if (inherits(modules, "teal_module")) {
|
|
| 4 | -+ | ||
| 133 | +1x |
- #' into one message passed to `validate`.+ modules <- list(modules) |
|
| 5 | +134 |
- #'+ } |
|
| 6 | -+ | ||
| 135 | +32x |
- #' `shiny::validate` is used to withhold rendering of an output element until+ if (inherits(modules, "list")) {
|
|
| 7 | -+ | ||
| 136 | +2x |
- #' certain conditions are met and to print a validation message in place+ modules <- do.call(teal::modules, modules) |
|
| 8 | +137 |
- #' of the output element.+ } |
|
| 9 | +138 |
- #' `shinyvalidate::InputValidator` allows to validate input elements+ |
|
| 10 | +139 |
- #' and to display specific messages in their respective input widgets.+ # resolve modules datanames |
|
| 11 | -+ | ||
| 140 | +32x |
- #' `validate_inputs` provides a hybrid solution.+ datanames <- teal.data::get_dataname(data) |
|
| 12 | -+ | ||
| 141 | +32x |
- #' Given an `InputValidator` object, messages corresponding to inputs that fail validation+ join_keys <- data$get_join_keys() |
|
| 13 | -+ | ||
| 142 | +32x |
- #' are extracted and placed in one validation message that is passed to a `validate`/`need` call.+ resolve_modules_datanames <- function(modules) {
|
|
| 14 | -+ | ||
| 143 | +240x |
- #' This way the input `validator` messages are repeated in the output.+ if (inherits(modules, "teal_modules")) {
|
|
| 15 | -+ | ||
| 144 | +90x |
- #'+ modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE) |
|
| 16 | -+ | ||
| 145 | +90x |
- #' The `...` argument accepts any number of `InputValidator` objects+ modules |
|
| 17 | +146 |
- #' or a nested list of such objects.+ } else {
|
|
| 18 | -+ | ||
| 147 | +150x |
- #' If `validators` are passed directly, all their messages are printed together+ modules$datanames <- if (identical(modules$datanames, "all")) {
|
|
| 19 | -+ | ||
| 148 | +5x |
- #' under one (optional) header message specified by `header`. If a list is passed,+ datanames |
|
| 20 | -+ | ||
| 149 | +150x |
- #' messages are grouped by `validator`. The list's names are used as headers+ } else if (is.character(modules$datanames)) {
|
|
| 21 | -+ | ||
| 150 | +145x |
- #' for their respective message groups.+ datanames_adjusted <- intersect(modules$datanames, datanames) |
|
| 22 | -+ | ||
| 151 | +145x |
- #' If neither of the nested list elements is named, a header message is taken from `header`.+ include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys) |
|
| 23 | +152 |
- #'+ } |
|
| 24 | -+ | ||
| 153 | +150x |
- #' @param ... either any number of `InputValidator` objects+ modules |
|
| 25 | +154 |
- #' or an optionally named, possibly nested `list` of `InputValidator`+ } |
|
| 26 | +155 |
- #' objects, see `Details`+ } |
|
| 27 | -+ | ||
| 156 | +32x |
- #' @param header `character(1)` generic validation message; set to NULL to omit+ modules <- resolve_modules_datanames(modules = modules) |
|
| 28 | +157 |
- #'+ |
|
| 29 | -+ | ||
| 158 | +32x |
- #' @return+ if (!inherits(filter, "teal_slices")) {
|
|
| 30 | -+ | ||
| 159 | +1x |
- #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails.+ checkmate::assert_subset(names(filter), choices = datanames) |
|
| 31 | +160 |
- #'+ # list_to_teal_slices is lifted from teal.slice package, see zzz.R |
|
| 32 | +161 |
- #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`]+ # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0). |
|
| 33 | -+ | ||
| 162 | +1x |
- #'+ filter <- list_to_teal_slices(filter) |
|
| 34 | +163 |
- #' @examples+ } |
|
| 35 | +164 |
- #' library(shiny)+ # convert teal.slice::teal_slices to teal::teal_slices |
|
| 36 | -+ | ||
| 165 | +32x |
- #' library(shinyvalidate)+ filter <- as.teal_slices(as.list(filter)) |
|
| 37 | +166 |
- #'+ |
|
| 38 | +167 |
- #' ui <- fluidPage(+ # check teal_slices |
|
| 39 | -+ | ||
| 168 | +32x |
- #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
+ for (i in seq_along(filter)) {
|
|
| 40 | -+ | ||
| 169 | +2x |
- #' sidebarLayout(+ dataname_i <- shiny::isolate(filter[[i]]$dataname) |
|
| 41 | -+ | ||
| 170 | +2x |
- #' sidebarPanel(+ if (!dataname_i %in% datanames) {
|
|
| 42 | -+ | ||
| 171 | +! |
- #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
+ stop( |
|
| 43 | -+ | ||
| 172 | +! |
- #' selectInput("number", "select a number:", 1:6),
+ sprintf( |
|
| 44 | -+ | ||
| 173 | +! |
- #' br(),+ "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s", |
|
| 45 | -+ | ||
| 174 | +! |
- #' selectInput("color", "select a color:",
+ i, |
|
| 46 | -+ | ||
| 175 | +! |
- #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
+ dataname_i, |
|
| 47 | -+ | ||
| 176 | +! |
- #' multiple = TRUE+ toString(datanames) |
|
| 48 | +177 |
- #' ),+ ) |
|
| 49 | +178 |
- #' sliderInput("size", "select point size:",
+ ) |
|
| 50 | +179 |
- #' min = 0.1, max = 4, value = 0.25+ } |
|
| 51 | +180 |
- #' )+ } |
|
| 52 | +181 |
- #' ),+ |
|
| 53 | -+ | ||
| 182 | +32x |
- #' mainPanel(plotOutput("plot"))
+ if (isTRUE(attr(filter, "module_specific"))) {
|
|
| 54 | -+ | ||
| 183 | +! |
- #' )+ module_names <- unlist(c(module_labels(modules), "global_filters")) |
|
| 55 | -+ | ||
| 184 | +! |
- #' )+ failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names) |
|
| 56 | -+ | ||
| 185 | +! |
- #'+ if (length(failed_mod_names)) {
|
|
| 57 | -+ | ||
| 186 | +! |
- #' server <- function(input, output) {
+ stop( |
|
| 58 | -+ | ||
| 187 | +! |
- #' # set up input validation+ sprintf( |
|
| 59 | -+ | ||
| 188 | +! |
- #' iv <- InputValidator$new()+ "Some module names in the mapping arguments don't match module labels.\n %s not in %s", |
|
| 60 | -+ | ||
| 189 | +! |
- #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
+ toString(failed_mod_names), |
|
| 61 | -+ | ||
| 190 | +! |
- #' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
+ toString(unique(module_names)) |
|
| 62 | +191 |
- #' iv$enable()+ ) |
|
| 63 | +192 |
- #' # more input validation+ ) |
|
| 64 | +193 |
- #' iv_par <- InputValidator$new()+ } |
|
| 65 | +194 |
- #' iv_par$add_rule("color", sv_required(message = "choose a color"))
+
|
|
| 66 | -+ | ||
| 195 | +! |
- #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color")
+ if (anyDuplicated(module_names)) {
|
|
| 67 | +196 |
- #' iv_par$add_rule(+ # In teal we are able to set nested modules with duplicated label. |
|
| 68 | +197 |
- #' "size",+ # Because mapping argument bases on the relationship between module-label and filter-id, |
|
| 69 | +198 |
- #' sv_between(+ # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label) |
|
| 70 | -+ | ||
| 199 | +! |
- #' left = 0.5, right = 3,+ stop( |
|
| 71 | -+ | ||
| 200 | +! |
- #' message_fmt = "choose a value between {left} and {right}"
+ sprintf( |
|
| 72 | -+ | ||
| 201 | +! |
- #' )+ "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ", |
|
| 73 | -+ | ||
| 202 | +! |
- #' )+ toString(module_names[duplicated(module_names)]) |
|
| 74 | +203 |
- #' iv_par$enable()+ ) |
|
| 75 | +204 |
- #'+ ) |
|
| 76 | +205 |
- #' output$plot <- renderPlot({
+ } |
|
| 77 | +206 |
- #' # validate output+ } |
|
| 78 | +207 |
- #' switch(input[["method"]],+ |
|
| 79 | +208 |
- #' "sequential" = {
+ # Note regarding case `id = character(0)`: |
|
| 80 | +209 |
- #' validate_inputs(iv)+ # rather than using `callModule` and creating a submodule of this module, we directly modify |
|
| 81 | +210 |
- #' validate_inputs(iv_par, header = "Set proper graphical parameters")+ # the `ui` and `server` with `id = character(0)` and calling the server function directly |
|
| 82 | +211 |
- #' },+ # rather than through `callModule` |
|
| 83 | -+ | ||
| 212 | +32x |
- #' "combined" = validate_inputs(iv, iv_par),+ res <- list( |
|
| 84 | -+ | ||
| 213 | +32x |
- #' "grouped" = validate_inputs(list(+ ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer), |
|
| 85 | -+ | ||
| 214 | +32x |
- #' "Some inputs require attention" = iv,+ server = function(input, output, session) {
|
|
| 86 | +215 |
- #' "Set proper graphical parameters" = iv_par+ # copy object so that load won't be shared between the session |
|
| 87 | -+ | ||
| 216 | +! |
- #' ))+ data <- data$copy(deep = TRUE) |
|
| 88 | -+ | ||
| 217 | +! |
- #' )+ filter <- deep_copy_filter(filter) |
|
| 89 | -+ | ||
| 218 | +! |
- #'+ srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter) |
|
| 90 | +219 |
- #' plot(eruptions ~ waiting, faithful,+ } |
|
| 91 | +220 |
- #' las = 1, pch = 16,+ ) |
|
| 92 | -+ | ||
| 221 | +32x |
- #' col = input[["color"]], cex = input[["size"]]+ logger::log_trace("init teal app has been initialized.")
|
|
| 93 | -+ | ||
| 222 | +32x |
- #' )+ return(res) |
|
| 94 | +223 |
- #' })+ } |
| 95 | +1 |
- #' }+ #' Get dummy `CDISC` data |
|
| 96 | +2 |
#' |
|
| 97 | +3 |
- #' if (interactive()) {
+ #' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`. |
|
| 98 | +4 |
- #' shinyApp(ui, server)+ #' Some NAs are also introduced to stress test. |
|
| 99 | +5 |
- #' }+ #' |
|
| 100 | +6 |
- #'+ #' @return `cdisc_data` |
|
| 101 | +7 |
- #' @export+ #' @keywords internal |
|
| 102 | +8 |
- #'+ example_cdisc_data <- function() { # nolint
|
|
| 103 | -+ | ||
| 9 | +! |
- validate_inputs <- function(..., header = "Some inputs require attention") {
+ ADSL <- data.frame( # nolint |
|
| 104 | -36x | +||
| 10 | +! |
- dots <- list(...)+ STUDYID = "study", |
|
| 105 | -2x | +||
| 11 | +! |
- if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
+ USUBJID = 1:10,+ |
+ |
| 12 | +! | +
+ SEX = sample(c("F", "M"), 10, replace = TRUE),
+ |
+ |
| 13 | +! | +
+ AGE = stats::rpois(10, 40) |
|
| 106 | +14 |
-
+ )+ |
+ |
| 15 | +! | +
+ ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint |
|
| 107 | -34x | +||
| 16 | +! |
- messages <- extract_validator(dots, header)+ ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
|
|
| 108 | -34x | +||
| 17 | +! |
- failings <- if (!any_names(dots)) {
+ ADTTE$AVAL <- c( # nolint |
|
| 109 | -29x | +||
| 18 | +! |
- add_header(messages, header)+ stats::rnorm(10, mean = 700, sd = 200), # dummy OS level |
|
| 110 | -+ | ||
| 19 | +! |
- } else {
+ stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level |
|
| 111 | -5x | +||
| 20 | +! |
- unlist(messages)+ stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level |
|
| 112 | +21 |
- }+ ) |
|
| 113 | +22 | ||
| 114 | -34x | +||
| 23 | +! |
- shiny::validate(shiny::need(is.null(failings), failings))+ ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint |
|
| 115 | -+ | ||
| 24 | +! |
- }+ ADSL$SEX[c(2, 5)] <- NA # nolint |
|
| 116 | +25 | ||
| 117 | -- |
- ### internal functions- |
- |
| 118 | -+ | ||
| 26 | +! |
-
+ cdisc_data_obj <- teal.data::cdisc_data( |
|
| 119 | -+ | ||
| 27 | +! |
- #' @keywords internal+ cdisc_dataset(dataname = "ADSL", x = ADSL), |
|
| 120 | -+ | ||
| 28 | +! |
- # recursive object type test+ cdisc_dataset(dataname = "ADTTE", x = ADTTE) |
|
| 121 | +29 |
- # returns logical of length 1+ ) |
|
| 122 | +30 |
- is_validators <- function(x) {
+
|
|
| 123 | -118x | +||
| 31 | +! |
- all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))+ res <- teal.data::cdisc_data( |
|
| 124 | -+ | ||
| 32 | +! |
- }+ teal.data::cdisc_dataset(dataname = "ADSL", x = ADSL), |
|
| 125 | -+ | ||
| 33 | +! |
-
+ teal.data::cdisc_dataset(dataname = "ADTTE", x = ADTTE), |
|
| 126 | -+ | ||
| 34 | +! |
- #' @keywords internal+ code = ' |
|
| 127 | -+ | ||
| 35 | +! |
- # test if an InputValidator object is enabled+ ADSL <- data.frame( |
|
| 128 | -+ | ||
| 36 | +! |
- # returns logical of length 1+ STUDYID = "study", |
|
| 129 | -+ | ||
| 37 | +! |
- # official method requested at https://github.com/rstudio/shinyvalidate/issues/64+ USUBJID = 1:10, |
|
| 130 | -+ | ||
| 38 | +! |
- validator_enabled <- function(x) {
+ SEX = sample(c("F", "M"), 10, replace = TRUE),
|
|
| 131 | -49x | +||
| 39 | +! |
- x$.__enclos_env__$private$enabled+ AGE = rpois(10, 40) |
|
| 132 | +40 |
- }+ ) |
|
| 133 | -+ | ||
| 41 | +! |
-
+ ADTTE <- rbind(ADSL, ADSL, ADSL) |
|
| 134 | -+ | ||
| 42 | +! |
- #' @keywords internal+ ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
|
|
| 135 | -+ | ||
| 43 | +! |
- # recursively extract messages from validator list+ ADTTE$AVAL <- c( |
|
| 136 | -+ | ||
| 44 | +! |
- # returns character vector or a list of character vectors, possibly nested and named+ rnorm(10, mean = 700, sd = 200), |
|
| 137 | -+ | ||
| 45 | +! |
- extract_validator <- function(iv, header) {
+ rnorm(10, mean = 400, sd = 100), |
|
| 138 | -113x | +||
| 46 | +! |
- if (inherits(iv, "InputValidator")) {
+ rnorm(10, mean = 450, sd = 200) |
|
| 139 | -49x | +||
| 47 | +
- add_header(gather_messages(iv), header)+ ) |
||
| 140 | +48 |
- } else {
+
|
|
| 141 | -58x | +||
| 49 | +! |
- if (is.null(names(iv))) names(iv) <- rep("", length(iv))
+ ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE)+ |
+ |
| 50 | +! | +
+ ADSL$SEX[c(2, 5)] <- NA |
|
| 142 | -64x | +||
| 51 | +
- mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)+ ' |
||
| 143 | +52 |
- }+ )+ |
+ |
| 53 | +! | +
+ return(res) |
|
| 144 | +54 |
} |
|
| 145 | +55 | ||
| 146 | +56 |
- #' @keywords internal+ #' Get datasets to go with example modules. |
|
| 147 | +57 |
- # collate failing messages from validator+ #' |
|
| 148 | +58 |
- # returns list+ #' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`. |
|
| 149 | +59 |
- gather_messages <- function(iv) {
+ #' Each list leaf is the same `FilteredData` object. |
|
| 150 | -49x | +||
| 60 | +
- if (validator_enabled(iv)) {
+ #' |
||
| 151 | -46x | +||
| 61 | +
- status <- iv$validate()+ #' @return named list of `FilteredData` objects, each with `ADSL` set. |
||
| 152 | -46x | +||
| 62 | +
- failing_inputs <- Filter(Negate(is.null), status)+ #' @keywords internal |
||
| 153 | -46x | +||
| 63 | +
- unique(lapply(failing_inputs, function(x) x[["message"]]))+ example_datasets <- function() { # nolint
|
||
| 154 | -+ | ||
| 64 | +! |
- } else {
+ dummy_cdisc_data <- example_cdisc_data() |
|
| 155 | -3x | +||
| 65 | +! |
- logger::log_warn("Validator is disabled and will be omitted.")
+ datasets <- teal.slice::init_filtered_data(dummy_cdisc_data) |
|
| 156 | -3x | +||
| 66 | +! |
- list()+ list( |
|
| 157 | -+ | ||
| 67 | +! |
- }+ "d2" = list( |
|
| 158 | -+ | ||
| 68 | +! |
- }+ "d3" = list( |
|
| 159 | -+ | ||
| 69 | +! |
-
+ "aaa1" = datasets, |
|
| 160 | -+ | ||
| 70 | +! |
- #' @keywords internal+ "aaa2" = datasets, |
|
| 161 | -+ | ||
| 71 | +! |
- # add optional header to failing messages+ "aaa3" = datasets |
|
| 162 | +72 |
- add_header <- function(messages, header = "") {
+ ), |
|
| 163 | -78x | +||
| 73 | +! |
- ans <- unlist(messages)+ "bbb" = datasets |
|
| 164 | -78x | +||
| 74 | +
- if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
+ ), |
||
| 165 | -31x | +||
| 75 | +! |
- ans <- c(paste0(header, "\n"), ans, "\n")+ "ccc" = datasets |
|
| 166 | +76 |
- }+ ) |
|
| 167 | -78x | +||
| 77 | +
- ans+ } |
||
| 168 | +78 |
- }+ |
|
| 169 | +79 |
-
+ #' An example `teal` module |
|
| 170 | +80 |
- #' @keywords internal+ #' |
|
| 171 | +81 |
- # recursively check if the object contains a named list+ #' @description `r lifecycle::badge("experimental")`
|
|
| 172 | +82 |
- any_names <- function(x) {
+ #' @inheritParams module |
|
| 173 | -103x | +||
| 83 | +
- any(+ #' @return A `teal` module which can be included in the `modules` argument to [teal::init()]. |
||
| 174 | -103x | +||
| 84 | +
- if (is.list(x)) {
+ #' @examples |
||
| 175 | -58x | +||
| 85 | +
- if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))+ #' app <- init( |
||
| 176 | +86 |
- } else {
+ #' data = teal_data( |
|
| 177 | -40x | +||
| 87 | +
- FALSE+ #' dataset("IRIS", iris),
|
||
| 178 | +88 |
- }+ #' dataset("MTCARS", mtcars)
|
|
| 179 | +89 |
- )+ #' ), |
|
| 180 | +90 |
- }+ #' modules = example_module() |
| 1 | +91 |
- #' Get dummy `CDISC` data+ #' ) |
|
| 2 | +92 |
- #'+ #' if (interactive()) {
|
|
| 3 | +93 |
- #' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`.+ #' shinyApp(app$ui, app$server) |
|
| 4 | +94 |
- #' Some NAs are also introduced to stress test.+ #' } |
|
| 5 | +95 |
- #'+ #' @export |
|
| 6 | +96 |
- #' @return `cdisc_data`+ example_module <- function(label = "example teal module", datanames = "all") {
|
|
| 7 | -+ | ||
| 97 | +15x |
- #' @keywords internal+ checkmate::assert_string(label) |
|
| 8 | -+ | ||
| 98 | +15x |
- example_cdisc_data <- function() { # nolint
+ module( |
|
| 9 | -! | +||
| 99 | +15x |
- ADSL <- data.frame( # nolint+ label, |
|
| 10 | -! | +||
| 100 | +15x |
- STUDYID = "study",+ server = function(id, data) {
|
|
| 11 | +101 | ! |
- USUBJID = 1:10,+ checkmate::assert_class(data, "tdata") |
| 12 | +102 | ! |
- SEX = sample(c("F", "M"), 10, replace = TRUE),
+ moduleServer(id, function(input, output, session) {
|
| 13 | +103 | ! |
- AGE = stats::rpois(10, 40)+ output$text <- renderPrint(data[[input$dataname]]()) |
| 14 | +104 |
- )+ }) |
|
| 15 | -! | +||
| 105 | +
- ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint+ }, |
||
| 16 | -! | +||
| 106 | +15x |
- ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
+ ui = function(id, data) {
|
|
| 17 | +107 | ! |
- ADTTE$AVAL <- c( # nolint+ ns <- NS(id) |
| 18 | +108 | ! |
- stats::rnorm(10, mean = 700, sd = 200), # dummy OS level+ teal.widgets::standard_layout( |
| 19 | +109 | ! |
- stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level+ output = verbatimTextOutput(ns("text")),
|
| 20 | +110 | ! |
- stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level+ encoding = selectInput(ns("dataname"), "Choose a dataset", choices = names(data))
|
| 21 | +111 |
- )+ ) |
|
| 22 | +112 | - - | -|
| 23 | -! | -
- ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint+ }, |
|
| 24 | -! | +||
| 113 | +15x |
- ADSL$SEX[c(2, 5)] <- NA # nolint+ datanames = datanames |
|
| 25 | +114 | - - | -|
| 26 | -! | -
- cdisc_data_obj <- teal.data::cdisc_data(- |
- |
| 27 | -! | -
- cdisc_dataset(dataname = "ADSL", x = ADSL),- |
- |
| 28 | -! | -
- cdisc_dataset(dataname = "ADTTE", x = ADTTE)+ ) |
|
| 29 | +115 |
- )+ } |
|
| 30 | +116 | ||
| 31 | -! | -
- res <- teal.data::cdisc_data(- |
- |
| 32 | -! | +||
| 117 | +
- teal.data::cdisc_dataset(dataname = "ADSL", x = ADSL),+ |
||
| 33 | -! | +||
| 118 | +
- teal.data::cdisc_dataset(dataname = "ADTTE", x = ADTTE),+ #' Get example modules. |
||
| 34 | -! | +||
| 119 | +
- code = '+ #' |
||
| 35 | -! | +||
| 120 | +
- ADSL <- data.frame(+ #' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created. |
||
| 36 | -! | +||
| 121 | +
- STUDYID = "study",+ #' @param datanames (`character`)\cr |
||
| 37 | -! | +||
| 122 | +
- USUBJID = 1:10,+ #' names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`. |
||
| 38 | -! | +||
| 123 | +
- SEX = sample(c("F", "M"), 10, replace = TRUE),
+ #' @return `teal_modules` |
||
| 39 | -! | +||
| 124 | +
- AGE = rpois(10, 40)+ #' @keywords internal |
||
| 40 | +125 |
- )+ example_modules <- function(datanames = c("ADSL", "ADTTE")) {
|
|
| 41 | -! | +||
| 126 | +2x |
- ADTTE <- rbind(ADSL, ADSL, ADSL)+ checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
|
|
| 42 | -! | +||
| 127 | +2x |
- ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
+ mods <- modules( |
|
| 43 | -! | +||
| 128 | +2x |
- ADTTE$AVAL <- c(+ label = "d1", |
|
| 44 | -! | +||
| 129 | +2x |
- rnorm(10, mean = 700, sd = 200),+ modules( |
|
| 45 | -! | +||
| 130 | +2x |
- rnorm(10, mean = 400, sd = 100),+ label = "d2", |
|
| 46 | -! | +||
| 131 | +2x |
- rnorm(10, mean = 450, sd = 200)+ modules( |
|
| 47 | -+ | ||
| 132 | +2x |
- )+ label = "d3", |
|
| 48 | -+ | ||
| 133 | +2x |
-
+ example_module(label = "aaa1", datanames = datanames), |
|
| 49 | -! | +||
| 134 | +2x |
- ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE)+ example_module(label = "aaa2", datanames = datanames), |
|
| 50 | -! | +||
| 135 | +2x |
- ADSL$SEX[c(2, 5)] <- NA+ example_module(label = "aaa3", datanames = datanames) |
|
| 51 | +136 |
- '+ ),+ |
+ |
| 137 | +2x | +
+ example_module(label = "bbb", datanames = datanames) |
|
| 52 | +138 |
- )+ ), |
|
| 53 | -! | +||
| 139 | +2x |
- return(res)+ example_module(label = "ccc", datanames = datanames) |
|
| 54 | +140 |
- }+ ) |
|
| 55 | -+ | ||
| 141 | +2x |
-
+ return(mods) |
|
| 56 | +142 |
- #' Get datasets to go with example modules.+ } |
| 57 | +1 |
- #'+ #' Generates library calls from current session info |
||
| 58 | +2 |
- #' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`.+ #' |
||
| 59 | +3 |
- #' Each list leaf is the same `FilteredData` object.+ #' Function to create multiple library calls out of current session info to make reproducible code works. |
||
| 60 | +4 |
#' |
||
| 61 | +5 |
- #' @return named list of `FilteredData` objects, each with `ADSL` set.+ #' @return Character object contain code |
||
| 62 | +6 |
#' @keywords internal |
||
| 63 | +7 |
- example_datasets <- function() { # nolint
- |
- ||
| 64 | -! | -
- dummy_cdisc_data <- example_cdisc_data()+ get_rcode_libraries <- function() {
|
||
| 65 | -! | +|||
| 8 | +14x |
- datasets <- teal.slice::init_filtered_data(dummy_cdisc_data)+ vapply( |
||
| 66 | -! | +|||
| 9 | +14x |
- list(+ utils::sessionInfo()$otherPkgs, |
||
| 67 | -! | +|||
| 10 | +14x |
- "d2" = list(+ function(x) {
|
||
| 68 | -! | +|||
| 11 | +238x |
- "d3" = list(+ paste0("library(", x$Package, ")")
|
||
| 69 | -! | +|||
| 12 | +
- "aaa1" = datasets,+ }, |
|||
| 70 | -! | +|||
| 13 | +14x |
- "aaa2" = datasets,+ character(1) |
||
| 71 | -! | +|||
| 14 | +
- "aaa3" = datasets+ ) %>% |
|||
| 72 | +15 |
- ),+ # put it into reverse order to correctly simulate executed code |
||
| 73 | -! | +|||
| 16 | +14x |
- "bbb" = datasets+ rev() %>% |
||
| 74 | -+ | |||
| 17 | +14x |
- ),+ paste0(sep = "\n") %>% |
||
| 75 | -! | +|||
| 18 | +14x |
- "ccc" = datasets+ paste0(collapse = "") |
||
| 76 | +19 |
- )+ } |
||
| 77 | +20 |
- }+ |
||
| 78 | +21 | |||
| 79 | +22 |
- #' An example `teal` module+ |
||
| 80 | +23 |
- #'+ get_rcode_str_install <- function() {
|
||
| 81 | -+ | |||
| 24 | +18x |
- #' @description `r lifecycle::badge("experimental")`
+ code_string <- getOption("teal.load_nest_code")
|
||
| 82 | +25 |
- #' @inheritParams module+ |
||
| 83 | -+ | |||
| 26 | +18x |
- #' @return A `teal` module which can be included in the `modules` argument to [teal::init()].+ if (!is.null(code_string) && is.character(code_string)) {
|
||
| 84 | -+ | |||
| 27 | +2x |
- #' @examples+ return(code_string) |
||
| 85 | +28 |
- #' app <- init(+ } |
||
| 86 | +29 |
- #' data = teal_data(+ |
||
| 87 | -+ | |||
| 30 | +16x |
- #' dataset("IRIS", iris),
+ return("# Add any code to install/load your NEST environment here\n")
|
||
| 88 | +31 |
- #' dataset("MTCARS", mtcars)
+ } |
||
| 89 | +32 |
- #' ),+ |
||
| 90 | +33 |
- #' modules = example_module()+ #' Get datasets code |
||
| 91 | +34 |
- #' )+ #' |
||
| 92 | +35 |
- #' if (interactive()) {
+ #' Get combined code from `FilteredData` and from `CodeClass` object. |
||
| 93 | +36 |
- #' shinyApp(app$ui, app$server)+ #' |
||
| 94 | +37 |
- #' }+ #' @param datanames (`character`) names of datasets to extract code from |
||
| 95 | +38 |
- #' @export+ #' @param datasets (`FilteredData`) object |
||
| 96 | +39 |
- example_module <- function(label = "example teal module", datanames = "all") {
- |
- ||
| 97 | -15x | -
- checkmate::assert_string(label)- |
- ||
| 98 | -15x | -
- module(+ #' @param hashes named (`list`) of hashes per dataset |
||
| 99 | -15x | +|||
| 40 | +
- label,+ #' |
|||
| 100 | -15x | +|||
| 41 | +
- server = function(id, data) {
+ #' @return `character(3)` containing following elements: |
|||
| 101 | -! | +|||
| 42 | +
- checkmate::assert_class(data, "tdata")+ #' - code from `CodeClass` (data loading code) |
|||
| 102 | -! | +|||
| 43 | +
- moduleServer(id, function(input, output, session) {
+ #' - hash check of loaded objects |
|||
| 103 | -! | +|||
| 44 | +
- output$text <- renderPrint(data[[input$dataname]]())+ #' |
|||
| 104 | +45 |
- })+ #' @keywords internal |
||
| 105 | +46 |
- },+ get_datasets_code <- function(datanames, datasets, hashes) {
|
||
| 106 | -15x | +47 | +14x |
- ui = function(id, data) {
+ str_code <- datasets$get_code(datanames) |
| 107 | -! | +|||
| 48 | +14x |
- ns <- NS(id)+ if (length(str_code) == 0 || (length(str_code) == 1 && str_code == "")) {
|
||
| 108 | +49 | ! |
- teal.widgets::standard_layout(+ str_code <- "message('Preprocessing is empty')"
|
|
| 109 | -! | +|||
| 50 | +14x |
- output = verbatimTextOutput(ns("text")),
+ } else if (length(str_code) > 0) {
|
||
| 110 | -! | +|||
| 51 | +14x |
- encoding = selectInput(ns("dataname"), "Choose a dataset", choices = names(data))
+ str_code <- paste0(str_code, "\n\n") |
||
| 111 | +52 |
- )+ } |
||
| 112 | +53 |
- },+ |
||
| 113 | -15x | +54 | +14x |
- datanames = datanames+ if (!datasets$get_check()) {
|
| 114 | -+ | |||
| 55 | +10x |
- )+ check_note_string <- paste0( |
||
| 115 | -+ | |||
| 56 | +10x |
- }+ c( |
||
| 116 | -+ | |||
| 57 | +10x |
-
+ "message(paste(\"Reproducibility of data import and preprocessing was not explicitly checked\",", |
||
| 117 | -+ | |||
| 58 | +10x |
-
+ " \" ('check = FALSE' is set). Contact app developer if this is an issue.\n\"))"
|
||
| 118 | +59 |
- #' Get example modules.+ ), |
||
| 119 | -+ | |||
| 60 | +10x |
- #'+ collapse = "\n" |
||
| 120 | +61 |
- #' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created.+ ) |
||
| 121 | -+ | |||
| 62 | +10x |
- #' @param datanames (`character`)\cr+ str_code <- paste0(str_code, "\n\n", check_note_string) |
||
| 122 | +63 |
- #' names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`.+ } |
||
| 123 | +64 |
- #' @return `teal_modules`+ |
||
| 124 | -+ | |||
| 65 | +14x |
- #' @keywords internal+ str_hash <- paste( |
||
| 125 | -+ | |||
| 66 | +14x |
- example_modules <- function(datanames = c("ADSL", "ADTTE")) {
+ paste0( |
||
| 126 | -2x | +67 | +14x |
- checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
+ vapply( |
| 127 | -2x | +68 | +14x |
- mods <- modules(+ datanames, |
| 128 | -2x | +69 | +14x |
- label = "d1",+ function(dataname) {
|
| 129 | -2x | +70 | +17x |
- modules(+ sprintf( |
| 130 | -2x | +71 | +17x |
- label = "d2",+ "stopifnot(%s == %s)", |
| 131 | -2x | +72 | +17x |
- modules(+ deparse1(bquote(rlang::hash(.(as.name(dataname))))), |
| 132 | -2x | +73 | +17x |
- label = "d3",+ deparse1(hashes[[dataname]]) |
| 133 | -2x | +|||
| 74 | +
- example_module(label = "aaa1", datanames = datanames),+ ) |
|||
| 134 | -2x | +|||
| 75 | +
- example_module(label = "aaa2", datanames = datanames),+ }, |
|||
| 135 | -2x | +76 | +14x |
- example_module(label = "aaa3", datanames = datanames)+ character(1) |
| 136 | +77 |
), |
||
| 137 | -2x | +78 | +14x |
- example_module(label = "bbb", datanames = datanames)+ collapse = "\n" |
| 138 | +79 |
), |
||
| 139 | -2x | +80 | +14x |
- example_module(label = "ccc", datanames = datanames)+ "\n\n" |
| 140 | +81 |
) |
||
| 82 | ++ | + + | +||
| 141 | -2x | +83 | +14x |
- return(mods)+ c(str_code, str_hash) |
| 142 | +84 |
}@@ -22692,14 +22908,14 @@ teal coverage - 72.64% |
| 1 |
- #' Generates library calls from current session info+ #' Create a `teal` module for previewing a report |
|||
| 3 |
- #' Function to create multiple library calls out of current session info to make reproducible code works.+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 4 |
- #'+ #' This function wraps [teal.reporter::reporter_previewer_ui()] and |
|||
| 5 |
- #' @return Character object contain code+ #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be |
|||
| 6 |
- #' @keywords internal+ #' used in `teal` applications. |
|||
| 7 |
- get_rcode_libraries <- function() {
+ #' |
|||
| 8 | -14x | -
- vapply(- |
- ||
| 9 | -14x | -
- utils::sessionInfo()$otherPkgs,- |
- ||
| 10 | -14x | -
- function(x) {
- |
- ||
| 11 | -238x | +
- paste0("library(", x$Package, ")")
+ #' If you are creating a `teal` application using [teal::init()] then this |
||
| 12 | +9 |
- },- |
- ||
| 13 | -14x | -
- character(1)+ #' module will be added to your application automatically if any of your `teal modules` |
||
| 14 | +10 |
- ) %>%+ #' support report generation |
||
| 15 | +11 |
- # put it into reverse order to correctly simulate executed code- |
- ||
| 16 | -14x | -
- rev() %>%- |
- ||
| 17 | -14x | -
- paste0(sep = "\n") %>%- |
- ||
| 18 | -14x | -
- paste0(collapse = "")+ #' |
||
| 19 | +12 |
- }+ #' @inheritParams module |
||
| 20 | +13 |
-
+ #' @param server_args (`named list`)\cr |
||
| 21 | +14 |
-
+ #' Arguments passed to [teal.reporter::reporter_previewer_srv()]. |
||
| 22 | +15 |
-
+ #' @return `teal_module` containing the `teal.reporter` previewer functionality |
||
| 23 | +16 |
- get_rcode_str_install <- function() {
- |
- ||
| 24 | -18x | -
- code_string <- getOption("teal.load_nest_code")
+ #' @export |
||
| 25 | +17 |
-
+ reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
|
||
| 26 | -18x | +18 | +4x |
- if (!is.null(code_string) && is.character(code_string)) {
+ checkmate::assert_string(label) |
| 27 | +19 | 2x |
- return(code_string)- |
- |
| 28 | -- |
- }- |
- ||
| 29 | -- |
-
+ checkmate::assert_list(server_args, names = "named") |
||
| 30 | -16x | -
- return("# Add any code to install/load your NEST environment here\n")
- |
- ||
| 31 | -+ | 20 | +2x |
- }+ checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv)))) |
| 32 | +21 | |||
| 33 | -- |
- #' Get datasets code- |
- ||
| 34 | -+ | |||
| 22 | +2x |
- #'+ srv <- function(id, reporter, ...) {
|
||
| 35 | -+ | |||
| 23 | +! |
- #' Get combined code from `FilteredData` and from `CodeClass` object.+ teal.reporter::reporter_previewer_srv(id, reporter, ...) |
||
| 36 | +24 |
- #'+ } |
||
| 37 | +25 |
- #' @param datanames (`character`) names of datasets to extract code from+ |
||
| 38 | -+ | |||
| 26 | +2x |
- #' @param datasets (`FilteredData`) object+ ui <- function(id, ...) {
|
||
| 39 | -+ | |||
| 27 | +! |
- #' @param hashes named (`list`) of hashes per dataset+ teal.reporter::reporter_previewer_ui(id, ...) |
||
| 40 | +28 |
- #'+ } |
||
| 41 | +29 |
- #' @return `character(3)` containing following elements:+ |
||
| 42 | -+ | |||
| 30 | +2x |
- #' - code from `CodeClass` (data loading code)+ module <- module( |
||
| 43 | -+ | |||
| 31 | +2x |
- #' - hash check of loaded objects+ label = "temporary label", |
||
| 44 | -+ | |||
| 32 | +2x |
- #'+ server = srv, ui = ui, |
||
| 45 | -+ | |||
| 33 | +2x |
- #' @keywords internal+ server_args = server_args, ui_args = list(), datanames = NULL |
||
| 46 | +34 |
- get_datasets_code <- function(datanames, datasets, hashes) {
+ ) |
||
| 47 | -14x | +35 | +2x |
- str_code <- datasets$get_code(datanames)+ class(module) <- c("teal_module_previewer", class(module))
|
| 48 | -14x | -
- if (length(str_code) == 0 || (length(str_code) == 1 && str_code == "")) {
- |
- ||
| 49 | -! | +36 | +2x |
- str_code <- "message('Preprocessing is empty')"
+ module$label <- label |
| 50 | -14x | +37 | +2x |
- } else if (length(str_code) > 0) {
+ module |
| 51 | -14x | +|||
| 38 | +
- str_code <- paste0(str_code, "\n\n")+ } |
| 52 | +1 |
- }+ #' @title `TealReportCard` |
||
| 53 | +2 |
-
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 54 | -14x | +|||
| 3 | +
- if (!datasets$get_check()) {
+ #' A child of [`ReportCard`] that is used for teal specific applications. |
|||
| 55 | -10x | +|||
| 4 | +
- check_note_string <- paste0(+ #' In addition to the parent methods, it supports rendering teal specific elements such as |
|||
| 56 | -10x | +|||
| 5 | +
- c(+ #' the source code, the encodings panel content and the filter panel content as part of the |
|||
| 57 | -10x | +|||
| 6 | +
- "message(paste(\"Reproducibility of data import and preprocessing was not explicitly checked\",",+ #' meta data. |
|||
| 58 | -10x | +|||
| 7 | +
- " \" ('check = FALSE' is set). Contact app developer if this is an issue.\n\"))"
+ #' @export |
|||
| 59 | +8 |
- ),+ #' |
||
| 60 | -10x | +|||
| 9 | +
- collapse = "\n"+ TealReportCard <- R6::R6Class( # nolint: object_name_linter. |
|||
| 61 | +10 |
- )+ classname = "TealReportCard", |
||
| 62 | -10x | +|||
| 11 | +
- str_code <- paste0(str_code, "\n\n", check_note_string)+ inherit = teal.reporter::ReportCard, |
|||
| 63 | +12 |
- }+ public = list( |
||
| 64 | +13 |
-
+ #' @description Appends the source code to the `content` meta data of this `TealReportCard`. |
||
| 65 | -14x | +|||
| 14 | +
- str_hash <- paste(+ #' |
|||
| 66 | -14x | +|||
| 15 | +
- paste0(+ #' @param src (`character(1)`) code as text. |
|||
| 67 | -14x | +|||
| 16 | +
- vapply(+ #' @param ... any `rmarkdown` R chunk parameter and its value. |
|||
| 68 | -14x | +|||
| 17 | +
- datanames,+ #' But `eval` parameter is always set to `FALSE`. |
|||
| 69 | -14x | +|||
| 18 | +
- function(dataname) {
+ #' @return invisibly self |
|||
| 70 | -17x | +|||
| 19 | +
- sprintf(+ #' @examples |
|||
| 71 | -17x | +|||
| 20 | +
- "stopifnot(%s == %s)",+ #' card <- TealReportCard$new()$append_src( |
|||
| 72 | -17x | +|||
| 21 | +
- deparse1(bquote(rlang::hash(.(as.name(dataname))))),+ #' "plot(iris)" |
|||
| 73 | -17x | +|||
| 22 | +
- deparse1(hashes[[dataname]])+ #' ) |
|||
| 74 | +23 |
- )+ #' card$get_content()[[1]]$get_content() |
||
| 75 | +24 |
- },+ append_src = function(src, ...) {
|
||
| 76 | -14x | -
- character(1)- |
- ||
| 77 | -+ | 25 | +4x |
- ),+ checkmate::assert_character(src, min.len = 0, max.len = 1) |
| 78 | -14x | +26 | +4x |
- collapse = "\n"+ params <- list(...) |
| 79 | -+ | |||
| 27 | +4x |
- ),+ params$eval <- FALSE |
||
| 80 | -14x | +28 | +4x |
- "\n\n"+ rblock <- RcodeBlock$new(src) |
| 81 | -+ | |||
| 29 | +4x |
- )+ rblock$set_params(params) |
||
| 82 | -+ | |||
| 30 | +4x |
-
+ self$append_content(rblock) |
||
| 83 | -14x | +31 | +4x |
- c(str_code, str_hash)+ self$append_metadata("SRC", src)
|
| 84 | -+ | |||
| 32 | +4x |
- }+ invisible(self) |
| 1 | +33 |
- # This file adds a splash screen for delayed data loading on top of teal+ }, |
||
| 2 | +34 |
-
+ #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`. |
||
| 3 | +35 |
- #' UI to show a splash screen in the beginning, then delegate to [srv_teal()]+ #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses |
||
| 4 | +36 |
- #'+ #' the default `yaml::as.yaml` to format the list. |
||
| 5 | +37 |
- #' @description `r lifecycle::badge("stable")`
+ #' If the filter state list is empty, nothing is appended to the `content`. |
||
| 6 | +38 |
- #' The splash screen could be used to query for a password to fetch the data.+ #' |
||
| 7 | +39 |
- #' [init()] is a very thin wrapper around this module useful for end-users which+ #' @param fs (`teal_slices`) object returned from [teal_slices()] function. |
||
| 8 | +40 |
- #' assumes that it is a top-level module and cannot be embedded.+ #' @return invisibly self |
||
| 9 | +41 |
- #' This function instead adheres to the Shiny module conventions.+ append_fs = function(fs) {
|
||
| 10 | -+ | |||
| 42 | +4x |
- #'+ checkmate::assert_class(fs, "teal_slices") |
||
| 11 | -+ | |||
| 43 | +3x |
- #' If data is obtained through delayed loading, its splash screen is used. Otherwise,+ self$append_text("Filter State", "header3")
|
||
| 12 | -+ | |||
| 44 | +3x |
- #' a default splash screen is shown.+ self$append_content(TealSlicesBlock$new(fs)) |
||
| 13 | -+ | |||
| 45 | +3x |
- #'+ invisible(self) |
||
| 14 | +46 |
- #' Please also refer to the doc of [init()].+ }, |
||
| 15 | +47 |
- #'+ #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`. |
||
| 16 | +48 |
- #' @param id (`character(1)`)\cr+ #' |
||
| 17 | +49 |
- #' module id+ #' @param encodings (`list`) list of encodings selections of the teal app. |
||
| 18 | +50 |
- #' @inheritParams init+ #' @return invisibly self |
||
| 19 | +51 |
- #' @export+ #' @examples |
||
| 20 | +52 |
- ui_teal_with_splash <- function(id,+ #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X")) |
||
| 21 | +53 |
- data,+ #' card$get_content()[[1]]$get_content() |
||
| 22 | +54 |
- title,+ #' |
||
| 23 | +55 |
- header = tags$p("Add Title Here"),
+ append_encodings = function(encodings) {
|
||
| 24 | -+ | |||
| 56 | +4x |
- footer = tags$p("Add Footer Here")) {
+ checkmate::assert_list(encodings) |
||
| 25 | -32x | +57 | +4x |
- checkmate::assert_class(data, "TealDataAbstract")+ self$append_text("Selected Options", "header3")
|
| 26 | -32x | +58 | +4x |
- is_pulled_data <- teal.data::is_pulled(data)+ if (requireNamespace("yaml", quietly = TRUE)) {
|
| 27 | -32x | +59 | +4x |
- ns <- NS(id)+ self$append_text(yaml::as.yaml(encodings, handlers = list( |
| 28 | -+ | |||
| 60 | +4x |
-
+ POSIXct = function(x) format(x, "%Y-%m-%d"), |
||
| 29 | -+ | |||
| 61 | +4x |
- # Startup splash screen for delayed loading+ POSIXlt = function(x) format(x, "%Y-%m-%d"), |
||
| 30 | -+ | |||
| 62 | +4x |
- # We use delayed loading in all cases, even when the data does not need to be fetched.+ Date = function(x) format(x, "%Y-%m-%d") |
||
| 31 | -+ | |||
| 63 | +4x |
- # This has the benefit that when filtering the data takes a lot of time initially, the+ )), "verbatim") |
||
| 32 | +64 |
- # Shiny app does not time out.+ } else {
|
||
| 33 | -32x | +|||
| 65 | +! |
- splash_ui <- if (is_pulled_data) {
+ stop("yaml package is required to format the encodings list")
|
||
| 34 | +66 |
- # blank ui if data is already pulled+ } |
||
| 35 | -28x | +67 | +4x |
- div()+ self$append_metadata("Encodings", encodings)
+ |
+
| 68 | +4x | +
+ invisible(self) |
||
| 36 | +69 |
- } else {
+ } |
||
| 37 | -4x | +|||
| 70 | +
- message("App was initialized with delayed data loading.")
+ ), |
|||
| 38 | -4x | +|||
| 71 | +
- data$get_ui(ns("startapp_module"))
+ private = list() |
|||
| 39 | +72 |
- }+ ) |
||
| 40 | +73 | |||
| 41 | -32x | +|||
| 74 | +
- ui_teal(id = ns("teal"), splash_ui = splash_ui, title = title, header = header, footer = footer)
+ #' @title `RcodeBlock` |
|||
| 42 | +75 |
- }+ #' @keywords internal |
||
| 43 | +76 |
-
+ TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter. |
||
| 44 | +77 |
- #' Server function that loads the data through reactive loading and then delegates+ classname = "TealSlicesBlock", |
||
| 45 | +78 |
- #' to [srv_teal()].+ inherit = teal.reporter:::TextBlock, |
||
| 46 | +79 |
- #'+ public = list( |
||
| 47 | +80 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description Returns a `TealSlicesBlock` object. |
||
| 48 | +81 |
- #' Please also refer to the doc of [init()].+ #' |
||
| 49 | +82 |
- #'+ #' @details Returns a `TealSlicesBlock` object with no content and no parameters. |
||
| 50 | +83 |
- #' @inheritParams init+ #' |
||
| 51 | +84 |
- #' @param modules `teal_modules` object containing the output modules which+ #' @param content (`teal_slices`) object returned from [teal_slices()] function. |
||
| 52 | +85 |
- #' will be displayed in the teal application. See [modules()] and [module()] for+ #' @param style (`character(1)`) string specifying style to apply. |
||
| 53 | +86 |
- #' more details.+ #' |
||
| 54 | +87 |
- #' @inheritParams shiny::moduleServer+ #' @return `TealSlicesBlock` |
||
| 55 | +88 |
- #' @return `reactive`, return value of [srv_teal()]+ #' @examples |
||
| 56 | +89 |
- #' @export+ #' block <- teal:::TealSlicesBlock$new() |
||
| 57 | +90 |
- srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
+ #' |
||
| 58 | -4x | +|||
| 91 | +
- checkmate::assert_class(data, "TealDataAbstract")+ initialize = function(content = teal_slices(), style = "verbatim") {
|
|||
| 59 | -4x | +92 | +9x |
- moduleServer(id, function(input, output, session) {
+ self$set_content(content) |
| 60 | -4x | +93 | +8x |
- logger::log_trace(+ self$set_style(style) |
| 61 | -4x | +94 | +8x |
- "srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
+ invisible(self) |
| 62 | +95 |
- )+ }, |
||
| 63 | +96 | |||
| 64 | -4x | -
- if (getOption("teal.show_js_log", default = FALSE)) {
- |
- ||
| 65 | -! | +|||
| 97 | +
- shinyjs::showLog()+ #' @description Sets content of this `TealSlicesBlock`. |
|||
| 66 | +98 |
- }+ #' Sets content as `YAML` text which represents a list generated from `teal_slices`. |
||
| 67 | +99 |
-
+ #' The list displays limited number of fields from `teal_slice` objects, but this list is |
||
| 68 | -4x | +|||
| 100 | +
- is_pulled_data <- teal.data::is_pulled(data)+ #' sufficient to conclude which filters were applied. |
|||
| 69 | +101 |
- # raw_data contains TealDataAbstract, i.e. R6 object and container for data+ #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min" |
||
| 70 | +102 |
- # reactive to get data through delayed loading+ #' |
||
| 71 | +103 |
- # we must leave it inside the server because of callModule which needs to pick up the right session+ #' |
||
| 72 | -4x | +|||
| 104 | +
- if (is_pulled_data) {
+ #' @param content (`teal_slices`) object returned from [teal_slices()] function. |
|||
| 73 | -2x | +|||
| 105 | +
- raw_data <- reactiveVal(data) # will trigger by setting it+ #' @return invisibly self |
|||
| 74 | +106 |
- } else {
+ set_content = function(content) {
|
||
| 75 | -2x | +107 | +10x |
- raw_data <- data$get_server()(id = "startapp_module")+ checkmate::assert_class(content, "teal_slices") |
| 76 | -2x | -
- if (!is.reactive(raw_data)) {
- |
- ||
| 77 | -! | +108 | +9x |
- stop("The delayed loading module has to return a reactive object.")
+ if (length(content) != 0) {
|
| 78 | -+ | |||
| 109 | +7x |
- }+ states_list <- lapply(content, function(x) {
|
||
| 79 | -+ | |||
| 110 | +7x |
- }+ x_list <- shiny::isolate(as.list(x)) |
||
| 80 | -+ | |||
| 111 | +7x |
-
+ if ( |
||
| 81 | -4x | +112 | +7x |
- res <- srv_teal(id = "teal", modules = modules, raw_data = raw_data, filter = filter)+ inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
|
| 82 | -4x | +113 | +7x |
- logger::log_trace(+ length(x_list$choices) == 2 && |
| 83 | -4x | +114 | +7x |
- "srv_teal_with_splash initialized the module with data { paste(data$get_datanames(), collapse = ' ') }."
+ length(x_list$selected) == 2 |
| 84 | +115 |
- )+ ) {
|
||
| 85 | -4x | +|||
| 116 | +! |
- return(res)+ x_list$range <- paste(x_list$selected, collapse = " - ") |
||
| 86 | -+ | |||
| 117 | +! |
- })+ x_list["selected"] <- NULL |
||
| 87 | +118 |
- }+ } |
| 1 | -+ | |||
| 119 | +7x |
- #' Get Client Timezone+ if (!is.null(x_list$arg)) {
|
||
| 2 | -+ | |||
| 120 | +! |
- #'+ x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples" |
||
| 3 | +121 |
- #' Local timezone in the browser may differ from the system timezone from the server.+ } |
||
| 4 | +122 |
- #' This script can be run to register a shiny input which contains information about+ |
||
| 5 | -+ | |||
| 123 | +7x |
- #' the timezone in the browser.+ x_list <- x_list[ |
||
| 6 | -+ | |||
| 124 | +7x |
- #'+ c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
|
||
| 7 | +125 |
- #' @param ns (`function`) namespace function passed from the `session` object in the+ ] |
||
| 8 | -+ | |||
| 126 | +7x |
- #' Shiny server. For Shiny modules this will allow for proper name spacing of the+ names(x_list) <- c( |
||
| 9 | -+ | |||
| 127 | +7x |
- #' registered input.+ "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression", |
||
| 10 | -+ | |||
| 128 | +7x |
- #'+ "Selected Values", "Selected range", "Include NA values", "Include Inf values" |
||
| 11 | +129 |
- #' @return (`Shiny`) input variable accessible with `input$tz` which is a (`character`)+ ) |
||
| 12 | +130 |
- #' string containing the timezone of the browser/client.+ |
||
| 13 | -+ | |||
| 131 | +7x |
- #' @keywords internal+ Filter(Negate(is.null), x_list) |
||
| 14 | +132 |
- get_client_timezone <- function(ns) {
+ }) |
||
| 15 | -8x | +|||
| 133 | +
- script <- sprintf(+ |
|||
| 16 | -8x | +134 | +7x |
- "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",+ if (requireNamespace("yaml", quietly = TRUE)) {
|
| 17 | -8x | +135 | +7x |
- ns("timezone")
+ super$set_content(yaml::as.yaml(states_list)) |
| 18 | +136 |
- )+ } else {
|
||
| 19 | -8x | +|||
| 137 | +! |
- shinyjs::runjs(script) # function does not return anything+ stop("yaml package is required to format the filter state list")
|
||
| 20 | -8x | +|||
| 138 | +
- return(invisible(NULL))+ } |
|||
| 21 | +139 |
- }+ } |
||
| 22 | -+ | |||
| 140 | +9x |
-
+ private$teal_slices <- content |
||
| 23 | -+ | |||
| 141 | +9x |
- #' Resolve the expected bootstrap theme+ invisible(self) |
||
| 24 | +142 |
- #' @keywords internal+ }, |
||
| 25 | +143 |
- get_teal_bs_theme <- function() {
+ #' @description Create the `RcodeBlock` from a list. |
||
| 26 | -36x | +|||
| 144 | +
- bs_theme <- getOption("teal.bs_theme")
+ #' @param x `named list` with two fields `c("text", "params")`.
|
|||
| 27 | -36x | +|||
| 145 | +
- if (is.null(bs_theme)) {
+ #' Use the `get_available_params` method to get all possible parameters. |
|||
| 28 | -33x | +|||
| 146 | +
- NULL+ #' @return invisibly self |
|||
| 29 | -3x | +|||
| 147 | +
- } else if (!inherits(bs_theme, "bs_theme")) {
+ from_list = function(x) {
|
|||
| 30 | -2x | +148 | +1x |
- warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
+ checkmate::assert_list(x) |
| 31 | -2x | +149 | +1x |
- NULL+ checkmate::assert_names(names(x), must.include = c("teal_slices"))
|
| 32 | -+ | |||
| 150 | +1x |
- } else {
+ self$set_content(x$teal_slices) |
||
| 33 | +151 | 1x |
- bs_theme+ invisible(self) |
|
| 34 | +152 |
- }+ }, |
||
| 35 | +153 |
- }+ #' @description Convert the `RcodeBlock` to a list. |
||
| 36 | +154 |
-
+ #' @return `named list` with a text and `params`. |
||
| 37 | +155 |
- include_parent_datanames <- function(dataname, join_keys) {
- |
- ||
| 38 | -145x | -
- parents <- character(0)- |
- ||
| 39 | -145x | -
- for (i in dataname) {
+
|
||
| 40 | -25x | +|||
| 156 | +
- while (length(i) > 0) {
+ to_list = function() {
|
|||
| 41 | -25x | +157 | +2x |
- parent_i <- join_keys$get_parent(i)+ list(teal_slices = private$teal_slices) |
| 42 | -25x | +|||
| 158 | +
- parents <- c(parent_i, parents)+ } |
|||
| 43 | -25x | +|||
| 159 | +
- i <- parent_i+ ), |
|||
| 44 | +160 |
- }+ private = list( |
||
| 45 | +161 |
- }+ style = "verbatim", |
||
| 46 | +162 |
-
+ teal_slices = NULL # teal_slices |
||
| 47 | -145x | +|||
| 163 | +
- return(unique(c(parents, dataname)))+ ) |
|||
| 48 | +164 |
- }+ ) |
| 1 |
- # This file contains Shiny modules useful for debugging and developing teal.+ .onLoad <- function(libname, pkgname) { # nolint
|
|||
| 2 |
- # We do not export the functions in this file. They are for+ # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R |
|||
| 3 | -+ | ! |
- # developers only and can be accessed via `:::`.+ teal_default_options <- list(teal.show_js_log = FALSE) |
|
| 5 | -+ | ! |
- #' Dummy module to show the filter calls generated by the right encoding panel+ op <- options() |
|
| 6 | -+ | ! |
- #'+ toset <- !(names(teal_default_options) %in% names(op)) |
|
| 7 | -+ | ! |
- #'+ if (any(toset)) options(teal_default_options[toset]) |
|
| 8 |
- #' Please do not remove, this is useful for debugging teal without+ |
|||
| 9 | -+ | ! |
- #' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
+ options("shiny.sanitize.errors" = FALSE)
|
|
| 10 |
- #' and avoids session restarts!+ |
|||
| 11 |
- #'+ # Set up the teal logger instance |
|||
| 12 | -+ | ! |
- #' @param label `character` label of module+ teal.logger::register_logger("teal")
|
|
| 13 |
- #' @keywords internal+ |
|||
| 14 | -+ | ! |
- #'+ invisible() |
|
| 15 |
- #' @examples+ } |
|||
| 16 |
- #' app <- init(+ |
|||
| 17 |
- #' data = list(iris = iris, mtcars = mtcars),+ .onAttach <- function(libname, pkgname) { # nolint
|
|||
| 18 | -+ | 2x |
- #' modules = teal:::filter_calls_module(),+ packageStartupMessage( |
|
| 19 | -+ | 2x |
- #' header = "Simple teal app"+ "\nYou are using teal version ", |
|
| 20 |
- #' )+ # `system.file` uses the `shim` of `system.file` by `teal` |
|||
| 21 |
- #' if (interactive()) {
+ # we avoid `desc` dependency here to get the version |
|||
| 22 | -+ | 2x |
- #' runApp(app)+ read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
|
|
| 23 |
- #' }+ ) |
|||
| 24 |
- filter_calls_module <- function(label = "Filter Calls Module") { # nolint
- |
- |||
| 25 | -! | -
- checkmate::assert_string(label)- |
- ||
| 26 | -- | - - | -||
| 27 | -! | -
- module(- |
- ||
| 28 | -! | -
- label = label,- |
- ||
| 29 | -! | -
- server = function(input, output, session, data) {
- |
- ||
| 30 | -! | -
- checkmate::assert_class(data, "tdata")+ } |
||
| 31 | +25 | |||
| 32 | -! | -
- output$filter_calls <- renderText({
- |
- ||
| 33 | -! | -
- get_code_tdata(data)- |
- ||
| 34 | -- |
- })- |
- ||
| 35 | -- |
- },- |
- ||
| 36 | -! | -
- ui = function(id, ...) {
- |
- ||
| 37 | -! | +26 | +
- ns <- NS(id)+ # Use non-exported function(s) from teal.slice. |
|
| 38 | -! | +|||
| 27 | +
- div(+ # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0). |
|||
| 39 | -! | +|||
| 28 | +
- h2("The following filter calls are generated:"),
+ list_to_teal_slices <- getFromNamespace("list_to_teal_slices", "teal.slice")
|
|||
| 40 | -! | +|||
| 29 | +
- verbatimTextOutput(ns("filter_calls"))
+ # This one is here because setdiff_teal_slice should not be exported from teal.slice. |
|||
| 41 | +30 |
- )+ setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
|
||
| 42 | +31 |
- },+ # This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice. |
||
| 43 | -! | +|||
| 32 | +
- datanames = "all"+ coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
|
|||
| 44 | +33 |
- )+ # all *Block objects are private in teal.reporter |
||
| 45 | +34 |
- }+ RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint
|
| 1 |
- #' Create a `teal` module for previewing a report+ #' Get Client Timezone |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' Local timezone in the browser may differ from the system timezone from the server. |
||
| 4 |
- #' This function wraps [teal.reporter::reporter_previewer_ui()] and+ #' This script can be run to register a shiny input which contains information about |
||
| 5 |
- #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be+ #' the timezone in the browser. |
||
| 6 |
- #' used in `teal` applications.+ #' |
||
| 7 |
- #'+ #' @param ns (`function`) namespace function passed from the `session` object in the |
||
| 8 |
- #' If you are creating a `teal` application using [teal::init()] then this+ #' Shiny server. For Shiny modules this will allow for proper name spacing of the |
||
| 9 |
- #' module will be added to your application automatically if any of your `teal modules`+ #' registered input. |
||
| 10 |
- #' support report generation+ #' |
||
| 11 |
- #'+ #' @return (`Shiny`) input variable accessible with `input$tz` which is a (`character`) |
||
| 12 |
- #' @inheritParams module+ #' string containing the timezone of the browser/client. |
||
| 13 |
- #' @param server_args (`named list`)\cr+ #' @keywords internal |
||
| 14 |
- #' Arguments passed to [teal.reporter::reporter_previewer_srv()].+ get_client_timezone <- function(ns) {
|
||
| 15 | -+ | 8x |
- #' @return `teal_module` containing the `teal.reporter` previewer functionality+ script <- sprintf( |
| 16 | -+ | 8x |
- #' @export+ "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)", |
| 17 | -+ | 8x |
- reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
+ ns("timezone")
|
| 18 | -4x | +
- checkmate::assert_string(label)+ ) |
|
| 19 | -2x | +8x |
- checkmate::assert_list(server_args, names = "named")+ shinyjs::runjs(script) # function does not return anything |
| 20 | -2x | +8x |
- checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))+ return(invisible(NULL)) |
| 21 |
-
+ } |
||
| 22 | -2x | +
- srv <- function(id, reporter, ...) {
+
|
|
| 23 | -! | +
- teal.reporter::reporter_previewer_srv(id, reporter, ...)+ #' Resolve the expected bootstrap theme |
|
| 24 |
- }+ #' @keywords internal |
||
| 25 |
-
+ get_teal_bs_theme <- function() {
|
||
| 26 | -2x | +36x |
- ui <- function(id, ...) {
+ bs_theme <- getOption("teal.bs_theme")
|
| 27 | -! | +36x |
- teal.reporter::reporter_previewer_ui(id, ...)+ if (is.null(bs_theme)) {
|
| 28 | -+ | 33x |
- }+ NULL |
| 29 | -+ | 3x |
-
+ } else if (!inherits(bs_theme, "bs_theme")) {
|
| 30 | 2x |
- module <- module(+ warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
|
|
| 31 | 2x |
- label = label,+ NULL |
|
| 32 | -2x | +
- server = srv, ui = ui,+ } else {
|
|
| 33 | -2x | +1x |
- server_args = server_args, ui_args = list(), datanames = NULL+ bs_theme |
| 34 |
- )+ } |
||
| 35 | -2x | +
- class(module) <- c("teal_module_previewer", class(module))
+ } |
|
| 36 | -2x | +
- module+ |
|
| 37 | + |
+ include_parent_datanames <- function(dataname, join_keys) {
+ |
+ |
| 38 | +145x | +
+ parents <- character(0)+ |
+ |
| 39 | +145x | +
+ for (i in dataname) {
+ |
+ |
| 40 | +25x | +
+ while (length(i) > 0) {
+ |
+ |
| 41 | +25x | +
+ parent_i <- join_keys$get_parent(i)+ |
+ |
| 42 | +25x | +
+ parents <- c(parent_i, parents)+ |
+ |
| 43 | +25x | +
+ i <- parent_i+ |
+ |
| 44 | ++ |
+ }+ |
+ |
| 45 | ++ |
+ }+ |
+ |
| 46 | ++ | + + | +|
| 47 | +145x | +
+ return(unique(c(parents, dataname)))+ |
+ |
| 48 | +
} |