| 1 | ++ |
+ #' Generates library calls from current session info+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Function to create multiple library calls out of current session info to ensure reproducible code works.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @return Character vector of `library(<package>)` calls.+ |
+
| 6 | ++ |
+ #' @keywords internal+ |
+
| 7 | ++ |
+ get_rcode_libraries <- function() {
+ |
+
| 8 | +6x | +
+ vapply(+ |
+
| 9 | +6x | +
+ utils::sessionInfo()$otherPkgs,+ |
+
| 10 | +6x | +
+ function(x) {
+ |
+
| 11 | +36x | +
+ paste0("library(", x$Package, ")")
+ |
+
| 12 | ++ |
+ },+ |
+
| 13 | +6x | +
+ character(1)+ |
+
| 14 | ++ |
+ ) %>%+ |
+
| 15 | ++ |
+ # put it into reverse order to correctly simulate executed code+ |
+
| 16 | +6x | +
+ rev() %>%+ |
+
| 17 | +6x | +
+ paste0(sep = "\n") %>%+ |
+
| 18 | +6x | +
+ paste0(collapse = "")+ |
+
| 19 | ++ |
+ }+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ #' @noRd+ |
+
| 22 | ++ |
+ #' @keywords internal+ |
+
| 23 | ++ |
+ get_rcode_str_install <- function() {
+ |
+
| 24 | +10x | +
+ code_string <- getOption("teal.load_nest_code")
+ |
+
| 25 | +10x | +
+ if (is.character(code_string)) {
+ |
+
| 26 | +2x | +
+ code_string+ |
+
| 27 | ++ |
+ } else {
+ |
+
| 28 | +8x | +
+ "# Add any code to install/load your NEST environment here\n"+ |
+
| 29 | ++ |
+ }+ |
+
| 30 | ++ |
+ }+ |
+
| 31 | ++ | + + | +
| 32 | ++ |
+ #' Get datasets code+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' Retrieve complete code to create, verify, and filter a dataset.+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @param datanames (`character`) names of datasets to extract code from+ |
+
| 37 | ++ |
+ #' @param datasets (`FilteredData`) object+ |
+
| 38 | ++ |
+ #' @param hashes named (`list`) of hashes per dataset+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @return Character string concatenated from the following elements:+ |
+
| 41 | ++ |
+ #' - data pre-processing code (from `data` argument in `init`)+ |
+
| 42 | ++ |
+ #' - hash check of loaded objects+ |
+
| 43 | ++ |
+ #' - filter code (if any)+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @keywords internal+ |
+
| 46 | ++ |
+ get_datasets_code <- function(datanames, datasets, hashes) {
+ |
+
| 47 | ++ |
+ # preprocessing code+ |
+
| 48 | +4x | +
+ str_prepro <-+ |
+
| 49 | +4x | +
+ teal.data:::get_code_dependency(attr(datasets, "preprocessing_code"), names = datanames, check_names = FALSE)+ |
+
| 50 | +4x | +
+ if (length(str_prepro) == 0) {
+ |
+
| 51 | +! | +
+ str_prepro <- "message('Preprocessing is empty')"
+ |
+
| 52 | ++ |
+ } else {
+ |
+
| 53 | +4x | +
+ str_prepro <- paste(str_prepro, collapse = "\n")+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | ++ | + + | +
| 56 | ++ |
+ # hash checks+ |
+
| 57 | +4x | +
+ str_hash <- vapply(datanames, function(dataname) {
+ |
+
| 58 | +6x | +
+ sprintf(+ |
+
| 59 | +6x | +
+ "stopifnot(%s == %s)",+ |
+
| 60 | +6x | +
+ deparse1(bquote(rlang::hash(.(as.name(dataname))))),+ |
+
| 61 | +6x | +
+ deparse1(hashes[[dataname]])+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | +4x | +
+ }, character(1))+ |
+
| 64 | +4x | +
+ str_hash <- paste(str_hash, collapse = "\n")+ |
+
| 65 | ++ | + + | +
| 66 | ++ |
+ # filter expressions+ |
+
| 67 | +4x | +
+ str_filter <- teal.slice::get_filter_expr(datasets, datanames)+ |
+
| 68 | +4x | +
+ if (str_filter == "") {
+ |
+
| 69 | +2x | +
+ str_filter <- character(0)+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ # concatenate all code+ |
+
| 73 | +4x | +
+ str_code <- paste(c(str_prepro, str_hash, str_filter), collapse = "\n\n")+ |
+
| 74 | +4x | +
+ sprintf("%s\n", str_code)
+ |
+
| 75 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Create `teal_module` and `teal_modules` objects+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' `r lifecycle::badge("stable")`
+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' Create a nested tab structure to embed modules in a `teal` application.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @details+ |
+
| 9 | ++ |
+ #' `module()` creates an instance of a `teal_module` that can be placed in a `teal` application.+ |
+
| 10 | ++ |
+ #' `modules()` shapes the structure of a the application by organizing `teal_module` within the navigation panel.+ |
+
| 11 | ++ |
+ #' It wraps `teal_module` and `teal_modules` objects in a `teal_modules` object,+ |
+
| 12 | ++ |
+ #' which results in a nested structure corresponding to the nested tabs in the final application.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' Note that for `modules()` `label` comes after `...`, so it must be passed as a named argument,+ |
+
| 15 | ++ |
+ #' otherwise it will be captured by `...`.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' The labels `"global_filters"` and `"Report previewer"` are reserved+ |
+
| 18 | ++ |
+ #' because they are used by the `mapping` argument of [teal_slices()]+ |
+
| 19 | ++ |
+ #' and the report previewer module [reporter_previewer_module()], respectively.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @param label (`character(1)`) Label shown in the navigation item for the module or module group.+ |
+
| 22 | ++ |
+ #' For `modules()` defaults to `"root"`. See `Details`.+ |
+
| 23 | ++ |
+ #' @param server (`function`) `shiny` module with following arguments:+ |
+
| 24 | ++ |
+ #' - `id` - `teal` will set proper `shiny` namespace for this module (see [shiny::moduleServer()]).+ |
+
| 25 | ++ |
+ #' - `input`, `output`, `session` - (optional; not recommended) When provided, then [shiny::callModule()]+ |
+
| 26 | ++ |
+ #' will be used to call a module. From `shiny` 1.5.0, the recommended way is to use+ |
+
| 27 | ++ |
+ #' [shiny::moduleServer()] instead which doesn't require these arguments.+ |
+
| 28 | ++ |
+ #' - `data` (optional) When provided, the module will be called with `teal_data` object (i.e. a list of+ |
+
| 29 | ++ |
+ #' reactive (filtered) data specified in the `filters` argument) as the value of this argument.+ |
+
| 30 | ++ |
+ #' - `datasets` (optional) When provided, the module will be called with `FilteredData` object as the+ |
+
| 31 | ++ |
+ #' value of this argument. (See [`teal.slice::FilteredData`]).+ |
+
| 32 | ++ |
+ #' - `reporter` (optional) When provided, the module will be called with `Reporter` object as the value+ |
+
| 33 | ++ |
+ #' of this argument. (See [`teal.reporter::Reporter`]).+ |
+
| 34 | ++ |
+ #' - `filter_panel_api` (optional) When provided, the module will be called with `FilterPanelAPI` object+ |
+
| 35 | ++ |
+ #' as the value of this argument. (See [`teal.slice::FilterPanelAPI`]).+ |
+
| 36 | ++ |
+ #' - `...` (optional) When provided, `server_args` elements will be passed to the module named argument+ |
+
| 37 | ++ |
+ #' or to the `...`.+ |
+
| 38 | ++ |
+ #' @param ui (`function`) `shiny` UI module function with following arguments:+ |
+
| 39 | ++ |
+ #' - `id` - `teal` will set proper `shiny` namespace for this module.+ |
+
| 40 | ++ |
+ #' - `...` (optional) When provided, `ui_args` elements will be passed to the module named argument+ |
+
| 41 | ++ |
+ #' or to the `...`.+ |
+
| 42 | ++ |
+ #' @param filters (`character`) Deprecated. Use `datanames` instead.+ |
+
| 43 | ++ |
+ #' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The+ |
+
| 44 | ++ |
+ #' filter panel will automatically update the shown filters to include only+ |
+
| 45 | ++ |
+ #' filters in the listed datasets. `NULL` will hide the filter panel,+ |
+
| 46 | ++ |
+ #' and the keyword `"all"` will show filters of all datasets. `datanames` also determines+ |
+
| 47 | ++ |
+ #' a subset of datasets which are appended to the `data` argument in server function.+ |
+
| 48 | ++ |
+ #' @param server_args (named `list`) with additional arguments passed on to the server function.+ |
+
| 49 | ++ |
+ #' @param ui_args (named `list`) with additional arguments passed on to the UI function.+ |
+
| 50 | ++ |
+ #' @param x (`teal_module` or `teal_modules`) Object to format/print.+ |
+
| 51 | ++ |
+ #' @param indent (`integer(1)`) Indention level; each nested element is indented one level more.+ |
+
| 52 | ++ |
+ #' @param ...+ |
+
| 53 | ++ |
+ #' - For `modules()`: (`teal_module` or `teal_modules`) Objects to wrap into a tab.+ |
+
| 54 | ++ |
+ #' - For `format()` and `print()`: Arguments passed to other methods.+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' @return+ |
+
| 57 | ++ |
+ #' `module()` returns an object of class `teal_module`.+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' `modules()` returns a `teal_modules` object which contains following fields:+ |
+
| 60 | ++ |
+ #' - `label`: taken from the `label` argument.+ |
+
| 61 | ++ |
+ #' - `children`: a list containing objects passed in `...`. List elements are named after+ |
+
| 62 | ++ |
+ #' their `label` attribute converted to a valid `shiny` id.+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @name teal_modules+ |
+
| 65 | ++ |
+ #' @aliases teal_module+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @examples+ |
+
| 68 | ++ |
+ #' library(shiny)+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' module_1 <- module(+ |
+
| 71 | ++ |
+ #' label = "a module",+ |
+
| 72 | ++ |
+ #' server = function(id, data) {
+ |
+
| 73 | ++ |
+ #' moduleServer(+ |
+
| 74 | ++ |
+ #' id,+ |
+
| 75 | ++ |
+ #' module = function(input, output, session) {
+ |
+
| 76 | ++ |
+ #' output$data <- renderDataTable(data()[["iris"]])+ |
+
| 77 | ++ |
+ #' }+ |
+
| 78 | ++ |
+ #' )+ |
+
| 79 | ++ |
+ #' },+ |
+
| 80 | ++ |
+ #' ui = function(id) {
+ |
+
| 81 | ++ |
+ #' ns <- NS(id)+ |
+
| 82 | ++ |
+ #' tagList(dataTableOutput(ns("data")))
+ |
+
| 83 | ++ |
+ #' },+ |
+
| 84 | ++ |
+ #' datanames = "all"+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' module_2 <- module(+ |
+
| 88 | ++ |
+ #' label = "another module",+ |
+
| 89 | ++ |
+ #' server = function(id) {
+ |
+
| 90 | ++ |
+ #' moduleServer(+ |
+
| 91 | ++ |
+ #' id,+ |
+
| 92 | ++ |
+ #' module = function(input, output, session) {
+ |
+
| 93 | ++ |
+ #' output$text <- renderText("Another Module")
+ |
+
| 94 | ++ |
+ #' }+ |
+
| 95 | ++ |
+ #' )+ |
+
| 96 | ++ |
+ #' },+ |
+
| 97 | ++ |
+ #' ui = function(id) {
+ |
+
| 98 | ++ |
+ #' ns <- NS(id)+ |
+
| 99 | ++ |
+ #' tagList(textOutput(ns("text")))
+ |
+
| 100 | ++ |
+ #' },+ |
+
| 101 | ++ |
+ #' datanames = NULL+ |
+
| 102 | ++ |
+ #' )+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' modules <- modules(+ |
+
| 105 | ++ |
+ #' label = "modules",+ |
+
| 106 | ++ |
+ #' modules(+ |
+
| 107 | ++ |
+ #' label = "nested modules",+ |
+
| 108 | ++ |
+ #' module_1+ |
+
| 109 | ++ |
+ #' ),+ |
+
| 110 | ++ |
+ #' module_2+ |
+
| 111 | ++ |
+ #' )+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ #' app <- init(+ |
+
| 114 | ++ |
+ #' data = teal_data(iris = iris),+ |
+
| 115 | ++ |
+ #' modules = modules+ |
+
| 116 | ++ |
+ #' )+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' if (interactive()) {
+ |
+
| 119 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 120 | ++ |
+ #' }+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ #' @rdname teal_modules+ |
+
| 123 | ++ |
+ #' @export+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ module <- function(label = "module",+ |
+
| 126 | ++ |
+ server = function(id, ...) {
+ |
+
| 127 | +! | +
+ moduleServer(id, function(input, output, session) {}) # nolint
+ |
+
| 128 | ++ |
+ },+ |
+
| 129 | ++ |
+ ui = function(id, ...) {
+ |
+
| 130 | +! | +
+ tags$p(paste0("This module has no UI (id: ", id, " )"))
+ |
+
| 131 | ++ |
+ },+ |
+
| 132 | ++ |
+ filters,+ |
+
| 133 | ++ |
+ datanames = "all",+ |
+
| 134 | ++ |
+ server_args = NULL,+ |
+
| 135 | ++ |
+ ui_args = NULL) {
+ |
+
| 136 | ++ |
+ # argument checking (independent)+ |
+
| 137 | ++ |
+ ## `label`+ |
+
| 138 | +143x | +
+ checkmate::assert_string(label)+ |
+
| 139 | +140x | +
+ if (label == "global_filters") {
+ |
+
| 140 | +1x | +
+ stop(+ |
+
| 141 | +1x | +
+ sprintf("module(label = \"%s\", ...\n ", label),
+ |
+
| 142 | +1x | +
+ "Label 'global_filters' is reserved in teal. Please change to something else.",+ |
+
| 143 | +1x | +
+ call. = FALSE+ |
+
| 144 | ++ |
+ )+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | +139x | +
+ if (label == "Report previewer") {
+ |
+
| 147 | +! | +
+ stop(+ |
+
| 148 | +! | +
+ sprintf("module(label = \"%s\", ...\n ", label),
+ |
+
| 149 | +! | +
+ "Label 'Report previewer' is reserved in teal. Please change to something else.",+ |
+
| 150 | +! | +
+ call. = FALSE+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ ## server+ |
+
| 155 | +139x | +
+ checkmate::assert_function(server)+ |
+
| 156 | +139x | +
+ server_formals <- names(formals(server))+ |
+
| 157 | +139x | +
+ if (!(+ |
+
| 158 | +139x | +
+ "id" %in% server_formals ||+ |
+
| 159 | +139x | +
+ all(c("input", "output", "session") %in% server_formals)
+ |
+
| 160 | ++ |
+ )) {
+ |
+
| 161 | +2x | +
+ stop(+ |
+
| 162 | +2x | +
+ "\nmodule() `server` argument requires a function with following arguments:",+ |
+
| 163 | +2x | +
+ "\n - id - `teal` will set proper `shiny` namespace for this module.",+ |
+
| 164 | +2x | +
+ "\n - input, output, session (not recommended) - then `shiny::callModule` will be used to call a module.",+ |
+
| 165 | +2x | +
+ "\n\nFollowing arguments can be used optionaly:",+ |
+
| 166 | +2x | +
+ "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",+ |
+
| 167 | +2x | +
+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ |
+
| 168 | +2x | +
+ "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",+ |
+
| 169 | +2x | +
+ "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",+ |
+
| 170 | +2x | +
+ "\n - `...` server_args elements will be passed to the module named argument or to the `...`"+ |
+
| 171 | ++ |
+ )+ |
+
| 172 | ++ |
+ }+ |
+
| 173 | +137x | +
+ if ("datasets" %in% server_formals) {
+ |
+
| 174 | +2x | +
+ warning(+ |
+
| 175 | +2x | +
+ sprintf("Called from module(label = \"%s\", ...)\n ", label),
+ |
+
| 176 | +2x | +
+ "`datasets` argument in the server is deprecated and will be removed in the next release. ",+ |
+
| 177 | +2x | +
+ "Please use `data` instead.",+ |
+
| 178 | +2x | +
+ call. = FALSE+ |
+
| 179 | ++ |
+ )+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ | + + | +
| 182 | ++ | + + | +
| 183 | ++ |
+ ## UI+ |
+
| 184 | +137x | +
+ checkmate::assert_function(ui)+ |
+
| 185 | +137x | +
+ ui_formals <- names(formals(ui))+ |
+
| 186 | +137x | +
+ if (!"id" %in% ui_formals) {
+ |
+
| 187 | +1x | +
+ stop(+ |
+
| 188 | +1x | +
+ "\nmodule() `ui` argument requires a function with following arguments:",+ |
+
| 189 | +1x | +
+ "\n - id - `teal` will set proper `shiny` namespace for this module.",+ |
+
| 190 | +1x | +
+ "\n\nFollowing arguments can be used optionally:",+ |
+
| 191 | +1x | +
+ "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"+ |
+
| 192 | ++ |
+ )+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | +136x | +
+ if (any(c("data", "datasets") %in% ui_formals)) {
+ |
+
| 195 | +2x | +
+ stop(+ |
+
| 196 | +2x | +
+ sprintf("Called from module(label = \"%s\", ...)\n ", label),
+ |
+
| 197 | +2x | +
+ "UI with `data` or `datasets` argument is no longer accepted.\n ",+ |
+
| 198 | +2x | +
+ "If some UI inputs depend on data, please move the logic to your server instead.\n ",+ |
+
| 199 | +2x | +
+ "Possible solutions are renderUI() or updateXyzInput() functions."+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ | + + | +
| 203 | ++ | + + | +
| 204 | ++ |
+ ## `filters`+ |
+
| 205 | +134x | +
+ if (!missing(filters)) {
+ |
+
| 206 | +! | +
+ datanames <- filters+ |
+
| 207 | +! | +
+ msg <-+ |
+
| 208 | +! | +
+ "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."+ |
+
| 209 | +! | +
+ logger::log_warn(msg)+ |
+
| 210 | +! | +
+ warning(msg)+ |
+
| 211 | ++ |
+ }+ |
+
| 212 | ++ | + + | +
| 213 | ++ |
+ ## `datanames` (also including deprecated `filters`)+ |
+
| 214 | ++ |
+ # please note a race condition between datanames set when filters is not missing and data arg in server function+ |
+
| 215 | +134x | +
+ if (!is.element("data", server_formals) && !is.null(datanames)) {
+ |
+
| 216 | +50x | +
+ message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
+ |
+
| 217 | +50x | +
+ datanames <- NULL+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | +134x | +
+ checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ |
+
| 220 | ++ | + + | +
| 221 | ++ |
+ ## `server_args`+ |
+
| 222 | +133x | +
+ checkmate::assert_list(server_args, null.ok = TRUE, names = "named")+ |
+
| 223 | +131x | +
+ srv_extra_args <- setdiff(names(server_args), server_formals)+ |
+
| 224 | +131x | +
+ if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
+ |
+
| 225 | +1x | +
+ stop(+ |
+
| 226 | +1x | +
+ "\nFollowing `server_args` elements have no equivalent in the formals of the server:\n",+ |
+
| 227 | +1x | +
+ paste(paste(" -", srv_extra_args), collapse = "\n"),
+ |
+
| 228 | +1x | +
+ "\n\nUpdate the server arguments by including above or add `...`"+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ | + + | +
| 232 | ++ |
+ ## `ui_args`+ |
+
| 233 | +130x | +
+ checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")+ |
+
| 234 | +128x | +
+ ui_extra_args <- setdiff(names(ui_args), ui_formals)+ |
+
| 235 | +128x | +
+ if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
+ |
+
| 236 | +1x | +
+ stop(+ |
+
| 237 | +1x | +
+ "\nFollowing `ui_args` elements have no equivalent in the formals of UI:\n",+ |
+
| 238 | +1x | +
+ paste(paste(" -", ui_extra_args), collapse = "\n"),
+ |
+
| 239 | +1x | +
+ "\n\nUpdate the UI arguments by including above or add `...`"+ |
+
| 240 | ++ |
+ )+ |
+
| 241 | ++ |
+ }+ |
+
| 242 | ++ | + + | +
| 243 | +127x | +
+ structure(+ |
+
| 244 | +127x | +
+ list(+ |
+
| 245 | +127x | +
+ label = label,+ |
+
| 246 | +127x | +
+ server = server, ui = ui, datanames = unique(datanames),+ |
+
| 247 | +127x | +
+ server_args = server_args, ui_args = ui_args+ |
+
| 248 | ++ |
+ ),+ |
+
| 249 | +127x | +
+ class = "teal_module"+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ |
+ }+ |
+
| 252 | ++ | + + | +
| 253 | ++ |
+ #' @rdname teal_modules+ |
+
| 254 | ++ |
+ #' @export+ |
+
| 255 | ++ |
+ #'+ |
+
| 256 | ++ |
+ modules <- function(..., label = "root") {
+ |
+
| 257 | +99x | +
+ checkmate::assert_string(label)+ |
+
| 258 | +97x | +
+ submodules <- list(...)+ |
+
| 259 | +97x | +
+ if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
+ |
+
| 260 | +2x | +
+ stop(+ |
+
| 261 | +2x | +
+ "The only character argument to modules() must be 'label' and it must be named, ",+ |
+
| 262 | +2x | +
+ "change modules('lab', ...) to modules(label = 'lab', ...)"
+ |
+
| 263 | ++ |
+ )+ |
+
| 264 | ++ |
+ }+ |
+
| 265 | ++ | + + | +
| 266 | +95x | +
+ checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+ |
+
| 267 | ++ |
+ # name them so we can more easily access the children+ |
+
| 268 | ++ |
+ # beware however that the label of the submodules should not be changed as it must be kept synced+ |
+
| 269 | +92x | +
+ labels <- vapply(submodules, function(submodule) submodule$label, character(1))+ |
+
| 270 | +92x | +
+ names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
+ |
+
| 271 | +92x | +
+ structure(+ |
+
| 272 | +92x | +
+ list(+ |
+
| 273 | +92x | +
+ label = label,+ |
+
| 274 | +92x | +
+ children = submodules+ |
+
| 275 | ++ |
+ ),+ |
+
| 276 | +92x | +
+ class = "teal_modules"+ |
+
| 277 | ++ |
+ )+ |
+
| 278 | ++ |
+ }+ |
+
| 279 | ++ | + + | +
| 280 | ++ |
+ # printing methods ----+ |
+
| 281 | ++ | + + | +
| 282 | ++ |
+ #' @rdname teal_modules+ |
+
| 283 | ++ |
+ #' @export+ |
+
| 284 | ++ |
+ format.teal_module <- function(x, indent = 0, ...) { # nolint
+ |
+
| 285 | +3x | +
+ paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, "\n", collapse = "")
+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ | + + | +
| 288 | ++ | + + | +
| 289 | ++ |
+ #' @rdname teal_modules+ |
+
| 290 | ++ |
+ #' @export+ |
+
| 291 | ++ |
+ print.teal_module <- function(x, ...) {
+ |
+
| 292 | +! | +
+ cat(format(x, ...))+ |
+
| 293 | +! | +
+ invisible(x)+ |
+
| 294 | ++ |
+ }+ |
+
| 295 | ++ | + + | +
| 296 | ++ | + + | +
| 297 | ++ |
+ #' @rdname teal_modules+ |
+
| 298 | ++ |
+ #' @export+ |
+
| 299 | ++ |
+ format.teal_modules <- function(x, indent = 0, ...) { # nolint
+ |
+
| 300 | +1x | +
+ paste(+ |
+
| 301 | +1x | +
+ c(+ |
+
| 302 | +1x | +
+ paste0(rep(" ", indent), "+ ", x$label, "\n"),
+ |
+
| 303 | +1x | +
+ unlist(lapply(x$children, format, indent = indent + 1, ...))+ |
+
| 304 | ++ |
+ ),+ |
+
| 305 | +1x | +
+ collapse = ""+ |
+
| 306 | ++ |
+ )+ |
+
| 307 | ++ |
+ }+ |
+
| 308 | ++ | + + | +
| 309 | ++ | + + | +
| 310 | ++ |
+ #' @rdname teal_modules+ |
+
| 311 | ++ |
+ #' @export+ |
+
| 312 | ++ |
+ print.teal_modules <- print.teal_module+ |
+
| 313 | ++ | + + | +
| 314 | ++ | + + | +
| 315 | ++ |
+ # utilities ----+ |
+
| 316 | ++ |
+ ## subset or modify modules ----+ |
+
| 317 | ++ | + + | +
| 318 | ++ |
+ #' Append a `teal_module` to `children` of a `teal_modules` object+ |
+
| 319 | ++ |
+ #' @keywords internal+ |
+
| 320 | ++ |
+ #' @param modules (`teal_modules`)+ |
+
| 321 | ++ |
+ #' @param module (`teal_module`) object to be appended onto the children of `modules`+ |
+
| 322 | ++ |
+ #' @return A `teal_modules` object with `module` appended.+ |
+
| 323 | ++ |
+ append_module <- function(modules, module) {
+ |
+
| 324 | +8x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 325 | +6x | +
+ checkmate::assert_class(module, "teal_module")+ |
+
| 326 | +4x | +
+ modules$children <- c(modules$children, list(module))+ |
+
| 327 | +4x | +
+ labels <- vapply(modules$children, function(submodule) submodule$label, character(1))+ |
+
| 328 | +4x | +
+ names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
+ |
+
| 329 | +4x | +
+ modules+ |
+
| 330 | ++ |
+ }+ |
+
| 331 | ++ | + + | +
| 332 | ++ |
+ #' Extract/Remove module(s) of specific class+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`.+ |
+
| 335 | ++ |
+ #'+ |
+
| 336 | ++ |
+ #' @param modules (`teal_modules`)+ |
+
| 337 | ++ |
+ #' @param class The class name of `teal_module` to be extracted or dropped.+ |
+
| 338 | ++ |
+ #' @keywords internal+ |
+
| 339 | ++ |
+ #' @return+ |
+
| 340 | ++ |
+ #' - For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`.+ |
+
| 341 | ++ |
+ #' - For `drop_module`, the opposite, which is all `teal_modules` of class other than `class`.+ |
+
| 342 | ++ |
+ #' @rdname module_management+ |
+
| 343 | ++ |
+ extract_module <- function(modules, class) {
+ |
+
| 344 | +20x | +
+ if (inherits(modules, class)) {
+ |
+
| 345 | +! | +
+ modules+ |
+
| 346 | +20x | +
+ } else if (inherits(modules, "teal_module")) {
+ |
+
| 347 | +11x | +
+ NULL+ |
+
| 348 | +9x | +
+ } else if (inherits(modules, "teal_modules")) {
+ |
+
| 349 | +9x | +
+ Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class))+ |
+
| 350 | ++ |
+ }+ |
+
| 351 | ++ |
+ }+ |
+
| 352 | ++ | + + | +
| 353 | ++ |
+ #' @keywords internal+ |
+
| 354 | ++ |
+ #' @return `teal_modules`+ |
+
| 355 | ++ |
+ #' @rdname module_management+ |
+
| 356 | ++ |
+ drop_module <- function(modules, class) {
+ |
+
| 357 | +! | +
+ if (inherits(modules, class)) {
+ |
+
| 358 | +! | +
+ NULL+ |
+
| 359 | +! | +
+ } else if (inherits(modules, "teal_module")) {
+ |
+
| 360 | +! | +
+ modules+ |
+
| 361 | +! | +
+ } else if (inherits(modules, "teal_modules")) {
+ |
+
| 362 | +! | +
+ do.call(+ |
+
| 363 | +! | +
+ "modules",+ |
+
| 364 | +! | +
+ c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label)+ |
+
| 365 | ++ |
+ )+ |
+
| 366 | ++ |
+ }+ |
+
| 367 | ++ |
+ }+ |
+
| 368 | ++ | + + | +
| 369 | ++ |
+ ## read modules ----+ |
+
| 370 | ++ | + + | +
| 371 | ++ |
+ #' Does the object make use of the `arg`+ |
+
| 372 | ++ |
+ #'+ |
+
| 373 | ++ |
+ #' @param modules (`teal_module` or `teal_modules`) object+ |
+
| 374 | ++ |
+ #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.+ |
+
| 375 | ++ |
+ #' @return `logical` whether the object makes use of `arg`.+ |
+
| 376 | ++ |
+ #' @rdname is_arg_used+ |
+
| 377 | ++ |
+ #' @keywords internal+ |
+
| 378 | ++ |
+ is_arg_used <- function(modules, arg) {
+ |
+
| 379 | +286x | +
+ checkmate::assert_string(arg)+ |
+
| 380 | +283x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 381 | +29x | +
+ any(unlist(lapply(modules$children, is_arg_used, arg)))+ |
+
| 382 | +254x | +
+ } else if (inherits(modules, "teal_module")) {
+ |
+
| 383 | +43x | +
+ is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg)+ |
+
| 384 | +211x | +
+ } else if (is.function(modules)) {
+ |
+
| 385 | +209x | +
+ isTRUE(arg %in% names(formals(modules)))+ |
+
| 386 | ++ |
+ } else {
+ |
+
| 387 | +2x | +
+ stop("is_arg_used function not implemented for this object")
+ |
+
| 388 | ++ |
+ }+ |
+
| 389 | ++ |
+ }+ |
+
| 390 | ++ | + + | +
| 391 | ++ | + + | +
| 392 | ++ |
+ #' Get module depth+ |
+
| 393 | ++ |
+ #'+ |
+
| 394 | ++ |
+ #' Depth starts at 0, so a single `teal.module` has depth 0.+ |
+
| 395 | ++ |
+ #' Nesting it increases overall depth by 1.+ |
+
| 396 | ++ |
+ #'+ |
+
| 397 | ++ |
+ #' @inheritParams init+ |
+
| 398 | ++ |
+ #' @param depth optional, integer determining current depth level+ |
+
| 399 | ++ |
+ #'+ |
+
| 400 | ++ |
+ #' @return Depth level for given module.+ |
+
| 401 | ++ |
+ #' @keywords internal+ |
+
| 402 | ++ |
+ modules_depth <- function(modules, depth = 0L) {
+ |
+
| 403 | +12x | +
+ checkmate::assert_multi_class(modules, c("teal_module", "teal_modules"))
+ |
+
| 404 | +12x | +
+ checkmate::assert_int(depth, lower = 0)+ |
+
| 405 | +11x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 406 | +4x | +
+ max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))+ |
+
| 407 | ++ |
+ } else {
+ |
+
| 408 | +7x | +
+ depth+ |
+
| 409 | ++ |
+ }+ |
+
| 410 | ++ |
+ }+ |
+
| 411 | ++ | + + | +
| 412 | ++ |
+ #' Retrieve labels from `teal_modules`+ |
+
| 413 | ++ |
+ #'+ |
+
| 414 | ++ |
+ #' @param modules (`teal_modules`)+ |
+
| 415 | ++ |
+ #' @return A `list` containing the labels of the modules. If the modules are nested,+ |
+
| 416 | ++ |
+ #' the function returns a nested `list` of labels.+ |
+
| 417 | ++ |
+ #' @keywords internal+ |
+
| 418 | ++ |
+ module_labels <- function(modules) {
+ |
+
| 419 | +! | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 420 | +! | +
+ lapply(modules$children, module_labels)+ |
+
| 421 | ++ |
+ } else {
+ |
+
| 422 | +! | +
+ modules$label+ |
+
| 423 | ++ |
+ }+ |
+
| 424 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Manage multiple `FilteredData` objects+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Oversee filter states across the entire application.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This module observes changes in the filters of each `FilteredData` object+ |
+
| 6 | ++ |
+ #' and keeps track of all filters used. A mapping of filters to modules+ |
+
| 7 | ++ |
+ #' is kept in the `mapping_matrix` object (which is actually a `data.frame`)+ |
+
| 8 | ++ |
+ #' that tracks which filters (rows) are active in which modules (columns).+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @name module_filter_manager+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @param id (`character(1)`)+ |
+
| 13 | ++ |
+ #' `shiny` module id.+ |
+
| 14 | ++ |
+ #' @param filtered_data_list (named `list`)+ |
+
| 15 | ++ |
+ #' A list, possibly nested, of `FilteredData` objects.+ |
+
| 16 | ++ |
+ #' Each `FilteredData` will be served to one module in the `teal` application.+ |
+
| 17 | ++ |
+ #' The structure of the list must reflect the nesting of modules in tabs+ |
+
| 18 | ++ |
+ #' and the names of the list must match the labels of their respective modules.+ |
+
| 19 | ++ |
+ #' @inheritParams init+ |
+
| 20 | ++ |
+ #' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.+ |
+
| 21 | ++ |
+ #' @keywords internal+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ NULL+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ #' Filter manager modal+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' Opens a modal containing the filter manager UI.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @name module_filter_manager_modal+ |
+
| 30 | ++ |
+ #' @inheritParams module_filter_manager+ |
+
| 31 | ++ |
+ #' @keywords internal+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ NULL+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ #' @rdname module_filter_manager_modal+ |
+
| 36 | ++ |
+ filter_manager_modal_ui <- function(id) {
+ |
+
| 37 | +! | +
+ ns <- NS(id)+ |
+
| 38 | +! | +
+ tags$button(+ |
+
| 39 | +! | +
+ id = ns("show"),
+ |
+
| 40 | +! | +
+ class = "btn action-button filter_manager_button",+ |
+
| 41 | +! | +
+ title = "Show filters manager modal",+ |
+
| 42 | +! | +
+ icon("gear")
+ |
+
| 43 | ++ |
+ )+ |
+
| 44 | ++ |
+ }+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ #' @rdname module_filter_manager_modal+ |
+
| 47 | ++ |
+ filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
+ |
+
| 48 | +3x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 49 | +3x | +
+ observeEvent(input$show, {
+ |
+
| 50 | +! | +
+ logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
+ |
+
| 51 | +! | +
+ showModal(+ |
+
| 52 | +! | +
+ modalDialog(+ |
+
| 53 | +! | +
+ filter_manager_ui(session$ns("filter_manager")),
+ |
+
| 54 | +! | +
+ size = "l",+ |
+
| 55 | +! | +
+ footer = NULL,+ |
+
| 56 | +! | +
+ easyClose = TRUE+ |
+
| 57 | ++ |
+ )+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ |
+ })+ |
+
| 60 | ++ | + + | +
| 61 | +3x | +
+ filter_manager_srv("filter_manager", filtered_data_list, filter)
+ |
+
| 62 | ++ |
+ })+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ #' @rdname module_filter_manager+ |
+
| 66 | ++ |
+ filter_manager_ui <- function(id) {
+ |
+
| 67 | +! | +
+ ns <- NS(id)+ |
+
| 68 | +! | +
+ div(+ |
+
| 69 | +! | +
+ class = "filter_manager_content",+ |
+
| 70 | +! | +
+ tableOutput(ns("slices_table")),
+ |
+
| 71 | +! | +
+ snapshot_manager_ui(ns("snapshot_manager"))
+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | ++ | + + | +
| 75 | ++ |
+ #' @rdname module_filter_manager+ |
+
| 76 | ++ |
+ filter_manager_srv <- function(id, filtered_data_list, filter) {
+ |
+
| 77 | +5x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 78 | +5x | +
+ logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
+ |
+
| 79 | ++ | + + | +
| 80 | +5x | +
+ is_module_specific <- isTRUE(attr(filter, "module_specific"))+ |
+
| 81 | ++ | + + | +
| 82 | ++ |
+ # Create a global list of slices.+ |
+
| 83 | ++ |
+ # Contains all available teal_slice objects available to all modules.+ |
+
| 84 | ++ |
+ # Passed whole to instances of FilteredData used for individual modules.+ |
+
| 85 | ++ |
+ # Down there a subset that pertains to the data sets used in that module is applied and displayed.+ |
+
| 86 | +5x | +
+ slices_global <- reactiveVal(filter)+ |
+
| 87 | ++ | + + | +
| 88 | +5x | +
+ filtered_data_list <-+ |
+
| 89 | +5x | +
+ if (!is_module_specific) {
+ |
+
| 90 | ++ |
+ # Retrieve the first FilteredData from potentially nested list.+ |
+
| 91 | ++ |
+ # List of length one is named "global_filters" because that name is forbidden for a module label.+ |
+
| 92 | +4x | +
+ list(global_filters = unlist(filtered_data_list)[[1]])+ |
+
| 93 | ++ |
+ } else {
+ |
+
| 94 | ++ |
+ # Flatten potentially nested list of FilteredData objects while maintaining useful names.+ |
+
| 95 | ++ |
+ # Simply using `unlist` would result in concatenated names.+ |
+
| 96 | +1x | +
+ flatten_nested <- function(x, name = NULL) {
+ |
+
| 97 | +5x | +
+ if (inherits(x, "FilteredData")) {
+ |
+
| 98 | +3x | +
+ setNames(list(x), name)+ |
+
| 99 | ++ |
+ } else {
+ |
+
| 100 | +2x | +
+ unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))+ |
+
| 101 | ++ |
+ }+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | +1x | +
+ flatten_nested(filtered_data_list)+ |
+
| 104 | ++ |
+ }+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ # Create mapping of filters to modules in matrix form (presented as data.frame).+ |
+
| 107 | ++ |
+ # Modules get NAs for filters that cannot be set for them.+ |
+
| 108 | +5x | +
+ mapping_matrix <- reactive({
+ |
+
| 109 | +5x | +
+ state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")+ |
+
| 110 | +5x | +
+ mapping_smooth <- lapply(filtered_data_list, function(x) {
+ |
+
| 111 | +7x | +
+ state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")+ |
+
| 112 | +7x | +
+ state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")+ |
+
| 113 | +7x | +
+ states_active <- state_ids_global %in% state_ids_local+ |
+
| 114 | +7x | +
+ ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)+ |
+
| 115 | ++ |
+ })+ |
+
| 116 | ++ | + + | +
| 117 | +5x | +
+ as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)+ |
+
| 118 | ++ |
+ })+ |
+
| 119 | ++ | + + | +
| 120 | +5x | +
+ output$slices_table <- renderTable(+ |
+
| 121 | +5x | +
+ expr = {
+ |
+
| 122 | ++ |
+ # Display logical values as UTF characters.+ |
+
| 123 | +2x | +
+ mm <- mapping_matrix()+ |
+
| 124 | +2x | +
+ mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))+ |
+
| 125 | +2x | +
+ mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))+ |
+
| 126 | +2x | +
+ if (!is_module_specific) colnames(mm) <- "Global Filters"+ |
+
| 127 | ++ | + + | +
| 128 | ++ |
+ # Display placeholder if no filters defined.+ |
+
| 129 | +2x | +
+ if (nrow(mm) == 0L) {
+ |
+
| 130 | +2x | +
+ mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)+ |
+
| 131 | +2x | +
+ rownames(mm) <- ""+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ # Report Previewer will not be displayed.+ |
+
| 135 | +2x | +
+ mm[names(mm) != "Report previewer"]+ |
+
| 136 | ++ |
+ },+ |
+
| 137 | +5x | +
+ align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
+ |
+
| 138 | +5x | +
+ rownames = TRUE+ |
+
| 139 | ++ |
+ )+ |
+
| 140 | ++ | + + | +
| 141 | ++ |
+ # Create list of module calls.+ |
+
| 142 | +5x | +
+ modules_out <- lapply(names(filtered_data_list), function(module_name) {
+ |
+
| 143 | +7x | +
+ filter_manager_module_srv(+ |
+
| 144 | +7x | +
+ id = module_name,+ |
+
| 145 | +7x | +
+ module_fd = filtered_data_list[[module_name]],+ |
+
| 146 | +7x | +
+ slices_global = slices_global+ |
+
| 147 | ++ |
+ )+ |
+
| 148 | ++ |
+ })+ |
+
| 149 | ++ | + + | +
| 150 | ++ |
+ # Call snapshot manager.+ |
+
| 151 | +5x | +
+ snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
+ |
+
| 152 | ++ | + + | +
| 153 | +5x | +
+ modules_out # returned for testing purpose+ |
+
| 154 | ++ |
+ })+ |
+
| 155 | ++ |
+ }+ |
+
| 156 | ++ | + + | +
| 157 | ++ |
+ #' Module specific filter manager+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' Tracks filter states in a single module.+ |
+
| 160 | ++ |
+ #'+ |
+
| 161 | ++ |
+ #' This module tracks the state of a single `FilteredData` object and global `teal_slices`+ |
+
| 162 | ++ |
+ #' and updates both objects as necessary. Filter states added in different modules+ |
+
| 163 | ++ |
+ #' Filter states added any individual module are added to global `teal_slices`+ |
+
| 164 | ++ |
+ #' and from there become available in other modules+ |
+
| 165 | ++ |
+ #' by setting `private$available_teal_slices` in each `FilteredData`.+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' @param id (`character(1)`)+ |
+
| 168 | ++ |
+ #' `shiny` module id.+ |
+
| 169 | ++ |
+ #' @param module_fd (`FilteredData`)+ |
+
| 170 | ++ |
+ #' Object containing the data to be filtered in a single `teal` module.+ |
+
| 171 | ++ |
+ #' @param slices_global (`reactiveVal`)+ |
+
| 172 | ++ |
+ #' stores `teal_slices` with all available filters; allows the following actions:+ |
+
| 173 | ++ |
+ #' - to disable/enable a specific filter in a module+ |
+
| 174 | ++ |
+ #' - to restore saved filter settings+ |
+
| 175 | ++ |
+ #' - to save current filter panel settings+ |
+
| 176 | ++ |
+ #' @return A `reactive` expression containing the slices active in this module.+ |
+
| 177 | ++ |
+ #' @keywords internal+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ filter_manager_module_srv <- function(id, module_fd, slices_global) {
+ |
+
| 180 | +7x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 181 | ++ |
+ # Only operate on slices that refer to data sets present in this module.+ |
+
| 182 | +7x | +
+ module_fd$set_available_teal_slices(reactive(slices_global()))+ |
+
| 183 | ++ | + + | +
| 184 | ++ |
+ # Track filter state of this module.+ |
+
| 185 | +7x | +
+ slices_module <- reactive(module_fd$get_filter_state())+ |
+
| 186 | ++ | + + | +
| 187 | ++ |
+ # Reactive values for comparing states.+ |
+
| 188 | +7x | +
+ previous_slices <- reactiveVal(isolate(slices_module()))+ |
+
| 189 | +7x | +
+ slices_added <- reactiveVal(NULL)+ |
+
| 190 | ++ | + + | +
| 191 | ++ |
+ # Observe changes in module filter state and trigger appropriate actions.+ |
+
| 192 | +7x | +
+ observeEvent(slices_module(), ignoreNULL = FALSE, {
+ |
+
| 193 | +2x | +
+ logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
+ |
+
| 194 | +2x | +
+ added <- setdiff_teal_slices(slices_module(), slices_global())+ |
+
| 195 | +! | +
+ if (length(added)) slices_added(added)+ |
+
| 196 | +2x | +
+ previous_slices(slices_module())+ |
+
| 197 | ++ |
+ })+ |
+
| 198 | ++ | + + | +
| 199 | +7x | +
+ observeEvent(slices_added(), ignoreNULL = TRUE, {
+ |
+
| 200 | +! | +
+ logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
+ |
+
| 201 | ++ |
+ # In case the new state has the same id as an existing state, add a suffix to it.+ |
+
| 202 | +! | +
+ global_ids <- vapply(slices_global(), `[[`, character(1L), "id")+ |
+
| 203 | +! | +
+ lapply(+ |
+
| 204 | +! | +
+ slices_added(),+ |
+
| 205 | +! | +
+ function(slice) {
+ |
+
| 206 | +! | +
+ if (slice$id %in% global_ids) {
+ |
+
| 207 | +! | +
+ slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | ++ |
+ )+ |
+
| 211 | +! | +
+ slices_global_new <- c(slices_global(), slices_added())+ |
+
| 212 | +! | +
+ slices_global(slices_global_new)+ |
+
| 213 | +! | +
+ slices_added(NULL)+ |
+
| 214 | ++ |
+ })+ |
+
| 215 | ++ | + + | +
| 216 | +7x | +
+ slices_module # returned for testing purpose+ |
+
| 217 | ++ |
+ })+ |
+
| 218 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Create a `tdata` object+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("deprecated")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Create a new object called `tdata` which contains `data`, a `reactive` list of `data.frames`+ |
+
| 6 | ++ |
+ #' (or `MultiAssayExperiment`), with attributes:+ |
+
| 7 | ++ |
+ #' - `code` (`reactive`) containing code used to generate the data+ |
+
| 8 | ++ |
+ #' - join_keys (`join_keys`) containing the relationships between the data+ |
+
| 9 | ++ |
+ #' - metadata (named `list`) containing any metadata associated with the data frames+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @name tdata+ |
+
| 12 | ++ |
+ #' @param data (named `list`) A list of `data.frame` or `MultiAssayExperiment` objects,+ |
+
| 13 | ++ |
+ #' which optionally can be `reactive`.+ |
+
| 14 | ++ |
+ #' Inside this object all of these items will be made `reactive`.+ |
+
| 15 | ++ |
+ #' @param code (`character` or `reactive` which evaluates to a `character`) containing+ |
+
| 16 | ++ |
+ #' the code used to generate the data. This should be `reactive` if the code is changing+ |
+
| 17 | ++ |
+ #' during a reactive context (e.g. if filtering changes the code). Inside this+ |
+
| 18 | ++ |
+ #' object `code` will be made reactive+ |
+
| 19 | ++ |
+ #' @param join_keys (`teal.data::join_keys`) object containing relationships between the+ |
+
| 20 | ++ |
+ #' datasets.+ |
+
| 21 | ++ |
+ #' @param metadata (named `list`) each element contains a list of metadata about the named `data.frame`+ |
+
| 22 | ++ |
+ #' Each element of these list should be atomic and length one.+ |
+
| 23 | ++ |
+ #' @return A `tdata` object.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @seealso `as_tdata`+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @examples+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' data <- new_tdata(+ |
+
| 30 | ++ |
+ #' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),+ |
+
| 31 | ++ |
+ #' code = "iris <- iris+ |
+
| 32 | ++ |
+ #' mtcars <- mtcars+ |
+
| 33 | ++ |
+ #' dd <- data.frame(x = 1:10)",+ |
+
| 34 | ++ |
+ #' metadata = list(dd = list(author = "NEST"), iris = list(version = 1))+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' # Extract a data.frame+ |
+
| 38 | ++ |
+ #' isolate(data[["iris"]]())+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' # Get code+ |
+
| 41 | ++ |
+ #' isolate(get_code_tdata(data))+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' # Get metadata+ |
+
| 44 | ++ |
+ #' get_metadata(data, "iris")+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @export+ |
+
| 47 | ++ |
+ new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
+ |
+
| 48 | +34x | +
+ lifecycle::deprecate_soft(+ |
+
| 49 | +34x | +
+ when = "0.15.0",+ |
+
| 50 | +34x | +
+ what = "tdata()",+ |
+
| 51 | +34x | +
+ details = paste(+ |
+
| 52 | +34x | +
+ "tdata is deprecated and will be removed in the next release. Use `teal_data` instead.\n",+ |
+
| 53 | +34x | +
+ "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/987."+ |
+
| 54 | ++ |
+ )+ |
+
| 55 | ++ |
+ )+ |
+
| 56 | +34x | +
+ checkmate::assert_list(+ |
+
| 57 | +34x | +
+ data,+ |
+
| 58 | +34x | +
+ any.missing = FALSE, names = "unique",+ |
+
| 59 | +34x | +
+ types = c("data.frame", "reactive", "MultiAssayExperiment")
+ |
+
| 60 | ++ |
+ )+ |
+
| 61 | +30x | +
+ checkmate::assert_class(join_keys, "join_keys", null.ok = TRUE)+ |
+
| 62 | +29x | +
+ checkmate::assert_multi_class(code, c("character", "reactive"))
+ |
+
| 63 | ++ | + + | +
| 64 | +28x | +
+ checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)+ |
+
| 65 | +26x | +
+ checkmate::assert_subset(names(metadata), names(data))+ |
+
| 66 | ++ | + + | +
| 67 | +25x | +
+ if (is.reactive(code)) {
+ |
+
| 68 | +9x | +
+ isolate(checkmate::assert_class(code(), "character", .var.name = "code"))+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ | + + | +
| 71 | ++ |
+ # create reactive data.frames+ |
+
| 72 | +24x | +
+ for (x in names(data)) {
+ |
+
| 73 | +47x | +
+ if (!is.reactive(data[[x]])) {
+ |
+
| 74 | +31x | +
+ data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | ++ |
+ }+ |
+
| 77 | ++ | + + | +
| 78 | ++ |
+ # set attributes+ |
+
| 79 | +24x | +
+ attr(data, "code") <- if (is.reactive(code)) code else reactive(code)+ |
+
| 80 | +24x | +
+ attr(data, "join_keys") <- join_keys+ |
+
| 81 | +24x | +
+ attr(data, "metadata") <- metadata+ |
+
| 82 | ++ | + + | +
| 83 | ++ |
+ # set class+ |
+
| 84 | +24x | +
+ class(data) <- c("tdata", class(data))
+ |
+
| 85 | +24x | +
+ data+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ #' Function to convert a `tdata` object to an `environment`+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' Any `reactive` expressions inside `tdata` are evaluated first.+ |
+
| 91 | ++ |
+ #' @param data (`tdata`) object+ |
+
| 92 | ++ |
+ #' @return An `environment`.+ |
+
| 93 | ++ |
+ #' @examples+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ #' data <- new_tdata(+ |
+
| 96 | ++ |
+ #' data = list(iris = iris, mtcars = reactive(mtcars)),+ |
+
| 97 | ++ |
+ #' code = "iris <- iris+ |
+
| 98 | ++ |
+ #' mtcars = mtcars"+ |
+
| 99 | ++ |
+ #' )+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' my_env <- isolate(tdata2env(data))+ |
+
| 102 | ++ |
+ #'+ |
+
| 103 | ++ |
+ #' @export+ |
+
| 104 | ++ |
+ tdata2env <- function(data) { # nolint
+ |
+
| 105 | +2x | +
+ checkmate::assert_class(data, "tdata")+ |
+
| 106 | +1x | +
+ list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))+ |
+
| 107 | ++ |
+ }+ |
+
| 108 | ++ | + + | +
| 109 | ++ | + + | +
| 110 | ++ |
+ #' Wrapper for `get_code.tdata`+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' This wrapper is to be used by downstream packages to extract the code of a `tdata` object.+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' @param data (`tdata`) object+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' @return (`character`) code used in the `tdata` object.+ |
+
| 117 | ++ |
+ #' @export+ |
+
| 118 | ++ |
+ get_code_tdata <- function(data) {
+ |
+
| 119 | +7x | +
+ checkmate::assert_class(data, "tdata")+ |
+
| 120 | +5x | +
+ attr(data, "code")()+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | ++ | + + | +
| 123 | ++ |
+ #' Extract `join_keys` from `tdata`+ |
+
| 124 | ++ |
+ #' @param data (`tdata`) object+ |
+
| 125 | ++ |
+ #' @param ... Additional arguments (not used)+ |
+
| 126 | ++ |
+ #' @export+ |
+
| 127 | ++ |
+ join_keys.tdata <- function(data, ...) {
+ |
+
| 128 | +2x | +
+ attr(data, "join_keys")+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' Function to get metadata from a `tdata` object+ |
+
| 132 | ++ |
+ #' @param data (`tdata` - object) to extract the data from+ |
+
| 133 | ++ |
+ #' @param dataname (`character(1)`) the dataset name whose metadata is requested+ |
+
| 134 | ++ |
+ #' @return Either list of metadata or NULL if no metadata.+ |
+
| 135 | ++ |
+ #' @export+ |
+
| 136 | ++ |
+ get_metadata <- function(data, dataname) {
+ |
+
| 137 | +4x | +
+ checkmate::assert_string(dataname)+ |
+
| 138 | +4x | +
+ UseMethod("get_metadata", data)
+ |
+
| 139 | ++ |
+ }+ |
+
| 140 | ++ | + + | +
| 141 | ++ |
+ #' @rdname get_metadata+ |
+
| 142 | ++ |
+ #' @export+ |
+
| 143 | ++ |
+ get_metadata.tdata <- function(data, dataname) {
+ |
+
| 144 | +4x | +
+ metadata <- attr(data, "metadata")+ |
+
| 145 | +4x | +
+ if (is.null(metadata)) {
+ |
+
| 146 | +1x | +
+ return(NULL)+ |
+
| 147 | ++ |
+ }+ |
+
| 148 | +3x | +
+ metadata[[dataname]]+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ | + + | +
| 151 | ++ |
+ #' @rdname get_metadata+ |
+
| 152 | ++ |
+ #' @export+ |
+
| 153 | ++ |
+ get_metadata.default <- function(data, dataname) {
+ |
+
| 154 | +! | +
+ stop("get_metadata function not implemented for this object")
+ |
+
| 155 | ++ |
+ }+ |
+
| 156 | ++ | + + | +
| 157 | ++ | + + | +
| 158 | ++ |
+ #' Downgrade `teal_data` objects in modules for compatibility+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' Convert `teal_data` to `tdata` in `teal` modules.+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' Recent changes in `teal` cause modules to fail because modules expect a `tdata` object+ |
+
| 163 | ++ |
+ #' to be passed to the `data` argument but instead they receive a `teal_data` object,+ |
+
| 164 | ++ |
+ #' which is additionally wrapped in a reactive expression in the server functions.+ |
+
| 165 | ++ |
+ #' In order to easily adapt such modules without a proper refactor,+ |
+
| 166 | ++ |
+ #' use this function to downgrade the `data` argument.+ |
+
| 167 | ++ |
+ #'+ |
+
| 168 | ++ |
+ #' @param x data object, either `tdata` or `teal_data`, the latter possibly in a reactive expression+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' @return Object of class `tdata`.+ |
+
| 171 | ++ |
+ #'+ |
+
| 172 | ++ |
+ #' @examples+ |
+
| 173 | ++ |
+ #' td <- teal_data()+ |
+
| 174 | ++ |
+ #' td <- within(td, iris <- iris) %>% within(mtcars <- mtcars)+ |
+
| 175 | ++ |
+ #' td+ |
+
| 176 | ++ |
+ #' as_tdata(td)+ |
+
| 177 | ++ |
+ #' as_tdata(reactive(td))+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' @export+ |
+
| 180 | ++ |
+ #' @rdname tdata_deprecation+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ as_tdata <- function(x) {
+ |
+
| 183 | +8x | +
+ if (inherits(x, "tdata")) {
+ |
+
| 184 | +2x | +
+ return(x)+ |
+
| 185 | ++ |
+ }+ |
+
| 186 | +6x | +
+ if (is.reactive(x)) {
+ |
+
| 187 | +1x | +
+ checkmate::assert_class(isolate(x()), "teal_data")+ |
+
| 188 | +1x | +
+ datanames <- isolate(teal_data_datanames(x()))+ |
+
| 189 | +1x | +
+ datasets <- sapply(datanames, function(dataname) reactive(x()[[dataname]]), simplify = FALSE)+ |
+
| 190 | +1x | +
+ code <- reactive(teal.code::get_code(x()))+ |
+
| 191 | +1x | +
+ join_keys <- isolate(teal.data::join_keys(x()))+ |
+
| 192 | +5x | +
+ } else if (inherits(x, "teal_data")) {
+ |
+
| 193 | +5x | +
+ datanames <- teal_data_datanames(x)+ |
+
| 194 | +5x | +
+ datasets <- sapply(datanames, function(dataname) reactive(x[[dataname]]), simplify = FALSE)+ |
+
| 195 | +5x | +
+ code <- reactive(teal.code::get_code(x))+ |
+
| 196 | +5x | +
+ join_keys <- isolate(teal.data::join_keys(x))+ |
+
| 197 | ++ |
+ }+ |
+
| 198 | ++ | + + | +
| 199 | +6x | +
+ new_tdata(data = datasets, code = code, join_keys = join_keys)+ |
+
| 200 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Get client timezone+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' User timezone in the browser may be different to the one on the server.+ |
+
| 4 | ++ |
+ #' This script can be run to register a `shiny` input which contains information about the timezone in the browser.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param ns (`function`) namespace function passed from the `session` object in the `shiny` server.+ |
+
| 7 | ++ |
+ #' For `shiny` modules this will allow for proper name spacing of the registered input.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @return (`shiny`) input variable accessible with `input$tz` which is a (`character`)+ |
+
| 10 | ++ |
+ #' string containing the timezone of the browser/client.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @keywords internal+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ get_client_timezone <- function(ns) {
+ |
+
| 15 | +18x | +
+ script <- sprintf(+ |
+
| 16 | +18x | +
+ "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",+ |
+
| 17 | +18x | +
+ ns("timezone")
+ |
+
| 18 | ++ |
+ )+ |
+
| 19 | +18x | +
+ shinyjs::runjs(script) # function does not return anything+ |
+
| 20 | +18x | +
+ invisible(NULL)+ |
+
| 21 | ++ |
+ }+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ #' Resolve the expected bootstrap theme+ |
+
| 24 | ++ |
+ #' @noRd+ |
+
| 25 | ++ |
+ #' @keywords internal+ |
+
| 26 | ++ |
+ get_teal_bs_theme <- function() {
+ |
+
| 27 | +11x | +
+ bs_theme <- getOption("teal.bs_theme")
+ |
+
| 28 | +11x | +
+ if (is.null(bs_theme)) {
+ |
+
| 29 | +8x | +
+ NULL+ |
+
| 30 | +3x | +
+ } else if (!inherits(bs_theme, "bs_theme")) {
+ |
+
| 31 | +2x | +
+ warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
+ |
+
| 32 | +2x | +
+ NULL+ |
+
| 33 | ++ |
+ } else {
+ |
+
| 34 | +1x | +
+ bs_theme+ |
+
| 35 | ++ |
+ }+ |
+
| 36 | ++ |
+ }+ |
+
| 37 | ++ | + + | +
| 38 | ++ |
+ #' Return parentnames along with datanames.+ |
+
| 39 | ++ |
+ #' @noRd+ |
+
| 40 | ++ |
+ #' @keywords internal+ |
+
| 41 | ++ |
+ include_parent_datanames <- function(dataname, join_keys) {
+ |
+
| 42 | +11x | +
+ parents <- character(0)+ |
+
| 43 | +11x | +
+ for (i in dataname) {
+ |
+
| 44 | +16x | +
+ while (length(i) > 0) {
+ |
+
| 45 | +18x | +
+ parent_i <- teal.data::parent(join_keys, i)+ |
+
| 46 | +18x | +
+ parents <- c(parent_i, parents)+ |
+
| 47 | +18x | +
+ i <- parent_i+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | ++ |
+ }+ |
+
| 50 | ++ | + + | +
| 51 | +11x | +
+ unique(c(parents, dataname))+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ #' Create a `FilteredData`+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' Create a `FilteredData` object from a `teal_data` object.+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' @param x (`teal_data`) object+ |
+
| 59 | ++ |
+ #' @param datanames (`character`) vector of data set names to include; must be subset of `datanames(x)`+ |
+
| 60 | ++ |
+ #' @return A `FilteredData` object.+ |
+
| 61 | ++ |
+ #' @keywords internal+ |
+
| 62 | ++ |
+ teal_data_to_filtered_data <- function(x, datanames = teal_data_datanames(x)) {
+ |
+
| 63 | +13x | +
+ checkmate::assert_class(x, "teal_data")+ |
+
| 64 | +13x | +
+ checkmate::assert_character(datanames, min.chars = 1L, any.missing = FALSE)+ |
+
| 65 | ++ | + + | +
| 66 | +13x | +
+ ans <- teal.slice::init_filtered_data(+ |
+
| 67 | +13x | +
+ x = sapply(datanames, function(dn) x[[dn]], simplify = FALSE),+ |
+
| 68 | +13x | +
+ join_keys = teal.data::join_keys(x)+ |
+
| 69 | ++ |
+ )+ |
+
| 70 | ++ |
+ # Piggy-back entire pre-processing code so that filtering code can be appended later.+ |
+
| 71 | +13x | +
+ attr(ans, "preprocessing_code") <- teal.code::get_code(x)+ |
+
| 72 | +13x | +
+ attr(ans, "verification_status") <- x@verified+ |
+
| 73 | +13x | +
+ ans+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ #' Template function for `TealReportCard` creation and customization+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' This function generates a report card with a title,+ |
+
| 79 | ++ |
+ #' an optional description, and the option to append the filter state list.+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @param title (`character(1)`) title of the card (unless overwritten by label)+ |
+
| 82 | ++ |
+ #' @param label (`character(1)`) label provided by the user when adding the card+ |
+
| 83 | ++ |
+ #' @param description (`character(1)`) optional additional description+ |
+
| 84 | ++ |
+ #' @param with_filter (`logical(1)`) flag indicating to add filter state+ |
+
| 85 | ++ |
+ #' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation+ |
+
| 86 | ++ |
+ #' of the filter state in the report+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @return (`TealReportCard`) populated with a title, description and filter state.+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' @export+ |
+
| 91 | ++ |
+ report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
+ |
+
| 92 | +2x | +
+ checkmate::assert_string(title)+ |
+
| 93 | +2x | +
+ checkmate::assert_string(label)+ |
+
| 94 | +2x | +
+ checkmate::assert_string(description, null.ok = TRUE)+ |
+
| 95 | +2x | +
+ checkmate::assert_flag(with_filter)+ |
+
| 96 | +2x | +
+ checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")+ |
+
| 97 | ++ | + + | +
| 98 | +2x | +
+ card <- teal::TealReportCard$new()+ |
+
| 99 | +2x | +
+ title <- if (label == "") title else label+ |
+
| 100 | +2x | +
+ card$set_name(title)+ |
+
| 101 | +2x | +
+ card$append_text(title, "header2")+ |
+
| 102 | +1x | +
+ if (!is.null(description)) card$append_text(description, "header3")+ |
+
| 103 | +1x | +
+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ |
+
| 104 | +2x | +
+ card+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ #' Resolve `datanames` for the modules+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' Modifies `module$datanames` to include names of the parent dataset (taken from `join_keys`).+ |
+
| 110 | ++ |
+ #' When `datanames` is set to `"all"` it is replaced with all available datasets names.+ |
+
| 111 | ++ |
+ #' @param modules (`teal_modules`) object+ |
+
| 112 | ++ |
+ #' @param datanames (`character`) names of datasets available in the `data` object+ |
+
| 113 | ++ |
+ #' @param join_keys (`join_keys`) object+ |
+
| 114 | ++ |
+ #' @return `teal_modules` with resolved `datanames`.+ |
+
| 115 | ++ |
+ #' @keywords internal+ |
+
| 116 | ++ |
+ resolve_modules_datanames <- function(modules, datanames, join_keys) {
+ |
+
| 117 | +! | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 118 | +! | +
+ modules$children <- sapply(+ |
+
| 119 | +! | +
+ modules$children,+ |
+
| 120 | +! | +
+ resolve_modules_datanames,+ |
+
| 121 | +! | +
+ simplify = FALSE,+ |
+
| 122 | +! | +
+ datanames = datanames,+ |
+
| 123 | +! | +
+ join_keys = join_keys+ |
+
| 124 | ++ |
+ )+ |
+
| 125 | +! | +
+ modules+ |
+
| 126 | ++ |
+ } else {
+ |
+
| 127 | +! | +
+ modules$datanames <- if (identical(modules$datanames, "all")) {
+ |
+
| 128 | +! | +
+ datanames+ |
+
| 129 | +! | +
+ } else if (is.character(modules$datanames)) {
+ |
+
| 130 | +! | +
+ extra_datanames <- setdiff(modules$datanames, datanames)+ |
+
| 131 | +! | +
+ if (length(extra_datanames)) {
+ |
+
| 132 | +! | +
+ stop(+ |
+
| 133 | +! | +
+ sprintf(+ |
+
| 134 | +! | +
+ "Module %s has datanames that are not available in a 'data':\n %s not in %s",+ |
+
| 135 | +! | +
+ modules$label,+ |
+
| 136 | +! | +
+ toString(extra_datanames),+ |
+
| 137 | +! | +
+ toString(datanames)+ |
+
| 138 | ++ |
+ )+ |
+
| 139 | ++ |
+ )+ |
+
| 140 | ++ |
+ }+ |
+
| 141 | +! | +
+ datanames_adjusted <- intersect(modules$datanames, datanames)+ |
+
| 142 | +! | +
+ include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)+ |
+
| 143 | ++ |
+ }+ |
+
| 144 | +! | +
+ modules+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | ++ |
+ #' Check `datanames` in modules+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #' This function ensures specified `datanames` in modules match those in the data object,+ |
+
| 151 | ++ |
+ #' returning error messages or `TRUE` for successful validation.+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @param modules (`teal_modules`) object+ |
+
| 154 | ++ |
+ #' @param datanames (`character`) names of datasets available in the `data` object+ |
+
| 155 | ++ |
+ #'+ |
+
| 156 | ++ |
+ #' @return A `character(1)` containing error message or `TRUE` if validation passes.+ |
+
| 157 | ++ |
+ #' @keywords internal+ |
+
| 158 | ++ |
+ check_modules_datanames <- function(modules, datanames) {
+ |
+
| 159 | +12x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 160 | +12x | +
+ checkmate::assert_character(datanames)+ |
+
| 161 | ++ | + + | +
| 162 | +12x | +
+ recursive_check_datanames <- function(modules, datanames) {
+ |
+
| 163 | ++ |
+ # check teal_modules against datanames+ |
+
| 164 | +26x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 165 | +12x | +
+ sapply(modules$children, function(module) recursive_check_datanames(module, datanames = datanames))+ |
+
| 166 | ++ |
+ } else {
+ |
+
| 167 | +14x | +
+ extra_datanames <- setdiff(modules$datanames, c("all", datanames))
+ |
+
| 168 | +14x | +
+ if (length(extra_datanames)) {
+ |
+
| 169 | +2x | +
+ sprintf(+ |
+
| 170 | +2x | +
+ "- Module '%s' uses datanames not available in 'data': (%s) not in (%s)",+ |
+
| 171 | +2x | +
+ modules$label,+ |
+
| 172 | +2x | +
+ toString(dQuote(extra_datanames, q = FALSE)),+ |
+
| 173 | +2x | +
+ toString(dQuote(datanames, q = FALSE))+ |
+
| 174 | ++ |
+ )+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | ++ |
+ }+ |
+
| 178 | +12x | +
+ check_datanames <- unlist(recursive_check_datanames(modules, datanames))+ |
+
| 179 | +12x | +
+ if (length(check_datanames)) {
+ |
+
| 180 | +2x | +
+ paste(check_datanames, collapse = "\n")+ |
+
| 181 | ++ |
+ } else {
+ |
+
| 182 | +10x | +
+ TRUE+ |
+
| 183 | ++ |
+ }+ |
+
| 184 | ++ |
+ }+ |
+
| 185 | ++ | + + | +
| 186 | ++ |
+ #' Check `datanames` in filters+ |
+
| 187 | ++ |
+ #'+ |
+
| 188 | ++ |
+ #' This function checks whether `datanames` in filters correspond to those in `data`,+ |
+
| 189 | ++ |
+ #' returning character vector with error messages or `TRUE` if all checks pass.+ |
+
| 190 | ++ |
+ #'+ |
+
| 191 | ++ |
+ #' @param filters (`teal_slices`) object+ |
+
| 192 | ++ |
+ #' @param datanames (`character`) names of datasets available in the `data` object+ |
+
| 193 | ++ |
+ #'+ |
+
| 194 | ++ |
+ #' @return A `character(1)` containing error message or TRUE if validation passes.+ |
+
| 195 | ++ |
+ #' @keywords internal+ |
+
| 196 | ++ |
+ check_filter_datanames <- function(filters, datanames) {
+ |
+
| 197 | +10x | +
+ checkmate::assert_class(filters, "teal_slices")+ |
+
| 198 | +10x | +
+ checkmate::assert_character(datanames)+ |
+
| 199 | ++ | + + | +
| 200 | ++ |
+ # check teal_slices against datanames+ |
+
| 201 | +10x | +
+ out <- unlist(sapply(+ |
+
| 202 | +10x | +
+ filters, function(filter) {
+ |
+
| 203 | +3x | +
+ dataname <- shiny::isolate(filter$dataname)+ |
+
| 204 | +3x | +
+ if (!dataname %in% datanames) {
+ |
+
| 205 | +2x | +
+ sprintf(+ |
+
| 206 | +2x | +
+ "- Filter '%s' refers to dataname not available in 'data':\n %s not in (%s)",+ |
+
| 207 | +2x | +
+ shiny::isolate(filter$id),+ |
+
| 208 | +2x | +
+ dQuote(dataname, q = FALSE),+ |
+
| 209 | +2x | +
+ toString(dQuote(datanames, q = FALSE))+ |
+
| 210 | ++ |
+ )+ |
+
| 211 | ++ |
+ }+ |
+
| 212 | ++ |
+ }+ |
+
| 213 | ++ |
+ ))+ |
+
| 214 | ++ | + + | +
| 215 | ++ | + + | +
| 216 | +10x | +
+ if (length(out)) {
+ |
+
| 217 | +2x | +
+ paste(out, collapse = "\n")+ |
+
| 218 | ++ |
+ } else {
+ |
+
| 219 | +8x | +
+ TRUE+ |
+
| 220 | ++ |
+ }+ |
+
| 221 | ++ |
+ }+ |
+
| 222 | ++ | + + | +
| 223 | ++ |
+ #' Wrapper on `teal.data::datanames`+ |
+
| 224 | ++ |
+ #'+ |
+
| 225 | ++ |
+ #' Special function used in internals of `teal` to return names of datasets even if `datanames`+ |
+
| 226 | ++ |
+ #' has not been set.+ |
+
| 227 | ++ |
+ #' @param data (`teal_data`)+ |
+
| 228 | ++ |
+ #' @return `character`+ |
+
| 229 | ++ |
+ #' @keywords internal+ |
+
| 230 | ++ |
+ teal_data_datanames <- function(data) {
+ |
+
| 231 | +51x | +
+ checkmate::assert_class(data, "teal_data")+ |
+
| 232 | +51x | +
+ if (length(teal.data::datanames(data))) {
+ |
+
| 233 | +47x | +
+ teal.data::datanames(data)+ |
+
| 234 | ++ |
+ } else {
+ |
+
| 235 | +4x | +
+ ls(teal.code::get_env(data), all.names = TRUE)+ |
+
| 236 | ++ |
+ }+ |
+
| 237 | ++ |
+ }+ |
+
| 238 | ++ | + + | +
| 239 | ++ |
+ #' Function for validating the title parameter of `teal::init`+ |
+
| 240 | ++ |
+ #'+ |
+
| 241 | ++ |
+ #' Checks if the input of the title from `teal::init` will create a valid title and favicon tag.+ |
+
| 242 | ++ |
+ #' @param shiny_tag (`shiny.tag`) Object to validate for a valid title.+ |
+
| 243 | ++ |
+ #' @keywords internal+ |
+
| 244 | ++ |
+ validate_app_title_tag <- function(shiny_tag) {
+ |
+
| 245 | +14x | +
+ checkmate::assert_class(shiny_tag, "shiny.tag")+ |
+
| 246 | +14x | +
+ checkmate::assert_true(shiny_tag$name == "head")+ |
+
| 247 | +13x | +
+ child_names <- vapply(shiny_tag$children, `[[`, character(1L), "name")+ |
+
| 248 | +13x | +
+ checkmate::assert_subset(c("title", "link"), child_names, .var.name = "child tags")
+ |
+
| 249 | +11x | +
+ rel_attr <- shiny_tag$children[[which(child_names == "link")]]$attribs$rel+ |
+
| 250 | +11x | +
+ checkmate::assert_subset(+ |
+
| 251 | +11x | +
+ rel_attr,+ |
+
| 252 | +11x | +
+ c("icon", "shortcut icon"),
+ |
+
| 253 | +11x | +
+ .var.name = "Link tag's rel attribute",+ |
+
| 254 | +11x | +
+ empty.ok = FALSE+ |
+
| 255 | ++ |
+ )+ |
+
| 256 | ++ |
+ }+ |
+
| 257 | ++ | + + | +
| 258 | ++ |
+ #' Build app title with favicon+ |
+
| 259 | ++ |
+ #'+ |
+
| 260 | ++ |
+ #' A helper function to create the browser title along with a logo.+ |
+
| 261 | ++ |
+ #'+ |
+
| 262 | ++ |
+ #' @param title (`character`) The browser title for the `teal` app.+ |
+
| 263 | ++ |
+ #' @param favicon (`character`) The path for the icon for the title.+ |
+
| 264 | ++ |
+ #' The image/icon path can be remote or the static path accessible by `shiny`, like the `www/`+ |
+
| 265 | ++ |
+ #'+ |
+
| 266 | ++ |
+ #' @return A `shiny.tag` containing the element that adds the title and logo to the `shiny` app.+ |
+
| 267 | ++ |
+ #' @export+ |
+
| 268 | ++ |
+ build_app_title <- function(+ |
+
| 269 | ++ |
+ title = "teal app",+ |
+
| 270 | ++ |
+ favicon = "https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/PNG/nest.png") {
+ |
+
| 271 | +11x | +
+ checkmate::assert_string(title, null.ok = TRUE)+ |
+
| 272 | +11x | +
+ checkmate::assert_string(favicon, null.ok = TRUE)+ |
+
| 273 | +11x | +
+ tags$head(+ |
+
| 274 | +11x | +
+ tags$title(title),+ |
+
| 275 | +11x | +
+ tags$link(+ |
+
| 276 | +11x | +
+ rel = "icon",+ |
+
| 277 | +11x | +
+ href = favicon,+ |
+
| 278 | +11x | +
+ sizes = "any"+ |
+
| 279 | ++ |
+ )+ |
+
| 280 | ++ |
+ )+ |
+
| 281 | ++ |
+ }+ |
+
| 282 | ++ | + + | +
| 283 | ++ |
+ #' Application ID+ |
+
| 284 | ++ |
+ #'+ |
+
| 285 | ++ |
+ #' Creates App ID used to match filter snapshots to application.+ |
+
| 286 | ++ |
+ #'+ |
+
| 287 | ++ |
+ #' Calculate app ID that will be used to stamp filter state snapshots.+ |
+
| 288 | ++ |
+ #' App ID is a hash of the app's data and modules.+ |
+
| 289 | ++ |
+ #' See "transferring snapshots" section in ?snapshot.+ |
+
| 290 | ++ |
+ #'+ |
+
| 291 | ++ |
+ #' @param data (`teal_data` or `teal_data_module`) as accepted by `init`+ |
+
| 292 | ++ |
+ #' @param modules (`teal_modules`) object as accepted by `init`+ |
+
| 293 | ++ |
+ #'+ |
+
| 294 | ++ |
+ #' @return A single character string.+ |
+
| 295 | ++ |
+ #'+ |
+
| 296 | ++ |
+ #' @keywords internal+ |
+
| 297 | ++ |
+ create_app_id <- function(data, modules) {
+ |
+
| 298 | +19x | +
+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
+ |
+
| 299 | +18x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 300 | ++ | + + | +
| 301 | +17x | +
+ data <- if (inherits(data, "teal_data")) {
+ |
+
| 302 | +15x | +
+ as.list(data@env)+ |
+
| 303 | +17x | +
+ } else if (inherits(data, "teal_data_module")) {
+ |
+
| 304 | +2x | +
+ deparse1(body(data$server))+ |
+
| 305 | ++ |
+ }+ |
+
| 306 | +17x | +
+ modules <- lapply(modules, defunction)+ |
+
| 307 | ++ | + + | +
| 308 | +17x | +
+ rlang::hash(list(data = data, modules = modules))+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | ++ | + + | +
| 311 | ++ |
+ #' Go through list and extract bodies of encountered functions as string, recursively.+ |
+
| 312 | ++ |
+ #' @keywords internal+ |
+
| 313 | ++ |
+ #' @noRd+ |
+
| 314 | ++ |
+ defunction <- function(x) {
+ |
+
| 315 | +186x | +
+ if (is.list(x)) {
+ |
+
| 316 | +40x | +
+ lapply(x, defunction)+ |
+
| 317 | +146x | +
+ } else if (is.function(x)) {
+ |
+
| 318 | +44x | +
+ deparse1(body(x))+ |
+
| 319 | ++ |
+ } else {
+ |
+
| 320 | +102x | +
+ x+ |
+
| 321 | ++ |
+ }+ |
+
| 322 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @title `TealReportCard`+ |
+
| 2 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 3 | ++ |
+ #' Child class of [`ReportCard`] that is used for `teal` specific applications.+ |
+
| 4 | ++ |
+ #' In addition to the parent methods, it supports rendering `teal` specific elements such as+ |
+
| 5 | ++ |
+ #' the source code, the encodings panel content and the filter panel content as part of the+ |
+
| 6 | ++ |
+ #' meta data.+ |
+
| 7 | ++ |
+ #' @export+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ TealReportCard <- R6::R6Class( # nolint: object_name_linter.+ |
+
| 10 | ++ |
+ classname = "TealReportCard",+ |
+
| 11 | ++ |
+ inherit = teal.reporter::ReportCard,+ |
+
| 12 | ++ |
+ public = list(+ |
+
| 13 | ++ |
+ #' @description Appends the source code to the `content` meta data of this `TealReportCard`.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @param src (`character(1)`) code as text.+ |
+
| 16 | ++ |
+ #' @param ... any `rmarkdown` `R` chunk parameter and its value.+ |
+
| 17 | ++ |
+ #' But `eval` parameter is always set to `FALSE`.+ |
+
| 18 | ++ |
+ #' @return Object of class `TealReportCard`, invisibly.+ |
+
| 19 | ++ |
+ #' @examples+ |
+
| 20 | ++ |
+ #' card <- TealReportCard$new()$append_src(+ |
+
| 21 | ++ |
+ #' "plot(iris)"+ |
+
| 22 | ++ |
+ #' )+ |
+
| 23 | ++ |
+ #' card$get_content()[[1]]$get_content()+ |
+
| 24 | ++ |
+ append_src = function(src, ...) {
+ |
+
| 25 | +4x | +
+ checkmate::assert_character(src, min.len = 0, max.len = 1)+ |
+
| 26 | +4x | +
+ params <- list(...)+ |
+
| 27 | +4x | +
+ params$eval <- FALSE+ |
+
| 28 | +4x | +
+ rblock <- RcodeBlock$new(src)+ |
+
| 29 | +4x | +
+ rblock$set_params(params)+ |
+
| 30 | +4x | +
+ self$append_content(rblock)+ |
+
| 31 | +4x | +
+ self$append_metadata("SRC", src)
+ |
+
| 32 | +4x | +
+ invisible(self)+ |
+
| 33 | ++ |
+ },+ |
+
| 34 | ++ |
+ #' @description Appends the filter state list to the `content` and `metadata` of this `TealReportCard`.+ |
+
| 35 | ++ |
+ #' If the filter state list has an attribute named `formatted`, it appends it to the card otherwise it uses+ |
+
| 36 | ++ |
+ #' the default `yaml::as.yaml` to format the list.+ |
+
| 37 | ++ |
+ #' If the filter state list is empty, nothing is appended to the `content`.+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @param fs (`teal_slices`) object returned from [teal_slices()] function.+ |
+
| 40 | ++ |
+ #' @return `self`, invisibly.+ |
+
| 41 | ++ |
+ append_fs = function(fs) {
+ |
+
| 42 | +5x | +
+ checkmate::assert_class(fs, "teal_slices")+ |
+
| 43 | +4x | +
+ self$append_text("Filter State", "header3")
+ |
+
| 44 | +4x | +
+ self$append_content(TealSlicesBlock$new(fs))+ |
+
| 45 | +4x | +
+ invisible(self)+ |
+
| 46 | ++ |
+ },+ |
+
| 47 | ++ |
+ #' @description Appends the encodings list to the `content` and `metadata` of this `TealReportCard`.+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' @param encodings (`list`) list of encodings selections of the `teal` app.+ |
+
| 50 | ++ |
+ #' @return `self`, invisibly.+ |
+
| 51 | ++ |
+ #' @examples+ |
+
| 52 | ++ |
+ #' card <- TealReportCard$new()$append_encodings(list(variable1 = "X"))+ |
+
| 53 | ++ |
+ #' card$get_content()[[1]]$get_content()+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ append_encodings = function(encodings) {
+ |
+
| 56 | +4x | +
+ checkmate::assert_list(encodings)+ |
+
| 57 | +4x | +
+ self$append_text("Selected Options", "header3")
+ |
+
| 58 | +4x | +
+ if (requireNamespace("yaml", quietly = TRUE)) {
+ |
+
| 59 | +4x | +
+ self$append_text(yaml::as.yaml(encodings, handlers = list(+ |
+
| 60 | +4x | +
+ POSIXct = function(x) format(x, "%Y-%m-%d"),+ |
+
| 61 | +4x | +
+ POSIXlt = function(x) format(x, "%Y-%m-%d"),+ |
+
| 62 | +4x | +
+ Date = function(x) format(x, "%Y-%m-%d")+ |
+
| 63 | +4x | +
+ )), "verbatim")+ |
+
| 64 | ++ |
+ } else {
+ |
+
| 65 | +! | +
+ stop("yaml package is required to format the encodings list")
+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | +4x | +
+ self$append_metadata("Encodings", encodings)
+ |
+
| 68 | +4x | +
+ invisible(self)+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ |
+ ),+ |
+
| 71 | ++ |
+ private = list()+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ | + + | +
| 74 | ++ |
+ #' @title `RcodeBlock`+ |
+
| 75 | ++ |
+ #' @keywords internal+ |
+
| 76 | ++ |
+ TealSlicesBlock <- R6::R6Class( # nolint: object_name_linter.+ |
+
| 77 | ++ |
+ classname = "TealSlicesBlock",+ |
+
| 78 | ++ |
+ inherit = teal.reporter:::TextBlock,+ |
+
| 79 | ++ |
+ public = list(+ |
+
| 80 | ++ |
+ #' @description Returns a `TealSlicesBlock` object.+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' @details Returns a `TealSlicesBlock` object with no content and no parameters.+ |
+
| 83 | ++ |
+ #'+ |
+
| 84 | ++ |
+ #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ |
+
| 85 | ++ |
+ #' @param style (`character(1)`) string specifying style to apply.+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' @return Object of class `TealSlicesBlock`, invisibly.+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ initialize = function(content = teal_slices(), style = "verbatim") {
+ |
+
| 90 | +10x | +
+ self$set_content(content)+ |
+
| 91 | +9x | +
+ self$set_style(style)+ |
+
| 92 | +9x | +
+ invisible(self)+ |
+
| 93 | ++ |
+ },+ |
+
| 94 | ++ | + + | +
| 95 | ++ |
+ #' @description Sets content of this `TealSlicesBlock`.+ |
+
| 96 | ++ |
+ #' Sets content as `YAML` text which represents a list generated from `teal_slices`.+ |
+
| 97 | ++ |
+ #' The list displays limited number of fields from `teal_slice` objects, but this list is+ |
+
| 98 | ++ |
+ #' sufficient to conclude which filters were applied.+ |
+
| 99 | ++ |
+ #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ |
+
| 103 | ++ |
+ #' @return `self`, invisibly.+ |
+
| 104 | ++ |
+ set_content = function(content) {
+ |
+
| 105 | +11x | +
+ checkmate::assert_class(content, "teal_slices")+ |
+
| 106 | +10x | +
+ if (length(content) != 0) {
+ |
+
| 107 | +7x | +
+ states_list <- lapply(content, function(x) {
+ |
+
| 108 | +7x | +
+ x_list <- shiny::isolate(as.list(x))+ |
+
| 109 | +7x | +
+ if (+ |
+
| 110 | +7x | +
+ inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
+ |
+
| 111 | +7x | +
+ length(x_list$choices) == 2 &&+ |
+
| 112 | +7x | +
+ length(x_list$selected) == 2+ |
+
| 113 | ++ |
+ ) {
+ |
+
| 114 | +! | +
+ x_list$range <- paste(x_list$selected, collapse = " - ")+ |
+
| 115 | +! | +
+ x_list["selected"] <- NULL+ |
+
| 116 | ++ |
+ }+ |
+
| 117 | +7x | +
+ if (!is.null(x_list$arg)) {
+ |
+
| 118 | +! | +
+ x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | ++ | + + | +
| 121 | +7x | +
+ x_list <- x_list[+ |
+
| 122 | +7x | +
+ c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
+ |
+
| 123 | ++ |
+ ]+ |
+
| 124 | +7x | +
+ names(x_list) <- c(+ |
+
| 125 | +7x | +
+ "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",+ |
+
| 126 | +7x | +
+ "Selected Values", "Selected range", "Include NA values", "Include Inf values"+ |
+
| 127 | ++ |
+ )+ |
+
| 128 | ++ | + + | +
| 129 | +7x | +
+ Filter(Negate(is.null), x_list)+ |
+
| 130 | ++ |
+ })+ |
+
| 131 | ++ | + + | +
| 132 | +7x | +
+ if (requireNamespace("yaml", quietly = TRUE)) {
+ |
+
| 133 | +7x | +
+ super$set_content(yaml::as.yaml(states_list))+ |
+
| 134 | ++ |
+ } else {
+ |
+
| 135 | +! | +
+ stop("yaml package is required to format the filter state list")
+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ |
+ }+ |
+
| 138 | +10x | +
+ private$teal_slices <- content+ |
+
| 139 | +10x | +
+ invisible(self)+ |
+
| 140 | ++ |
+ },+ |
+
| 141 | ++ |
+ #' @description Create the `RcodeBlock` from a list.+ |
+
| 142 | ++ |
+ #' @param x (named `list`) with two fields `c("text", "params")`.
+ |
+
| 143 | ++ |
+ #' Use the `get_available_params` method to get all possible parameters.+ |
+
| 144 | ++ |
+ #' @return `self`, invisibly.+ |
+
| 145 | ++ |
+ from_list = function(x) {
+ |
+
| 146 | +1x | +
+ checkmate::assert_list(x)+ |
+
| 147 | +1x | +
+ checkmate::assert_names(names(x), must.include = c("teal_slices"))
+ |
+
| 148 | +1x | +
+ self$set_content(x$teal_slices)+ |
+
| 149 | +1x | +
+ invisible(self)+ |
+
| 150 | ++ |
+ },+ |
+
| 151 | ++ |
+ #' @description Convert the `RcodeBlock` to a list.+ |
+
| 152 | ++ |
+ #' @return named `list` with a text and `params`.+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ to_list = function() {
+ |
+
| 155 | +2x | +
+ list(teal_slices = private$teal_slices)+ |
+
| 156 | ++ |
+ }+ |
+
| 157 | ++ |
+ ),+ |
+
| 158 | ++ |
+ private = list(+ |
+
| 159 | ++ |
+ style = "verbatim",+ |
+
| 160 | ++ |
+ teal_slices = NULL # teal_slices+ |
+
| 161 | ++ |
+ )+ |
+
| 162 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Filter state snapshot management+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Capture and restore snapshots of the global (app) filter state.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This module introduces snapshots: stored descriptions of the filter state of the entire application.+ |
+
| 6 | ++ |
+ #' Snapshots allow the user to save the current filter state of the application for later use in the session,+ |
+
| 7 | ++ |
+ #' as well as to save it to file in order to share it with an app developer or other users,+ |
+
| 8 | ++ |
+ #' who in turn can upload it to their own session.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner.+ |
+
| 11 | ++ |
+ #' At the beginning of a session it presents three icons: a camera, an upload, and an circular arrow.+ |
+
| 12 | ++ |
+ #' Clicking the camera captures a snapshot, clicking the upload adds a snapshot from a file+ |
+
| 13 | ++ |
+ #' and applies the filter states therein, and clicking the arrow resets initial application state.+ |
+
| 14 | ++ |
+ #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @section Server logic:+ |
+
| 17 | ++ |
+ #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance+ |
+
| 18 | ++ |
+ #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`+ |
+
| 19 | ++ |
+ #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation+ |
+
| 20 | ++ |
+ #' (attributes are maintained).+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' Snapshots are stored in a `reactiveVal` as a named list.+ |
+
| 23 | ++ |
+ #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' For every snapshot except the initial one, a piece of UI is generated that contains+ |
+
| 26 | ++ |
+ #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.+ |
+
| 27 | ++ |
+ #' The initial snapshot is restored by a separate "reset" button.+ |
+
| 28 | ++ |
+ #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @section Snapshot mechanics:+ |
+
| 31 | ++ |
+ #' When a snapshot is captured, the user is prompted to name it.+ |
+
| 32 | ++ |
+ #' Names are displayed as is but since they are used to create button ids,+ |
+
| 33 | ++ |
+ #' under the hood they are converted to syntactically valid strings.+ |
+
| 34 | ++ |
+ #' New snapshot names are validated so that their valid versions are unique.+ |
+
| 35 | ++ |
+ #' Leading and trailing white space is trimmed.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' The module can read the global state of the application from `slices_global` and `mapping_matrix`.+ |
+
| 38 | ++ |
+ #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.+ |
+
| 39 | ++ |
+ #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.+ |
+
| 40 | ++ |
+ #' The snapshot contains the `mapping` attribute of the initial application state+ |
+
| 41 | ++ |
+ #' (or one that has been restored), which may not reflect the current one,+ |
+
| 42 | ++ |
+ #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,+ |
+
| 43 | ++ |
+ #' when passed to the `mapping` argument of [teal_slices()], would result in the current mapping.+ |
+
| 44 | ++ |
+ #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.+ |
+
| 47 | ++ |
+ #' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared+ |
+
| 48 | ++ |
+ #' and set anew according to the `mapping` attribute of the snapshot.+ |
+
| 49 | ++ |
+ #' The snapshot is then set as the current content of `slices_global`.+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,+ |
+
| 52 | ++ |
+ #' and then saved to file with [slices_store()].+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' When a snapshot is uploaded, it will first be added to storage just like a newly created one,+ |
+
| 55 | ++ |
+ #' and then used to restore app state much like a snapshot taken from storage.+ |
+
| 56 | ++ |
+ #' Upon clicking the upload icon the user will be prompted for a file to upload+ |
+
| 57 | ++ |
+ #' and may choose to name the new snapshot. The name defaults to the name of the file (the extension is dropped)+ |
+
| 58 | ++ |
+ #' and normal naming rules apply. Loading the file yields a `teal_slices` object,+ |
+
| 59 | ++ |
+ #' which is disassembled for storage and used directly for restoring app state.+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' @section Transferring snapshots:+ |
+
| 62 | ++ |
+ #' Snapshots uploaded from disk should only be used in the same application they come from,+ |
+
| 63 | ++ |
+ #' _i.e._ an application that uses the same data and the same modules.+ |
+
| 64 | ++ |
+ #' To ensure this is the case, `init` stamps `teal_slices` with an app id that is stored in the `app_id` attribute of+ |
+
| 65 | ++ |
+ #' a `teal_slices` object. When a snapshot is restored from file, its `app_id` is compared to that+ |
+
| 66 | ++ |
+ #' of the current app state and only if the match is the snapshot admitted to the session.+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' @param id (`character(1)`) `shiny` module id+ |
+
| 69 | ++ |
+ #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object+ |
+
| 70 | ++ |
+ #' containing all `teal_slice`s existing in the app, both active and inactive+ |
+
| 71 | ++ |
+ #' @param mapping_matrix (`reactive`) that contains a `data.frame` representation+ |
+
| 72 | ++ |
+ #' of the mapping of filter state ids (rows) to modules labels (columns);+ |
+
| 73 | ++ |
+ #' all columns are `logical` vectors+ |
+
| 74 | ++ |
+ #' @param filtered_data_list non-nested (named `list`) that contains `FilteredData` objects+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @return Nothing is returned.+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @name snapshot_manager_module+ |
+
| 79 | ++ |
+ #' @aliases snapshot snapshot_manager+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @author Aleksander Chlebowski+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @rdname snapshot_manager_module+ |
+
| 84 | ++ |
+ #' @keywords internal+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ snapshot_manager_ui <- function(id) {
+ |
+
| 87 | +! | +
+ ns <- NS(id)+ |
+
| 88 | +! | +
+ div(+ |
+
| 89 | +! | +
+ class = "snapshot_manager_content",+ |
+
| 90 | +! | +
+ div(+ |
+
| 91 | +! | +
+ class = "snapshot_table_row",+ |
+
| 92 | +! | +
+ span(tags$b("Snapshot manager")),
+ |
+
| 93 | +! | +
+ actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
+ |
+
| 94 | +! | +
+ actionLink(ns("snapshot_load"), label = NULL, icon = icon("upload"), title = "upload snapshot"),
+ |
+
| 95 | +! | +
+ actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
+ |
+
| 96 | +! | +
+ NULL+ |
+
| 97 | ++ |
+ ),+ |
+
| 98 | +! | +
+ uiOutput(ns("snapshot_list"))
+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ #' @rdname snapshot_manager_module+ |
+
| 103 | ++ |
+ #' @keywords internal+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
+ |
+
| 106 | +6x | +
+ checkmate::assert_character(id)+ |
+
| 107 | +6x | +
+ checkmate::assert_true(is.reactive(slices_global))+ |
+
| 108 | +6x | +
+ checkmate::assert_class(isolate(slices_global()), "teal_slices")+ |
+
| 109 | +6x | +
+ checkmate::assert_true(is.reactive(mapping_matrix))+ |
+
| 110 | +6x | +
+ checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)+ |
+
| 111 | +6x | +
+ checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named")+ |
+
| 112 | ++ | + + | +
| 113 | +6x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 114 | +6x | +
+ ns <- session$ns+ |
+
| 115 | ++ | + + | +
| 116 | ++ |
+ # Store global filter states ----+ |
+
| 117 | +6x | +
+ filter <- isolate(slices_global())+ |
+
| 118 | +6x | +
+ snapshot_history <- reactiveVal({
+ |
+
| 119 | +6x | +
+ list(+ |
+
| 120 | +6x | +
+ "Initial application state" = as.list(filter, recursive = TRUE)+ |
+
| 121 | ++ |
+ )+ |
+
| 122 | ++ |
+ })+ |
+
| 123 | ++ | + + | +
| 124 | ++ |
+ # Snapshot current application state ----+ |
+
| 125 | ++ |
+ # Name snaphsot.+ |
+
| 126 | +6x | +
+ observeEvent(input$snapshot_add, {
+ |
+
| 127 | +! | +
+ showModal(+ |
+
| 128 | +! | +
+ modalDialog(+ |
+
| 129 | +! | +
+ textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
+ |
+
| 130 | +! | +
+ footer = tagList(+ |
+
| 131 | +! | +
+ actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
+ |
+
| 132 | +! | +
+ modalButton(label = "Cancel", icon = icon("thumbs-down"))
+ |
+
| 133 | ++ |
+ ),+ |
+
| 134 | +! | +
+ size = "s"+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ |
+ )+ |
+
| 137 | ++ |
+ })+ |
+
| 138 | ++ |
+ # Store snaphsot.+ |
+
| 139 | +6x | +
+ observeEvent(input$snapshot_name_accept, {
+ |
+
| 140 | +! | +
+ snapshot_name <- trimws(input$snapshot_name)+ |
+
| 141 | +! | +
+ if (identical(snapshot_name, "")) {
+ |
+
| 142 | +! | +
+ showNotification(+ |
+
| 143 | +! | +
+ "Please name the snapshot.",+ |
+
| 144 | +! | +
+ type = "message"+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | +! | +
+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ |
+
| 147 | +! | +
+ } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ |
+
| 148 | +! | +
+ showNotification(+ |
+
| 149 | +! | +
+ "This name is in conflict with other snapshot names. Please choose a different one.",+ |
+
| 150 | +! | +
+ type = "message"+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | +! | +
+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ |
+
| 153 | ++ |
+ } else {
+ |
+
| 154 | +! | +
+ snapshot <- as.list(slices_global(), recursive = TRUE)+ |
+
| 155 | +! | +
+ attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())+ |
+
| 156 | +! | +
+ snapshot_update <- c(snapshot_history(), list(snapshot))+ |
+
| 157 | +! | +
+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ |
+
| 158 | +! | +
+ snapshot_history(snapshot_update)+ |
+
| 159 | +! | +
+ removeModal()+ |
+
| 160 | ++ |
+ # Reopen filter manager modal by clicking button in the main application.+ |
+
| 161 | +! | +
+ shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE)+ |
+
| 162 | ++ |
+ }+ |
+
| 163 | ++ |
+ })+ |
+
| 164 | ++ | + + | +
| 165 | ++ |
+ # Upload a snapshot file ----+ |
+
| 166 | ++ |
+ # Select file.+ |
+
| 167 | +6x | +
+ observeEvent(input$snapshot_load, {
+ |
+
| 168 | +! | +
+ showModal(+ |
+
| 169 | +! | +
+ modalDialog(+ |
+
| 170 | +! | +
+ fileInput(ns("snapshot_file"), "Choose snapshot file", accept = ".json", width = "100%"),
+ |
+
| 171 | +! | +
+ textInput(+ |
+
| 172 | +! | +
+ ns("snapshot_name"),
+ |
+
| 173 | +! | +
+ "Name the snapshot (optional)",+ |
+
| 174 | +! | +
+ width = "100%",+ |
+
| 175 | +! | +
+ placeholder = "Meaningful, unique name"+ |
+
| 176 | ++ |
+ ),+ |
+
| 177 | +! | +
+ footer = tagList(+ |
+
| 178 | +! | +
+ actionButton(ns("snaphot_file_accept"), "Accept", icon = icon("thumbs-up")),
+ |
+
| 179 | +! | +
+ modalButton(label = "Cancel", icon = icon("thumbs-down"))
+ |
+
| 180 | ++ |
+ )+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | ++ |
+ )+ |
+
| 183 | ++ |
+ })+ |
+
| 184 | ++ |
+ # Store new snapshot to list and restore filter states.+ |
+
| 185 | +6x | +
+ observeEvent(input$snaphot_file_accept, {
+ |
+
| 186 | +! | +
+ snapshot_name <- trimws(input$snapshot_name)+ |
+
| 187 | +! | +
+ if (identical(snapshot_name, "")) {
+ |
+
| 188 | +! | +
+ snapshot_name <- tools::file_path_sans_ext(input$snapshot_file$name)+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | +! | +
+ if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ |
+
| 191 | +! | +
+ showNotification(+ |
+
| 192 | +! | +
+ "This name is in conflict with other snapshot names. Please choose a different one.",+ |
+
| 193 | +! | +
+ type = "message"+ |
+
| 194 | ++ |
+ )+ |
+
| 195 | +! | +
+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ |
+
| 196 | ++ |
+ } else {
+ |
+
| 197 | ++ |
+ # Restore snapshot and verify app compatibility.+ |
+
| 198 | +! | +
+ snapshot_state <- try(slices_restore(input$snapshot_file$datapath))+ |
+
| 199 | +! | +
+ if (!inherits(snapshot_state, "modules_teal_slices")) {
+ |
+
| 200 | +! | +
+ showNotification(+ |
+
| 201 | +! | +
+ "File appears to be corrupt.",+ |
+
| 202 | +! | +
+ type = "error"+ |
+
| 203 | ++ |
+ )+ |
+
| 204 | +! | +
+ } else if (!identical(attr(snapshot_state, "app_id"), attr(slices_global(), "app_id"))) {
+ |
+
| 205 | +! | +
+ showNotification(+ |
+
| 206 | +! | +
+ "This snapshot file is not compatible with the app and cannot be loaded.",+ |
+
| 207 | +! | +
+ type = "warning"+ |
+
| 208 | ++ |
+ )+ |
+
| 209 | ++ |
+ } else {
+ |
+
| 210 | ++ |
+ # Add to snapshot history.+ |
+
| 211 | +! | +
+ snapshot <- as.list(snapshot_state, recursive = TRUE)+ |
+
| 212 | +! | +
+ snapshot_update <- c(snapshot_history(), list(snapshot))+ |
+
| 213 | +! | +
+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ |
+
| 214 | +! | +
+ snapshot_history(snapshot_update)+ |
+
| 215 | ++ |
+ ### Begin simplified restore procedure. ###+ |
+
| 216 | +! | +
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ |
+
| 217 | +! | +
+ mapply(+ |
+
| 218 | +! | +
+ function(filtered_data, filter_ids) {
+ |
+
| 219 | +! | +
+ filtered_data$clear_filter_states(force = TRUE)+ |
+
| 220 | +! | +
+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ |
+
| 221 | +! | +
+ filtered_data$set_filter_state(slices)+ |
+
| 222 | ++ |
+ },+ |
+
| 223 | +! | +
+ filtered_data = filtered_data_list,+ |
+
| 224 | +! | +
+ filter_ids = mapping_unfolded+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | +! | +
+ slices_global(snapshot_state)+ |
+
| 227 | +! | +
+ removeModal()+ |
+
| 228 | ++ |
+ ### End simplified restore procedure. ###+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ |
+ })+ |
+
| 232 | ++ |
+ # Apply newly added snapshot.+ |
+
| 233 | ++ | + + | +
| 234 | ++ |
+ # Restore initial state ----+ |
+
| 235 | +6x | +
+ observeEvent(input$snapshot_reset, {
+ |
+
| 236 | +! | +
+ s <- "Initial application state"+ |
+
| 237 | ++ |
+ ### Begin restore procedure. ###+ |
+
| 238 | +! | +
+ snapshot <- snapshot_history()[[s]]+ |
+
| 239 | +! | +
+ snapshot_state <- as.teal_slices(snapshot)+ |
+
| 240 | +! | +
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ |
+
| 241 | +! | +
+ mapply(+ |
+
| 242 | +! | +
+ function(filtered_data, filter_ids) {
+ |
+
| 243 | +! | +
+ filtered_data$clear_filter_states(force = TRUE)+ |
+
| 244 | +! | +
+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ |
+
| 245 | +! | +
+ filtered_data$set_filter_state(slices)+ |
+
| 246 | ++ |
+ },+ |
+
| 247 | +! | +
+ filtered_data = filtered_data_list,+ |
+
| 248 | +! | +
+ filter_ids = mapping_unfolded+ |
+
| 249 | ++ |
+ )+ |
+
| 250 | +! | +
+ slices_global(snapshot_state)+ |
+
| 251 | +! | +
+ removeModal()+ |
+
| 252 | ++ |
+ ### End restore procedure. ###+ |
+
| 253 | ++ |
+ })+ |
+
| 254 | ++ | + + | +
| 255 | ++ |
+ # Build snapshot table ----+ |
+
| 256 | ++ |
+ # Create UI elements and server logic for the snapshot table.+ |
+
| 257 | ++ |
+ # Observers must be tracked to avoid duplication and excess reactivity.+ |
+
| 258 | ++ |
+ # Remaining elements are tracked likewise for consistency and a slight speed margin.+ |
+
| 259 | +6x | +
+ observers <- reactiveValues()+ |
+
| 260 | +6x | +
+ handlers <- reactiveValues()+ |
+
| 261 | +6x | +
+ divs <- reactiveValues()+ |
+
| 262 | ++ | + + | +
| 263 | +6x | +
+ observeEvent(snapshot_history(), {
+ |
+
| 264 | +2x | +
+ lapply(names(snapshot_history())[-1L], function(s) {
+ |
+
| 265 | +! | +
+ id_pickme <- sprintf("pickme_%s", make.names(s))
+ |
+
| 266 | +! | +
+ id_saveme <- sprintf("saveme_%s", make.names(s))
+ |
+
| 267 | +! | +
+ id_rowme <- sprintf("rowme_%s", make.names(s))
+ |
+
| 268 | ++ | + + | +
| 269 | ++ |
+ # Observer for restoring snapshot.+ |
+
| 270 | +! | +
+ if (!is.element(id_pickme, names(observers))) {
+ |
+
| 271 | +! | +
+ observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
+ |
+
| 272 | ++ |
+ ### Begin restore procedure. ###+ |
+
| 273 | +! | +
+ snapshot <- snapshot_history()[[s]]+ |
+
| 274 | +! | +
+ snapshot_state <- as.teal_slices(snapshot)+ |
+
| 275 | +! | +
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ |
+
| 276 | +! | +
+ mapply(+ |
+
| 277 | +! | +
+ function(filtered_data, filter_ids) {
+ |
+
| 278 | +! | +
+ filtered_data$clear_filter_states(force = TRUE)+ |
+
| 279 | +! | +
+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ |
+
| 280 | +! | +
+ filtered_data$set_filter_state(slices)+ |
+
| 281 | ++ |
+ },+ |
+
| 282 | +! | +
+ filtered_data = filtered_data_list,+ |
+
| 283 | +! | +
+ filter_ids = mapping_unfolded+ |
+
| 284 | ++ |
+ )+ |
+
| 285 | +! | +
+ slices_global(snapshot_state)+ |
+
| 286 | +! | +
+ removeModal()+ |
+
| 287 | ++ |
+ ### End restore procedure. ###+ |
+
| 288 | ++ |
+ })+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | ++ |
+ # Create handler for downloading snapshot.+ |
+
| 291 | +! | +
+ if (!is.element(id_saveme, names(handlers))) {
+ |
+
| 292 | +! | +
+ output[[id_saveme]] <- downloadHandler(+ |
+
| 293 | +! | +
+ filename = function() {
+ |
+
| 294 | +! | +
+ sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
+ |
+
| 295 | ++ |
+ },+ |
+
| 296 | +! | +
+ content = function(file) {
+ |
+
| 297 | +! | +
+ snapshot <- snapshot_history()[[s]]+ |
+
| 298 | +! | +
+ snapshot_state <- as.teal_slices(snapshot)+ |
+
| 299 | +! | +
+ slices_store(tss = snapshot_state, file = file)+ |
+
| 300 | ++ |
+ }+ |
+
| 301 | ++ |
+ )+ |
+
| 302 | +! | +
+ handlers[[id_saveme]] <- id_saveme+ |
+
| 303 | ++ |
+ }+ |
+
| 304 | ++ |
+ # Create a row for the snapshot table.+ |
+
| 305 | +! | +
+ if (!is.element(id_rowme, names(divs))) {
+ |
+
| 306 | +! | +
+ divs[[id_rowme]] <- div(+ |
+
| 307 | +! | +
+ class = "snapshot_table_row",+ |
+
| 308 | +! | +
+ span(h5(s)),+ |
+
| 309 | +! | +
+ actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
+ |
+
| 310 | +! | +
+ downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
+ |
+
| 311 | ++ |
+ )+ |
+
| 312 | ++ |
+ }+ |
+
| 313 | ++ |
+ })+ |
+
| 314 | ++ |
+ })+ |
+
| 315 | ++ | + + | +
| 316 | ++ |
+ # Create table to display list of snapshots and their actions.+ |
+
| 317 | +6x | +
+ output$snapshot_list <- renderUI({
+ |
+
| 318 | +2x | +
+ rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d)+ |
+
| 319 | +2x | +
+ if (length(rows) == 0L) {
+ |
+
| 320 | +2x | +
+ div(+ |
+
| 321 | +2x | +
+ class = "snapshot_manager_placeholder",+ |
+
| 322 | +2x | +
+ "Snapshots will appear here."+ |
+
| 323 | ++ |
+ )+ |
+
| 324 | ++ |
+ } else {
+ |
+
| 325 | +! | +
+ rows+ |
+
| 326 | ++ |
+ }+ |
+
| 327 | ++ |
+ })+ |
+
| 328 | ++ |
+ })+ |
+
| 329 | ++ |
+ }+ |
+
| 330 | ++ | + + | +
| 331 | ++ |
+ ### utility functions ----+ |
+
| 332 | ++ | + + | +
| 333 | ++ |
+ #' Explicitly enumerate global filters.+ |
+
| 334 | ++ |
+ #'+ |
+
| 335 | ++ |
+ #' Transform module mapping such that global filters are explicitly specified for every module.+ |
+
| 336 | ++ |
+ #'+ |
+
| 337 | ++ |
+ #' @param mapping (named `list`) as stored in mapping parameter of `teal_slices`+ |
+
| 338 | ++ |
+ #' @param module_names (`character`) vector containing names of all modules in the app+ |
+
| 339 | ++ |
+ #' @return A `named_list` with one element per module, each element containing all filters applied to that module.+ |
+
| 340 | ++ |
+ #' @keywords internal+ |
+
| 341 | ++ |
+ #'+ |
+
| 342 | ++ |
+ unfold_mapping <- function(mapping, module_names) {
+ |
+
| 343 | +! | +
+ module_names <- structure(module_names, names = module_names)+ |
+
| 344 | +! | +
+ lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))+ |
+
| 345 | ++ |
+ }+ |
+
| 346 | ++ | + + | +
| 347 | ++ |
+ #' Convert mapping matrix to filter mapping specification.+ |
+
| 348 | ++ |
+ #'+ |
+
| 349 | ++ |
+ #' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,+ |
+
| 350 | ++ |
+ #' to a list specification like the one used in the `mapping` attribute of `teal_slices`.+ |
+
| 351 | ++ |
+ #' Global filters are gathered in one list element.+ |
+
| 352 | ++ |
+ #' If a module has no active filters but the global ones, it will not be mentioned in the output.+ |
+
| 353 | ++ |
+ #'+ |
+
| 354 | ++ |
+ #' @param mapping_matrix (`data.frame`) of logical vectors where+ |
+
| 355 | ++ |
+ #' columns represent modules and row represent `teal_slice`s+ |
+
| 356 | ++ |
+ #' @return Named `list` like that in the `mapping` attribute of a `teal_slices` object.+ |
+
| 357 | ++ |
+ #' @keywords internal+ |
+
| 358 | ++ |
+ #'+ |
+
| 359 | ++ |
+ matrix_to_mapping <- function(mapping_matrix) {
+ |
+
| 360 | +! | +
+ mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x))+ |
+
| 361 | +! | +
+ global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))+ |
+
| 362 | +! | +
+ global_filters <- names(global[global])+ |
+
| 363 | +! | +
+ local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]+ |
+
| 364 | ++ | + + | +
| 365 | +! | +
+ mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))+ |
+
| 366 | +! | +
+ Filter(function(x) length(x) != 0L, mapping)+ |
+
| 367 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Store and restore `teal_slices` object+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Functions that write a `teal_slices` object to a file in the `JSON` format,+ |
+
| 4 | ++ |
+ #' and also restore the object from disk.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' Date and date time objects are stored in the following formats:+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' - `Date` class is converted to the `"ISO8601"` standard (`YYYY-MM-DD`).+ |
+
| 9 | ++ |
+ #' - `POSIX*t` classes are converted to character by using+ |
+
| 10 | ++ |
+ #' `format.POSIX*t(usetz = TRUE, tz = "UTC")` (`YYYY-MM-DD HH:MM:SS UTC`, where+ |
+
| 11 | ++ |
+ #' `UTC` is the `Coordinated Universal Time` timezone short-code).+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' This format is assumed during `slices_restore`. All `POSIX*t` objects in+ |
+
| 14 | ++ |
+ #' `selected` or `choices` fields of `teal_slice` objects are always printed in+ |
+
| 15 | ++ |
+ #' `UTC` timezone as well.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @param tss (`teal_slices`) object to be stored.+ |
+
| 18 | ++ |
+ #' @param file (`character(1)`) file path where `teal_slices` object will be+ |
+
| 19 | ++ |
+ #' saved and restored. The file extension should be `".json"`.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @return `slices_store` returns `NULL`, invisibly.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @seealso [teal_slices()]+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @keywords internal+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ slices_store <- function(tss, file) {
+ |
+
| 28 | +9x | +
+ checkmate::assert_class(tss, "teal_slices")+ |
+
| 29 | +9x | +
+ checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json")+ |
+
| 30 | ++ | + + | +
| 31 | +9x | +
+ cat(format(tss, trim_lines = FALSE), "\n", file = file)+ |
+
| 32 | ++ |
+ }+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ #' @rdname slices_store+ |
+
| 35 | ++ |
+ #' @return `slices_restore` returns a `teal_slices` object restored from the file.+ |
+
| 36 | ++ |
+ #' @keywords internal+ |
+
| 37 | ++ |
+ slices_restore <- function(file) {
+ |
+
| 38 | +9x | +
+ checkmate::assert_file_exists(file, access = "r", extension = "json")+ |
+
| 39 | ++ | + + | +
| 40 | +9x | +
+ tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE)+ |
+
| 41 | +9x | +
+ tss_json$slices <-+ |
+
| 42 | +9x | +
+ lapply(tss_json$slices, function(slice) {
+ |
+
| 43 | +9x | +
+ for (field in c("selected", "choices")) {
+ |
+
| 44 | +18x | +
+ if (!is.null(slice[[field]])) {
+ |
+
| 45 | +12x | +
+ if (length(slice[[field]]) > 0) {
+ |
+
| 46 | +9x | +
+ date_partial_regex <- "^[0-9]{4}-[0-9]{2}-[0-9]{2}"
+ |
+
| 47 | +9x | +
+ time_stamp_regex <- paste0(date_partial_regex, "\\s[0-9]{2}:[0-9]{2}:[0-9]{2}\\sUTC$")
+ |
+
| 48 | ++ | + + | +
| 49 | +9x | +
+ slice[[field]] <-+ |
+
| 50 | +9x | +
+ if (all(grepl(paste0(date_partial_regex, "$"), slice[[field]]))) {
+ |
+
| 51 | +3x | +
+ as.Date(slice[[field]])+ |
+
| 52 | +9x | +
+ } else if (all(grepl(time_stamp_regex, slice[[field]]))) {
+ |
+
| 53 | +3x | +
+ as.POSIXct(slice[[field]], tz = "UTC")+ |
+
| 54 | ++ |
+ } else {
+ |
+
| 55 | +3x | +
+ slice[[field]]+ |
+
| 56 | ++ |
+ }+ |
+
| 57 | ++ |
+ } else {
+ |
+
| 58 | +3x | +
+ slice[[field]] <- character(0)+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | +9x | +
+ slice+ |
+
| 63 | ++ |
+ })+ |
+
| 64 | ++ | + + | +
| 65 | +9x | +
+ tss_elements <- lapply(tss_json$slices, as.teal_slice)+ |
+
| 66 | ++ | + + | +
| 67 | +9x | +
+ do.call(teal_slices, c(tss_elements, tss_json$attributes))+ |
+
| 68 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Create a UI of nested tabs of `teal_modules`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @section `ui_nested_tabs`:+ |
+
| 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+ |
+
| 6 | ++ |
+ #' `teal_module` is obtained by calling its UI function.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' The `datasets` argument is required to resolve the `teal` arguments in an+ |
+
| 9 | ++ |
+ #' isolated context (with respect to reactivity).+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @section `srv_nested_tabs`:+ |
+
| 12 | ++ |
+ #' This module recursively calls all elements of `modules` and returns currently active one.+ |
+
| 13 | ++ |
+ #' - `teal_module` returns self as a active module.+ |
+
| 14 | ++ |
+ #' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @name module_nested_tabs+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @inheritParams module_tabs_with_filters+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @param depth (`integer(1)`)+ |
+
| 21 | ++ |
+ #' number which helps to determine depth of the modules nesting.+ |
+
| 22 | ++ |
+ #' @param is_module_specific (`logical(1)`)+ |
+
| 23 | ++ |
+ #' flag determining if the filter panel is global or module-specific.+ |
+
| 24 | ++ |
+ #' When set to `TRUE`, a filter panel is called inside of each module tab.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @return+ |
+
| 27 | ++ |
+ #' Depending on the class of `modules`, `ui_nested_tabs` returns:+ |
+
| 28 | ++ |
+ #' - `teal_module`: instantiated UI of the module.+ |
+
| 29 | ++ |
+ #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively+ |
+
| 30 | ++ |
+ #' calling this function on it.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @keywords internal+ |
+
| 35 | ++ |
+ NULL+ |
+
| 36 | ++ | + + | +
| 37 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 38 | ++ |
+ ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ |
+
| 39 | +! | +
+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ |
+
| 40 | +! | +
+ checkmate::assert_count(depth)+ |
+
| 41 | +! | +
+ UseMethod("ui_nested_tabs", modules)
+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 45 | ++ |
+ #' @export+ |
+
| 46 | ++ |
+ ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ |
+
| 47 | +! | +
+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | ++ | + + | +
| 50 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 51 | ++ |
+ #' @export+ |
+
| 52 | ++ |
+ ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ |
+
| 53 | +! | +
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ |
+
| 54 | +! | +
+ ns <- NS(id)+ |
+
| 55 | +! | +
+ do.call(+ |
+
| 56 | +! | +
+ tabsetPanel,+ |
+
| 57 | +! | +
+ c(+ |
+
| 58 | ++ |
+ # by giving an id, we can reactively respond to tab changes+ |
+
| 59 | +! | +
+ list(+ |
+
| 60 | +! | +
+ id = ns("active_tab"),
+ |
+
| 61 | +! | +
+ type = if (modules$label == "root") "pills" else "tabs"+ |
+
| 62 | ++ |
+ ),+ |
+
| 63 | +! | +
+ lapply(+ |
+
| 64 | +! | +
+ names(modules$children),+ |
+
| 65 | +! | +
+ function(module_id) {
+ |
+
| 66 | +! | +
+ module_label <- modules$children[[module_id]]$label+ |
+
| 67 | +! | +
+ tabPanel(+ |
+
| 68 | +! | +
+ title = module_label,+ |
+
| 69 | +! | +
+ value = module_id, # when clicked this tab value changes input$<tabset panel id>+ |
+
| 70 | +! | +
+ ui_nested_tabs(+ |
+
| 71 | +! | +
+ id = ns(module_id),+ |
+
| 72 | +! | +
+ modules = modules$children[[module_id]],+ |
+
| 73 | +! | +
+ datasets = datasets[[module_label]],+ |
+
| 74 | +! | +
+ depth = depth + 1L,+ |
+
| 75 | +! | +
+ is_module_specific = is_module_specific+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ |
+ )+ |
+
| 80 | ++ |
+ )+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 85 | ++ |
+ #' @export+ |
+
| 86 | ++ |
+ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ |
+
| 87 | +! | +
+ checkmate::assert_class(datasets, classes = "FilteredData")+ |
+
| 88 | +! | +
+ ns <- NS(id)+ |
+
| 89 | ++ | + + | +
| 90 | +! | +
+ args <- c(list(id = ns("module")), modules$ui_args)
+ |
+
| 91 | ++ | + + | +
| 92 | +! | +
+ teal_ui <- tags$div(+ |
+
| 93 | +! | +
+ id = id,+ |
+
| 94 | +! | +
+ class = "teal_module",+ |
+
| 95 | +! | +
+ uiOutput(ns("data_reactive"), inline = TRUE),
+ |
+
| 96 | +! | +
+ tagList(+ |
+
| 97 | +! | +
+ if (depth >= 2L) div(style = "mt-6"),+ |
+
| 98 | +! | +
+ do.call(modules$ui, args)+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ |
+ )+ |
+
| 101 | ++ | + + | +
| 102 | +! | +
+ if (!is.null(modules$datanames) && is_module_specific) {
+ |
+
| 103 | +! | +
+ fluidRow(+ |
+
| 104 | +! | +
+ column(width = 9, teal_ui, class = "teal_primary_col"),+ |
+
| 105 | +! | +
+ column(+ |
+
| 106 | +! | +
+ width = 3,+ |
+
| 107 | +! | +
+ datasets$ui_filter_panel(ns("module_filter_panel")),
+ |
+
| 108 | +! | +
+ class = "teal_secondary_col"+ |
+
| 109 | ++ |
+ )+ |
+
| 110 | ++ |
+ )+ |
+
| 111 | ++ |
+ } else {
+ |
+
| 112 | +! | +
+ teal_ui+ |
+
| 113 | ++ |
+ }+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ | + + | +
| 116 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 117 | ++ |
+ srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,+ |
+
| 118 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+
| 119 | +50x | +
+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ |
+
| 120 | +50x | +
+ checkmate::assert_class(reporter, "Reporter")+ |
+
| 121 | +49x | +
+ UseMethod("srv_nested_tabs", modules)
+ |
+
| 122 | ++ |
+ }+ |
+
| 123 | ++ | + + | +
| 124 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 125 | ++ |
+ #' @export+ |
+
| 126 | ++ |
+ srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,+ |
+
| 127 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+
| 128 | +! | +
+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 132 | ++ |
+ #' @export+ |
+
| 133 | ++ |
+ srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,+ |
+
| 134 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+
| 135 | +22x | +
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ |
+
| 136 | ++ | + + | +
| 137 | +22x | +
+ moduleServer(id = id, module = function(input, output, session) {
+ |
+
| 138 | +22x | +
+ logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
+ |
+
| 139 | ++ | + + | +
| 140 | +22x | +
+ labels <- vapply(modules$children, `[[`, character(1), "label")+ |
+
| 141 | +22x | +
+ modules_reactive <- sapply(+ |
+
| 142 | +22x | +
+ names(modules$children),+ |
+
| 143 | +22x | +
+ function(module_id) {
+ |
+
| 144 | +33x | +
+ srv_nested_tabs(+ |
+
| 145 | +33x | +
+ id = module_id,+ |
+
| 146 | +33x | +
+ datasets = datasets[[labels[module_id]]],+ |
+
| 147 | +33x | +
+ modules = modules$children[[module_id]],+ |
+
| 148 | +33x | +
+ is_module_specific = is_module_specific,+ |
+
| 149 | +33x | +
+ reporter = reporter+ |
+
| 150 | ++ |
+ )+ |
+
| 151 | ++ |
+ },+ |
+
| 152 | +22x | +
+ simplify = FALSE+ |
+
| 153 | ++ |
+ )+ |
+
| 154 | ++ | + + | +
| 155 | ++ |
+ # when not ready input$active_tab would return NULL - this would fail next reactive+ |
+
| 156 | +22x | +
+ input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)+ |
+
| 157 | +22x | +
+ get_active_module <- reactive({
+ |
+
| 158 | +12x | +
+ if (length(modules$children) == 1L) {
+ |
+
| 159 | ++ |
+ # single tab is active by default+ |
+
| 160 | +1x | +
+ modules_reactive[[1]]()+ |
+
| 161 | ++ |
+ } else {
+ |
+
| 162 | ++ |
+ # switch to active tab+ |
+
| 163 | +11x | +
+ modules_reactive[[input_validated()]]()+ |
+
| 164 | ++ |
+ }+ |
+
| 165 | ++ |
+ })+ |
+
| 166 | ++ | + + | +
| 167 | +22x | +
+ get_active_module+ |
+
| 168 | ++ |
+ })+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | ++ | + + | +
| 171 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 172 | ++ |
+ #' @export+ |
+
| 173 | ++ |
+ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,+ |
+
| 174 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+
| 175 | +27x | +
+ checkmate::assert_class(datasets, "FilteredData")+ |
+
| 176 | +27x | +
+ logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
+ |
+
| 177 | ++ | + + | +
| 178 | +27x | +
+ moduleServer(id = id, module = function(input, output, session) {
+ |
+
| 179 | +27x | +
+ if (!is.null(modules$datanames) && is_module_specific) {
+ |
+
| 180 | +! | +
+ datasets$srv_filter_panel("module_filter_panel")
+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ | + + | +
| 183 | ++ |
+ # Create two triggers to limit reactivity between filter-panel and modules.+ |
+
| 184 | ++ |
+ # We want to recalculate only visible modules+ |
+
| 185 | ++ |
+ # - trigger the data when the tab is selected+ |
+
| 186 | ++ |
+ # - trigger module to be called when the tab is selected for the first time+ |
+
| 187 | +27x | +
+ trigger_data <- reactiveVal(1L)+ |
+
| 188 | +27x | +
+ trigger_module <- reactiveVal(NULL)+ |
+
| 189 | +27x | +
+ output$data_reactive <- renderUI({
+ |
+
| 190 | +17x | +
+ lapply(datasets$datanames(), function(x) {
+ |
+
| 191 | +21x | +
+ datasets$get_data(x, filtered = TRUE)+ |
+
| 192 | ++ |
+ })+ |
+
| 193 | +17x | +
+ isolate(trigger_data(trigger_data() + 1))+ |
+
| 194 | +17x | +
+ isolate(trigger_module(TRUE))+ |
+
| 195 | ++ | + + | +
| 196 | +17x | +
+ NULL+ |
+
| 197 | ++ |
+ })+ |
+
| 198 | ++ | + + | +
| 199 | ++ |
+ # collect arguments to run teal_module+ |
+
| 200 | +27x | +
+ args <- c(list(id = "module"), modules$server_args)+ |
+
| 201 | +27x | +
+ if (is_arg_used(modules$server, "reporter")) {
+ |
+
| 202 | +! | +
+ args <- c(args, list(reporter = reporter))+ |
+
| 203 | ++ |
+ }+ |
+
| 204 | ++ | + + | +
| 205 | +27x | +
+ if (is_arg_used(modules$server, "datasets")) {
+ |
+
| 206 | +1x | +
+ args <- c(args, datasets = datasets)+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | ++ | + + | +
| 209 | +27x | +
+ if (is_arg_used(modules$server, "data")) {
+ |
+
| 210 | +7x | +
+ data <- eventReactive(trigger_data(), .datasets_to_data(modules, datasets))+ |
+
| 211 | +7x | +
+ args <- c(args, data = list(data))+ |
+
| 212 | ++ |
+ }+ |
+
| 213 | ++ | + + | +
| 214 | +27x | +
+ if (is_arg_used(modules$server, "filter_panel_api")) {
+ |
+
| 215 | +2x | +
+ filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)+ |
+
| 216 | +2x | +
+ args <- c(args, filter_panel_api = filter_panel_api)+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ | + + | +
| 219 | ++ |
+ # observe the trigger_module above to induce the module once the renderUI is triggered+ |
+
| 220 | +27x | +
+ observeEvent(+ |
+
| 221 | +27x | +
+ ignoreNULL = TRUE,+ |
+
| 222 | +27x | +
+ once = TRUE,+ |
+
| 223 | +27x | +
+ eventExpr = trigger_module(),+ |
+
| 224 | +27x | +
+ handlerExpr = {
+ |
+
| 225 | +17x | +
+ module_output <- if (is_arg_used(modules$server, "id")) {
+ |
+
| 226 | +17x | +
+ do.call(modules$server, args)+ |
+
| 227 | ++ |
+ } else {
+ |
+
| 228 | +! | +
+ do.call(callModule, c(args, list(module = modules$server)))+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ |
+ )+ |
+
| 232 | ++ | + + | +
| 233 | +27x | +
+ reactive(modules)+ |
+
| 234 | ++ |
+ })+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | ++ | + + | +
| 237 | ++ |
+ #' Convert `FilteredData` to reactive list of datasets of the `teal_data` type.+ |
+
| 238 | ++ |
+ #'+ |
+
| 239 | ++ |
+ #' Converts `FilteredData` object to `teal_data` object containing datasets needed for a specific module.+ |
+
| 240 | ++ |
+ #' Please note that if a module needs a dataset which has a parent, then the parent will also be returned.+ |
+
| 241 | ++ |
+ #' A hash per `dataset` is calculated internally and returned in the code.+ |
+
| 242 | ++ |
+ #'+ |
+
| 243 | ++ |
+ #' @param module (`teal_module`) module where needed filters are taken from+ |
+
| 244 | ++ |
+ #' @param datasets (`FilteredData`) object where needed data are taken from+ |
+
| 245 | ++ |
+ #'+ |
+
| 246 | ++ |
+ #' @return A `teal_data` object.+ |
+
| 247 | ++ |
+ #'+ |
+
| 248 | ++ |
+ #' @keywords internal+ |
+
| 249 | ++ |
+ .datasets_to_data <- function(module, datasets) {
+ |
+
| 250 | +4x | +
+ checkmate::assert_class(module, "teal_module")+ |
+
| 251 | +4x | +
+ checkmate::assert_class(datasets, "FilteredData")+ |
+
| 252 | ++ | + + | +
| 253 | +4x | +
+ datanames <- if (is.null(module$datanames) || identical(module$datanames, "all")) {
+ |
+
| 254 | +1x | +
+ datasets$datanames()+ |
+
| 255 | ++ |
+ } else {
+ |
+
| 256 | +3x | +
+ include_parent_datanames(+ |
+
| 257 | +3x | +
+ module$datanames,+ |
+
| 258 | +3x | +
+ datasets$get_join_keys()+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | ++ | + + | +
| 262 | ++ |
+ # list of reactive filtered data+ |
+
| 263 | +4x | +
+ data <- sapply(datanames, function(x) datasets$get_data(x, filtered = TRUE), simplify = FALSE)+ |
+
| 264 | ++ | + + | +
| 265 | +4x | +
+ hashes <- calculate_hashes(datanames, datasets)+ |
+
| 266 | ++ | + + | +
| 267 | +4x | +
+ code <- c(+ |
+
| 268 | +4x | +
+ get_rcode_str_install(),+ |
+
| 269 | +4x | +
+ get_rcode_libraries(),+ |
+
| 270 | +4x | +
+ get_datasets_code(datanames, datasets, hashes)+ |
+
| 271 | ++ |
+ )+ |
+
| 272 | ++ | + + | +
| 273 | ++ | + + | +
| 274 | +4x | +
+ data <- do.call(+ |
+
| 275 | +4x | +
+ teal.data::teal_data,+ |
+
| 276 | +4x | +
+ args = c(data, code = list(code), join_keys = list(datasets$get_join_keys()[datanames]))+ |
+
| 277 | ++ |
+ )+ |
+
| 278 | ++ | + + | +
| 279 | +4x | +
+ data@verified <- attr(datasets, "verification_status")+ |
+
| 280 | +4x | +
+ data+ |
+
| 281 | ++ |
+ }+ |
+
| 282 | ++ | + + | +
| 283 | ++ |
+ #' Get the hash of a dataset+ |
+
| 284 | ++ |
+ #'+ |
+
| 285 | ++ |
+ #' @param datanames (`character`) names of datasets+ |
+
| 286 | ++ |
+ #' @param datasets (`FilteredData`) object holding the data+ |
+
| 287 | ++ |
+ #'+ |
+
| 288 | ++ |
+ #' @return A list of hashes per dataset.+ |
+
| 289 | ++ |
+ #' @keywords internal+ |
+
| 290 | ++ |
+ #'+ |
+
| 291 | ++ |
+ calculate_hashes <- function(datanames, datasets) {
+ |
+
| 292 | +7x | +
+ sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)+ |
+
| 293 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Add right filter panel into each of the top-level `teal_modules` UIs+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' The [ui_nested_tabs] function returns a nested tabbed UI corresponding+ |
+
| 4 | ++ |
+ #' to the nested modules.+ |
+
| 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,+ |
+
| 8 | ++ |
+ #' all modules using the same `datasets` share the same filters.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' This works with nested modules of depth greater than 2, though the filter+ |
+
| 11 | ++ |
+ #' panel is inserted at the right of the modules at depth 1 and not at the leaves.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @name module_tabs_with_filters+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @inheritParams module_teal+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @param datasets (named `list` of `FilteredData`)+ |
+
| 18 | ++ |
+ #' object to store filter state and filtered datasets, shared across modules. For more+ |
+
| 19 | ++ |
+ #' details see [`teal.slice::FilteredData`]. Structure of the list must be the same as structure+ |
+
| 20 | ++ |
+ #' of the `modules` argument and list names must correspond to the labels in `modules`.+ |
+
| 21 | ++ |
+ #' When filter is not module-specific then list contains the same object in all elements.+ |
+
| 22 | ++ |
+ #' @param reporter (`Reporter`) object from `teal.reporter`+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @return+ |
+
| 25 | ++ |
+ #' A `shiny.tag.list` containing the main menu, placeholders for filters and placeholders for the `teal` modules.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @keywords internal+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ NULL+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ #' @rdname module_tabs_with_filters+ |
+
| 32 | ++ |
+ ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
+ |
+
| 33 | +! | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 34 | +! | +
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ |
+
| 35 | +! | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+
| 36 | ++ | + + | +
| 37 | +! | +
+ ns <- NS(id)+ |
+
| 38 | +! | +
+ is_module_specific <- isTRUE(attr(filter, "module_specific"))+ |
+
| 39 | ++ | + + | +
| 40 | +! | +
+ teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
+ |
+
| 41 | +! | +
+ filter_panel_btns <- tags$li(+ |
+
| 42 | +! | +
+ class = "flex-grow",+ |
+
| 43 | +! | +
+ tags$button(+ |
+
| 44 | +! | +
+ class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger+ |
+
| 45 | +! | +
+ href = "javascript:void(0)",+ |
+
| 46 | +! | +
+ onclick = "toggleFilterPanel();", # see sidebar.js+ |
+
| 47 | +! | +
+ title = "Toggle filter panels",+ |
+
| 48 | +! | +
+ icon("fas fa-bars")
+ |
+
| 49 | ++ |
+ ),+ |
+
| 50 | +! | +
+ filter_manager_modal_ui(ns("filter_manager"))
+ |
+
| 51 | ++ |
+ )+ |
+
| 52 | +! | +
+ teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)+ |
+
| 53 | ++ | + + | +
| 54 | +! | +
+ if (!is_module_specific) {
+ |
+
| 55 | ++ |
+ # need to rearrange html so that filter panel is within tabset+ |
+
| 56 | +! | +
+ tabset_bar <- teal_ui$children[[1]]+ |
+
| 57 | +! | +
+ teal_modules <- teal_ui$children[[2]]+ |
+
| 58 | +! | +
+ filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
+ |
+
| 59 | +! | +
+ list(+ |
+
| 60 | +! | +
+ tabset_bar,+ |
+
| 61 | +! | +
+ tags$hr(class = "my-2"),+ |
+
| 62 | +! | +
+ fluidRow(+ |
+
| 63 | +! | +
+ column(width = 9, teal_modules, class = "teal_primary_col"),+ |
+
| 64 | +! | +
+ column(width = 3, filter_ui, class = "teal_secondary_col")+ |
+
| 65 | ++ |
+ )+ |
+
| 66 | ++ |
+ )+ |
+
| 67 | ++ |
+ } else {
+ |
+
| 68 | +! | +
+ teal_ui+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ #' @rdname module_tabs_with_filters+ |
+
| 73 | ++ |
+ srv_tabs_with_filters <- function(id,+ |
+
| 74 | ++ |
+ datasets,+ |
+
| 75 | ++ |
+ modules,+ |
+
| 76 | ++ |
+ reporter = teal.reporter::Reporter$new(),+ |
+
| 77 | ++ |
+ filter = teal_slices()) {
+ |
+
| 78 | +5x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 79 | +5x | +
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ |
+
| 80 | +5x | +
+ checkmate::assert_class(reporter, "Reporter")+ |
+
| 81 | +3x | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+
| 82 | ++ | + + | +
| 83 | +3x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 84 | +3x | +
+ logger::log_trace("srv_tabs_with_filters initializing the module.")
+ |
+
| 85 | ++ | + + | +
| 86 | +3x | +
+ is_module_specific <- isTRUE(attr(filter, "module_specific"))+ |
+
| 87 | +3x | +
+ manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
+ |
+
| 88 | ++ | + + | +
| 89 | +3x | +
+ active_module <- srv_nested_tabs(+ |
+
| 90 | +3x | +
+ id = "root",+ |
+
| 91 | +3x | +
+ datasets = datasets,+ |
+
| 92 | +3x | +
+ modules = modules,+ |
+
| 93 | +3x | +
+ reporter = reporter,+ |
+
| 94 | +3x | +
+ is_module_specific = is_module_specific+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | ++ | + + | +
| 97 | +3x | +
+ if (!is_module_specific) {
+ |
+
| 98 | +3x | +
+ active_datanames <- reactive({
+ |
+
| 99 | +6x | +
+ if (identical(active_module()$datanames, "all")) {
+ |
+
| 100 | +! | +
+ singleton$datanames()+ |
+
| 101 | ++ |
+ } else {
+ |
+
| 102 | +5x | +
+ include_parent_datanames(+ |
+
| 103 | +5x | +
+ active_module()$datanames,+ |
+
| 104 | +5x | +
+ singleton$get_join_keys()+ |
+
| 105 | ++ |
+ )+ |
+
| 106 | ++ |
+ }+ |
+
| 107 | ++ |
+ })+ |
+
| 108 | +3x | +
+ singleton <- unlist(datasets)[[1]]+ |
+
| 109 | +3x | +
+ singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
+ |
+
| 110 | ++ | + + | +
| 111 | +3x | +
+ observeEvent(+ |
+
| 112 | +3x | +
+ eventExpr = active_datanames(),+ |
+
| 113 | +3x | +
+ handlerExpr = {
+ |
+
| 114 | +4x | +
+ script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
+ |
+
| 115 | ++ |
+ # hide the filter panel and disable the burger button+ |
+
| 116 | +! | +
+ "handleNoActiveDatasets();"+ |
+
| 117 | ++ |
+ } else {
+ |
+
| 118 | ++ |
+ # show the filter panel and enable the burger button+ |
+
| 119 | +4x | +
+ "handleActiveDatasetsPresent();"+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | +4x | +
+ shinyjs::runjs(script)+ |
+
| 122 | ++ |
+ },+ |
+
| 123 | +3x | +
+ ignoreNULL = FALSE+ |
+
| 124 | ++ |
+ )+ |
+
| 125 | ++ |
+ }+ |
+
| 126 | ++ | + + | +
| 127 | +3x | +
+ showNotification("Data loaded - App fully started up")
+ |
+
| 128 | +3x | +
+ logger::log_trace("srv_tabs_with_filters initialized the module")
+ |
+
| 129 | ++ | + + | +
| 130 | +3x | +
+ active_module+ |
+
| 131 | ++ |
+ })+ |
+
| 132 | ++ |
+ }+ |
+
| 1 | ++ |
+ # This file adds a splash screen for delayed data loading on top of teal+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ #' Add splash screen to `teal` application+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' Displays custom splash screen during initial delayed data loading.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @details+ |
+
| 10 | ++ |
+ #' This module pauses app initialization pending delayed data loading.+ |
+
| 11 | ++ |
+ #' This is necessary because the filter panel and modules depend on the data to initialize.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' `teal_with_splash` follows the `shiny` module convention.+ |
+
| 14 | ++ |
+ #' [`init()`] is a wrapper around this that assumes that `teal` it is+ |
+
| 15 | ++ |
+ #' the top-level module and cannot be embedded.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' Note: It is no longer recommended to embed `teal` in `shiny` apps as a module.+ |
+
| 18 | ++ |
+ #' but rather use `init` to create a standalone application.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @seealso [init()]+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @param id (`character(1)`)+ |
+
| 23 | ++ |
+ #' module id+ |
+
| 24 | ++ |
+ #' @inheritParams init+ |
+
| 25 | ++ |
+ #' @param modules (`teal_modules`) object containing the output modules which+ |
+
| 26 | ++ |
+ #' will be displayed in the `teal` application. See [modules()] and [module()] for+ |
+
| 27 | ++ |
+ #' more details.+ |
+
| 28 | ++ |
+ #' @inheritParams shiny::moduleServer+ |
+
| 29 | ++ |
+ #' @return+ |
+
| 30 | ++ |
+ #' Returns a `reactive` expression containing a `teal_data` object when data is loaded or `NULL` when it is not.+ |
+
| 31 | ++ |
+ #' @name module_teal_with_splash+ |
+
| 32 | ++ |
+ #' @examples+ |
+
| 33 | ++ |
+ #' teal_modules <- modules(example_module())+ |
+
| 34 | ++ |
+ #' # Shiny app with modular integration of teal+ |
+
| 35 | ++ |
+ #' ui <- fluidPage(+ |
+
| 36 | ++ |
+ #' ui_teal_with_splash(id = "app1", data = teal_data())+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 40 | ++ |
+ #' srv_teal_with_splash(+ |
+
| 41 | ++ |
+ #' id = "app1",+ |
+
| 42 | ++ |
+ #' data = teal_data(iris = iris),+ |
+
| 43 | ++ |
+ #' modules = teal_modules+ |
+
| 44 | ++ |
+ #' )+ |
+
| 45 | ++ |
+ #' }+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' if (interactive()) {
+ |
+
| 48 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 49 | ++ |
+ #' }+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ NULL+ |
+
| 52 | ++ | + + | +
| 53 | ++ |
+ #' @export+ |
+
| 54 | ++ |
+ #' @rdname module_teal_with_splash+ |
+
| 55 | ++ |
+ ui_teal_with_splash <- function(id,+ |
+
| 56 | ++ |
+ data,+ |
+
| 57 | ++ |
+ title = build_app_title(),+ |
+
| 58 | ++ |
+ header = tags$p(),+ |
+
| 59 | ++ |
+ footer = tags$p()) {
+ |
+
| 60 | +7x | +
+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ |
+
| 61 | +7x | +
+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
+ |
+
| 62 | +7x | +
+ checkmate::assert(+ |
+
| 63 | +7x | +
+ .var.name = "title",+ |
+
| 64 | +7x | +
+ checkmate::check_string(title),+ |
+
| 65 | +7x | +
+ checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 66 | ++ |
+ )+ |
+
| 67 | +7x | +
+ checkmate::assert(+ |
+
| 68 | +7x | +
+ .var.name = "header",+ |
+
| 69 | +7x | +
+ checkmate::check_string(header),+ |
+
| 70 | +7x | +
+ checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | +7x | +
+ checkmate::assert(+ |
+
| 73 | +7x | +
+ .var.name = "footer",+ |
+
| 74 | +7x | +
+ checkmate::check_string(footer),+ |
+
| 75 | +7x | +
+ checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | ++ | + + | +
| 78 | +7x | +
+ ns <- NS(id)+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ # Startup splash screen for delayed loading+ |
+
| 81 | ++ |
+ # We use delayed loading in all cases, even when the data does not need to be fetched.+ |
+
| 82 | ++ |
+ # This has the benefit that when filtering the data takes a lot of time initially, the+ |
+
| 83 | ++ |
+ # Shiny app does not time out.+ |
+
| 84 | +7x | +
+ splash_ui <- if (inherits(data, "teal_data_module")) {
+ |
+
| 85 | +1x | +
+ data$ui(ns("teal_data_module"))
+ |
+
| 86 | +7x | +
+ } else if (inherits(data, "teal_data")) {
+ |
+
| 87 | +6x | +
+ div()+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | +7x | +
+ ui_teal(+ |
+
| 90 | +7x | +
+ id = ns("teal"),
+ |
+
| 91 | +7x | +
+ splash_ui = div(splash_ui, uiOutput(ns("error"))),
+ |
+
| 92 | +7x | +
+ title = title,+ |
+
| 93 | +7x | +
+ header = header,+ |
+
| 94 | +7x | +
+ footer = footer+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ #' @export+ |
+
| 99 | ++ |
+ #' @rdname module_teal_with_splash+ |
+
| 100 | ++ |
+ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
+ |
+
| 101 | +15x | +
+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ |
+
| 102 | +15x | +
+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
+ |
+
| 103 | +15x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 104 | +15x | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+
| 105 | ++ | + + | +
| 106 | +15x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 107 | +15x | +
+ logger::log_trace("srv_teal_with_splash initializing module with data.")
+ |
+
| 108 | ++ | + + | +
| 109 | +15x | +
+ if (getOption("teal.show_js_log", default = FALSE)) {
+ |
+
| 110 | +! | +
+ shinyjs::showLog()+ |
+
| 111 | ++ |
+ }+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ # teal_data_rv contains teal_data object+ |
+
| 114 | ++ |
+ # either passed to teal::init or returned from teal_data_module+ |
+
| 115 | +15x | +
+ teal_data_rv <- if (inherits(data, "teal_data_module")) {
+ |
+
| 116 | +10x | +
+ data <- data$server(id = "teal_data_module")+ |
+
| 117 | +10x | +
+ if (!is.reactive(data)) {
+ |
+
| 118 | +1x | +
+ stop("The `teal_data_module` passed to `data` must return a reactive expression.", call. = FALSE)
+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | +9x | +
+ data+ |
+
| 121 | +15x | +
+ } else if (inherits(data, "teal_data")) {
+ |
+
| 122 | +5x | +
+ reactiveVal(data)+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | +14x | +
+ teal_data_rv_validate <- reactive({
+ |
+
| 126 | ++ |
+ # custom module can return error+ |
+
| 127 | +11x | +
+ data <- tryCatch(teal_data_rv(), error = function(e) e)+ |
+
| 128 | ++ | + + | +
| 129 | ++ |
+ # there is an empty reactive cycle on init!+ |
+
| 130 | +11x | +
+ if (inherits(data, "shiny.silent.error") && identical(data$message, "")) {
+ |
+
| 131 | +! | +
+ return(NULL)+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ # to handle qenv.error+ |
+
| 135 | +11x | +
+ if (inherits(data, "qenv.error")) {
+ |
+
| 136 | +2x | +
+ validate(+ |
+
| 137 | +2x | +
+ need(+ |
+
| 138 | +2x | +
+ FALSE,+ |
+
| 139 | +2x | +
+ paste(+ |
+
| 140 | +2x | +
+ "Error when executing `teal_data_module` passed to `data`:\n ",+ |
+
| 141 | +2x | +
+ paste(data$message, collapse = "\n"),+ |
+
| 142 | +2x | +
+ "\n Check your inputs or contact app developer if error persists."+ |
+
| 143 | ++ |
+ )+ |
+
| 144 | ++ |
+ )+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | ++ |
+ # to handle module non-qenv errors+ |
+
| 149 | +9x | +
+ if (inherits(data, "error")) {
+ |
+
| 150 | +1x | +
+ validate(+ |
+
| 151 | +1x | +
+ need(+ |
+
| 152 | +1x | +
+ FALSE,+ |
+
| 153 | +1x | +
+ paste(+ |
+
| 154 | +1x | +
+ "Error when executing `teal_data_module` passed to `data`:\n ",+ |
+
| 155 | +1x | +
+ paste(data$message, collpase = "\n"),+ |
+
| 156 | +1x | +
+ "\n Check your inputs or contact app developer if error persists."+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | ++ |
+ )+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ | + + | +
| 162 | +8x | +
+ validate(+ |
+
| 163 | +8x | +
+ need(+ |
+
| 164 | +8x | +
+ inherits(data, "teal_data"),+ |
+
| 165 | +8x | +
+ paste(+ |
+
| 166 | +8x | +
+ "Error: `teal_data_module` passed to `data` failed to return `teal_data` object, returned",+ |
+
| 167 | +8x | +
+ toString(sQuote(class(data))),+ |
+
| 168 | +8x | +
+ "instead.",+ |
+
| 169 | +8x | +
+ "\n Check your inputs or contact app developer if error persists."+ |
+
| 170 | ++ |
+ )+ |
+
| 171 | ++ |
+ )+ |
+
| 172 | ++ |
+ )+ |
+
| 173 | ++ | + + | +
| 174 | +5x | +
+ if (!length(teal.data::datanames(data))) {
+ |
+
| 175 | +1x | +
+ warning("`data` object has no datanames. Default datanames are set using `teal_data`'s environment.")
+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | ++ | + + | +
| 178 | +5x | +
+ is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))+ |
+
| 179 | +5x | +
+ if (!isTRUE(is_modules_ok)) {
+ |
+
| 180 | +1x | +
+ validate(need(isTRUE(is_modules_ok), sprintf("%s. Contact app developer.", is_modules_ok)))
+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ | + + | +
| 183 | +4x | +
+ is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))+ |
+
| 184 | +4x | +
+ if (!isTRUE(is_filter_ok)) {
+ |
+
| 185 | +1x | +
+ showNotification(+ |
+
| 186 | +1x | +
+ "Some filters were not applied because of incompatibility with data. Contact app developer.",+ |
+
| 187 | +1x | +
+ type = "warning",+ |
+
| 188 | +1x | +
+ duration = 10+ |
+
| 189 | ++ |
+ )+ |
+
| 190 | +1x | +
+ warning(is_filter_ok)+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | +4x | +
+ teal_data_rv()+ |
+
| 194 | ++ |
+ })+ |
+
| 195 | ++ | + + | +
| 196 | +14x | +
+ output$error <- renderUI({
+ |
+
| 197 | +! | +
+ teal_data_rv_validate()+ |
+
| 198 | +! | +
+ NULL+ |
+
| 199 | ++ |
+ })+ |
+
| 200 | ++ | + + | +
| 201 | ++ | + + | +
| 202 | +14x | +
+ res <- srv_teal(id = "teal", modules = modules, teal_data_rv = teal_data_rv_validate, filter = filter)+ |
+
| 203 | +14x | +
+ logger::log_trace("srv_teal_with_splash initialized module with data.")
+ |
+
| 204 | ++ | + + | +
| 205 | +14x | +
+ res+ |
+
| 206 | ++ |
+ })+ |
+
| 207 | ++ |
+ }+ |
+
| 1 | ++ |
+ .onLoad <- function(libname, pkgname) { # nolint
+ |
+
| 2 | ++ |
+ # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R+ |
+
| 3 | +! | +
+ teal_default_options <- list(teal.show_js_log = FALSE)+ |
+
| 4 | ++ | + + | +
| 5 | +! | +
+ op <- options()+ |
+
| 6 | +! | +
+ toset <- !(names(teal_default_options) %in% names(op))+ |
+
| 7 | +! | +
+ if (any(toset)) options(teal_default_options[toset])+ |
+
| 8 | ++ | + + | +
| 9 | +! | +
+ options("shiny.sanitize.errors" = FALSE)
+ |
+
| 10 | ++ | + + | +
| 11 | ++ |
+ # Set up the teal logger instance+ |
+
| 12 | +! | +
+ teal.logger::register_logger("teal")
+ |
+
| 13 | ++ | + + | +
| 14 | +! | +
+ invisible()+ |
+
| 15 | ++ |
+ }+ |
+
| 16 | ++ | + + | +
| 17 | ++ |
+ .onAttach <- function(libname, pkgname) { # nolint
+ |
+
| 18 | +2x | +
+ packageStartupMessage(+ |
+
| 19 | +2x | +
+ "\nYou are using teal version ",+ |
+
| 20 | ++ |
+ # `system.file` uses the `shim` of `system.file` by `teal`+ |
+
| 21 | ++ |
+ # we avoid `desc` dependency here to get the version+ |
+
| 22 | +2x | +
+ read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"]
+ |
+
| 23 | ++ |
+ )+ |
+
| 24 | ++ |
+ }+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ # This one is here because setdiff_teal_slice should not be exported from teal.slice.+ |
+
| 27 | ++ |
+ setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
+ |
+
| 28 | ++ |
+ # This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice.+ |
+
| 29 | ++ |
+ coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
+ |
+
| 30 | ++ |
+ # all *Block objects are private in teal.reporter+ |
+
| 31 | ++ |
+ RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint
+ |
+
| 32 | ++ | + + | +
| 33 | ++ |
+ # Use non-exported function(s) from teal.code+ |
+
| 34 | ++ |
+ # This one is here because lang2calls should not be exported from teal.code+ |
+
| 35 | ++ |
+ lang2calls <- getFromNamespace("lang2calls", "teal.code")
+ |
+
| 1 | ++ |
+ #' Create a `teal` module for previewing a report+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This function wraps [teal.reporter::reporter_previewer_ui()] and+ |
+
| 6 | ++ |
+ #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be+ |
+
| 7 | ++ |
+ #' used in `teal` applications.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' If you are creating a `teal` application using [init()] then this+ |
+
| 10 | ++ |
+ #' module will be added to your application automatically if any of your `teal_modules`+ |
+
| 11 | ++ |
+ #' support report generation.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @inheritParams teal_modules+ |
+
| 14 | ++ |
+ #' @param server_args (named `list`)+ |
+
| 15 | ++ |
+ #' Arguments passed to [teal.reporter::reporter_previewer_srv()].+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return+ |
+
| 18 | ++ |
+ #' `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer functionality.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
+ |
+
| 23 | +4x | +
+ checkmate::assert_string(label)+ |
+
| 24 | +2x | +
+ checkmate::assert_list(server_args, names = "named")+ |
+
| 25 | +2x | +
+ checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))+ |
+
| 26 | ++ | + + | +
| 27 | +2x | +
+ logger::log_info("Initializing reporter_previewer_module")
+ |
+
| 28 | ++ | + + | +
| 29 | +2x | +
+ srv <- function(id, reporter, ...) {
+ |
+
| 30 | +! | +
+ teal.reporter::reporter_previewer_srv(id, reporter, ...)+ |
+
| 31 | ++ |
+ }+ |
+
| 32 | ++ | + + | +
| 33 | +2x | +
+ ui <- function(id, ...) {
+ |
+
| 34 | +! | +
+ teal.reporter::reporter_previewer_ui(id, ...)+ |
+
| 35 | ++ |
+ }+ |
+
| 36 | ++ | + + | +
| 37 | +2x | +
+ module <- module(+ |
+
| 38 | +2x | +
+ label = "temporary label",+ |
+
| 39 | +2x | +
+ server = srv, ui = ui,+ |
+
| 40 | +2x | +
+ server_args = server_args, ui_args = list(), datanames = NULL+ |
+
| 41 | ++ |
+ )+ |
+
| 42 | ++ |
+ # Module is created with a placeholder label and the label is changed later.+ |
+
| 43 | ++ |
+ # This is to prevent another module being labeled "Report previewer".+ |
+
| 44 | +2x | +
+ class(module) <- c("teal_module_previewer", class(module))
+ |
+
| 45 | +2x | +
+ module$label <- label+ |
+
| 46 | +2x | +
+ module+ |
+
| 47 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Filter settings for `teal` applications+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Specify initial filter states and filtering settings for a `teal` app.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Produces a `teal_slices` object.+ |
+
| 6 | ++ |
+ #' The `teal_slice` components will specify filter states that will be active when the app starts.+ |
+
| 7 | ++ |
+ #' Attributes (created with the named arguments) will configure the way the app applies filters.+ |
+
| 8 | ++ |
+ #' See argument descriptions for details.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @inheritParams teal.slice::teal_slices+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @param module_specific optional (`logical(1)`)+ |
+
| 13 | ++ |
+ #' - `FALSE` (default) when one filter panel applied to all modules.+ |
+
| 14 | ++ |
+ #' All filters will be shared by all modules.+ |
+
| 15 | ++ |
+ #' - `TRUE` when filter panel module-specific.+ |
+
| 16 | ++ |
+ #' Modules can have different set of filters specified - see `mapping` argument.+ |
+
| 17 | ++ |
+ #' @param mapping `r lifecycle::badge("experimental")`
+ |
+
| 18 | ++ |
+ #' _This is a new feature. Do kindly share your opinions on+ |
+
| 19 | ++ |
+ #' [`teal`'s GitHub repository](https://github.com/insightsengineering/teal/)._+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' (named `list`) specifies which filters will be active in which modules on app start.+ |
+
| 22 | ++ |
+ #' Elements should contain character vector of `teal_slice` `id`s (see [`teal.slice::teal_slice`]).+ |
+
| 23 | ++ |
+ #' Names of the list should correspond to `teal_module` `label` set in [module()] function.+ |
+
| 24 | ++ |
+ #' - `id`s listed under `"global_filters` will be active in all modules.+ |
+
| 25 | ++ |
+ #' - If missing, all filters will be applied to all modules.+ |
+
| 26 | ++ |
+ #' - If empty list, all filters will be available to all modules but will start inactive.+ |
+
| 27 | ++ |
+ #' - If `module_specific` is `FALSE`, only `global_filters` will be active on start.+ |
+
| 28 | ++ |
+ #' @param app_id (`character(1)`)+ |
+
| 29 | ++ |
+ #' For internal use only, do not set manually.+ |
+
| 30 | ++ |
+ #' Added by `init` so that a `teal_slices` can be matched to the app in which it was used.+ |
+
| 31 | ++ |
+ #' Used for verifying snapshots uploaded from file. See `snapshot`.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @param x (`list`) of lists to convert to `teal_slices`+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @return+ |
+
| 36 | ++ |
+ #' A `teal_slices` object.+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @seealso [`teal.slice::teal_slices`], [`teal.slice::teal_slice`], [slices_store()]+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @examples+ |
+
| 41 | ++ |
+ #' filter <- teal_slices(+ |
+
| 42 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", id = "species"),+ |
+
| 43 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),+ |
+
| 44 | ++ |
+ #' teal_slice(+ |
+
| 45 | ++ |
+ #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"+ |
+
| 46 | ++ |
+ #' ),+ |
+
| 47 | ++ |
+ #' teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),+ |
+
| 48 | ++ |
+ #' mapping = list(+ |
+
| 49 | ++ |
+ #' module1 = c("species", "sepal_length"),
+ |
+
| 50 | ++ |
+ #' module2 = c("mtcars_mpg"),
+ |
+
| 51 | ++ |
+ #' global_filters = "long_petals"+ |
+
| 52 | ++ |
+ #' )+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' app <- init(+ |
+
| 56 | ++ |
+ #' data = teal_data(iris = iris, mtcars = mtcars),+ |
+
| 57 | ++ |
+ #' modules = list(+ |
+
| 58 | ++ |
+ #' module("module1"),
+ |
+
| 59 | ++ |
+ #' module("module2")
+ |
+
| 60 | ++ |
+ #' ),+ |
+
| 61 | ++ |
+ #' filter = filter+ |
+
| 62 | ++ |
+ #' )+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' if (interactive()) {
+ |
+
| 65 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 66 | ++ |
+ #' }+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' @export+ |
+
| 69 | ++ |
+ teal_slices <- function(...,+ |
+
| 70 | ++ |
+ exclude_varnames = NULL,+ |
+
| 71 | ++ |
+ include_varnames = NULL,+ |
+
| 72 | ++ |
+ count_type = NULL,+ |
+
| 73 | ++ |
+ allow_add = TRUE,+ |
+
| 74 | ++ |
+ module_specific = FALSE,+ |
+
| 75 | ++ |
+ mapping,+ |
+
| 76 | ++ |
+ app_id = NULL) {
+ |
+
| 77 | +78x | +
+ shiny::isolate({
+ |
+
| 78 | +78x | +
+ checkmate::assert_flag(allow_add)+ |
+
| 79 | +78x | +
+ checkmate::assert_flag(module_specific)+ |
+
| 80 | +32x | +
+ if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
+ |
+
| 81 | +75x | +
+ checkmate::assert_string(app_id, null.ok = TRUE)+ |
+
| 82 | ++ | + + | +
| 83 | +75x | +
+ slices <- list(...)+ |
+
| 84 | +75x | +
+ all_slice_id <- vapply(slices, `[[`, character(1L), "id")+ |
+
| 85 | ++ | + + | +
| 86 | +75x | +
+ if (missing(mapping)) {
+ |
+
| 87 | +46x | +
+ mapping <- list(global_filters = all_slice_id)+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | +75x | +
+ if (!module_specific) {
+ |
+
| 90 | +71x | +
+ mapping[setdiff(names(mapping), "global_filters")] <- NULL+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ | + + | +
| 93 | +75x | +
+ failed_slice_id <- setdiff(unlist(mapping), all_slice_id)+ |
+
| 94 | +75x | +
+ if (length(failed_slice_id)) {
+ |
+
| 95 | +1x | +
+ stop(sprintf(+ |
+
| 96 | +1x | +
+ "Filters in mapping don't match any available filter.\n %s not in %s",+ |
+
| 97 | +1x | +
+ toString(failed_slice_id),+ |
+
| 98 | +1x | +
+ toString(all_slice_id)+ |
+
| 99 | ++ |
+ ))+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ | + + | +
| 102 | +74x | +
+ tss <- teal.slice::teal_slices(+ |
+
| 103 | ++ |
+ ...,+ |
+
| 104 | +74x | +
+ exclude_varnames = exclude_varnames,+ |
+
| 105 | +74x | +
+ include_varnames = include_varnames,+ |
+
| 106 | +74x | +
+ count_type = count_type,+ |
+
| 107 | +74x | +
+ allow_add = allow_add+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | +74x | +
+ attr(tss, "mapping") <- mapping+ |
+
| 110 | +74x | +
+ attr(tss, "module_specific") <- module_specific+ |
+
| 111 | +74x | +
+ attr(tss, "app_id") <- app_id+ |
+
| 112 | +74x | +
+ class(tss) <- c("modules_teal_slices", class(tss))
+ |
+
| 113 | +74x | +
+ tss+ |
+
| 114 | ++ |
+ })+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | ++ | + + | +
| 118 | ++ |
+ #' @rdname teal_slices+ |
+
| 119 | ++ |
+ #' @export+ |
+
| 120 | ++ |
+ #' @keywords internal+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ as.teal_slices <- function(x) { # nolint
+ |
+
| 123 | +10x | +
+ checkmate::assert_list(x)+ |
+
| 124 | +10x | +
+ lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")+ |
+
| 125 | ++ | + + | +
| 126 | +10x | +
+ attrs <- attributes(unclass(x))+ |
+
| 127 | +10x | +
+ ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))+ |
+
| 128 | +10x | +
+ do.call(teal_slices, c(ans, attrs))+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ | + + | +
| 132 | ++ |
+ #' @rdname teal_slices+ |
+
| 133 | ++ |
+ #' @export+ |
+
| 134 | ++ |
+ #' @keywords internal+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ c.teal_slices <- function(...) {
+ |
+
| 137 | +! | +
+ x <- list(...)+ |
+
| 138 | +! | +
+ checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ |
+
| 139 | ++ | + + | +
| 140 | +! | +
+ all_attributes <- lapply(x, attributes)+ |
+
| 141 | +! | +
+ all_attributes <- coalesce_r(all_attributes)+ |
+
| 142 | +! | +
+ all_attributes <- all_attributes[names(all_attributes) != "class"]+ |
+
| 143 | ++ | + + | +
| 144 | +! | +
+ do.call(+ |
+
| 145 | +! | +
+ teal_slices,+ |
+
| 146 | +! | +
+ c(+ |
+
| 147 | +! | +
+ unique(unlist(x, recursive = FALSE)),+ |
+
| 148 | +! | +
+ all_attributes+ |
+
| 149 | ++ |
+ )+ |
+
| 150 | ++ |
+ )+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ | + + | +
| 153 | ++ | + + | +
| 154 | ++ |
+ #' Deep copy `teal_slices`+ |
+
| 155 | ++ |
+ #'+ |
+
| 156 | ++ |
+ #' it's important to create a new copy of `teal_slices` when+ |
+
| 157 | ++ |
+ #' starting a new `shiny` session. Otherwise, object will be shared+ |
+
| 158 | ++ |
+ #' by multiple users as it is created in global environment before+ |
+
| 159 | ++ |
+ #' `shiny` session starts.+ |
+
| 160 | ++ |
+ #' @param filter (`teal_slices`)+ |
+
| 161 | ++ |
+ #' @return `teal_slices`+ |
+
| 162 | ++ |
+ #' @keywords internal+ |
+
| 163 | ++ |
+ deep_copy_filter <- function(filter) {
+ |
+
| 164 | +1x | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+
| 165 | +1x | +
+ shiny::isolate({
+ |
+
| 166 | +1x | +
+ filter_copy <- lapply(filter, function(slice) {
+ |
+
| 167 | +2x | +
+ teal.slice::as.teal_slice(as.list(slice))+ |
+
| 168 | ++ |
+ })+ |
+
| 169 | +1x | +
+ attributes(filter_copy) <- attributes(filter)+ |
+
| 170 | +1x | +
+ filter_copy+ |
+
| 171 | ++ |
+ })+ |
+
| 172 | ++ |
+ }+ |
+
| 1 | ++ |
+ # This is the main function from teal to be used by the end-users. Although it delegates+ |
+
| 2 | ++ |
+ # directly to `module_teal_with_splash.R`, we keep it in a separate file because its documentation is quite large+ |
+
| 3 | ++ |
+ # and it is very end-user oriented. It may also perform more argument checking with more informative+ |
+
| 4 | ++ |
+ # error messages.+ |
+
| 5 | ++ | + + | +
| 6 | ++ |
+ #' Create the server and UI function for the `shiny` app+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' End-users: This is the most important function for you to start a+ |
+
| 11 | ++ |
+ #' `teal` app that is composed of `teal` modules.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @details+ |
+
| 14 | ++ |
+ #' When initializing the `teal` app, if `datanames` are not set for the `teal_data` object,+ |
+
| 15 | ++ |
+ #' defaults from the `teal_data` environment will be used.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @param data (`teal_data` or `teal_data_module`)+ |
+
| 18 | ++ |
+ #' For constructing the data object, refer to [teal_data()] and [teal_data_module()].+ |
+
| 19 | ++ |
+ #' @param modules (`list` or `teal_modules` or `teal_module`)+ |
+
| 20 | ++ |
+ #' nested list of `teal_modules` or `teal_module` objects or a single+ |
+
| 21 | ++ |
+ #' `teal_modules` or `teal_module` object. These are the specific output modules which+ |
+
| 22 | ++ |
+ #' will be displayed in the `teal` application. See [modules()] and [module()] for+ |
+
| 23 | ++ |
+ #' more details.+ |
+
| 24 | ++ |
+ #' @param filter (`teal_slices`)+ |
+
| 25 | ++ |
+ #' Specifies the initial filter using [teal_slices()].+ |
+
| 26 | ++ |
+ #' @param title (`shiny.tag` or `character(1)`)+ |
+
| 27 | ++ |
+ #' The browser window title. Defaults to a title "teal app" with the icon of NEST.+ |
+
| 28 | ++ |
+ #' Can be created using the `build_app_title()` or+ |
+
| 29 | ++ |
+ #' by passing a valid `shiny.tag` which is a head tag with title and link tag.+ |
+
| 30 | ++ |
+ #' @param header (`shiny.tag` or `character(1)`)+ |
+
| 31 | ++ |
+ #' The header of the app.+ |
+
| 32 | ++ |
+ #' @param footer (`shiny.tag` or `character(1)`)+ |
+
| 33 | ++ |
+ #' The footer of the app.+ |
+
| 34 | ++ |
+ #' @param id (`character`)+ |
+
| 35 | ++ |
+ #' Optional string specifying the `shiny` module id in cases it is used as a `shiny` module+ |
+
| 36 | ++ |
+ #' rather than a standalone `shiny` app. This is a legacy feature.+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @return Named list with server and UI functions.+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @export+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @include modules.R+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @examples+ |
+
| 45 | ++ |
+ #' app <- init(+ |
+
| 46 | ++ |
+ #' data = teal_data(+ |
+
| 47 | ++ |
+ #' new_iris = transform(iris, id = seq_len(nrow(iris))),+ |
+
| 48 | ++ |
+ #' new_mtcars = transform(mtcars, id = seq_len(nrow(mtcars))),+ |
+
| 49 | ++ |
+ #' code = "+ |
+
| 50 | ++ |
+ #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ |
+
| 51 | ++ |
+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ |
+
| 52 | ++ |
+ #' "+ |
+
| 53 | ++ |
+ #' ),+ |
+
| 54 | ++ |
+ #' modules = modules(+ |
+
| 55 | ++ |
+ #' module(+ |
+
| 56 | ++ |
+ #' label = "data source",+ |
+
| 57 | ++ |
+ #' server = function(input, output, session, data) {},
+ |
+
| 58 | ++ |
+ #' ui = function(id, ...) div(p("information about data source")),
+ |
+
| 59 | ++ |
+ #' datanames = "all"+ |
+
| 60 | ++ |
+ #' ),+ |
+
| 61 | ++ |
+ #' example_module(label = "example teal module"),+ |
+
| 62 | ++ |
+ #' module(+ |
+
| 63 | ++ |
+ #' "Iris Sepal.Length histogram",+ |
+
| 64 | ++ |
+ #' server = function(input, output, session, data) {
+ |
+
| 65 | ++ |
+ #' output$hist <- renderPlot(+ |
+
| 66 | ++ |
+ #' hist(data()[["new_iris"]]$Sepal.Length)+ |
+
| 67 | ++ |
+ #' )+ |
+
| 68 | ++ |
+ #' },+ |
+
| 69 | ++ |
+ #' ui = function(id, ...) {
+ |
+
| 70 | ++ |
+ #' ns <- NS(id)+ |
+
| 71 | ++ |
+ #' plotOutput(ns("hist"))
+ |
+
| 72 | ++ |
+ #' },+ |
+
| 73 | ++ |
+ #' datanames = "new_iris"+ |
+
| 74 | ++ |
+ #' )+ |
+
| 75 | ++ |
+ #' ),+ |
+
| 76 | ++ |
+ #' filter = teal_slices(+ |
+
| 77 | ++ |
+ #' teal_slice(dataname = "new_iris", varname = "Species"),+ |
+
| 78 | ++ |
+ #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),+ |
+
| 79 | ++ |
+ #' teal_slice(dataname = "new_mtcars", varname = "cyl"),+ |
+
| 80 | ++ |
+ #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
+ |
+
| 81 | ++ |
+ #' mapping = list(+ |
+
| 82 | ++ |
+ #' `example teal module` = "new_iris Species",+ |
+
| 83 | ++ |
+ #' `Iris Sepal.Length histogram` = "new_iris Species",+ |
+
| 84 | ++ |
+ #' global_filters = "new_mtcars cyl"+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ #' ),+ |
+
| 87 | ++ |
+ #' title = "App title",+ |
+
| 88 | ++ |
+ #' header = tags$h1("Sample App"),
+ |
+
| 89 | ++ |
+ #' footer = tags$p("Copyright 2017 - 2023")
+ |
+
| 90 | ++ |
+ #' )+ |
+
| 91 | ++ |
+ #' if (interactive()) {
+ |
+
| 92 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 93 | ++ |
+ #' }+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ init <- function(data,+ |
+
| 96 | ++ |
+ modules,+ |
+
| 97 | ++ |
+ filter = teal_slices(),+ |
+
| 98 | ++ |
+ title = build_app_title(),+ |
+
| 99 | ++ |
+ header = tags$p(),+ |
+
| 100 | ++ |
+ footer = tags$p(),+ |
+
| 101 | ++ |
+ id = character(0)) {
+ |
+
| 102 | +10x | +
+ logger::log_trace("init initializing teal app with: data ('{ class(data) }').")
+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ # argument checking (independent)+ |
+
| 105 | ++ |
+ ## `data`+ |
+
| 106 | +10x | +
+ if (inherits(data, "TealData")) {
+ |
+
| 107 | +! | +
+ lifecycle::deprecate_stop(+ |
+
| 108 | +! | +
+ when = "0.15.0",+ |
+
| 109 | +! | +
+ what = "init(data)",+ |
+
| 110 | +! | +
+ paste(+ |
+
| 111 | +! | +
+ "TealData is no longer supported. Use teal_data() instead.",+ |
+
| 112 | +! | +
+ "Please follow migration instructions https://github.com/insightsengineering/teal/discussions/988."+ |
+
| 113 | ++ |
+ )+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | +10x | +
+ checkmate::assert_multi_class(data, c("teal_data", "teal_data_module"))
+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ ## `modules`+ |
+
| 119 | +10x | +
+ checkmate::assert(+ |
+
| 120 | +10x | +
+ .var.name = "modules",+ |
+
| 121 | +10x | +
+ checkmate::check_multi_class(modules, c("teal_modules", "teal_module")),
+ |
+
| 122 | +10x | +
+ checkmate::check_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+ |
+
| 123 | ++ |
+ )+ |
+
| 124 | +10x | +
+ if (inherits(modules, "teal_module")) {
+ |
+
| 125 | +1x | +
+ modules <- list(modules)+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | +10x | +
+ if (checkmate::test_list(modules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))) {
+ |
+
| 128 | +4x | +
+ modules <- do.call(teal::modules, modules)+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ ## `filter`+ |
+
| 132 | +10x | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ ## all other arguments+ |
+
| 135 | +9x | +
+ checkmate::assert(+ |
+
| 136 | +9x | +
+ .var.name = "title",+ |
+
| 137 | +9x | +
+ checkmate::check_string(title),+ |
+
| 138 | +9x | +
+ checkmate::check_multi_class(title, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 139 | ++ |
+ )+ |
+
| 140 | +9x | +
+ checkmate::assert(+ |
+
| 141 | +9x | +
+ .var.name = "header",+ |
+
| 142 | +9x | +
+ checkmate::check_string(header),+ |
+
| 143 | +9x | +
+ checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 144 | ++ |
+ )+ |
+
| 145 | +9x | +
+ checkmate::assert(+ |
+
| 146 | +9x | +
+ .var.name = "footer",+ |
+
| 147 | +9x | +
+ checkmate::check_string(footer),+ |
+
| 148 | +9x | +
+ checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 149 | ++ |
+ )+ |
+
| 150 | +9x | +
+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ |
+
| 151 | ++ | + + | +
| 152 | ++ |
+ # log+ |
+
| 153 | +9x | +
+ teal.logger::log_system_info()+ |
+
| 154 | ++ | + + | +
| 155 | ++ |
+ # argument transformations+ |
+
| 156 | ++ |
+ ## `modules` - landing module+ |
+
| 157 | +9x | +
+ landing <- extract_module(modules, "teal_module_landing")+ |
+
| 158 | +9x | +
+ landing_module <- NULL+ |
+
| 159 | +9x | +
+ if (length(landing) == 1L) {
+ |
+
| 160 | +! | +
+ landing_module <- landing[[1L]]+ |
+
| 161 | +! | +
+ modules <- drop_module(modules, "teal_module_landing")+ |
+
| 162 | +9x | +
+ } else if (length(landing) > 1L) {
+ |
+
| 163 | +! | +
+ stop("Only one `landing_popup_module` can be used.")
+ |
+
| 164 | ++ |
+ }+ |
+
| 165 | ++ | + + | +
| 166 | ++ |
+ ## `filter` - app_id attribute+ |
+
| 167 | +9x | +
+ attr(filter, "app_id") <- create_app_id(data, modules)+ |
+
| 168 | ++ | + + | +
| 169 | ++ |
+ ## `filter` - convert teal.slice::teal_slices to teal::teal_slices+ |
+
| 170 | +9x | +
+ filter <- as.teal_slices(as.list(filter))+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ # argument checking (interdependent)+ |
+
| 173 | ++ |
+ ## `filter` - `modules`+ |
+
| 174 | +9x | +
+ if (isTRUE(attr(filter, "module_specific"))) {
+ |
+
| 175 | +! | +
+ module_names <- unlist(c(module_labels(modules), "global_filters"))+ |
+
| 176 | +! | +
+ failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)+ |
+
| 177 | +! | +
+ if (length(failed_mod_names)) {
+ |
+
| 178 | +! | +
+ stop(+ |
+
| 179 | +! | +
+ sprintf(+ |
+
| 180 | +! | +
+ "Some module names in the mapping arguments don't match module labels.\n %s not in %s",+ |
+
| 181 | +! | +
+ toString(failed_mod_names),+ |
+
| 182 | +! | +
+ toString(unique(module_names))+ |
+
| 183 | ++ |
+ )+ |
+
| 184 | ++ |
+ )+ |
+
| 185 | ++ |
+ }+ |
+
| 186 | ++ | + + | +
| 187 | +! | +
+ if (anyDuplicated(module_names)) {
+ |
+
| 188 | ++ |
+ # In teal we are able to set nested modules with duplicated label.+ |
+
| 189 | ++ |
+ # Because mapping argument bases on the relationship between module-label and filter-id,+ |
+
| 190 | ++ |
+ # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)+ |
+
| 191 | +! | +
+ stop(+ |
+
| 192 | +! | +
+ sprintf(+ |
+
| 193 | +! | +
+ "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",+ |
+
| 194 | +! | +
+ toString(module_names[duplicated(module_names)])+ |
+
| 195 | ++ |
+ )+ |
+
| 196 | ++ |
+ )+ |
+
| 197 | ++ |
+ }+ |
+
| 198 | ++ |
+ }+ |
+
| 199 | ++ | + + | +
| 200 | ++ |
+ ## `data` - `modules`+ |
+
| 201 | +9x | +
+ if (inherits(data, "teal_data")) {
+ |
+
| 202 | +8x | +
+ if (length(teal_data_datanames(data)) == 0) {
+ |
+
| 203 | +1x | +
+ stop("The environment of `data` is empty.")
+ |
+
| 204 | ++ |
+ }+ |
+
| 205 | ++ |
+ # in case of teal_data_module this check is postponed to the srv_teal_with_splash+ |
+
| 206 | +7x | +
+ is_modules_ok <- check_modules_datanames(modules, teal_data_datanames(data))+ |
+
| 207 | +7x | +
+ if (!isTRUE(is_modules_ok)) {
+ |
+
| 208 | +1x | +
+ logger::log_error(is_modules_ok)+ |
+
| 209 | +1x | +
+ checkmate::assert(is_modules_ok, .var.name = "modules")+ |
+
| 210 | ++ |
+ }+ |
+
| 211 | ++ | + + | +
| 212 | +6x | +
+ is_filter_ok <- check_filter_datanames(filter, teal_data_datanames(data))+ |
+
| 213 | +6x | +
+ if (!isTRUE(is_filter_ok)) {
+ |
+
| 214 | +1x | +
+ warning(is_filter_ok)+ |
+
| 215 | ++ |
+ # we allow app to continue if applied filters are outside+ |
+
| 216 | ++ |
+ # of possible data range+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ # Note regarding case `id = character(0)`:+ |
+
| 221 | ++ |
+ # rather than creating a submodule of this module, we directly modify+ |
+
| 222 | ++ |
+ # the UI and server with `id = character(0)` and calling the server function directly+ |
+
| 223 | +7x | +
+ res <- list(+ |
+
| 224 | +7x | +
+ ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),+ |
+
| 225 | +7x | +
+ server = function(input, output, session) {
+ |
+
| 226 | +! | +
+ if (!is.null(landing_module)) {
+ |
+
| 227 | +! | +
+ do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args))+ |
+
| 228 | ++ |
+ }+ |
+
| 229 | +! | +
+ srv_teal_with_splash(id = id, data = data, modules = modules, filter = deep_copy_filter(filter))+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ |
+ )+ |
+
| 232 | ++ | + + | +
| 233 | +7x | +
+ logger::log_trace("init teal app has been initialized.")
+ |
+
| 234 | ++ | + + | +
| 235 | +7x | +
+ res+ |
+
| 236 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Send input validation messages to output+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Captures messages from `InputValidator` objects and collates them+ |
+
| 4 | ++ |
+ #' into one message passed to `validate`.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' `shiny::validate` is used to withhold rendering of an output element until+ |
+
| 7 | ++ |
+ #' certain conditions are met and to print a validation message in place+ |
+
| 8 | ++ |
+ #' of the output element.+ |
+
| 9 | ++ |
+ #' `shinyvalidate::InputValidator` allows to validate input elements+ |
+
| 10 | ++ |
+ #' and to display specific messages in their respective input widgets.+ |
+
| 11 | ++ |
+ #' `validate_inputs` provides a hybrid solution.+ |
+
| 12 | ++ |
+ #' Given an `InputValidator` object, messages corresponding to inputs that fail validation+ |
+
| 13 | ++ |
+ #' are extracted and placed in one validation message that is passed to a `validate`/`need` call.+ |
+
| 14 | ++ |
+ #' This way the input `validator` messages are repeated in the output.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' The `...` argument accepts any number of `InputValidator` objects+ |
+
| 17 | ++ |
+ #' or a nested list of such objects.+ |
+
| 18 | ++ |
+ #' If `validators` are passed directly, all their messages are printed together+ |
+
| 19 | ++ |
+ #' under one (optional) header message specified by `header`. If a list is passed,+ |
+
| 20 | ++ |
+ #' messages are grouped by `validator`. The list's names are used as headers+ |
+
| 21 | ++ |
+ #' for their respective message groups.+ |
+
| 22 | ++ |
+ #' If neither of the nested list elements is named, a header message is taken from `header`.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @param ... either any number of `InputValidator` objects+ |
+
| 25 | ++ |
+ #' or an optionally named, possibly nested `list` of `InputValidator`+ |
+
| 26 | ++ |
+ #' objects, see `Details`+ |
+
| 27 | ++ |
+ #' @param header (`character(1)`) generic validation message; set to NULL to omit+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @return+ |
+
| 30 | ++ |
+ #' Returns NULL if the final validation call passes and a `shiny.silent.error` if it fails.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @seealso [`shinyvalidate::InputValidator`], [`shiny::validate`]+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @examples+ |
+
| 35 | ++ |
+ #' library(shiny)+ |
+
| 36 | ++ |
+ #' library(shinyvalidate)+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' ui <- fluidPage(+ |
+
| 39 | ++ |
+ #' selectInput("method", "validation method", c("sequential", "combined", "grouped")),
+ |
+
| 40 | ++ |
+ #' sidebarLayout(+ |
+
| 41 | ++ |
+ #' sidebarPanel(+ |
+
| 42 | ++ |
+ #' selectInput("letter", "select a letter:", c(letters[1:3], LETTERS[4:6])),
+ |
+
| 43 | ++ |
+ #' selectInput("number", "select a number:", 1:6),
+ |
+
| 44 | ++ |
+ #' br(),+ |
+
| 45 | ++ |
+ #' selectInput("color", "select a color:",
+ |
+
| 46 | ++ |
+ #' c("black", "indianred2", "springgreen2", "cornflowerblue"),
+ |
+
| 47 | ++ |
+ #' multiple = TRUE+ |
+
| 48 | ++ |
+ #' ),+ |
+
| 49 | ++ |
+ #' sliderInput("size", "select point size:",
+ |
+
| 50 | ++ |
+ #' min = 0.1, max = 4, value = 0.25+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #' ),+ |
+
| 53 | ++ |
+ #' mainPanel(plotOutput("plot"))
+ |
+
| 54 | ++ |
+ #' )+ |
+
| 55 | ++ |
+ #' )+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 58 | ++ |
+ #' # set up input validation+ |
+
| 59 | ++ |
+ #' iv <- InputValidator$new()+ |
+
| 60 | ++ |
+ #' iv$add_rule("letter", sv_in_set(LETTERS, "choose a capital letter"))
+ |
+
| 61 | ++ |
+ #' iv$add_rule("number", ~ if (as.integer(.) %% 2L == 1L) "choose an even number")
+ |
+
| 62 | ++ |
+ #' iv$enable()+ |
+
| 63 | ++ |
+ #' # more input validation+ |
+
| 64 | ++ |
+ #' iv_par <- InputValidator$new()+ |
+
| 65 | ++ |
+ #' iv_par$add_rule("color", sv_required(message = "choose a color"))
+ |
+
| 66 | ++ |
+ #' iv_par$add_rule("color", ~ if (length(.) > 1L) "choose only one color")
+ |
+
| 67 | ++ |
+ #' iv_par$add_rule(+ |
+
| 68 | ++ |
+ #' "size",+ |
+
| 69 | ++ |
+ #' sv_between(+ |
+
| 70 | ++ |
+ #' left = 0.5, right = 3,+ |
+
| 71 | ++ |
+ #' message_fmt = "choose a value between {left} and {right}"
+ |
+
| 72 | ++ |
+ #' )+ |
+
| 73 | ++ |
+ #' )+ |
+
| 74 | ++ |
+ #' iv_par$enable()+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' output$plot <- renderPlot({
+ |
+
| 77 | ++ |
+ #' # validate output+ |
+
| 78 | ++ |
+ #' switch(input[["method"]],+ |
+
| 79 | ++ |
+ #' "sequential" = {
+ |
+
| 80 | ++ |
+ #' validate_inputs(iv)+ |
+
| 81 | ++ |
+ #' validate_inputs(iv_par, header = "Set proper graphical parameters")+ |
+
| 82 | ++ |
+ #' },+ |
+
| 83 | ++ |
+ #' "combined" = validate_inputs(iv, iv_par),+ |
+
| 84 | ++ |
+ #' "grouped" = validate_inputs(list(+ |
+
| 85 | ++ |
+ #' "Some inputs require attention" = iv,+ |
+
| 86 | ++ |
+ #' "Set proper graphical parameters" = iv_par+ |
+
| 87 | ++ |
+ #' ))+ |
+
| 88 | ++ |
+ #' )+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' plot(eruptions ~ waiting, faithful,+ |
+
| 91 | ++ |
+ #' las = 1, pch = 16,+ |
+
| 92 | ++ |
+ #' col = input[["color"]], cex = input[["size"]]+ |
+
| 93 | ++ |
+ #' )+ |
+
| 94 | ++ |
+ #' })+ |
+
| 95 | ++ |
+ #' }+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' if (interactive()) {
+ |
+
| 98 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 99 | ++ |
+ #' }+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' @export+ |
+
| 102 | ++ |
+ #'+ |
+
| 103 | ++ |
+ validate_inputs <- function(..., header = "Some inputs require attention") {
+ |
+
| 104 | +36x | +
+ dots <- list(...)+ |
+
| 105 | +2x | +
+ if (!is_validators(dots)) stop("validate_inputs accepts validators or a list thereof")
+ |
+
| 106 | ++ | + + | +
| 107 | +34x | +
+ messages <- extract_validator(dots, header)+ |
+
| 108 | +34x | +
+ failings <- if (!any_names(dots)) {
+ |
+
| 109 | +29x | +
+ add_header(messages, header)+ |
+
| 110 | ++ |
+ } else {
+ |
+
| 111 | +5x | +
+ unlist(messages)+ |
+
| 112 | ++ |
+ }+ |
+
| 113 | ++ | + + | +
| 114 | +34x | +
+ shiny::validate(shiny::need(is.null(failings), failings))+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ ### internal functions+ |
+
| 118 | ++ | + + | +
| 119 | ++ |
+ #' @noRd+ |
+
| 120 | ++ |
+ #' @keywords internal+ |
+
| 121 | ++ |
+ # recursive object type test+ |
+
| 122 | ++ |
+ # returns logical of length 1+ |
+
| 123 | ++ |
+ is_validators <- function(x) {
+ |
+
| 124 | +118x | +
+ all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))+ |
+
| 125 | ++ |
+ }+ |
+
| 126 | ++ | + + | +
| 127 | ++ |
+ #' @noRd+ |
+
| 128 | ++ |
+ #' @keywords internal+ |
+
| 129 | ++ |
+ # test if an InputValidator object is enabled+ |
+
| 130 | ++ |
+ # returns logical of length 1+ |
+
| 131 | ++ |
+ # official method requested at https://github.com/rstudio/shinyvalidate/issues/64+ |
+
| 132 | ++ |
+ validator_enabled <- function(x) {
+ |
+
| 133 | +49x | +
+ x$.__enclos_env__$private$enabled+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | ++ | + + | +
| 136 | ++ |
+ #' Recursively extract messages from validator list+ |
+
| 137 | ++ |
+ #' @return A character vector or a list of character vectors, possibly nested and named.+ |
+
| 138 | ++ |
+ #' @noRd+ |
+
| 139 | ++ |
+ #' @keywords internal+ |
+
| 140 | ++ |
+ extract_validator <- function(iv, header) {
+ |
+
| 141 | +113x | +
+ if (inherits(iv, "InputValidator")) {
+ |
+
| 142 | +49x | +
+ add_header(gather_messages(iv), header)+ |
+
| 143 | ++ |
+ } else {
+ |
+
| 144 | +58x | +
+ if (is.null(names(iv))) names(iv) <- rep("", length(iv))
+ |
+
| 145 | +64x | +
+ mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ |
+ }+ |
+
| 148 | ++ | + + | +
| 149 | ++ |
+ #' Collate failing messages from validator.+ |
+
| 150 | ++ |
+ #' @return `list`+ |
+
| 151 | ++ |
+ #' @noRd+ |
+
| 152 | ++ |
+ #' @keywords internal+ |
+
| 153 | ++ |
+ gather_messages <- function(iv) {
+ |
+
| 154 | +49x | +
+ if (validator_enabled(iv)) {
+ |
+
| 155 | +46x | +
+ status <- iv$validate()+ |
+
| 156 | +46x | +
+ failing_inputs <- Filter(Negate(is.null), status)+ |
+
| 157 | +46x | +
+ unique(lapply(failing_inputs, function(x) x[["message"]]))+ |
+
| 158 | ++ |
+ } else {
+ |
+
| 159 | +3x | +
+ warning("Validator is disabled and will be omitted.")
+ |
+
| 160 | +3x | +
+ list()+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ |
+ }+ |
+
| 163 | ++ | + + | +
| 164 | ++ |
+ #' Add optional header to failing messages+ |
+
| 165 | ++ |
+ #' @noRd+ |
+
| 166 | ++ |
+ #' @keywords internal+ |
+
| 167 | ++ |
+ add_header <- function(messages, header = "") {
+ |
+
| 168 | +78x | +
+ ans <- unlist(messages)+ |
+
| 169 | +78x | +
+ if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
+ |
+
| 170 | +31x | +
+ ans <- c(paste0(header, "\n"), ans, "\n")+ |
+
| 171 | ++ |
+ }+ |
+
| 172 | +78x | +
+ ans+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ | + + | +
| 175 | ++ |
+ #' Recursively check if the object contains a named list+ |
+
| 176 | ++ |
+ #' @noRd+ |
+
| 177 | ++ |
+ #' @keywords internal+ |
+
| 178 | ++ |
+ any_names <- function(x) {
+ |
+
| 179 | +103x | +
+ any(+ |
+
| 180 | +103x | +
+ if (is.list(x)) {
+ |
+
| 181 | +58x | +
+ if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))+ |
+
| 182 | ++ |
+ } else {
+ |
+
| 183 | +40x | +
+ FALSE+ |
+
| 184 | ++ |
+ }+ |
+
| 185 | ++ |
+ )+ |
+
| 186 | ++ |
+ }+ |
+
| 1 | ++ |
+ # This module is the main teal module that puts everything together.+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ #' `teal` main app module+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This is the main `teal` app that puts everything together.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' It displays the splash UI which is used to fetch the data, possibly+ |
+
| 8 | ++ |
+ #' prompting for a password input to fetch the data. Once the data is ready,+ |
+
| 9 | ++ |
+ #' the splash screen is replaced by the actual `teal` UI that is tabsetted and+ |
+
| 10 | ++ |
+ #' has a filter panel with `datanames` that are relevant for the current tab.+ |
+
| 11 | ++ |
+ #' Nested tabs are possible, but we limit it to two nesting levels for reasons+ |
+
| 12 | ++ |
+ #' of clarity of the UI.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' The splash screen functionality can also be used+ |
+
| 15 | ++ |
+ #' for non-delayed data which takes time to load into memory, avoiding+ |
+
| 16 | ++ |
+ #' `shiny` session timeouts.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' Server evaluates the `teal_data_rv` (delayed data mechanism) and creates the+ |
+
| 19 | ++ |
+ #' `datasets` object that is shared across modules.+ |
+
| 20 | ++ |
+ #' Once it is ready and non-`NULL`, the splash screen is replaced by the+ |
+
| 21 | ++ |
+ #' main `teal` UI that depends on the data.+ |
+
| 22 | ++ |
+ #' The currently active tab is tracked and the right filter panel+ |
+
| 23 | ++ |
+ #' updates the displayed datasets to filter for according to the active `datanames`+ |
+
| 24 | ++ |
+ #' of the tab.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' It is written as a `shiny` module so it can be added into other apps as well.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @name module_teal+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @inheritParams module_teal_with_splash+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @param splash_ui (`shiny.tag`) UI to display initially,+ |
+
| 33 | ++ |
+ #' can be a splash screen or a `shiny` module UI. For the latter, see+ |
+
| 34 | ++ |
+ #' [init()] about how to call the corresponding server function.+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @param teal_data_rv (`reactive`)+ |
+
| 37 | ++ |
+ #' returns the `teal_data`, only evaluated once, `NULL` value is ignored+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @return+ |
+
| 40 | ++ |
+ #' Returns a `reactive` expression which returns the currently active module.+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @keywords internal+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ NULL+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ #' @rdname module_teal+ |
+
| 47 | ++ |
+ ui_teal <- function(id,+ |
+
| 48 | ++ |
+ splash_ui = tags$h2("Starting the Teal App"),
+ |
+
| 49 | ++ |
+ title = build_app_title(),+ |
+
| 50 | ++ |
+ header = tags$p(),+ |
+
| 51 | ++ |
+ footer = tags$p()) {
+ |
+
| 52 | +7x | +
+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ |
+
| 53 | ++ | + + | +
| 54 | +7x | +
+ checkmate::assert_multi_class(splash_ui, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 55 | ++ | + + | +
| 56 | +7x | +
+ if (is.character(title)) {
+ |
+
| 57 | +! | +
+ title <- build_app_title(title)+ |
+
| 58 | ++ |
+ } else {
+ |
+
| 59 | +7x | +
+ validate_app_title_tag(title)+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ | + + | +
| 62 | +7x | +
+ checkmate::assert(+ |
+
| 63 | +7x | +
+ .var.name = "header",+ |
+
| 64 | +7x | +
+ checkmate::check_string(header),+ |
+
| 65 | +7x | +
+ checkmate::check_multi_class(header, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 66 | ++ |
+ )+ |
+
| 67 | +7x | +
+ if (checkmate::test_string(header)) {
+ |
+
| 68 | +! | +
+ header <- tags$p(header)+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ | + + | +
| 71 | +7x | +
+ checkmate::assert(+ |
+
| 72 | +7x | +
+ .var.name = "footer",+ |
+
| 73 | +7x | +
+ checkmate::check_string(footer),+ |
+
| 74 | +7x | +
+ checkmate::check_multi_class(footer, c("shiny.tag", "shiny.tag.list", "html"))
+ |
+
| 75 | ++ |
+ )+ |
+
| 76 | +7x | +
+ if (checkmate::test_string(footer)) {
+ |
+
| 77 | +! | +
+ footer <- tags$p(footer)+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | +7x | +
+ ns <- NS(id)+ |
+
| 81 | ++ | + + | +
| 82 | ++ |
+ # Once the data is loaded, we will remove this element and add the real teal UI instead+ |
+
| 83 | +7x | +
+ splash_ui <- div(+ |
+
| 84 | ++ |
+ # id so we can remove the splash screen once ready, which is the first child of this container+ |
+
| 85 | +7x | +
+ id = ns("main_ui_container"),
+ |
+
| 86 | ++ |
+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ |
+
| 87 | ++ |
+ # just the first item of the tagList)+ |
+
| 88 | +7x | +
+ div(splash_ui)+ |
+
| 89 | ++ |
+ )+ |
+
| 90 | ++ | + + | +
| 91 | ++ |
+ # show busy icon when `shiny` session is busy computing stuff+ |
+
| 92 | ++ |
+ # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 # nolint+ |
+
| 93 | +7x | +
+ shiny_busy_message_panel <- conditionalPanel(+ |
+
| 94 | +7x | +
+ condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
+ |
+
| 95 | +7x | +
+ div(+ |
+
| 96 | +7x | +
+ icon("arrows-rotate", "spin fa-spin"),
+ |
+
| 97 | +7x | +
+ "Computing ...",+ |
+
| 98 | ++ |
+ # CSS defined in `custom.css`+ |
+
| 99 | +7x | +
+ class = "shinybusymessage"+ |
+
| 100 | ++ |
+ )+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | ++ | + + | +
| 103 | +7x | +
+ fluidPage(+ |
+
| 104 | +7x | +
+ title = title,+ |
+
| 105 | +7x | +
+ theme = get_teal_bs_theme(),+ |
+
| 106 | +7x | +
+ include_teal_css_js(),+ |
+
| 107 | +7x | +
+ tags$header(header),+ |
+
| 108 | +7x | +
+ tags$hr(class = "my-2"),+ |
+
| 109 | +7x | +
+ shiny_busy_message_panel,+ |
+
| 110 | +7x | +
+ splash_ui,+ |
+
| 111 | +7x | +
+ tags$hr(),+ |
+
| 112 | +7x | +
+ tags$footer(+ |
+
| 113 | +7x | +
+ div(+ |
+
| 114 | +7x | +
+ footer,+ |
+
| 115 | +7x | +
+ teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
+ |
+
| 116 | +7x | +
+ textOutput(ns("identifier"))
+ |
+
| 117 | ++ |
+ )+ |
+
| 118 | ++ |
+ )+ |
+
| 119 | ++ |
+ )+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | ++ | + + | +
| 122 | ++ | + + | +
| 123 | ++ |
+ #' @rdname module_teal+ |
+
| 124 | ++ |
+ srv_teal <- function(id, modules, teal_data_rv, filter = teal_slices()) {
+ |
+
| 125 | +19x | +
+ stopifnot(is.reactive(teal_data_rv))+ |
+
| 126 | +18x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 127 | +18x | +
+ logger::log_trace("srv_teal initializing the module.")
+ |
+
| 128 | ++ | + + | +
| 129 | +18x | +
+ output$identifier <- renderText(+ |
+
| 130 | +18x | +
+ paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
+ |
+
| 131 | ++ |
+ )+ |
+
| 132 | ++ | + + | +
| 133 | +18x | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 134 | +18x | +
+ "sessionInfo",+ |
+
| 135 | +18x | +
+ verbatim_content = utils::capture.output(utils::sessionInfo()),+ |
+
| 136 | +18x | +
+ title = "SessionInfo"+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ | + + | +
| 139 | ++ |
+ # `JavaScript` code+ |
+
| 140 | +18x | +
+ run_js_files(files = "init.js")+ |
+
| 141 | ++ | + + | +
| 142 | ++ |
+ # set timezone in shiny app+ |
+
| 143 | ++ |
+ # timezone is set in the early beginning so it will be available also+ |
+
| 144 | ++ |
+ # for `DDL` and all shiny modules+ |
+
| 145 | +18x | +
+ get_client_timezone(session$ns)+ |
+
| 146 | +18x | +
+ observeEvent(+ |
+
| 147 | +18x | +
+ eventExpr = input$timezone,+ |
+
| 148 | +18x | +
+ once = TRUE,+ |
+
| 149 | +18x | +
+ handlerExpr = {
+ |
+
| 150 | +! | +
+ session$userData$timezone <- input$timezone+ |
+
| 151 | +! | +
+ logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ |
+ )+ |
+
| 154 | ++ | + + | +
| 155 | +18x | +
+ reporter <- teal.reporter::Reporter$new()+ |
+
| 156 | +18x | +
+ if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
+ |
+
| 157 | +! | +
+ modules <- append_module(modules, reporter_previewer_module())+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ | + + | +
| 160 | +18x | +
+ env <- environment()+ |
+
| 161 | +18x | +
+ datasets_reactive <- eventReactive(teal_data_rv(), {
+ |
+
| 162 | +4x | +
+ env$progress <- shiny::Progress$new(session)+ |
+
| 163 | +4x | +
+ env$progress$set(0.25, message = "Setting data")+ |
+
| 164 | ++ | + + | +
| 165 | ++ |
+ # create a list of data following structure of the nested modules list structure.+ |
+
| 166 | ++ |
+ # Because it's easier to unpack modules and datasets when they follow the same nested structure.+ |
+
| 167 | +4x | +
+ datasets_singleton <- teal_data_to_filtered_data(teal_data_rv())+ |
+
| 168 | ++ | + + | +
| 169 | ++ |
+ # Singleton starts with only global filters active.+ |
+
| 170 | +4x | +
+ filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)+ |
+
| 171 | +4x | +
+ datasets_singleton$set_filter_state(filter_global)+ |
+
| 172 | ++ | + + | +
| 173 | +4x | +
+ module_datasets <- function(modules) {
+ |
+
| 174 | +18x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 175 | +7x | +
+ datasets <- lapply(modules$children, module_datasets)+ |
+
| 176 | +7x | +
+ labels <- vapply(modules$children, `[[`, character(1), "label")+ |
+
| 177 | +7x | +
+ names(datasets) <- labels+ |
+
| 178 | +7x | +
+ datasets+ |
+
| 179 | +11x | +
+ } else if (isTRUE(attr(filter, "module_specific"))) {
+ |
+
| 180 | ++ |
+ # we should create FilteredData even if modules$datanames is null+ |
+
| 181 | ++ |
+ # null controls a display of filter panel but data should be still passed+ |
+
| 182 | +3x | +
+ datanames <- if (is.null(modules$datanames) || identical(modules$datanames, "all")) {
+ |
+
| 183 | +3x | +
+ include_parent_datanames(+ |
+
| 184 | +3x | +
+ teal_data_datanames(teal_data_rv()),+ |
+
| 185 | +3x | +
+ teal.data::join_keys(teal_data_rv())+ |
+
| 186 | ++ |
+ )+ |
+
| 187 | ++ |
+ } else {
+ |
+
| 188 | +! | +
+ modules$datanames+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | ++ |
+ # todo: subset teal_data to datanames+ |
+
| 191 | +3x | +
+ datasets_module <- teal_data_to_filtered_data(teal_data_rv(), datanames = datanames)+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ # set initial filters+ |
+
| 194 | ++ |
+ # - filtering filters for this module+ |
+
| 195 | +3x | +
+ slices <- Filter(x = filter, f = function(x) {
+ |
+
| 196 | +! | +
+ x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&+ |
+
| 197 | +! | +
+ x$dataname %in% datanames+ |
+
| 198 | ++ |
+ })+ |
+
| 199 | +3x | +
+ include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]+ |
+
| 200 | +3x | +
+ exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]+ |
+
| 201 | +3x | +
+ slices$include_varnames <- include_varnames+ |
+
| 202 | +3x | +
+ slices$exclude_varnames <- exclude_varnames+ |
+
| 203 | +3x | +
+ datasets_module$set_filter_state(slices)+ |
+
| 204 | +3x | +
+ datasets_module+ |
+
| 205 | ++ |
+ } else {
+ |
+
| 206 | +8x | +
+ datasets_singleton+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | +4x | +
+ module_datasets(modules)+ |
+
| 210 | ++ |
+ })+ |
+
| 211 | ++ | + + | +
| 212 | ++ |
+ # Replace splash / welcome screen once data is loaded ----+ |
+
| 213 | ++ |
+ # ignoreNULL to not trigger at the beginning when data is NULL+ |
+
| 214 | ++ |
+ # just handle it once because data obtained through delayed loading should+ |
+
| 215 | ++ |
+ # usually not change afterwards+ |
+
| 216 | ++ |
+ # if restored from bookmarked state, `filter` is ignored+ |
+
| 217 | ++ | + + | +
| 218 | +18x | +
+ observeEvent(datasets_reactive(), once = TRUE, {
+ |
+
| 219 | +! | +
+ logger::log_trace("srv_teal@5 setting main ui after data was pulled")
+ |
+
| 220 | +! | +
+ on.exit(env$progress$close())+ |
+
| 221 | +! | +
+ env$progress$set(0.5, message = "Setting up main UI")+ |
+
| 222 | +! | +
+ datasets <- datasets_reactive()+ |
+
| 223 | ++ | + + | +
| 224 | ++ |
+ # main_ui_container contains splash screen first and we remove it and replace it by the real UI+ |
+
| 225 | +! | +
+ removeUI(sprintf("#%s > div:nth-child(1)", session$ns("main_ui_container")))
+ |
+
| 226 | +! | +
+ insertUI(+ |
+
| 227 | +! | +
+ selector = paste0("#", session$ns("main_ui_container")),
+ |
+
| 228 | +! | +
+ where = "beforeEnd",+ |
+
| 229 | ++ |
+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ |
+
| 230 | ++ |
+ # just the first item of the tagList)+ |
+
| 231 | +! | +
+ ui = div(ui_tabs_with_filters(+ |
+
| 232 | +! | +
+ session$ns("main_ui"),
+ |
+
| 233 | +! | +
+ modules = modules,+ |
+
| 234 | +! | +
+ datasets = datasets,+ |
+
| 235 | +! | +
+ filter = filter+ |
+
| 236 | ++ |
+ )),+ |
+
| 237 | ++ |
+ # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not+ |
+
| 238 | ++ |
+ # have any effect as they are ignored when not present+ |
+
| 239 | +! | +
+ immediate = TRUE+ |
+
| 240 | ++ |
+ )+ |
+
| 241 | ++ | + + | +
| 242 | ++ |
+ # must make sure that this is only executed once as modules assume their observers are only+ |
+
| 243 | ++ |
+ # registered once (calling server functions twice would trigger observers twice each time)+ |
+
| 244 | +! | +
+ srv_tabs_with_filters(+ |
+
| 245 | +! | +
+ id = "main_ui",+ |
+
| 246 | +! | +
+ datasets = datasets,+ |
+
| 247 | +! | +
+ modules = modules,+ |
+
| 248 | +! | +
+ reporter = reporter,+ |
+
| 249 | +! | +
+ filter = filter+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ |
+ })+ |
+
| 252 | ++ |
+ })+ |
+
| 253 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Validate that dataset has a minimum number of observations+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This function is a wrapper for `shiny::validate`.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param x (`data.frame`)+ |
+
| 8 | ++ |
+ #' @param min_nrow (`numeric(1)`) Minimum allowed number of rows in `x`.+ |
+
| 9 | ++ |
+ #' @param complete (`logical(1)`) Flag specifying whether to check only complete cases. Defaults to `FALSE`.+ |
+
| 10 | ++ |
+ #' @param allow_inf (`logical(1)`) Flag specifying whether to allow infinite values. Defaults to `TRUE`.+ |
+
| 11 | ++ |
+ #' @param msg (`character(1)`) Additional message to display alongside the default message.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @export+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' library(teal)+ |
+
| 17 | ++ |
+ #' ui <- fluidPage(+ |
+
| 18 | ++ |
+ #' sliderInput("len", "Max Length of Sepal",
+ |
+
| 19 | ++ |
+ #' min = 4.3, max = 7.9, value = 5+ |
+
| 20 | ++ |
+ #' ),+ |
+
| 21 | ++ |
+ #' plotOutput("plot")
+ |
+
| 22 | ++ |
+ #' )+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 25 | ++ |
+ #' output$plot <- renderPlot({
+ |
+
| 26 | ++ |
+ #' iris_df <- iris[iris$Sepal.Length <= input$len, ]+ |
+
| 27 | ++ |
+ #' validate_has_data(+ |
+
| 28 | ++ |
+ #' iris_df,+ |
+
| 29 | ++ |
+ #' min_nrow = 10,+ |
+
| 30 | ++ |
+ #' complete = FALSE,+ |
+
| 31 | ++ |
+ #' msg = "Please adjust Max Length of Sepal"+ |
+
| 32 | ++ |
+ #' )+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' hist(iris_df$Sepal.Length, breaks = 5)+ |
+
| 35 | ++ |
+ #' })+ |
+
| 36 | ++ |
+ #' }+ |
+
| 37 | ++ |
+ #' if (interactive()) {
+ |
+
| 38 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 39 | ++ |
+ #' }+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ validate_has_data <- function(x,+ |
+
| 42 | ++ |
+ min_nrow = NULL,+ |
+
| 43 | ++ |
+ complete = FALSE,+ |
+
| 44 | ++ |
+ allow_inf = TRUE,+ |
+
| 45 | ++ |
+ msg = NULL) {
+ |
+
| 46 | +17x | +
+ checkmate::assert_string(msg, null.ok = TRUE)+ |
+
| 47 | +15x | +
+ checkmate::assert_data_frame(x)+ |
+
| 48 | +15x | +
+ if (!is.null(min_nrow)) {
+ |
+
| 49 | +15x | +
+ if (complete) {
+ |
+
| 50 | +5x | +
+ complete_index <- stats::complete.cases(x)+ |
+
| 51 | +5x | +
+ validate(need(+ |
+
| 52 | +5x | +
+ sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,+ |
+
| 53 | +5x | +
+ paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
+ |
+
| 54 | ++ |
+ ))+ |
+
| 55 | ++ |
+ } else {
+ |
+
| 56 | +10x | +
+ validate(need(+ |
+
| 57 | +10x | +
+ nrow(x) >= min_nrow,+ |
+
| 58 | +10x | +
+ paste(+ |
+
| 59 | +10x | +
+ c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
+ |
+
| 60 | +10x | +
+ collapse = "\n"+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | ++ |
+ ))+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | +10x | +
+ if (!allow_inf) {
+ |
+
| 66 | +6x | +
+ validate(need(+ |
+
| 67 | +6x | +
+ all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))),+ |
+
| 68 | +6x | +
+ "Dataframe contains Inf values which is not allowed."+ |
+
| 69 | ++ |
+ ))+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ | + + | +
| 74 | ++ |
+ #' Validate that dataset has unique rows for key variables+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' `r lifecycle::badge("stable")`
+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' This function is a wrapper for `shiny::validate`.+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' @param x (`data.frame`)+ |
+
| 81 | ++ |
+ #' @param key (`character`) Vector of ID variables from `x` that identify unique records.+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @export+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @examples+ |
+
| 86 | ++ |
+ #' iris$id <- rep(1:50, times = 3)+ |
+
| 87 | ++ |
+ #' ui <- fluidPage(+ |
+
| 88 | ++ |
+ #' selectInput(+ |
+
| 89 | ++ |
+ #' inputId = "species",+ |
+
| 90 | ++ |
+ #' label = "Select species",+ |
+
| 91 | ++ |
+ #' choices = c("setosa", "versicolor", "virginica"),
+ |
+
| 92 | ++ |
+ #' selected = "setosa",+ |
+
| 93 | ++ |
+ #' multiple = TRUE+ |
+
| 94 | ++ |
+ #' ),+ |
+
| 95 | ++ |
+ #' plotOutput("plot")
+ |
+
| 96 | ++ |
+ #' )+ |
+
| 97 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 98 | ++ |
+ #' output$plot <- renderPlot({
+ |
+
| 99 | ++ |
+ #' iris_f <- iris[iris$Species %in% input$species, ]+ |
+
| 100 | ++ |
+ #' validate_one_row_per_id(iris_f, key = c("id"))
+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' hist(iris_f$Sepal.Length, breaks = 5)+ |
+
| 103 | ++ |
+ #' })+ |
+
| 104 | ++ |
+ #' }+ |
+
| 105 | ++ |
+ #' if (interactive()) {
+ |
+
| 106 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 107 | ++ |
+ #' }+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
+ |
+
| 110 | +! | +
+ validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
+ |
+
| 111 | ++ |
+ }+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ #' Validates that vector includes all expected values+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' `r lifecycle::badge("stable")`
+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ #' This function is a wrapper for `shiny::validate`.+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @param x Vector of values to test.+ |
+
| 120 | ++ |
+ #' @param choices Vector to test against.+ |
+
| 121 | ++ |
+ #' @param msg (`character(1)`) Error message to display if some elements of `x` are not elements of `choices`.+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @export+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @examples+ |
+
| 126 | ++ |
+ #' ui <- fluidPage(+ |
+
| 127 | ++ |
+ #' selectInput(+ |
+
| 128 | ++ |
+ #' "species",+ |
+
| 129 | ++ |
+ #' "Select species",+ |
+
| 130 | ++ |
+ #' choices = c("setosa", "versicolor", "virginica", "unknown species"),
+ |
+
| 131 | ++ |
+ #' selected = "setosa",+ |
+
| 132 | ++ |
+ #' multiple = FALSE+ |
+
| 133 | ++ |
+ #' ),+ |
+
| 134 | ++ |
+ #' verbatimTextOutput("summary")
+ |
+
| 135 | ++ |
+ #' )+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 138 | ++ |
+ #' output$summary <- renderPrint({
+ |
+
| 139 | ++ |
+ #' validate_in(input$species, iris$Species, "Species does not exist.")+ |
+
| 140 | ++ |
+ #' nrow(iris[iris$Species == input$species, ])+ |
+
| 141 | ++ |
+ #' })+ |
+
| 142 | ++ |
+ #' }+ |
+
| 143 | ++ |
+ #' if (interactive()) {
+ |
+
| 144 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 145 | ++ |
+ #' }+ |
+
| 146 | ++ |
+ #'+ |
+
| 147 | ++ |
+ validate_in <- function(x, choices, msg) {
+ |
+
| 148 | +! | +
+ validate(need(length(x) > 0 && length(choices) > 0 && all(x %in% choices), msg))+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ | + + | +
| 151 | ++ |
+ #' Validates that vector has length greater than 0+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' `r lifecycle::badge("stable")`
+ |
+
| 154 | ++ |
+ #'+ |
+
| 155 | ++ |
+ #' This function is a wrapper for `shiny::validate`.+ |
+
| 156 | ++ |
+ #'+ |
+
| 157 | ++ |
+ #' @param x vector+ |
+
| 158 | ++ |
+ #' @param msg message to display+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' @export+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' @examples+ |
+
| 163 | ++ |
+ #' data <- data.frame(+ |
+
| 164 | ++ |
+ #' id = c(1:10, 11:20, 1:10),+ |
+
| 165 | ++ |
+ #' strata = rep(c("A", "B"), each = 15)
+ |
+
| 166 | ++ |
+ #' )+ |
+
| 167 | ++ |
+ #' ui <- fluidPage(+ |
+
| 168 | ++ |
+ #' selectInput("ref1", "Select strata1 to compare",
+ |
+
| 169 | ++ |
+ #' choices = c("A", "B", "C"), selected = "A"
+ |
+
| 170 | ++ |
+ #' ),+ |
+
| 171 | ++ |
+ #' selectInput("ref2", "Select strata2 to compare",
+ |
+
| 172 | ++ |
+ #' choices = c("A", "B", "C"), selected = "B"
+ |
+
| 173 | ++ |
+ #' ),+ |
+
| 174 | ++ |
+ #' verbatimTextOutput("arm_summary")
+ |
+
| 175 | ++ |
+ #' )+ |
+
| 176 | ++ |
+ #'+ |
+
| 177 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 178 | ++ |
+ #' output$arm_summary <- renderText({
+ |
+
| 179 | ++ |
+ #' sample_1 <- data$id[data$strata == input$ref1]+ |
+
| 180 | ++ |
+ #' sample_2 <- data$id[data$strata == input$ref2]+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' validate_has_elements(sample_1, "No subjects in strata1.")+ |
+
| 183 | ++ |
+ #' validate_has_elements(sample_2, "No subjects in strata2.")+ |
+
| 184 | ++ |
+ #'+ |
+
| 185 | ++ |
+ #' paste0(+ |
+
| 186 | ++ |
+ #' "Number of samples in: strata1=", length(sample_1),+ |
+
| 187 | ++ |
+ #' " comparions strata2=", length(sample_2)+ |
+
| 188 | ++ |
+ #' )+ |
+
| 189 | ++ |
+ #' })+ |
+
| 190 | ++ |
+ #' }+ |
+
| 191 | ++ |
+ #' if (interactive()) {
+ |
+
| 192 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 193 | ++ |
+ #' }+ |
+
| 194 | ++ |
+ validate_has_elements <- function(x, msg) {
+ |
+
| 195 | +! | +
+ validate(need(length(x) > 0, msg))+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ | + + | +
| 198 | ++ |
+ #' Validates no intersection between two vectors+ |
+
| 199 | ++ |
+ #'+ |
+
| 200 | ++ |
+ #' `r lifecycle::badge("stable")`
+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' This function is a wrapper for `shiny::validate`.+ |
+
| 203 | ++ |
+ #'+ |
+
| 204 | ++ |
+ #' @param x vector+ |
+
| 205 | ++ |
+ #' @param y vector+ |
+
| 206 | ++ |
+ #' @param msg (`character(1)`) message to display if `x` and `y` intersect+ |
+
| 207 | ++ |
+ #'+ |
+
| 208 | ++ |
+ #' @export+ |
+
| 209 | ++ |
+ #'+ |
+
| 210 | ++ |
+ #' @examples+ |
+
| 211 | ++ |
+ #' data <- data.frame(+ |
+
| 212 | ++ |
+ #' id = c(1:10, 11:20, 1:10),+ |
+
| 213 | ++ |
+ #' strata = rep(c("A", "B", "C"), each = 10)
+ |
+
| 214 | ++ |
+ #' )+ |
+
| 215 | ++ |
+ #'+ |
+
| 216 | ++ |
+ #' ui <- fluidPage(+ |
+
| 217 | ++ |
+ #' selectInput("ref1", "Select strata1 to compare",
+ |
+
| 218 | ++ |
+ #' choices = c("A", "B", "C"),
+ |
+
| 219 | ++ |
+ #' selected = "A"+ |
+
| 220 | ++ |
+ #' ),+ |
+
| 221 | ++ |
+ #' selectInput("ref2", "Select strata2 to compare",
+ |
+
| 222 | ++ |
+ #' choices = c("A", "B", "C"),
+ |
+
| 223 | ++ |
+ #' selected = "B"+ |
+
| 224 | ++ |
+ #' ),+ |
+
| 225 | ++ |
+ #' verbatimTextOutput("summary")
+ |
+
| 226 | ++ |
+ #' )+ |
+
| 227 | ++ |
+ #'+ |
+
| 228 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 229 | ++ |
+ #' output$summary <- renderText({
+ |
+
| 230 | ++ |
+ #' sample_1 <- data$id[data$strata == input$ref1]+ |
+
| 231 | ++ |
+ #' sample_2 <- data$id[data$strata == input$ref2]+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' validate_no_intersection(+ |
+
| 234 | ++ |
+ #' sample_1, sample_2,+ |
+
| 235 | ++ |
+ #' "subjects within strata1 and strata2 cannot overlap"+ |
+
| 236 | ++ |
+ #' )+ |
+
| 237 | ++ |
+ #' paste0(+ |
+
| 238 | ++ |
+ #' "Number of subject in: reference treatment=", length(sample_1),+ |
+
| 239 | ++ |
+ #' " comparions treatment=", length(sample_2)+ |
+
| 240 | ++ |
+ #' )+ |
+
| 241 | ++ |
+ #' })+ |
+
| 242 | ++ |
+ #' }+ |
+
| 243 | ++ |
+ #' if (interactive()) {
+ |
+
| 244 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 245 | ++ |
+ #' }+ |
+
| 246 | ++ |
+ #'+ |
+
| 247 | ++ |
+ validate_no_intersection <- function(x, y, msg) {
+ |
+
| 248 | +! | +
+ validate(need(length(intersect(x, y)) == 0, msg))+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ | + + | +
| 251 | ++ | + + | +
| 252 | ++ |
+ #' Validates that dataset contains specific variable+ |
+
| 253 | ++ |
+ #'+ |
+
| 254 | ++ |
+ #' `r lifecycle::badge("stable")`
+ |
+
| 255 | ++ |
+ #'+ |
+
| 256 | ++ |
+ #' This function is a wrapper for `shiny::validate`.+ |
+
| 257 | ++ |
+ #'+ |
+
| 258 | ++ |
+ #' @param data (`data.frame`)+ |
+
| 259 | ++ |
+ #' @param varname (`character(1)`) name of variable to check for in `data`+ |
+
| 260 | ++ |
+ #' @param msg (`character(1)`) message to display if `data` does not include `varname`+ |
+
| 261 | ++ |
+ #'+ |
+
| 262 | ++ |
+ #' @export+ |
+
| 263 | ++ |
+ #'+ |
+
| 264 | ++ |
+ #' @examples+ |
+
| 265 | ++ |
+ #' data <- data.frame(+ |
+
| 266 | ++ |
+ #' one = rep("a", length.out = 20),
+ |
+
| 267 | ++ |
+ #' two = rep(c("a", "b"), length.out = 20)
+ |
+
| 268 | ++ |
+ #' )+ |
+
| 269 | ++ |
+ #' ui <- fluidPage(+ |
+
| 270 | ++ |
+ #' selectInput(+ |
+
| 271 | ++ |
+ #' "var",+ |
+
| 272 | ++ |
+ #' "Select variable",+ |
+
| 273 | ++ |
+ #' choices = c("one", "two", "three", "four"),
+ |
+
| 274 | ++ |
+ #' selected = "one"+ |
+
| 275 | ++ |
+ #' ),+ |
+
| 276 | ++ |
+ #' verbatimTextOutput("summary")
+ |
+
| 277 | ++ |
+ #' )+ |
+
| 278 | ++ |
+ #'+ |
+
| 279 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 280 | ++ |
+ #' output$summary <- renderText({
+ |
+
| 281 | ++ |
+ #' validate_has_variable(data, input$var)+ |
+
| 282 | ++ |
+ #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
+ |
+
| 283 | ++ |
+ #' })+ |
+
| 284 | ++ |
+ #' }+ |
+
| 285 | ++ |
+ #' if (interactive()) {
+ |
+
| 286 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 287 | ++ |
+ #' }+ |
+
| 288 | ++ |
+ validate_has_variable <- function(data, varname, msg) {
+ |
+
| 289 | +! | +
+ if (length(varname) != 0) {
+ |
+
| 290 | +! | +
+ has_vars <- varname %in% names(data)+ |
+
| 291 | ++ | + + | +
| 292 | +! | +
+ if (!all(has_vars)) {
+ |
+
| 293 | +! | +
+ if (missing(msg)) {
+ |
+
| 294 | +! | +
+ msg <- sprintf(+ |
+
| 295 | +! | +
+ "%s does not have the required variables: %s.",+ |
+
| 296 | +! | +
+ deparse(substitute(data)),+ |
+
| 297 | +! | +
+ toString(varname[!has_vars])+ |
+
| 298 | ++ |
+ )+ |
+
| 299 | ++ |
+ }+ |
+
| 300 | +! | +
+ validate(need(FALSE, msg))+ |
+
| 301 | ++ |
+ }+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ |
+ }+ |
+
| 304 | ++ | + + | +
| 305 | ++ |
+ #' Validate that variables has expected number of levels+ |
+
| 306 | ++ |
+ #'+ |
+
| 307 | ++ |
+ #' `r lifecycle::badge("stable")`
+ |
+
| 308 | ++ |
+ #'+ |
+
| 309 | ++ |
+ #' If the number of levels of `x` is less than `min_levels`+ |
+
| 310 | ++ |
+ #' or greater than `max_levels` the validation will fail.+ |
+
| 311 | ++ |
+ #' This function is a wrapper for `shiny::validate`.+ |
+
| 312 | ++ |
+ #'+ |
+
| 313 | ++ |
+ #' @param x variable name. If `x` is not a factor, the unique values+ |
+
| 314 | ++ |
+ #' are treated as levels.+ |
+
| 315 | ++ |
+ #' @param min_levels cutoff for minimum number of levels of `x`+ |
+
| 316 | ++ |
+ #' @param max_levels cutoff for maximum number of levels of `x`+ |
+
| 317 | ++ |
+ #' @param var_name name of variable being validated for use in+ |
+
| 318 | ++ |
+ #' validation message+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' @export+ |
+
| 321 | ++ |
+ #' @examples+ |
+
| 322 | ++ |
+ #' data <- data.frame(+ |
+
| 323 | ++ |
+ #' one = rep("a", length.out = 20),
+ |
+
| 324 | ++ |
+ #' two = rep(c("a", "b"), length.out = 20),
+ |
+
| 325 | ++ |
+ #' three = rep(c("a", "b", "c"), length.out = 20),
+ |
+
| 326 | ++ |
+ #' four = rep(c("a", "b", "c", "d"), length.out = 20),
+ |
+
| 327 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 328 | ++ |
+ #' )+ |
+
| 329 | ++ |
+ #' ui <- fluidPage(+ |
+
| 330 | ++ |
+ #' selectInput(+ |
+
| 331 | ++ |
+ #' "var",+ |
+
| 332 | ++ |
+ #' "Select variable",+ |
+
| 333 | ++ |
+ #' choices = c("one", "two", "three", "four"),
+ |
+
| 334 | ++ |
+ #' selected = "one"+ |
+
| 335 | ++ |
+ #' ),+ |
+
| 336 | ++ |
+ #' verbatimTextOutput("summary")
+ |
+
| 337 | ++ |
+ #' )+ |
+
| 338 | ++ |
+ #'+ |
+
| 339 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 340 | ++ |
+ #' output$summary <- renderText({
+ |
+
| 341 | ++ |
+ #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var)+ |
+
| 342 | ++ |
+ #' paste0(+ |
+
| 343 | ++ |
+ #' "Levels of selected treatment variable: ",+ |
+
| 344 | ++ |
+ #' paste(levels(data[[input$var]]),+ |
+
| 345 | ++ |
+ #' collapse = ", "+ |
+
| 346 | ++ |
+ #' )+ |
+
| 347 | ++ |
+ #' )+ |
+
| 348 | ++ |
+ #' })+ |
+
| 349 | ++ |
+ #' }+ |
+
| 350 | ++ |
+ #' if (interactive()) {
+ |
+
| 351 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 352 | ++ |
+ #' }+ |
+
| 353 | ++ |
+ validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
+ |
+
| 354 | +! | +
+ x_levels <- if (is.factor(x)) {
+ |
+
| 355 | +! | +
+ levels(x)+ |
+
| 356 | ++ |
+ } else {
+ |
+
| 357 | +! | +
+ unique(x)+ |
+
| 358 | ++ |
+ }+ |
+
| 359 | ++ | + + | +
| 360 | +! | +
+ if (!is.null(min_levels) && !(is.null(max_levels))) {
+ |
+
| 361 | +! | +
+ validate(need(+ |
+
| 362 | +! | +
+ length(x_levels) >= min_levels && length(x_levels) <= max_levels,+ |
+
| 363 | +! | +
+ sprintf(+ |
+
| 364 | +! | +
+ "%s variable needs minimum %s level(s) and maximum %s level(s).",+ |
+
| 365 | +! | +
+ var_name, min_levels, max_levels+ |
+
| 366 | ++ |
+ )+ |
+
| 367 | ++ |
+ ))+ |
+
| 368 | +! | +
+ } else if (!is.null(min_levels)) {
+ |
+
| 369 | +! | +
+ validate(need(+ |
+
| 370 | +! | +
+ length(x_levels) >= min_levels,+ |
+
| 371 | +! | +
+ sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
+ |
+
| 372 | ++ |
+ ))+ |
+
| 373 | +! | +
+ } else if (!is.null(max_levels)) {
+ |
+
| 374 | +! | +
+ validate(need(+ |
+
| 375 | +! | +
+ length(x_levels) <= max_levels,+ |
+
| 376 | +! | +
+ sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
+ |
+
| 377 | ++ |
+ ))+ |
+
| 378 | ++ |
+ }+ |
+
| 379 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Include `CSS` files from `/inst/css/` package directory to application header+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' `system.file` should not be used to access files in other packages, it does+ |
+
| 4 | ++ |
+ #' not work with `devtools`. Therefore, we redefine this method in each package+ |
+
| 5 | ++ |
+ #' as needed. Thus, we do not export this method.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param pattern (`character`) pattern of files to be included+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @return HTML code that includes `CSS` files.+ |
+
| 10 | ++ |
+ #' @keywords internal+ |
+
| 11 | ++ |
+ include_css_files <- function(pattern = "*") {
+ |
+
| 12 | +7x | +
+ css_files <- list.files(+ |
+
| 13 | +7x | +
+ system.file("css", package = "teal", mustWork = TRUE),
+ |
+
| 14 | +7x | +
+ pattern = pattern, full.names = TRUE+ |
+
| 15 | ++ |
+ )+ |
+
| 16 | ++ | + + | +
| 17 | +7x | +
+ singleton(+ |
+
| 18 | +7x | +
+ tags$head(lapply(css_files, includeCSS))+ |
+
| 19 | ++ |
+ )+ |
+
| 20 | ++ |
+ }+ |
+
| 21 | ++ | + + | +
| 22 | ++ |
+ #' Include `JS` files from `/inst/js/` package directory to application header+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' `system.file` should not be used to access files in other packages, it does+ |
+
| 25 | ++ |
+ #' not work with `devtools`. Therefore, we redefine this method in each package+ |
+
| 26 | ++ |
+ #' as needed. Thus, we do not export this method+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ |
+
| 29 | ++ |
+ #' @param except (`character`) vector of basename filenames to be excluded+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @return HTML code that includes `JS` files.+ |
+
| 32 | ++ |
+ #' @keywords internal+ |
+
| 33 | ++ |
+ include_js_files <- function(pattern = NULL, except = NULL) {
+ |
+
| 34 | +7x | +
+ checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)+ |
+
| 35 | +7x | +
+ js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
+ |
+
| 36 | +7x | +
+ js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL+ |
+
| 37 | ++ | + + | +
| 38 | +7x | +
+ singleton(lapply(js_files, includeScript))+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | ++ |
+ #' Run `JS` file from `/inst/js/` package directory+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' This is triggered from the server to execute on the client+ |
+
| 44 | ++ |
+ #' rather than triggered directly on the client.+ |
+
| 45 | ++ |
+ #' Unlike `include_js_files` which includes `JavaScript` functions,+ |
+
| 46 | ++ |
+ #' the `run_js` actually executes `JavaScript` functions.+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' `system.file` should not be used to access files in other packages, it does+ |
+
| 49 | ++ |
+ #' not work with `devtools`. Therefore, we redefine this method in each package+ |
+
| 50 | ++ |
+ #' as needed. Thus, we do not export this method.+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' @param files (`character`) vector of filenames.+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' @return returns `NULL`, invisibly.+ |
+
| 55 | ++ |
+ #' @keywords internal+ |
+
| 56 | ++ |
+ run_js_files <- function(files) {
+ |
+
| 57 | +18x | +
+ checkmate::assert_character(files, min.len = 1, any.missing = FALSE)+ |
+
| 58 | +18x | +
+ lapply(files, function(file) {
+ |
+
| 59 | +18x | +
+ shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
+ |
+
| 60 | ++ |
+ })+ |
+
| 61 | +18x | +
+ invisible(NULL)+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ | + + | +
| 64 | ++ |
+ #' Code to include `teal` `CSS` and `JavaScript` files+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' This is useful when you want to use the same `JavaScript` and `CSS` files that are+ |
+
| 67 | ++ |
+ #' used with the `teal` application.+ |
+
| 68 | ++ |
+ #' This is also useful for running standalone modules in `teal` with the correct+ |
+
| 69 | ++ |
+ #' styles.+ |
+
| 70 | ++ |
+ #' Also initializes `shinyjs` so you can use it.+ |
+
| 71 | ++ |
+ #'+ |
+
| 72 | ++ |
+ #' Simply add `include_teal_css_js()` as one of the UI elements.+ |
+
| 73 | ++ |
+ #' @return A `shiny.tag.list`.+ |
+
| 74 | ++ |
+ #' @keywords internal+ |
+
| 75 | ++ |
+ include_teal_css_js <- function() {
+ |
+
| 76 | +7x | +
+ tagList(+ |
+
| 77 | +7x | +
+ shinyjs::useShinyjs(),+ |
+
| 78 | +7x | +
+ include_css_files(),+ |
+
| 79 | ++ |
+ # init.js is executed from the server+ |
+
| 80 | +7x | +
+ include_js_files(except = "init.js"),+ |
+
| 81 | +7x | +
+ shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
+ |
+
| 82 | ++ |
+ )+ |
+
| 83 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Evaluate expression on `teal_data_module`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @details+ |
+
| 4 | ++ |
+ #' `within` is a convenience function for evaluating inline code inside the environment of a `teal_data_module`.+ |
+
| 5 | ++ |
+ #' It accepts only inline expressions (both simple and compound) and allows for injecting values into `expr` through+ |
+
| 6 | ++ |
+ #' the `...` argument: as `name:value` pairs are passed to `...`, `name` in `expr` will be replaced with `value.`+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param data (`teal_data_module`) object+ |
+
| 9 | ++ |
+ #' @param expr (`expression`) to evaluate. Must be inline code. See+ |
+
| 10 | ++ |
+ #' @param ... See `Details`.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return+ |
+
| 13 | ++ |
+ #' `within` returns a `teal_data_module` object with a delayed evaluation of `expr` when the module is run.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' within(tdm, dataset1 <- subset(dataset1, Species == "virginica"))+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' # use additional parameter for expression value substitution.+ |
+
| 19 | ++ |
+ #' valid_species <- "versicolor"+ |
+
| 20 | ++ |
+ #' within(tdm, dataset1 <- subset(dataset1, Species %in% species), species = valid_species)+ |
+
| 21 | ++ |
+ #' @include teal_data_module.R+ |
+
| 22 | ++ |
+ #' @name within+ |
+
| 23 | ++ |
+ #' @rdname teal_data_module+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @export+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ within.teal_data_module <- function(data, expr, ...) {
+ |
+
| 28 | +6x | +
+ expr <- substitute(expr)+ |
+
| 29 | +6x | +
+ extras <- list(...)+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # Add braces for consistency.+ |
+
| 32 | +6x | +
+ if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
+ |
+
| 33 | +6x | +
+ expr <- call("{", expr)
+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | ++ | + + | +
| 36 | +6x | +
+ calls <- as.list(expr)[-1]+ |
+
| 37 | ++ | + + | +
| 38 | ++ |
+ # Inject extra values into expressions.+ |
+
| 39 | +6x | +
+ calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))+ |
+
| 40 | ++ | + + | +
| 41 | +6x | +
+ eval_code(object = data, code = as.expression(calls))+ |
+
| 42 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' An example `teal` module+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams teal_modules+ |
+
| 6 | ++ |
+ #' @return A `teal` module which can be included in the `modules` argument to [init()].+ |
+
| 7 | ++ |
+ #' @examples+ |
+
| 8 | ++ |
+ #' app <- init(+ |
+
| 9 | ++ |
+ #' data = teal_data(IRIS = iris, MTCARS = mtcars),+ |
+
| 10 | ++ |
+ #' modules = example_module()+ |
+
| 11 | ++ |
+ #' )+ |
+
| 12 | ++ |
+ #' if (interactive()) {
+ |
+
| 13 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 14 | ++ |
+ #' }+ |
+
| 15 | ++ |
+ #' @export+ |
+
| 16 | ++ |
+ example_module <- function(label = "example teal module", datanames = "all") {
+ |
+
| 17 | +49x | +
+ checkmate::assert_string(label)+ |
+
| 18 | +49x | +
+ module(+ |
+
| 19 | +49x | +
+ label,+ |
+
| 20 | +49x | +
+ server = function(id, data) {
+ |
+
| 21 | +! | +
+ checkmate::assert_class(data(), "teal_data")+ |
+
| 22 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 23 | +! | +
+ updateSelectInput(session, "dataname", choices = isolate(teal.data::datanames(data())))+ |
+
| 24 | +! | +
+ output$text <- renderPrint({
+ |
+
| 25 | +! | +
+ req(input$dataname)+ |
+
| 26 | +! | +
+ data()[[input$dataname]]+ |
+
| 27 | ++ |
+ })+ |
+
| 28 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 29 | +! | +
+ id = "rcode",+ |
+
| 30 | +! | +
+ verbatim_content = reactive(teal.code::get_code(data())),+ |
+
| 31 | +! | +
+ title = "Example Code"+ |
+
| 32 | ++ |
+ )+ |
+
| 33 | ++ |
+ })+ |
+
| 34 | ++ |
+ },+ |
+
| 35 | +49x | +
+ ui = function(id) {
+ |
+
| 36 | +! | +
+ ns <- NS(id)+ |
+
| 37 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 38 | +! | +
+ output = verbatimTextOutput(ns("text")),
+ |
+
| 39 | +! | +
+ encoding = div(+ |
+
| 40 | +! | +
+ selectInput(ns("dataname"), "Choose a dataset", choices = NULL),
+ |
+
| 41 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 42 | ++ |
+ )+ |
+
| 43 | ++ |
+ )+ |
+
| 44 | ++ |
+ },+ |
+
| 45 | +49x | +
+ datanames = datanames+ |
+
| 46 | ++ |
+ )+ |
+
| 47 | ++ |
+ }+ |
+
| 1 | ++ |
+ setOldClass("teal_data_module")
+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ #' Evaluate code on `teal_data_module`+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @details+ |
+
| 6 | ++ |
+ #' `eval_code` evaluates given code in the environment of the `teal_data` object created by the `teal_data_module`.+ |
+
| 7 | ++ |
+ #' The code is added to the `@code` slot of the `teal_data`.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @param object (`teal_data_module`)+ |
+
| 10 | ++ |
+ #' @inheritParams teal.code::eval_code+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return+ |
+
| 13 | ++ |
+ #' `eval_code` returns a `teal_data_module` object with a delayed evaluation of `code` when the module is run.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' eval_code(tdm, "dataset1 <- subset(dataset1, Species == 'virginica')")+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @include teal_data_module.R+ |
+
| 19 | ++ |
+ #' @name eval_code+ |
+
| 20 | ++ |
+ #' @rdname teal_data_module+ |
+
| 21 | ++ |
+ #' @aliases eval_code,teal_data_module,character-method+ |
+
| 22 | ++ |
+ #' @aliases eval_code,teal_data_module,language-method+ |
+
| 23 | ++ |
+ #' @aliases eval_code,teal_data_module,expression-method+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @importFrom methods setMethod+ |
+
| 26 | ++ |
+ #' @importMethodsFrom teal.code eval_code+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ setMethod("eval_code", signature = c("teal_data_module", "character"), function(object, code) {
+ |
+
| 29 | +13x | +
+ teal_data_module(+ |
+
| 30 | +13x | +
+ ui = function(id) {
+ |
+
| 31 | +1x | +
+ ns <- NS(id)+ |
+
| 32 | +1x | +
+ object$ui(ns("mutate_inner"))
+ |
+
| 33 | ++ |
+ },+ |
+
| 34 | +13x | +
+ server = function(id) {
+ |
+
| 35 | +11x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 36 | +11x | +
+ teal_data_rv <- object$server("mutate_inner")
+ |
+
| 37 | ++ | + + | +
| 38 | +11x | +
+ if (!is.reactive(teal_data_rv)) {
+ |
+
| 39 | +1x | +
+ stop("The `teal_data_module` must return a reactive expression.", call. = FALSE)
+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | ++ | + + | +
| 42 | +10x | +
+ td <- eventReactive(teal_data_rv(),+ |
+
| 43 | ++ |
+ {
+ |
+
| 44 | +10x | +
+ if (inherits(teal_data_rv(), c("teal_data", "qenv.error"))) {
+ |
+
| 45 | +6x | +
+ eval_code(teal_data_rv(), code)+ |
+
| 46 | ++ |
+ } else {
+ |
+
| 47 | +4x | +
+ teal_data_rv()+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | ++ |
+ },+ |
+
| 50 | +10x | +
+ ignoreNULL = FALSE+ |
+
| 51 | ++ |
+ )+ |
+
| 52 | +10x | +
+ td+ |
+
| 53 | ++ |
+ })+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | ++ |
+ )+ |
+
| 56 | ++ |
+ })+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ setMethod("eval_code", signature = c("teal_data_module", "language"), function(object, code) {
+ |
+
| 59 | +1x | +
+ eval_code(object, code = paste(lang2calls(code), collapse = "\n"))+ |
+
| 60 | ++ |
+ })+ |
+
| 61 | ++ | + + | +
| 62 | ++ |
+ setMethod("eval_code", signature = c("teal_data_module", "expression"), function(object, code) {
+ |
+
| 63 | +6x | +
+ eval_code(object, code = paste(lang2calls(code), collapse = "\n"))+ |
+
| 64 | ++ |
+ })+ |
+
| 1 | ++ |
+ #' Landing popup module+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description Creates a landing welcome popup for `teal` applications.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This module is used to display a popup dialog when the application starts.+ |
+
| 6 | ++ |
+ #' The dialog blocks access to the application and must be closed with a button before the application can be viewed.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param label (`character(1)`) Label of the module.+ |
+
| 9 | ++ |
+ #' @param title (`character(1)`) Text to be displayed as popup title.+ |
+
| 10 | ++ |
+ #' @param content (`character(1)`, `shiny.tag` or `shiny.tag.list`) with the content of the popup.+ |
+
| 11 | ++ |
+ #' Passed to `...` of `shiny::modalDialog`. See examples.+ |
+
| 12 | ++ |
+ #' @param buttons (`shiny.tag` or `shiny.tag.list`) Typically a `modalButton` or `actionButton`. See examples.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @examples+ |
+
| 17 | ++ |
+ #' app1 <- init(+ |
+
| 18 | ++ |
+ #' data = teal_data(iris = iris),+ |
+
| 19 | ++ |
+ #' modules = modules(+ |
+
| 20 | ++ |
+ #' landing_popup_module(+ |
+
| 21 | ++ |
+ #' content = "A place for the welcome message or a disclaimer statement.",+ |
+
| 22 | ++ |
+ #' buttons = modalButton("Proceed")
+ |
+
| 23 | ++ |
+ #' ),+ |
+
| 24 | ++ |
+ #' example_module()+ |
+
| 25 | ++ |
+ #' )+ |
+
| 26 | ++ |
+ #' )+ |
+
| 27 | ++ |
+ #' if (interactive()) {
+ |
+
| 28 | ++ |
+ #' shinyApp(app1$ui, app1$server)+ |
+
| 29 | ++ |
+ #' }+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' app2 <- init(+ |
+
| 32 | ++ |
+ #' data = teal_data(iris = iris),+ |
+
| 33 | ++ |
+ #' modules = modules(+ |
+
| 34 | ++ |
+ #' landing_popup_module(+ |
+
| 35 | ++ |
+ #' title = "Welcome",+ |
+
| 36 | ++ |
+ #' content = tags$b(+ |
+
| 37 | ++ |
+ #' "A place for the welcome message or a disclaimer statement.",+ |
+
| 38 | ++ |
+ #' style = "color: red;"+ |
+
| 39 | ++ |
+ #' ),+ |
+
| 40 | ++ |
+ #' buttons = tagList(+ |
+
| 41 | ++ |
+ #' modalButton("Proceed"),
+ |
+
| 42 | ++ |
+ #' actionButton("read", "Read more",
+ |
+
| 43 | ++ |
+ #' onclick = "window.open('http://google.com', '_blank')"
+ |
+
| 44 | ++ |
+ #' ),+ |
+
| 45 | ++ |
+ #' actionButton("close", "Reject", onclick = "window.close()")
+ |
+
| 46 | ++ |
+ #' )+ |
+
| 47 | ++ |
+ #' ),+ |
+
| 48 | ++ |
+ #' example_module()+ |
+
| 49 | ++ |
+ #' )+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' if (interactive()) {
+ |
+
| 53 | ++ |
+ #' shinyApp(app2$ui, app2$server)+ |
+
| 54 | ++ |
+ #' }+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' @export+ |
+
| 57 | ++ |
+ landing_popup_module <- function(label = "Landing Popup",+ |
+
| 58 | ++ |
+ title = NULL,+ |
+
| 59 | ++ |
+ content = NULL,+ |
+
| 60 | ++ |
+ buttons = modalButton("Accept")) {
+ |
+
| 61 | +! | +
+ checkmate::assert_string(label)+ |
+
| 62 | +! | +
+ checkmate::assert_string(title, null.ok = TRUE)+ |
+
| 63 | +! | +
+ checkmate::assert_multi_class(+ |
+
| 64 | +! | +
+ content,+ |
+
| 65 | +! | +
+ classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
+ |
+
| 66 | ++ |
+ )+ |
+
| 67 | +! | +
+ checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
+ |
+
| 68 | ++ | + + | +
| 69 | +! | +
+ logger::log_info("Initializing landing_popup_module")
+ |
+
| 70 | ++ | + + | +
| 71 | +! | +
+ module <- module(+ |
+
| 72 | +! | +
+ label = label,+ |
+
| 73 | +! | +
+ server = function(id) {
+ |
+
| 74 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 75 | +! | +
+ showModal(+ |
+
| 76 | +! | +
+ modalDialog(+ |
+
| 77 | +! | +
+ id = "landingpopup",+ |
+
| 78 | +! | +
+ title = title,+ |
+
| 79 | +! | +
+ content,+ |
+
| 80 | +! | +
+ footer = buttons+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ )+ |
+
| 83 | ++ |
+ })+ |
+
| 84 | ++ |
+ }+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | +! | +
+ class(module) <- c("teal_module_landing", class(module))
+ |
+
| 87 | +! | +
+ module+ |
+
| 88 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Data module for `teal` applications+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' `r lifecycle::badge("experimental")`
+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' Create a `teal_data_module` object and evaluate code on it with history tracking.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @details+ |
+
| 9 | ++ |
+ #' `teal_data_module` creates a `shiny` module to supply or modify data in a `teal` application.+ |
+
| 10 | ++ |
+ #' The module allows for running data pre-processing code (creation _and_ some modification) after the app starts.+ |
+
| 11 | ++ |
+ #' The body of the server function will be run in the app rather than in the global environment.+ |
+
| 12 | ++ |
+ #' This means it will be run every time the app starts, so use sparingly.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' Pass this module instead of a `teal_data` object in a call to [init()].+ |
+
| 15 | ++ |
+ #' Note that the server function must always return a `teal_data` object wrapped in a reactive expression.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' See vignette `vignette("data-as-shiny-module", package = "teal")` for more details.
+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @param ui (`function(id)`)+ |
+
| 20 | ++ |
+ #' `shiny` module UI function; must only take `id` argument+ |
+
| 21 | ++ |
+ #' @param server (`function(id)`)+ |
+
| 22 | ++ |
+ #' `shiny` module server function; must only take `id` argument;+ |
+
| 23 | ++ |
+ #' must return reactive expression containing `teal_data` object+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @return+ |
+
| 26 | ++ |
+ #' `teal_data_module` returns an object of class `teal_data_module`.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @examples+ |
+
| 29 | ++ |
+ #' tdm <- teal_data_module(+ |
+
| 30 | ++ |
+ #' ui = function(id) {
+ |
+
| 31 | ++ |
+ #' ns <- NS(id)+ |
+
| 32 | ++ |
+ #' actionButton(ns("submit"), label = "Load data")
+ |
+
| 33 | ++ |
+ #' },+ |
+
| 34 | ++ |
+ #' server = function(id) {
+ |
+
| 35 | ++ |
+ #' moduleServer(id, function(input, output, session) {
+ |
+
| 36 | ++ |
+ #' eventReactive(input$submit, {
+ |
+
| 37 | ++ |
+ #' data <- within(+ |
+
| 38 | ++ |
+ #' teal_data(),+ |
+
| 39 | ++ |
+ #' {
+ |
+
| 40 | ++ |
+ #' dataset1 <- iris+ |
+
| 41 | ++ |
+ #' dataset2 <- mtcars+ |
+
| 42 | ++ |
+ #' }+ |
+
| 43 | ++ |
+ #' )+ |
+
| 44 | ++ |
+ #' datanames(data) <- c("dataset1", "dataset2")
+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' data+ |
+
| 47 | ++ |
+ #' })+ |
+
| 48 | ++ |
+ #' })+ |
+
| 49 | ++ |
+ #' }+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' @name teal_data_module+ |
+
| 53 | ++ |
+ #' @seealso [`teal.data::teal_data-class`], [teal.code::qenv()]+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @export+ |
+
| 56 | ++ |
+ teal_data_module <- function(ui, server) {
+ |
+
| 57 | +36x | +
+ checkmate::assert_function(ui, args = "id", nargs = 1)+ |
+
| 58 | +35x | +
+ checkmate::assert_function(server, args = "id", nargs = 1)+ |
+
| 59 | +34x | +
+ structure(+ |
+
| 60 | +34x | +
+ list(ui = ui, server = server),+ |
+
| 61 | +34x | +
+ class = "teal_data_module"+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Show `R` code modal+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Use the [shiny::showModal()] function to show the `R` code inside.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param title (`character(1)`)+ |
+
| 8 | ++ |
+ #' Title of the modal, displayed in the first comment of the `R` code.+ |
+
| 9 | ++ |
+ #' @param rcode (`character`)+ |
+
| 10 | ++ |
+ #' vector with `R` code to show inside the modal.+ |
+
| 11 | ++ |
+ #' @param session (`ShinySession` optional)+ |
+
| 12 | ++ |
+ #' `shiny` session object, if missing then [shiny::getDefaultReactiveDomain()] is used.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @references [shiny::showModal()]+ |
+
| 15 | ++ |
+ #' @export+ |
+
| 16 | ++ |
+ show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) {
+ |
+
| 17 | +! | +
+ rcode <- paste(rcode, collapse = "\n")+ |
+
| 18 | ++ | + + | +
| 19 | +! | +
+ ns <- session$ns+ |
+
| 20 | +! | +
+ showModal(modalDialog(+ |
+
| 21 | +! | +
+ tagList(+ |
+
| 22 | +! | +
+ tags$div(+ |
+
| 23 | +! | +
+ actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ |
+
| 24 | +! | +
+ modalButton("Dismiss"),
+ |
+
| 25 | +! | +
+ style = "mb-4"+ |
+
| 26 | ++ |
+ ),+ |
+
| 27 | +! | +
+ tags$div(tags$pre(id = ns("r_code"), rcode)),
+ |
+
| 28 | ++ |
+ ),+ |
+
| 29 | +! | +
+ title = title,+ |
+
| 30 | +! | +
+ footer = tagList(+ |
+
| 31 | +! | +
+ actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ |
+
| 32 | +! | +
+ modalButton("Dismiss")
+ |
+
| 33 | ++ |
+ ),+ |
+
| 34 | +! | +
+ size = "l",+ |
+
| 35 | +! | +
+ easyClose = TRUE+ |
+
| 36 | ++ |
+ ))+ |
+
| 37 | ++ |
+ }+ |
+