| 1 | ++ |
+ #' Filter settings for teal applications+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Filter settings for teal applications+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams teal.slice::teal_slices+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param module_specific (`logical(1)`)\cr+ |
+
| 8 | ++ |
+ #' - `TRUE` when filter panel should be module-specific. All modules can have different set+ |
+
| 9 | ++ |
+ #' of filters specified - see `mapping` argument.+ |
+
| 10 | ++ |
+ #' - `FALSE` when one filter panel needed to all modules. All filters will be shared+ |
+
| 11 | ++ |
+ #' by all modules.+ |
+
| 12 | ++ |
+ #' @param mapping `r lifecycle::badge("experimental")` _This is a new feature. Do kindly share your opinions.\cr_
+ |
+
| 13 | ++ |
+ #' (`named list`)\cr+ |
+
| 14 | ++ |
+ #' Specifies which filters will be active in which modules on app start.+ |
+
| 15 | ++ |
+ #' Elements should contain character vector of `teal_slice` `id`s (see [teal.slice::teal_slice()]).+ |
+
| 16 | ++ |
+ #' Names of the list should correspond to `teal_module` `label` set in [module()] function.+ |
+
| 17 | ++ |
+ #' `id`s listed under `"global_filters` will be active in all modules.+ |
+
| 18 | ++ |
+ #' If missing, all filters will be applied to all modules.+ |
+
| 19 | ++ |
+ #' If empty list, all filters will be available to all modules but will start inactive.+ |
+
| 20 | ++ |
+ #' If `module_specific` is `FALSE`, only `global_filters` will be active on start.+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @param x (`list`) of lists to convert to `teal_slices`+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examples+ |
+
| 25 | ++ |
+ #' filter <- teal_slices(+ |
+
| 26 | ++ |
+ #' teal.slice::teal_slice(dataname = "iris", varname = "Species", id = "species"),+ |
+
| 27 | ++ |
+ #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"),+ |
+
| 28 | ++ |
+ #' teal.slice::teal_slice(+ |
+
| 29 | ++ |
+ #' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5"+ |
+
| 30 | ++ |
+ #' ),+ |
+
| 31 | ++ |
+ #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"),+ |
+
| 32 | ++ |
+ #' mapping = list(+ |
+
| 33 | ++ |
+ #' module1 = c("species", "sepal_length"),
+ |
+
| 34 | ++ |
+ #' module2 = c("mtcars_mpg"),
+ |
+
| 35 | ++ |
+ #' global_filters = "long_petals"+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' app <- teal::init(+ |
+
| 40 | ++ |
+ #' modules = list(+ |
+
| 41 | ++ |
+ #' module("module1"),
+ |
+
| 42 | ++ |
+ #' module("module2")
+ |
+
| 43 | ++ |
+ #' ),+ |
+
| 44 | ++ |
+ #' data = list(iris, mtcars),+ |
+
| 45 | ++ |
+ #' filter = filter+ |
+
| 46 | ++ |
+ #' )+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' if (interactive()) {
+ |
+
| 49 | ++ |
+ #' shiny::runApp(app)+ |
+
| 50 | ++ |
+ #' }+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' @export+ |
+
| 53 | ++ |
+ teal_slices <- function(...,+ |
+
| 54 | ++ |
+ exclude_varnames = NULL,+ |
+
| 55 | ++ |
+ include_varnames = NULL,+ |
+
| 56 | ++ |
+ count_type = NULL,+ |
+
| 57 | ++ |
+ allow_add = TRUE,+ |
+
| 58 | ++ |
+ module_specific = FALSE,+ |
+
| 59 | ++ |
+ mapping) {
+ |
+
| 60 | +91x | +
+ shiny::isolate({
+ |
+
| 61 | +91x | +
+ checkmate::assert_flag(allow_add)+ |
+
| 62 | +91x | +
+ checkmate::assert_flag(module_specific)+ |
+
| 63 | +45x | +
+ if (!missing(mapping)) checkmate::assert_list(mapping, types = c("character", "NULL"), names = "named")
+ |
+
| 64 | ++ | + + | +
| 65 | +88x | +
+ slices <- list(...)+ |
+
| 66 | +88x | +
+ all_slice_id <- vapply(slices, `[[`, character(1L), "id")+ |
+
| 67 | ++ | + + | +
| 68 | +88x | +
+ if (missing(mapping)) {
+ |
+
| 69 | +46x | +
+ mapping <- list(global_filters = all_slice_id)+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | +88x | +
+ if (!module_specific) {
+ |
+
| 72 | +84x | +
+ mapping[setdiff(names(mapping), "global_filters")] <- NULL+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | ++ | + + | +
| 75 | +88x | +
+ failed_slice_id <- setdiff(unlist(mapping), all_slice_id)+ |
+
| 76 | +88x | +
+ if (length(failed_slice_id)) {
+ |
+
| 77 | +1x | +
+ stop(sprintf(+ |
+
| 78 | +1x | +
+ "Filters in mapping don't match any available filter.\n %s not in %s",+ |
+
| 79 | +1x | +
+ toString(failed_slice_id),+ |
+
| 80 | +1x | +
+ toString(all_slice_id)+ |
+
| 81 | ++ |
+ ))+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | ++ | + + | +
| 84 | +87x | +
+ tss <- teal.slice::teal_slices(+ |
+
| 85 | ++ |
+ ...,+ |
+
| 86 | +87x | +
+ exclude_varnames = exclude_varnames,+ |
+
| 87 | +87x | +
+ include_varnames = include_varnames,+ |
+
| 88 | +87x | +
+ count_type = count_type,+ |
+
| 89 | +87x | +
+ allow_add = allow_add+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | +87x | +
+ attr(tss, "mapping") <- mapping+ |
+
| 92 | +87x | +
+ attr(tss, "module_specific") <- module_specific+ |
+
| 93 | +87x | +
+ class(tss) <- c("modules_teal_slices", class(tss))
+ |
+
| 94 | +87x | +
+ tss+ |
+
| 95 | ++ |
+ })+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ | + + | +
| 98 | ++ | + + | +
| 99 | ++ |
+ #' @rdname teal_slices+ |
+
| 100 | ++ |
+ #' @export+ |
+
| 101 | ++ |
+ #' @keywords internal+ |
+
| 102 | ++ |
+ #'+ |
+
| 103 | ++ |
+ as.teal_slices <- function(x) { # nolint
+ |
+
| 104 | +33x | +
+ checkmate::assert_list(x)+ |
+
| 105 | +33x | +
+ lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")+ |
+
| 106 | ++ | + + | +
| 107 | +33x | +
+ attrs <- attributes(unclass(x))+ |
+
| 108 | +33x | +
+ ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))+ |
+
| 109 | +33x | +
+ do.call(teal_slices, c(ans, attrs))+ |
+
| 110 | ++ |
+ }+ |
+
| 111 | ++ | + + | +
| 112 | ++ | + + | +
| 113 | ++ |
+ #' @rdname teal_slices+ |
+
| 114 | ++ |
+ #' @export+ |
+
| 115 | ++ |
+ #' @keywords internal+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ c.teal_slices <- function(...) {
+ |
+
| 118 | +! | +
+ x <- list(...)+ |
+
| 119 | +! | +
+ checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ |
+
| 120 | ++ | + + | +
| 121 | +! | +
+ all_attributes <- lapply(x, attributes)+ |
+
| 122 | +! | +
+ all_attributes <- coalesce_r(all_attributes)+ |
+
| 123 | +! | +
+ all_attributes <- all_attributes[names(all_attributes) != "class"]+ |
+
| 124 | ++ | + + | +
| 125 | +! | +
+ do.call(+ |
+
| 126 | +! | +
+ teal_slices,+ |
+
| 127 | +! | +
+ c(+ |
+
| 128 | +! | +
+ unique(unlist(x, recursive = FALSE)),+ |
+
| 129 | +! | +
+ all_attributes+ |
+
| 130 | ++ |
+ )+ |
+
| 131 | ++ |
+ )+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | ++ | + + | +
| 135 | ++ |
+ #' Deep copy `teal_slices`+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' it's important to create a new copy of `teal_slices` when+ |
+
| 138 | ++ |
+ #' starting a new `shiny` session. Otherwise, object will be shared+ |
+
| 139 | ++ |
+ #' by multiple users as it is created in global environment before+ |
+
| 140 | ++ |
+ #' `shiny` session starts.+ |
+
| 141 | ++ |
+ #' @param filter (`teal_slices`)+ |
+
| 142 | ++ |
+ #' @return `teal_slices`+ |
+
| 143 | ++ |
+ #' @keywords internal+ |
+
| 144 | ++ |
+ deep_copy_filter <- function(filter) {
+ |
+
| 145 | +1x | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+
| 146 | +1x | +
+ shiny::isolate({
+ |
+
| 147 | +1x | +
+ filter_copy <- lapply(filter, function(slice) {
+ |
+
| 148 | +2x | +
+ teal.slice::as.teal_slice(as.list(slice))+ |
+
| 149 | ++ |
+ })+ |
+
| 150 | +1x | +
+ attributes(filter_copy) <- attributes(filter)+ |
+
| 151 | +1x | +
+ filter_copy+ |
+
| 152 | ++ |
+ })+ |
+
| 153 | ++ |
+ }+ |
+
| 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 `raw_data` (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 ui_teal_with_splash+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @param splash_ui (`shiny.tag`)\cr 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 raw_data (`reactive`)\cr+ |
+
| 37 | ++ |
+ #' returns the `TealData`, only evaluated once, `NULL` value is ignored+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @return+ |
+
| 40 | ++ |
+ #' `ui_teal` returns `HTML` for Shiny module UI.+ |
+
| 41 | ++ |
+ #' `srv_teal` returns `reactive` which returns the currently active module.+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @keywords internal+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @examples+ |
+
| 46 | ++ |
+ #' mods <- teal:::example_modules()+ |
+
| 47 | ++ |
+ #' raw_data <- reactive(teal:::example_cdisc_data())+ |
+
| 48 | ++ |
+ #' app <- shinyApp(+ |
+
| 49 | ++ |
+ #' ui = function() {
+ |
+
| 50 | ++ |
+ #' teal:::ui_teal("dummy")
+ |
+
| 51 | ++ |
+ #' },+ |
+
| 52 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 53 | ++ |
+ #' active_module <- teal:::srv_teal(id = "dummy", modules = mods, raw_data = raw_data)+ |
+
| 54 | ++ |
+ #' }+ |
+
| 55 | ++ |
+ #' )+ |
+
| 56 | ++ |
+ #' if (interactive()) {
+ |
+
| 57 | ++ |
+ #' runApp(app)+ |
+
| 58 | ++ |
+ #' }+ |
+
| 59 | ++ |
+ NULL+ |
+
| 60 | ++ | + + | +
| 61 | ++ |
+ #' @rdname module_teal+ |
+
| 62 | ++ |
+ ui_teal <- function(id,+ |
+
| 63 | ++ |
+ splash_ui = tags$h2("Starting the Teal App"),
+ |
+
| 64 | ++ |
+ title = NULL,+ |
+
| 65 | ++ |
+ header = tags$p(""),
+ |
+
| 66 | ++ |
+ footer = tags$p("")) {
+ |
+
| 67 | +32x | +
+ if (checkmate::test_string(header)) {
+ |
+
| 68 | +! | +
+ header <- tags$h1(header)+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | +32x | +
+ if (checkmate::test_string(footer)) {
+ |
+
| 71 | +! | +
+ footer <- tags$p(footer)+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | +32x | +
+ checkmate::assert(+ |
+
| 74 | +32x | +
+ checkmate::check_class(splash_ui, "shiny.tag"),+ |
+
| 75 | +32x | +
+ checkmate::check_class(splash_ui, "shiny.tag.list"),+ |
+
| 76 | +32x | +
+ checkmate::check_class(splash_ui, "html")+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | +32x | +
+ checkmate::assert(+ |
+
| 79 | +32x | +
+ checkmate::check_class(header, "shiny.tag"),+ |
+
| 80 | +32x | +
+ checkmate::check_class(header, "shiny.tag.list"),+ |
+
| 81 | +32x | +
+ checkmate::check_class(header, "html")+ |
+
| 82 | ++ |
+ )+ |
+
| 83 | +32x | +
+ checkmate::assert(+ |
+
| 84 | +32x | +
+ checkmate::check_class(footer, "shiny.tag"),+ |
+
| 85 | +32x | +
+ checkmate::check_class(footer, "shiny.tag.list"),+ |
+
| 86 | +32x | +
+ checkmate::check_class(footer, "html")+ |
+
| 87 | ++ |
+ )+ |
+
| 88 | ++ | + + | +
| 89 | +32x | +
+ ns <- NS(id)+ |
+
| 90 | ++ |
+ # Once the data is loaded, we will remove this element and add the real teal UI instead+ |
+
| 91 | +32x | +
+ splash_ui <- div(+ |
+
| 92 | ++ |
+ # id so we can remove the splash screen once ready, which is the first child of this container+ |
+
| 93 | +32x | +
+ id = ns("main_ui_container"),
+ |
+
| 94 | ++ |
+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ |
+
| 95 | ++ |
+ # just the first item of the tagList)+ |
+
| 96 | +32x | +
+ div(splash_ui)+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ # show busy icon when shiny session is busy computing stuff+ |
+
| 100 | ++ |
+ # based on https://stackoverflow.com/questions/17325521/r-shiny-display-loading-message-while-function-is-running/22475216#22475216 #nolint+ |
+
| 101 | +32x | +
+ shiny_busy_message_panel <- conditionalPanel(+ |
+
| 102 | +32x | +
+ condition = "(($('html').hasClass('shiny-busy')) && (document.getElementById('shiny-notification-panel') == null))", # nolint
+ |
+
| 103 | +32x | +
+ div(+ |
+
| 104 | +32x | +
+ icon("arrows-rotate", "spin fa-spin"),
+ |
+
| 105 | +32x | +
+ "Computing ...",+ |
+
| 106 | ++ |
+ # CSS defined in `custom.css`+ |
+
| 107 | +32x | +
+ class = "shinybusymessage"+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ |
+ )+ |
+
| 110 | ++ | + + | +
| 111 | +32x | +
+ res <- fluidPage(+ |
+
| 112 | +32x | +
+ title = title,+ |
+
| 113 | +32x | +
+ theme = get_teal_bs_theme(),+ |
+
| 114 | +32x | +
+ include_teal_css_js(),+ |
+
| 115 | +32x | +
+ tags$header(header),+ |
+
| 116 | +32x | +
+ tags$hr(class = "my-2"),+ |
+
| 117 | +32x | +
+ shiny_busy_message_panel,+ |
+
| 118 | +32x | +
+ splash_ui,+ |
+
| 119 | +32x | +
+ tags$hr(),+ |
+
| 120 | +32x | +
+ tags$footer(+ |
+
| 121 | +32x | +
+ div(+ |
+
| 122 | +32x | +
+ footer,+ |
+
| 123 | +32x | +
+ teal.widgets::verbatim_popup_ui(ns("sessionInfo"), "Session Info", type = "link"),
+ |
+
| 124 | +32x | +
+ textOutput(ns("identifier"))
+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | ++ |
+ )+ |
+
| 127 | ++ |
+ )+ |
+
| 128 | +32x | +
+ return(res)+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ | + + | +
| 132 | ++ |
+ #' @rdname module_teal+ |
+
| 133 | ++ |
+ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
+ |
+
| 134 | +9x | +
+ stopifnot(is.reactive(raw_data))+ |
+
| 135 | +8x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 136 | +8x | +
+ logger::log_trace("srv_teal initializing the module.")
+ |
+
| 137 | ++ | + + | +
| 138 | +8x | +
+ output$identifier <- renderText(+ |
+
| 139 | +8x | +
+ paste0("Pid:", Sys.getpid(), " Token:", substr(session$token, 25, 32))
+ |
+
| 140 | ++ |
+ )+ |
+
| 141 | ++ | + + | +
| 142 | +8x | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 143 | +8x | +
+ "sessionInfo",+ |
+
| 144 | +8x | +
+ verbatim_content = utils::capture.output(utils::sessionInfo()),+ |
+
| 145 | +8x | +
+ title = "SessionInfo"+ |
+
| 146 | ++ |
+ )+ |
+
| 147 | ++ | + + | +
| 148 | ++ |
+ # `JavaScript` code+ |
+
| 149 | +8x | +
+ run_js_files(files = "init.js") # `JavaScript` code to make the clipboard accessible+ |
+
| 150 | ++ |
+ # set timezone in shiny app+ |
+
| 151 | ++ |
+ # timezone is set in the early beginning so it will be available also+ |
+
| 152 | ++ |
+ # for `DDL` and all shiny modules+ |
+
| 153 | +8x | +
+ get_client_timezone(session$ns)+ |
+
| 154 | +8x | +
+ observeEvent(+ |
+
| 155 | +8x | +
+ eventExpr = input$timezone,+ |
+
| 156 | +8x | +
+ once = TRUE,+ |
+
| 157 | +8x | +
+ handlerExpr = {
+ |
+
| 158 | +! | +
+ session$userData$timezone <- input$timezone+ |
+
| 159 | +! | +
+ logger::log_trace("srv_teal@1 Timezone set to client's timezone: { input$timezone }.")
+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ |
+ )+ |
+
| 162 | ++ | + + | +
| 163 | ++ |
+ # loading the data -----+ |
+
| 164 | +8x | +
+ env <- environment()+ |
+
| 165 | +8x | +
+ datasets_reactive <- reactive({
+ |
+
| 166 | +6x | +
+ if (is.null(raw_data())) {
+ |
+
| 167 | +1x | +
+ return(NULL)+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | +5x | +
+ env$progress <- shiny::Progress$new(session)+ |
+
| 170 | +5x | +
+ env$progress$set(0.25, message = "Setting data")+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ # create a list of data following structure of the nested modules list structure.+ |
+
| 173 | ++ |
+ # Because it's easier to unpack modules and datasets when they follow the same nested structure.+ |
+
| 174 | +5x | +
+ datasets_singleton <- teal.slice::init_filtered_data(raw_data())+ |
+
| 175 | ++ |
+ # Singleton starts with only global filters active.+ |
+
| 176 | +5x | +
+ filter_global <- Filter(function(x) x$id %in% attr(filter, "mapping")$global_filters, filter)+ |
+
| 177 | +5x | +
+ datasets_singleton$set_filter_state(filter_global)+ |
+
| 178 | +5x | +
+ module_datasets <- function(modules) {
+ |
+
| 179 | +19x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 180 | +8x | +
+ datasets <- lapply(modules$children, module_datasets)+ |
+
| 181 | +8x | +
+ labels <- vapply(modules$children, `[[`, character(1), "label")+ |
+
| 182 | +8x | +
+ names(datasets) <- labels+ |
+
| 183 | +8x | +
+ datasets+ |
+
| 184 | +11x | +
+ } else if (isTRUE(attr(filter, "module_specific"))) {
+ |
+
| 185 | ++ |
+ # we should create FilteredData even if modules$datanames is null+ |
+
| 186 | ++ |
+ # null controls a display of filter panel but data should be still passed+ |
+
| 187 | +3x | +
+ datanames <- if (is.null(modules$datanames)) raw_data()$get_datanames() else modules$datanames+ |
+
| 188 | +3x | +
+ data_objects <- sapply(+ |
+
| 189 | +3x | +
+ datanames,+ |
+
| 190 | +3x | +
+ function(dataname) {
+ |
+
| 191 | +6x | +
+ dataset <- raw_data()$get_dataset(dataname)+ |
+
| 192 | +6x | +
+ list(+ |
+
| 193 | +6x | +
+ dataset = dataset$get_raw_data(),+ |
+
| 194 | +6x | +
+ metadata = dataset$get_metadata(),+ |
+
| 195 | +6x | +
+ label = dataset$get_dataset_label()+ |
+
| 196 | ++ |
+ )+ |
+
| 197 | ++ |
+ },+ |
+
| 198 | +3x | +
+ simplify = FALSE+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | +3x | +
+ datasets_module <- teal.slice::init_filtered_data(+ |
+
| 201 | +3x | +
+ data_objects,+ |
+
| 202 | +3x | +
+ join_keys = raw_data()$get_join_keys(),+ |
+
| 203 | +3x | +
+ code = raw_data()$get_code_class(),+ |
+
| 204 | +3x | +
+ check = raw_data()$get_check()+ |
+
| 205 | ++ |
+ )+ |
+
| 206 | ++ | + + | +
| 207 | ++ |
+ # set initial filters+ |
+
| 208 | +3x | +
+ slices <- Filter(x = filter, f = function(x) {
+ |
+
| 209 | +! | +
+ x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) &&+ |
+
| 210 | +! | +
+ x$dataname %in% datanames+ |
+
| 211 | ++ |
+ })+ |
+
| 212 | +3x | +
+ include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames]+ |
+
| 213 | +3x | +
+ exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames]+ |
+
| 214 | +3x | +
+ slices$include_varnames <- include_varnames+ |
+
| 215 | +3x | +
+ slices$exclude_varnames <- exclude_varnames+ |
+
| 216 | +3x | +
+ datasets_module$set_filter_state(slices)+ |
+
| 217 | +3x | +
+ datasets_module+ |
+
| 218 | ++ |
+ } else {
+ |
+
| 219 | +8x | +
+ datasets_singleton+ |
+
| 220 | ++ |
+ }+ |
+
| 221 | ++ |
+ }+ |
+
| 222 | +5x | +
+ datasets <- module_datasets(modules)+ |
+
| 223 | ++ | + + | +
| 224 | +5x | +
+ logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.")
+ |
+
| 225 | +5x | +
+ datasets+ |
+
| 226 | ++ |
+ })+ |
+
| 227 | ++ | + + | +
| 228 | +8x | +
+ reporter <- teal.reporter::Reporter$new()+ |
+
| 229 | +8x | +
+ is_any_previewer <- function(modules) {
+ |
+
| 230 | +! | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 231 | +! | +
+ any(unlist(lapply(modules$children, is_any_previewer), use.names = FALSE))+ |
+
| 232 | +! | +
+ } else if (inherits(modules, "teal_module_previewer")) {
+ |
+
| 233 | +! | +
+ TRUE+ |
+
| 234 | ++ |
+ } else {
+ |
+
| 235 | +! | +
+ FALSE+ |
+
| 236 | ++ |
+ }+ |
+
| 237 | ++ |
+ }+ |
+
| 238 | +8x | +
+ if (is_arg_used(modules, "reporter") && !is_any_previewer(modules)) {
+ |
+
| 239 | +! | +
+ modules <- append_module(modules, reporter_previewer_module())+ |
+
| 240 | ++ |
+ }+ |
+
| 241 | ++ | + + | +
| 242 | ++ |
+ # Replace splash / welcome screen once data is loaded ----+ |
+
| 243 | ++ |
+ # ignoreNULL to not trigger at the beginning when data is NULL+ |
+
| 244 | ++ |
+ # just handle it once because data obtained through delayed loading should+ |
+
| 245 | ++ |
+ # usually not change afterwards+ |
+
| 246 | ++ |
+ # if restored from bookmarked state, `filter` is ignored+ |
+
| 247 | +8x | +
+ observeEvent(datasets_reactive(), ignoreNULL = TRUE, once = TRUE, {
+ |
+
| 248 | +1x | +
+ logger::log_trace("srv_teal@5 setting main ui after data was pulled")
+ |
+
| 249 | +1x | +
+ env$progress$set(0.5, message = "Setting up main UI")+ |
+
| 250 | +1x | +
+ on.exit(env$progress$close())+ |
+
| 251 | ++ |
+ # main_ui_container contains splash screen first and we remove it and replace it by the real UI+ |
+
| 252 | ++ | + + | +
| 253 | +1x | +
+ removeUI(sprintf("#%s:first-child", session$ns("main_ui_container")))
+ |
+
| 254 | +1x | +
+ insertUI(+ |
+
| 255 | +1x | +
+ selector = paste0("#", session$ns("main_ui_container")),
+ |
+
| 256 | +1x | +
+ where = "beforeEnd",+ |
+
| 257 | ++ |
+ # we put it into a div, so it can easily be removed as a whole, also when it is a tagList (and not+ |
+
| 258 | ++ |
+ # just the first item of the tagList)+ |
+
| 259 | +1x | +
+ ui = div(ui_tabs_with_filters(+ |
+
| 260 | +1x | +
+ session$ns("main_ui"),
+ |
+
| 261 | +1x | +
+ modules = modules,+ |
+
| 262 | +1x | +
+ datasets = datasets_reactive(),+ |
+
| 263 | +1x | +
+ filter = filter+ |
+
| 264 | ++ |
+ )),+ |
+
| 265 | ++ |
+ # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not+ |
+
| 266 | ++ |
+ # have any effect as they are ignored when not present+ |
+
| 267 | +1x | +
+ immediate = TRUE+ |
+
| 268 | ++ |
+ )+ |
+
| 269 | ++ | + + | +
| 270 | ++ |
+ # must make sure that this is only executed once as modules assume their observers are only+ |
+
| 271 | ++ |
+ # registered once (calling server functions twice would trigger observers twice each time)+ |
+
| 272 | +1x | +
+ active_module <- srv_tabs_with_filters(+ |
+
| 273 | +1x | +
+ id = "main_ui",+ |
+
| 274 | +1x | +
+ datasets = datasets_reactive(),+ |
+
| 275 | +1x | +
+ modules = modules,+ |
+
| 276 | +1x | +
+ reporter = reporter,+ |
+
| 277 | +1x | +
+ filter = filter+ |
+
| 278 | ++ |
+ )+ |
+
| 279 | +1x | +
+ return(active_module)+ |
+
| 280 | ++ |
+ })+ |
+
| 281 | ++ |
+ })+ |
+
| 282 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Create a `tdata` Object+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Create a new object called `tdata` which contains `data`, a `reactive` list of data.frames+ |
+
| 4 | ++ |
+ #' (or `MultiAssayExperiment`), with attributes:+ |
+
| 5 | ++ |
+ #' \itemize{
+ |
+
| 6 | ++ |
+ #' \item{`code` (`reactive`) containing code used to generate the data}
+ |
+
| 7 | ++ |
+ #' \item{join_keys (`JoinKeys`) containing the relationships between the data}
+ |
+
| 8 | ++ |
+ #' \item{metadata (`named list`) containing any metadata associated with the data frames}
+ |
+
| 9 | ++ |
+ #' }+ |
+
| 10 | ++ |
+ #' @name tdata+ |
+
| 11 | ++ |
+ #' @param data A `named list` of `data.frames` (or `MultiAssayExperiment`)+ |
+
| 12 | ++ |
+ #' which optionally can be `reactive`.+ |
+
| 13 | ++ |
+ #' Inside this object all of these items will be made `reactive`.+ |
+
| 14 | ++ |
+ #' @param code A `character` (or `reactive` which evaluates to a `character`) containing+ |
+
| 15 | ++ |
+ #' the code used to generate the data. This should be `reactive` if the code is changing+ |
+
| 16 | ++ |
+ #' during a reactive context (e.g. if filtering changes the code). Inside this+ |
+
| 17 | ++ |
+ #' object `code` will be made reactive+ |
+
| 18 | ++ |
+ #' @param join_keys A `teal.data::JoinKeys` object containing relationships between the+ |
+
| 19 | ++ |
+ #' datasets.+ |
+
| 20 | ++ |
+ #' @param metadata A `named list` each element contains a list of metadata about the named data.frame+ |
+
| 21 | ++ |
+ #' Each element of these list should be atomic and length one.+ |
+
| 22 | ++ |
+ #' @return A `tdata` object+ |
+
| 23 | ++ |
+ #' @examples+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' data <- new_tdata(+ |
+
| 26 | ++ |
+ #' data = list(iris = iris, mtcars = reactive(mtcars), dd = data.frame(x = 1:10)),+ |
+
| 27 | ++ |
+ #' code = "iris <- iris+ |
+
| 28 | ++ |
+ #' mtcars <- mtcars+ |
+
| 29 | ++ |
+ #' dd <- data.frame(x = 1:10)",+ |
+
| 30 | ++ |
+ #' metadata = list(dd = list(author = "NEST"), iris = list(version = 1))+ |
+
| 31 | ++ |
+ #' )+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' # Extract a data.frame+ |
+
| 34 | ++ |
+ #' isolate(data[["iris"]]())+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' # Get code+ |
+
| 37 | ++ |
+ #' isolate(get_code(data))+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' # Get metadata+ |
+
| 40 | ++ |
+ #' get_metadata(data, "iris")+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @export+ |
+
| 43 | ++ |
+ new_tdata <- function(data, code = "", join_keys = NULL, metadata = NULL) {
+ |
+
| 44 | +40x | +
+ checkmate::assert_list(+ |
+
| 45 | +40x | +
+ data,+ |
+
| 46 | +40x | +
+ any.missing = FALSE, names = "unique",+ |
+
| 47 | +40x | +
+ types = c("data.frame", "reactive", "MultiAssayExperiment")
+ |
+
| 48 | ++ |
+ )+ |
+
| 49 | +36x | +
+ checkmate::assert_class(join_keys, "JoinKeys", null.ok = TRUE)+ |
+
| 50 | +35x | +
+ checkmate::assert_multi_class(code, c("character", "reactive"))
+ |
+
| 51 | ++ | + + | +
| 52 | +34x | +
+ checkmate::assert_list(metadata, names = "unique", null.ok = TRUE)+ |
+
| 53 | +32x | +
+ checkmate::assert_subset(names(metadata), names(data))+ |
+
| 54 | +20x | +
+ for (m in metadata) teal.data::validate_metadata(m)+ |
+
| 55 | ++ | + + | +
| 56 | +31x | +
+ if (is.reactive(code)) {
+ |
+
| 57 | +15x | +
+ isolate(checkmate::assert_class(code(), "character", .var.name = "code"))+ |
+
| 58 | ++ |
+ }+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ # create reactive data.frames+ |
+
| 61 | +30x | +
+ for (x in names(data)) {
+ |
+
| 62 | +49x | +
+ if (!is.reactive(data[[x]])) {
+ |
+
| 63 | +29x | +
+ data[[x]] <- do.call(reactive, list(as.name(x)), envir = list2env(data[x]))+ |
+
| 64 | ++ |
+ } else {
+ |
+
| 65 | +20x | +
+ isolate(+ |
+
| 66 | +20x | +
+ checkmate::assert_multi_class(+ |
+
| 67 | +20x | +
+ data[[x]](), c("data.frame", "MultiAssayExperiment"),
+ |
+
| 68 | +20x | +
+ .var.name = "data"+ |
+
| 69 | ++ |
+ )+ |
+
| 70 | ++ |
+ )+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ | + + | +
| 74 | ++ |
+ # set attributes+ |
+
| 75 | +29x | +
+ attr(data, "code") <- if (is.reactive(code)) code else reactive(code)+ |
+
| 76 | +29x | +
+ attr(data, "join_keys") <- join_keys+ |
+
| 77 | +29x | +
+ attr(data, "metadata") <- metadata+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ # set class+ |
+
| 80 | +29x | +
+ class(data) <- c("tdata", class(data))
+ |
+
| 81 | +29x | +
+ data+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ #' Function to convert a `tdata` object to an `environment`+ |
+
| 85 | ++ |
+ #' Any `reactives` inside `tdata` are first evaluated+ |
+
| 86 | ++ |
+ #' @param data a `tdata` object+ |
+
| 87 | ++ |
+ #' @return an `environment`+ |
+
| 88 | ++ |
+ #' @examples+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' data <- new_tdata(+ |
+
| 91 | ++ |
+ #' data = list(iris = iris, mtcars = reactive(mtcars)),+ |
+
| 92 | ++ |
+ #' code = "iris <- iris+ |
+
| 93 | ++ |
+ #' mtcars = mtcars"+ |
+
| 94 | ++ |
+ #' )+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' my_env <- isolate(tdata2env(data))+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ #' @export+ |
+
| 99 | ++ |
+ tdata2env <- function(data) { # nolint
+ |
+
| 100 | +2x | +
+ checkmate::assert_class(data, "tdata")+ |
+
| 101 | +1x | +
+ list2env(lapply(data, function(x) if (is.reactive(x)) x() else x))+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ #' @rdname tdata+ |
+
| 105 | ++ |
+ #' @param x a `tdata` object+ |
+
| 106 | ++ |
+ #' @param ... additional arguments for the generic+ |
+
| 107 | ++ |
+ #' @export+ |
+
| 108 | ++ |
+ get_code.tdata <- function(x, ...) { # nolint
+ |
+
| 109 | ++ |
+ # note teal.data which teal depends on defines the get_code method+ |
+
| 110 | +6x | +
+ attr(x, "code")()+ |
+
| 111 | ++ |
+ }+ |
+
| 112 | ++ | + + | +
| 113 | ++ | + + | +
| 114 | ++ |
+ #' Wrapper for `get_code.tdata`+ |
+
| 115 | ++ |
+ #' This wrapper is to be used by downstream packages to extract the code of a `tdata` object+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ #' @param data (`tdata`) object+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @return (`character`) code used in the `tdata` object.+ |
+
| 120 | ++ |
+ #' @export+ |
+
| 121 | ++ |
+ get_code_tdata <- function(data) {
+ |
+
| 122 | +4x | +
+ checkmate::assert_class(data, "tdata")+ |
+
| 123 | +2x | +
+ get_code(data)+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | ++ | + + | +
| 126 | ++ | + + | +
| 127 | ++ |
+ #' Function to get join keys from a `tdata` object+ |
+
| 128 | ++ |
+ #' @param data `tdata` - object to extract the join keys+ |
+
| 129 | ++ |
+ #' @return Either `JoinKeys` object or `NULL` if no join keys+ |
+
| 130 | ++ |
+ #' @export+ |
+
| 131 | ++ |
+ get_join_keys <- function(data) {
+ |
+
| 132 | +3x | +
+ UseMethod("get_join_keys", data)
+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | ++ | + + | +
| 135 | ++ | + + | +
| 136 | ++ |
+ #' @rdname get_join_keys+ |
+
| 137 | ++ |
+ #' @export+ |
+
| 138 | ++ |
+ get_join_keys.tdata <- function(data) {
+ |
+
| 139 | +3x | +
+ attr(data, "join_keys")+ |
+
| 140 | ++ |
+ }+ |
+
| 141 | ++ | + + | +
| 142 | ++ | + + | +
| 143 | ++ |
+ #' @rdname get_join_keys+ |
+
| 144 | ++ |
+ #' @export+ |
+
| 145 | ++ |
+ get_join_keys.default <- function(data) {
+ |
+
| 146 | +! | +
+ stop("get_join_keys function not implemented for this object")
+ |
+
| 147 | ++ |
+ }+ |
+
| 148 | ++ | + + | +
| 149 | ++ |
+ #' Function to get metadata from a `tdata` object+ |
+
| 150 | ++ |
+ #' @param data `tdata` - object to extract the data from+ |
+
| 151 | ++ |
+ #' @param dataname `character(1)` the dataset name whose metadata is requested+ |
+
| 152 | ++ |
+ #' @return Either list of metadata or NULL if no metadata+ |
+
| 153 | ++ |
+ #' @export+ |
+
| 154 | ++ |
+ get_metadata <- function(data, dataname) {
+ |
+
| 155 | +6x | +
+ checkmate::assert_string(dataname)+ |
+
| 156 | +6x | +
+ UseMethod("get_metadata", data)
+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | ++ |
+ #' @rdname get_metadata+ |
+
| 160 | ++ |
+ #' @export+ |
+
| 161 | ++ |
+ get_metadata.tdata <- function(data, dataname) {
+ |
+
| 162 | +6x | +
+ metadata <- attr(data, "metadata")+ |
+
| 163 | +6x | +
+ if (is.null(metadata)) {
+ |
+
| 164 | +1x | +
+ return(NULL)+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | +5x | +
+ metadata[[dataname]]+ |
+
| 167 | ++ |
+ }+ |
+
| 168 | ++ | + + | +
| 169 | ++ |
+ #' @rdname get_metadata+ |
+
| 170 | ++ |
+ #' @export+ |
+
| 171 | ++ |
+ get_metadata.default <- function(data, dataname) {
+ |
+
| 172 | +! | +
+ stop("get_metadata function not implemented for this object")
+ |
+
| 173 | ++ |
+ }+ |
+
| 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 | +32x | +
+ css_files <- list.files(+ |
+
| 13 | +32x | +
+ system.file("css", package = "teal", mustWork = TRUE),
+ |
+
| 14 | +32x | +
+ pattern = pattern, full.names = TRUE+ |
+
| 15 | ++ |
+ )+ |
+
| 16 | +32x | +
+ return(+ |
+
| 17 | +32x | +
+ shiny::singleton(+ |
+
| 18 | +32x | +
+ shiny::tags$head(lapply(css_files, shiny::includeCSS))+ |
+
| 19 | ++ |
+ )+ |
+
| 20 | ++ |
+ )+ |
+
| 21 | ++ |
+ }+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ #' Include `JS` files from `/inst/js/` package directory to application header+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' `system.file` should not be used to access files in other packages, it does+ |
+
| 26 | ++ |
+ #' not work with `devtools`. Therefore, we redefine this method in each package+ |
+
| 27 | ++ |
+ #' as needed. Thus, we do not export this method+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ |
+
| 30 | ++ |
+ #' @param except (`character`) vector of basename filenames to be excluded+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @return HTML code that includes `JS` files+ |
+
| 33 | ++ |
+ #' @keywords internal+ |
+
| 34 | ++ |
+ include_js_files <- function(pattern = NULL, except = NULL) {
+ |
+
| 35 | +32x | +
+ checkmate::assert_character(except, min.len = 1, any.missing = FALSE, null.ok = TRUE)+ |
+
| 36 | +32x | +
+ js_files <- list.files(system.file("js", package = "teal", mustWork = TRUE), pattern = pattern, full.names = TRUE)
+ |
+
| 37 | +32x | +
+ js_files <- js_files[!(basename(js_files) %in% except)] # no-op if except is NULL+ |
+
| 38 | ++ | + + | +
| 39 | +32x | +
+ return(singleton(lapply(js_files, includeScript)))+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ #' Run `JS` file from `/inst/js/` package directory+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' This is triggered from the server to execute on the client+ |
+
| 45 | ++ |
+ #' rather than triggered directly on the client.+ |
+
| 46 | ++ |
+ #' Unlike `include_js_files` which includes `JavaScript` functions,+ |
+
| 47 | ++ |
+ #' the `run_js` actually executes `JavaScript` functions.+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' `system.file` should not be used to access files in other packages, it does+ |
+
| 50 | ++ |
+ #' not work with `devtools`. Therefore, we redefine this method in each package+ |
+
| 51 | ++ |
+ #' as needed. Thus, we do not export this method+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' @param files (`character`) vector of filenames+ |
+
| 54 | ++ |
+ #' @keywords internal+ |
+
| 55 | ++ |
+ run_js_files <- function(files) {
+ |
+
| 56 | +8x | +
+ checkmate::assert_character(files, min.len = 1, any.missing = FALSE)+ |
+
| 57 | +8x | +
+ lapply(files, function(file) {
+ |
+
| 58 | +8x | +
+ shinyjs::runjs(paste0(readLines(system.file("js", file, package = "teal", mustWork = TRUE)), collapse = "\n"))
+ |
+
| 59 | ++ |
+ })+ |
+
| 60 | +8x | +
+ return(invisible(NULL))+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ #' Code to include teal `CSS` and `JavaScript` files+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' This is useful when you want to use the same `JavaScript` and `CSS` files that are+ |
+
| 66 | ++ |
+ #' used with the teal application.+ |
+
| 67 | ++ |
+ #' This is also useful for running standalone modules in teal with the correct+ |
+
| 68 | ++ |
+ #' styles.+ |
+
| 69 | ++ |
+ #' Also initializes `shinyjs` so you can use it.+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @return HTML code to include+ |
+
| 72 | ++ |
+ #' @examples+ |
+
| 73 | ++ |
+ #' shiny_ui <- tagList(+ |
+
| 74 | ++ |
+ #' teal:::include_teal_css_js(),+ |
+
| 75 | ++ |
+ #' p("Hello")
+ |
+
| 76 | ++ |
+ #' )+ |
+
| 77 | ++ |
+ #' @keywords internal+ |
+
| 78 | ++ |
+ include_teal_css_js <- function() {
+ |
+
| 79 | +32x | +
+ tagList(+ |
+
| 80 | +32x | +
+ shinyjs::useShinyjs(),+ |
+
| 81 | +32x | +
+ include_css_files(),+ |
+
| 82 | ++ |
+ # init.js is executed from the server+ |
+
| 83 | +32x | +
+ include_js_files(except = "init.js"),+ |
+
| 84 | +32x | +
+ shinyjs::hidden(icon("gear")), # add hidden icon to load font-awesome css for icons
+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ |
+ }+ |
+
| 1 | ++ |
+ # This file adds a splash screen for delayed data loading on top of teal+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ #' UI to show a splash screen in the beginning, then delegate to [srv_teal()]+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 6 | ++ |
+ #' The splash screen could be used to query for a password to fetch the data.+ |
+
| 7 | ++ |
+ #' [init()] is a very thin wrapper around this module useful for end-users which+ |
+
| 8 | ++ |
+ #' assumes that it is a top-level module and cannot be embedded.+ |
+
| 9 | ++ |
+ #' This function instead adheres to the Shiny module conventions.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' If data is obtained through delayed loading, its splash screen is used. Otherwise,+ |
+
| 12 | ++ |
+ #' a default splash screen is shown.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' Please also refer to the doc of [init()].+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 17 | ++ |
+ #' module id+ |
+
| 18 | ++ |
+ #' @inheritParams init+ |
+
| 19 | ++ |
+ #' @export+ |
+
| 20 | ++ |
+ ui_teal_with_splash <- function(id,+ |
+
| 21 | ++ |
+ data,+ |
+
| 22 | ++ |
+ title,+ |
+
| 23 | ++ |
+ header = tags$p("Add Title Here"),
+ |
+
| 24 | ++ |
+ footer = tags$p("Add Footer Here")) {
+ |
+
| 25 | +32x | +
+ checkmate::assert_class(data, "TealDataAbstract")+ |
+
| 26 | +32x | +
+ is_pulled_data <- teal.data::is_pulled(data)+ |
+
| 27 | +32x | +
+ ns <- NS(id)+ |
+
| 28 | ++ | + + | +
| 29 | ++ |
+ # Startup splash screen for delayed loading+ |
+
| 30 | ++ |
+ # We use delayed loading in all cases, even when the data does not need to be fetched.+ |
+
| 31 | ++ |
+ # This has the benefit that when filtering the data takes a lot of time initially, the+ |
+
| 32 | ++ |
+ # Shiny app does not time out.+ |
+
| 33 | +32x | +
+ splash_ui <- if (is_pulled_data) {
+ |
+
| 34 | ++ |
+ # blank ui if data is already pulled+ |
+
| 35 | +28x | +
+ div()+ |
+
| 36 | ++ |
+ } else {
+ |
+
| 37 | +4x | +
+ message("App was initialized with delayed data loading.")
+ |
+
| 38 | +4x | +
+ data$get_ui(ns("startapp_module"))
+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | +32x | +
+ ui_teal(id = ns("teal"), splash_ui = splash_ui, title = title, header = header, footer = footer)
+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' Server function that loads the data through reactive loading and then delegates+ |
+
| 45 | ++ |
+ #' to [srv_teal()].+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 48 | ++ |
+ #' Please also refer to the doc of [init()].+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @inheritParams init+ |
+
| 51 | ++ |
+ #' @param modules `teal_modules` object containing the output modules which+ |
+
| 52 | ++ |
+ #' will be displayed in the teal application. See [modules()] and [module()] for+ |
+
| 53 | ++ |
+ #' more details.+ |
+
| 54 | ++ |
+ #' @inheritParams shiny::moduleServer+ |
+
| 55 | ++ |
+ #' @return `reactive`, return value of [srv_teal()]+ |
+
| 56 | ++ |
+ #' @export+ |
+
| 57 | ++ |
+ srv_teal_with_splash <- function(id, data, modules, filter = teal_slices()) {
+ |
+
| 58 | +4x | +
+ checkmate::assert_class(data, "TealDataAbstract")+ |
+
| 59 | +4x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 60 | +4x | +
+ logger::log_trace(+ |
+
| 61 | +4x | +
+ "srv_teal_with_splash initializing module with data { paste(data$get_datanames(), collapse = ' ')}."
+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | ++ | + + | +
| 64 | +4x | +
+ if (getOption("teal.show_js_log", default = FALSE)) {
+ |
+
| 65 | +! | +
+ shinyjs::showLog()+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ | + + | +
| 68 | +4x | +
+ is_pulled_data <- teal.data::is_pulled(data)+ |
+
| 69 | ++ |
+ # raw_data contains TealDataAbstract, i.e. R6 object and container for data+ |
+
| 70 | ++ |
+ # reactive to get data through delayed loading+ |
+
| 71 | ++ |
+ # we must leave it inside the server because of callModule which needs to pick up the right session+ |
+
| 72 | +4x | +
+ if (is_pulled_data) {
+ |
+
| 73 | +2x | +
+ raw_data <- reactiveVal(data) # will trigger by setting it+ |
+
| 74 | ++ |
+ } else {
+ |
+
| 75 | +2x | +
+ raw_data <- data$get_server()(id = "startapp_module")+ |
+
| 76 | +2x | +
+ if (!is.reactive(raw_data)) {
+ |
+
| 77 | +! | +
+ stop("The delayed loading module has to return a reactive object.")
+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | ++ | + + | +
| 81 | +4x | +
+ res <- srv_teal(id = "teal", modules = modules, raw_data = raw_data, filter = filter)+ |
+
| 82 | +4x | +
+ logger::log_trace(+ |
+
| 83 | +4x | +
+ "srv_teal_with_splash initialized the module with data { paste(data$get_datanames(), collapse = ' ') }."
+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | +4x | +
+ return(res)+ |
+
| 86 | ++ |
+ })+ |
+
| 87 | ++ |
+ }+ |
+
| 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 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' The snapshot manager is accessed through the filter manager, with the cog icon in the top right corner.+ |
+
| 10 | ++ |
+ #' At the beginning of a session it presents two icons: a camera and an circular arrow.+ |
+
| 11 | ++ |
+ #' Clicking the camera captures a snapshot and clicking the arrow resets initial application state.+ |
+
| 12 | ++ |
+ #' As snapshots are added, they will show up as rows in a table and each will have a select button and a save button.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @section Server logic:+ |
+
| 15 | ++ |
+ #' Snapshots are basically `teal_slices` objects, however, since each module is served by a separate instance+ |
+
| 16 | ++ |
+ #' of `FilteredData` and these objects require shared state, `teal_slice` is a `reactiveVal` so `teal_slices`+ |
+
| 17 | ++ |
+ #' cannot be stored as is. Therefore, `teal_slices` are reversibly converted to a list of lists representation+ |
+
| 18 | ++ |
+ #' (attributes are maintained).+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' Snapshots are stored in a `reactiveVal` as a named list.+ |
+
| 21 | ++ |
+ #' The first snapshot is the initial state of the application and the user can add a snapshot whenever they see fit.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' For every snapshot except the initial one, a piece of UI is generated that contains+ |
+
| 24 | ++ |
+ #' the snapshot name, a select button to restore that snapshot, and a save button to save it to a file.+ |
+
| 25 | ++ |
+ #' The initial snapshot is restored by a separate "reset" button.+ |
+
| 26 | ++ |
+ #' It cannot be saved directly but a user is welcome to capture the initial state as a snapshot and save that.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @section Snapshot mechanics:+ |
+
| 29 | ++ |
+ #' When a snapshot is captured, the user is prompted to name it.+ |
+
| 30 | ++ |
+ #' Names are displayed as is but since they are used to create button ids,+ |
+
| 31 | ++ |
+ #' under the hood they are converted to syntactically valid strings.+ |
+
| 32 | ++ |
+ #' New snapshot names are validated so that their valid versions are unique.+ |
+
| 33 | ++ |
+ #' Leading and trailing white space is trimmed.+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' The module can read the global state of the application from `slices_global` and `mapping_matrix`.+ |
+
| 36 | ++ |
+ #' The former provides a list of all existing `teal_slice`s and the latter says which slice is active in which module.+ |
+
| 37 | ++ |
+ #' Once a name has been accepted, `slices_global` is converted to a list of lists - a snapshot.+ |
+
| 38 | ++ |
+ #' The snapshot contains the `mapping` attribute of the initial application state+ |
+
| 39 | ++ |
+ #' (or one that has been restored), which may not reflect the current one,+ |
+
| 40 | ++ |
+ #' so `mapping_matrix` is transformed to obtain the current mapping, i.e. a list that,+ |
+
| 41 | ++ |
+ #' when passed to the `mapping` argument of [`teal::teal_slices`], would result in the current mapping.+ |
+
| 42 | ++ |
+ #' This is substituted as the snapshot's `mapping` attribute and the snapshot is added to the snapshot list.+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' To restore app state, a snapshot is retrieved from storage and rebuilt into a `teal_slices` object.+ |
+
| 45 | ++ |
+ #' Then state of all `FilteredData` objects (provided in `filtered_data_list`) is cleared+ |
+
| 46 | ++ |
+ #' and set anew according to the `mapping` attribute of the snapshot.+ |
+
| 47 | ++ |
+ #' The snapshot is then set as the current content of `slices_global`.+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' To save a snapshot, the snapshot is retrieved and reassembled just like for restoring,+ |
+
| 50 | ++ |
+ #' and then saved to file with [`teal.slice::slices_store`].+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' @param id (`character(1)`) `shiny` module id+ |
+
| 53 | ++ |
+ #' @param slices_global (`reactiveVal`) that contains a `teal_slices` object+ |
+
| 54 | ++ |
+ #' containing all `teal_slice`s existing in the app, both active and inactive+ |
+
| 55 | ++ |
+ #' @param mapping_matrix (`reactive`) that contains a `data.frame` representation+ |
+
| 56 | ++ |
+ #' of the mapping of filter state ids (rows) to modules labels (columns);+ |
+
| 57 | ++ |
+ #' all columns are `logical` vectors+ |
+
| 58 | ++ |
+ #' @param filtered_data_list non-nested (`named list`) that contains `FilteredData` objects+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' @return Nothing is returned.+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @name snapshot_manager_module+ |
+
| 63 | ++ |
+ #' @aliases snapshot snapshot_manager+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' @author Aleksander Chlebowski+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @rdname snapshot_manager_module+ |
+
| 68 | ++ |
+ #' @keywords internal+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ snapshot_manager_ui <- function(id) {
+ |
+
| 71 | +! | +
+ ns <- NS(id)+ |
+
| 72 | +! | +
+ div(+ |
+
| 73 | +! | +
+ class = "snapshot_manager_content",+ |
+
| 74 | +! | +
+ div(+ |
+
| 75 | +! | +
+ class = "snapshot_table_row",+ |
+
| 76 | +! | +
+ span(tags$b("Snapshot manager")),
+ |
+
| 77 | +! | +
+ actionLink(ns("snapshot_add"), label = NULL, icon = icon("camera"), title = "add snapshot"),
+ |
+
| 78 | +! | +
+ actionLink(ns("snapshot_reset"), label = NULL, icon = icon("undo"), title = "reset initial state"),
+ |
+
| 79 | +! | +
+ NULL+ |
+
| 80 | ++ |
+ ),+ |
+
| 81 | +! | +
+ uiOutput(ns("snapshot_list"))
+ |
+
| 82 | ++ |
+ )+ |
+
| 83 | ++ |
+ }+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ #' @rdname snapshot_manager_module+ |
+
| 86 | ++ |
+ #' @keywords internal+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ snapshot_manager_srv <- function(id, slices_global, mapping_matrix, filtered_data_list) {
+ |
+
| 89 | +7x | +
+ checkmate::assert_character(id)+ |
+
| 90 | +7x | +
+ checkmate::assert_true(is.reactive(slices_global))+ |
+
| 91 | +7x | +
+ checkmate::assert_class(isolate(slices_global()), "teal_slices")+ |
+
| 92 | +7x | +
+ checkmate::assert_true(is.reactive(mapping_matrix))+ |
+
| 93 | +7x | +
+ checkmate::assert_data_frame(isolate(mapping_matrix()), null.ok = TRUE)+ |
+
| 94 | +7x | +
+ checkmate::assert_list(filtered_data_list, types = "FilteredData", any.missing = FALSE, names = "named")+ |
+
| 95 | ++ | + + | +
| 96 | +7x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 97 | +7x | +
+ ns <- session$ns+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ # Store global filter states.+ |
+
| 100 | +7x | +
+ filter <- isolate(slices_global())+ |
+
| 101 | +7x | +
+ snapshot_history <- reactiveVal({
+ |
+
| 102 | +7x | +
+ list(+ |
+
| 103 | +7x | +
+ "Initial application state" = as.list(filter, recursive = TRUE)+ |
+
| 104 | ++ |
+ )+ |
+
| 105 | ++ |
+ })+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ # Snapshot current application state - name snaphsot.+ |
+
| 108 | +7x | +
+ observeEvent(input$snapshot_add, {
+ |
+
| 109 | +! | +
+ showModal(+ |
+
| 110 | +! | +
+ modalDialog(+ |
+
| 111 | +! | +
+ textInput(ns("snapshot_name"), "Name the snapshot", width = "100%", placeholder = "Meaningful, unique name"),
+ |
+
| 112 | +! | +
+ footer = tagList(+ |
+
| 113 | +! | +
+ actionButton(ns("snapshot_name_accept"), "Accept", icon = icon("thumbs-up")),
+ |
+
| 114 | +! | +
+ modalButton(label = "Cancel", icon = icon("thumbs-down"))
+ |
+
| 115 | ++ |
+ ),+ |
+
| 116 | +! | +
+ size = "s"+ |
+
| 117 | ++ |
+ )+ |
+
| 118 | ++ |
+ )+ |
+
| 119 | ++ |
+ })+ |
+
| 120 | ++ |
+ # Snapshot current application state - store snaphsot.+ |
+
| 121 | +7x | +
+ observeEvent(input$snapshot_name_accept, {
+ |
+
| 122 | +! | +
+ snapshot_name <- trimws(input$snapshot_name)+ |
+
| 123 | +! | +
+ if (identical(snapshot_name, "")) {
+ |
+
| 124 | +! | +
+ showNotification(+ |
+
| 125 | +! | +
+ "Please name the snapshot.",+ |
+
| 126 | +! | +
+ type = "message"+ |
+
| 127 | ++ |
+ )+ |
+
| 128 | +! | +
+ updateTextInput(inputId = "snapshot_name", value = "", placeholder = "Meaningful, unique name")+ |
+
| 129 | +! | +
+ } else if (is.element(make.names(snapshot_name), make.names(names(snapshot_history())))) {
+ |
+
| 130 | +! | +
+ showNotification(+ |
+
| 131 | +! | +
+ "This name is in conflict with other snapshot names. Please choose a different one.",+ |
+
| 132 | +! | +
+ type = "message"+ |
+
| 133 | ++ |
+ )+ |
+
| 134 | +! | +
+ updateTextInput(inputId = "snapshot_name", value = , placeholder = "Meaningful, unique name")+ |
+
| 135 | ++ |
+ } else {
+ |
+
| 136 | +! | +
+ snapshot <- as.list(slices_global(), recursive = TRUE)+ |
+
| 137 | +! | +
+ attr(snapshot, "mapping") <- matrix_to_mapping(mapping_matrix())+ |
+
| 138 | +! | +
+ snapshot_update <- c(snapshot_history(), list(snapshot))+ |
+
| 139 | +! | +
+ names(snapshot_update)[length(snapshot_update)] <- snapshot_name+ |
+
| 140 | +! | +
+ snapshot_history(snapshot_update)+ |
+
| 141 | +! | +
+ removeModal()+ |
+
| 142 | ++ |
+ # Reopen filter manager modal by clicking button in the main application.+ |
+
| 143 | +! | +
+ shinyjs::click(id = "teal-main_ui-filter_manager-show", asis = TRUE)+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | ++ |
+ })+ |
+
| 146 | ++ | + + | +
| 147 | ++ |
+ # Restore initial state.+ |
+
| 148 | +7x | +
+ observeEvent(input$snapshot_reset, {
+ |
+
| 149 | +! | +
+ s <- "Initial application state"+ |
+
| 150 | ++ |
+ ### Begin restore procedure. ###+ |
+
| 151 | +! | +
+ snapshot <- snapshot_history()[[s]]+ |
+
| 152 | +! | +
+ snapshot_state <- as.teal_slices(snapshot)+ |
+
| 153 | +! | +
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ |
+
| 154 | +! | +
+ mapply(+ |
+
| 155 | +! | +
+ function(filtered_data, filter_ids) {
+ |
+
| 156 | +! | +
+ filtered_data$clear_filter_states(force = TRUE)+ |
+
| 157 | +! | +
+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ |
+
| 158 | +! | +
+ filtered_data$set_filter_state(slices)+ |
+
| 159 | ++ |
+ },+ |
+
| 160 | +! | +
+ filtered_data = filtered_data_list,+ |
+
| 161 | +! | +
+ filter_ids = mapping_unfolded+ |
+
| 162 | ++ |
+ )+ |
+
| 163 | +! | +
+ slices_global(snapshot_state)+ |
+
| 164 | +! | +
+ removeModal()+ |
+
| 165 | ++ |
+ ### End restore procedure. ###+ |
+
| 166 | ++ |
+ })+ |
+
| 167 | ++ | + + | +
| 168 | ++ |
+ # Create UI elements and server logic for the snapshot table.+ |
+
| 169 | ++ |
+ # Observers must be tracked to avoid duplication and excess reactivity.+ |
+
| 170 | ++ |
+ # Remaining elements are tracked likewise for consistency and a slight speed margin.+ |
+
| 171 | +7x | +
+ observers <- reactiveValues()+ |
+
| 172 | +7x | +
+ handlers <- reactiveValues()+ |
+
| 173 | +7x | +
+ divs <- reactiveValues()+ |
+
| 174 | ++ | + + | +
| 175 | +7x | +
+ observeEvent(snapshot_history(), {
+ |
+
| 176 | +3x | +
+ lapply(names(snapshot_history())[-1L], function(s) {
+ |
+
| 177 | +! | +
+ id_pickme <- sprintf("pickme_%s", make.names(s))
+ |
+
| 178 | +! | +
+ id_saveme <- sprintf("saveme_%s", make.names(s))
+ |
+
| 179 | +! | +
+ id_rowme <- sprintf("rowme_%s", make.names(s))
+ |
+
| 180 | ++ | + + | +
| 181 | ++ |
+ # Observer for restoring snapshot.+ |
+
| 182 | +! | +
+ if (!is.element(id_pickme, names(observers))) {
+ |
+
| 183 | +! | +
+ observers[[id_pickme]] <- observeEvent(input[[id_pickme]], {
+ |
+
| 184 | ++ |
+ ### Begin restore procedure. ###+ |
+
| 185 | +! | +
+ snapshot <- snapshot_history()[[s]]+ |
+
| 186 | +! | +
+ snapshot_state <- as.teal_slices(snapshot)+ |
+
| 187 | +! | +
+ mapping_unfolded <- unfold_mapping(attr(snapshot_state, "mapping"), names(filtered_data_list))+ |
+
| 188 | +! | +
+ mapply(+ |
+
| 189 | +! | +
+ function(filtered_data, filter_ids) {
+ |
+
| 190 | +! | +
+ filtered_data$clear_filter_states(force = TRUE)+ |
+
| 191 | +! | +
+ slices <- Filter(function(x) x$id %in% filter_ids, snapshot_state)+ |
+
| 192 | +! | +
+ filtered_data$set_filter_state(slices)+ |
+
| 193 | ++ |
+ },+ |
+
| 194 | +! | +
+ filtered_data = filtered_data_list,+ |
+
| 195 | +! | +
+ filter_ids = mapping_unfolded+ |
+
| 196 | ++ |
+ )+ |
+
| 197 | +! | +
+ slices_global(snapshot_state)+ |
+
| 198 | +! | +
+ removeModal()+ |
+
| 199 | ++ |
+ ### End restore procedure. ###+ |
+
| 200 | ++ |
+ })+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ |
+ # Create handler for downloading snapshot.+ |
+
| 203 | +! | +
+ if (!is.element(id_saveme, names(handlers))) {
+ |
+
| 204 | +! | +
+ output[[id_saveme]] <- downloadHandler(+ |
+
| 205 | +! | +
+ filename = function() {
+ |
+
| 206 | +! | +
+ sprintf("teal_snapshot_%s_%s.json", s, Sys.Date())
+ |
+
| 207 | ++ |
+ },+ |
+
| 208 | +! | +
+ content = function(file) {
+ |
+
| 209 | +! | +
+ snapshot <- snapshot_history()[[s]]+ |
+
| 210 | +! | +
+ snapshot_state <- as.teal_slices(snapshot)+ |
+
| 211 | +! | +
+ teal.slice::slices_store(tss = snapshot_state, file = file)+ |
+
| 212 | ++ |
+ }+ |
+
| 213 | ++ |
+ )+ |
+
| 214 | +! | +
+ handlers[[id_saveme]] <- id_saveme+ |
+
| 215 | ++ |
+ }+ |
+
| 216 | ++ |
+ # Create a row for the snapshot table.+ |
+
| 217 | +! | +
+ if (!is.element(id_rowme, names(divs))) {
+ |
+
| 218 | +! | +
+ divs[[id_rowme]] <- div(+ |
+
| 219 | +! | +
+ class = "snapshot_table_row",+ |
+
| 220 | +! | +
+ span(h5(s)),+ |
+
| 221 | +! | +
+ actionLink(inputId = ns(id_pickme), label = icon("circle-check"), title = "select"),
+ |
+
| 222 | +! | +
+ downloadLink(outputId = ns(id_saveme), label = icon("save"), title = "save to file")
+ |
+
| 223 | ++ |
+ )+ |
+
| 224 | ++ |
+ }+ |
+
| 225 | ++ |
+ })+ |
+
| 226 | ++ |
+ })+ |
+
| 227 | ++ | + + | +
| 228 | ++ |
+ # Create table to display list of snapshots and their actions.+ |
+
| 229 | +7x | +
+ output$snapshot_list <- renderUI({
+ |
+
| 230 | +3x | +
+ rows <- lapply(rev(reactiveValuesToList(divs)), function(d) d)+ |
+
| 231 | +3x | +
+ if (length(rows) == 0L) {
+ |
+
| 232 | +3x | +
+ div(+ |
+
| 233 | +3x | +
+ class = "snapshot_manager_placeholder",+ |
+
| 234 | +3x | +
+ "Snapshots will appear here."+ |
+
| 235 | ++ |
+ )+ |
+
| 236 | ++ |
+ } else {
+ |
+
| 237 | +! | +
+ rows+ |
+
| 238 | ++ |
+ }+ |
+
| 239 | ++ |
+ })+ |
+
| 240 | ++ |
+ })+ |
+
| 241 | ++ |
+ }+ |
+
| 242 | ++ | + + | +
| 243 | ++ | + + | +
| 244 | ++ | + + | +
| 245 | ++ | + + | +
| 246 | ++ |
+ ### utility functions ----+ |
+
| 247 | ++ | + + | +
| 248 | ++ |
+ #' Explicitly enumerate global filters.+ |
+
| 249 | ++ |
+ #'+ |
+
| 250 | ++ |
+ #' Transform module mapping such that global filters are explicitly specified for every module.+ |
+
| 251 | ++ |
+ #'+ |
+
| 252 | ++ |
+ #' @param mapping (`named list`) as stored in mapping parameter of `teal_slices`+ |
+
| 253 | ++ |
+ #' @param module_names (`character`) vector containing names of all modules in the app+ |
+
| 254 | ++ |
+ #' @return A `named_list` with one element per module, each element containing all filters applied to that module.+ |
+
| 255 | ++ |
+ #' @keywords internal+ |
+
| 256 | ++ |
+ #'+ |
+
| 257 | ++ |
+ unfold_mapping <- function(mapping, module_names) {
+ |
+
| 258 | +! | +
+ module_names <- structure(module_names, names = module_names)+ |
+
| 259 | +! | +
+ lapply(module_names, function(x) c(mapping[[x]], mapping[["global_filters"]]))+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | ++ | + + | +
| 262 | ++ |
+ #' Convert mapping matrix to filter mapping specification.+ |
+
| 263 | ++ |
+ #'+ |
+
| 264 | ++ |
+ #' Transform a mapping matrix, i.e. a data frame that maps each filter state to each module,+ |
+
| 265 | ++ |
+ #' to a list specification like the one used in the `mapping` attribute of `teal_slices`.+ |
+
| 266 | ++ |
+ #' Global filters are gathered in one list element.+ |
+
| 267 | ++ |
+ #' If a module has no active filters but the global ones, it will not be mentioned in the output.+ |
+
| 268 | ++ |
+ #'+ |
+
| 269 | ++ |
+ #' @param mapping_matrix (`data.frame`) of logical vectors where+ |
+
| 270 | ++ |
+ #' columns represent modules and row represent `teal_slice`s+ |
+
| 271 | ++ |
+ #' @return `named list` like that in the `mapping` attribute of a `teal_slices` object.+ |
+
| 272 | ++ |
+ #' @keywords internal+ |
+
| 273 | ++ |
+ #'+ |
+
| 274 | ++ |
+ matrix_to_mapping <- function(mapping_matrix) {
+ |
+
| 275 | +! | +
+ mapping_matrix[] <- lapply(mapping_matrix, function(x) x | is.na(x))+ |
+
| 276 | +! | +
+ global <- vapply(as.data.frame(t(mapping_matrix)), all, logical(1L))+ |
+
| 277 | +! | +
+ global_filters <- names(global[global])+ |
+
| 278 | +! | +
+ local_filters <- mapping_matrix[!rownames(mapping_matrix) %in% global_filters, ]+ |
+
| 279 | ++ | + + | +
| 280 | +! | +
+ mapping <- c(lapply(local_filters, function(x) rownames(local_filters)[x]), list(global_filters = global_filters))+ |
+
| 281 | +! | +
+ Filter(function(x) length(x) != 0L, mapping)+ |
+
| 282 | ++ |
+ }+ |
+
| 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 the `ui` function on it.+ |
+
| 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 calls recursively all elements of the `modules` returns one which+ |
+
| 13 | ++ |
+ #' is currently active.+ |
+
| 14 | ++ |
+ #' - `teal_module` returns self as a active module.+ |
+
| 15 | ++ |
+ #' - `teal_modules` also returns module active within self which is determined by the `input$active_tab`.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @name module_nested_tabs+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @inheritParams module_tabs_with_filters+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @param depth (`integer(1)`)\cr+ |
+
| 22 | ++ |
+ #' number which helps to determine depth of the modules nesting.+ |
+
| 23 | ++ |
+ #' @param is_module_specific (`logical(1)`)\cr+ |
+
| 24 | ++ |
+ #' flag determining if the filter panel is global or module-specific.+ |
+
| 25 | ++ |
+ #' When set to `TRUE`, a filter panel is called inside of each module tab.+ |
+
| 26 | ++ |
+ #' @return depending on class of `modules`, `ui_nested_tabs` returns:+ |
+
| 27 | ++ |
+ #' - `teal_module`: instantiated UI of the module+ |
+
| 28 | ++ |
+ #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively+ |
+
| 29 | ++ |
+ #' calling this function on it.\cr+ |
+
| 30 | ++ |
+ #' `srv_nested_tabs` returns a reactive which returns the active module that corresponds to the selected tab.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examples+ |
+
| 33 | ++ |
+ #' mods <- teal:::example_modules()+ |
+
| 34 | ++ |
+ #' datasets <- teal:::example_datasets()+ |
+
| 35 | ++ |
+ #' app <- shinyApp(+ |
+
| 36 | ++ |
+ #' ui = function() {
+ |
+
| 37 | ++ |
+ #' tagList(+ |
+
| 38 | ++ |
+ #' teal:::include_teal_css_js(),+ |
+
| 39 | ++ |
+ #' textOutput("info"),
+ |
+
| 40 | ++ |
+ #' fluidPage( # needed for nice tabs+ |
+
| 41 | ++ |
+ #' teal:::ui_nested_tabs("dummy", modules = mods, datasets = datasets)
+ |
+
| 42 | ++ |
+ #' )+ |
+
| 43 | ++ |
+ #' )+ |
+
| 44 | ++ |
+ #' },+ |
+
| 45 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 46 | ++ |
+ #' active_module <- teal:::srv_nested_tabs(+ |
+
| 47 | ++ |
+ #' "dummy",+ |
+
| 48 | ++ |
+ #' datasets = datasets,+ |
+
| 49 | ++ |
+ #' modules = mods+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #' output$info <- renderText({
+ |
+
| 52 | ++ |
+ #' paste0("The currently active tab name is ", active_module()$label)
+ |
+
| 53 | ++ |
+ #' })+ |
+
| 54 | ++ |
+ #' }+ |
+
| 55 | ++ |
+ #' )+ |
+
| 56 | ++ |
+ #' if (interactive()) {
+ |
+
| 57 | ++ |
+ #' runApp(app)+ |
+
| 58 | ++ |
+ #' }+ |
+
| 59 | ++ |
+ #' @keywords internal+ |
+
| 60 | ++ |
+ NULL+ |
+
| 61 | ++ | + + | +
| 62 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 63 | ++ |
+ ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ |
+
| 64 | +2x | +
+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ |
+
| 65 | +2x | +
+ checkmate::assert_count(depth)+ |
+
| 66 | +2x | +
+ UseMethod("ui_nested_tabs", modules)
+ |
+
| 67 | ++ |
+ }+ |
+
| 68 | ++ | + + | +
| 69 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 70 | ++ |
+ #' @export+ |
+
| 71 | ++ |
+ ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ |
+
| 72 | +! | +
+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | ++ | + + | +
| 75 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 76 | ++ |
+ #' @export+ |
+
| 77 | ++ |
+ ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ |
+
| 78 | +1x | +
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ |
+
| 79 | +1x | +
+ ns <- NS(id)+ |
+
| 80 | +1x | +
+ do.call(+ |
+
| 81 | +1x | +
+ tabsetPanel,+ |
+
| 82 | +1x | +
+ c(+ |
+
| 83 | ++ |
+ # by giving an id, we can reactively respond to tab changes+ |
+
| 84 | +1x | +
+ list(+ |
+
| 85 | +1x | +
+ id = ns("active_tab"),
+ |
+
| 86 | +1x | +
+ type = if (modules$label == "root") "pills" else "tabs"+ |
+
| 87 | ++ |
+ ),+ |
+
| 88 | +1x | +
+ lapply(+ |
+
| 89 | +1x | +
+ names(modules$children),+ |
+
| 90 | +1x | +
+ function(module_id) {
+ |
+
| 91 | +1x | +
+ module_label <- modules$children[[module_id]]$label+ |
+
| 92 | +1x | +
+ tabPanel(+ |
+
| 93 | +1x | +
+ title = module_label,+ |
+
| 94 | +1x | +
+ value = module_id, # when clicked this tab value changes input$<tabset panel id>+ |
+
| 95 | +1x | +
+ ui_nested_tabs(+ |
+
| 96 | +1x | +
+ id = ns(module_id),+ |
+
| 97 | +1x | +
+ modules = modules$children[[module_id]],+ |
+
| 98 | +1x | +
+ datasets = datasets[[module_label]],+ |
+
| 99 | +1x | +
+ depth = depth + 1L,+ |
+
| 100 | +1x | +
+ is_module_specific = is_module_specific+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | ++ |
+ )+ |
+
| 103 | ++ |
+ }+ |
+
| 104 | ++ |
+ )+ |
+
| 105 | ++ |
+ )+ |
+
| 106 | ++ |
+ )+ |
+
| 107 | ++ |
+ }+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 110 | ++ |
+ #' @export+ |
+
| 111 | ++ |
+ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) {
+ |
+
| 112 | +1x | +
+ checkmate::assert_class(datasets, class = "FilteredData")+ |
+
| 113 | +1x | +
+ ns <- NS(id)+ |
+
| 114 | ++ | + + | +
| 115 | +1x | +
+ args <- isolate(teal.transform::resolve_delayed(modules$ui_args, datasets))+ |
+
| 116 | +1x | +
+ args <- c(list(id = ns("module")), args)
+ |
+
| 117 | ++ | + + | +
| 118 | +1x | +
+ if (is_arg_used(modules$ui, "datasets")) {
+ |
+
| 119 | +! | +
+ args <- c(args, datasets = datasets)+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | ++ | + + | +
| 122 | +1x | +
+ if (is_arg_used(modules$ui, "data")) {
+ |
+
| 123 | +! | +
+ data <- .datasets_to_data(modules, datasets)+ |
+
| 124 | +! | +
+ args <- c(args, data = list(data))+ |
+
| 125 | ++ |
+ }+ |
+
| 126 | ++ | + + | +
| 127 | +1x | +
+ teal_ui <- tags$div(+ |
+
| 128 | +1x | +
+ id = id,+ |
+
| 129 | +1x | +
+ class = "teal_module",+ |
+
| 130 | +1x | +
+ uiOutput(ns("data_reactive"), inline = TRUE),
+ |
+
| 131 | +1x | +
+ tagList(+ |
+
| 132 | +1x | +
+ if (depth >= 2L) div(style = "mt-6"),+ |
+
| 133 | +1x | +
+ do.call(modules$ui, args)+ |
+
| 134 | ++ |
+ )+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ | + + | +
| 137 | +1x | +
+ if (!is.null(modules$datanames) && is_module_specific) {
+ |
+
| 138 | +! | +
+ fluidRow(+ |
+
| 139 | +! | +
+ column(width = 9, teal_ui, class = "teal_primary_col"),+ |
+
| 140 | +! | +
+ column(+ |
+
| 141 | +! | +
+ width = 3,+ |
+
| 142 | +! | +
+ datasets$ui_filter_panel(ns("module_filter_panel")),
+ |
+
| 143 | +! | +
+ class = "teal_secondary_col"+ |
+
| 144 | ++ |
+ )+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | ++ |
+ } else {
+ |
+
| 147 | +1x | +
+ teal_ui+ |
+
| 148 | ++ |
+ }+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ | + + | +
| 151 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 152 | ++ |
+ srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE,+ |
+
| 153 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+
| 154 | +54x | +
+ checkmate::assert_multi_class(modules, c("teal_modules", "teal_module"))
+ |
+
| 155 | +54x | +
+ checkmate::assert_class(reporter, "Reporter")+ |
+
| 156 | +53x | +
+ UseMethod("srv_nested_tabs", modules)
+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 160 | ++ |
+ #' @export+ |
+
| 161 | ++ |
+ srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE,+ |
+
| 162 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+
| 163 | +! | +
+ stop("Modules class not supported: ", paste(class(modules), collapse = " "))
+ |
+
| 164 | ++ |
+ }+ |
+
| 165 | ++ | + + | +
| 166 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 167 | ++ |
+ #' @export+ |
+
| 168 | ++ |
+ srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE,+ |
+
| 169 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+
| 170 | +24x | +
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ |
+
| 171 | ++ | + + | +
| 172 | +24x | +
+ moduleServer(id = id, module = function(input, output, session) {
+ |
+
| 173 | +24x | +
+ logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.")
+ |
+
| 174 | ++ | + + | +
| 175 | +24x | +
+ labels <- vapply(modules$children, `[[`, character(1), "label")+ |
+
| 176 | +24x | +
+ modules_reactive <- sapply(+ |
+
| 177 | +24x | +
+ names(modules$children),+ |
+
| 178 | +24x | +
+ function(module_id) {
+ |
+
| 179 | +35x | +
+ srv_nested_tabs(+ |
+
| 180 | +35x | +
+ id = module_id,+ |
+
| 181 | +35x | +
+ datasets = datasets[[labels[module_id]]],+ |
+
| 182 | +35x | +
+ modules = modules$children[[module_id]],+ |
+
| 183 | +35x | +
+ is_module_specific = is_module_specific,+ |
+
| 184 | +35x | +
+ reporter = reporter+ |
+
| 185 | ++ |
+ )+ |
+
| 186 | ++ |
+ },+ |
+
| 187 | +24x | +
+ simplify = FALSE+ |
+
| 188 | ++ |
+ )+ |
+
| 189 | ++ | + + | +
| 190 | ++ |
+ # when not ready input$active_tab would return NULL - this would fail next reactive+ |
+
| 191 | +24x | +
+ input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE)+ |
+
| 192 | +24x | +
+ get_active_module <- reactive({
+ |
+
| 193 | +13x | +
+ if (length(modules$children) == 1L) {
+ |
+
| 194 | ++ |
+ # single tab is active by default+ |
+
| 195 | +2x | +
+ modules_reactive[[1]]()+ |
+
| 196 | ++ |
+ } else {
+ |
+
| 197 | ++ |
+ # switch to active tab+ |
+
| 198 | +11x | +
+ modules_reactive[[input_validated()]]()+ |
+
| 199 | ++ |
+ }+ |
+
| 200 | ++ |
+ })+ |
+
| 201 | ++ | + + | +
| 202 | +24x | +
+ get_active_module+ |
+
| 203 | ++ |
+ })+ |
+
| 204 | ++ |
+ }+ |
+
| 205 | ++ | + + | +
| 206 | ++ |
+ #' @rdname module_nested_tabs+ |
+
| 207 | ++ |
+ #' @export+ |
+
| 208 | ++ |
+ srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE,+ |
+
| 209 | ++ |
+ reporter = teal.reporter::Reporter$new()) {
+ |
+
| 210 | +29x | +
+ checkmate::assert_class(datasets, "FilteredData")+ |
+
| 211 | +29x | +
+ logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.")
+ |
+
| 212 | ++ | + + | +
| 213 | +29x | +
+ moduleServer(id = id, module = function(input, output, session) {
+ |
+
| 214 | +29x | +
+ modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets)+ |
+
| 215 | +29x | +
+ if (!is.null(modules$datanames) && is_module_specific) {
+ |
+
| 216 | +! | +
+ datasets$srv_filter_panel("module_filter_panel", active_datanames = reactive(modules$datanames))
+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ | + + | +
| 219 | ++ |
+ # Create two triggers to limit reactivity between filter-panel and modules.+ |
+
| 220 | ++ |
+ # We want to recalculate only visible modules+ |
+
| 221 | ++ |
+ # - trigger the data when the tab is selected+ |
+
| 222 | ++ |
+ # - trigger module to be called when the tab is selected for the first time+ |
+
| 223 | +29x | +
+ trigger_data <- reactiveVal(1L)+ |
+
| 224 | +29x | +
+ trigger_module <- reactiveVal(NULL)+ |
+
| 225 | +29x | +
+ output$data_reactive <- renderUI({
+ |
+
| 226 | +18x | +
+ lapply(datasets$datanames(), function(x) {
+ |
+
| 227 | +22x | +
+ datasets$get_data(x, filtered = TRUE)+ |
+
| 228 | ++ |
+ })+ |
+
| 229 | +18x | +
+ isolate(trigger_data(trigger_data() + 1))+ |
+
| 230 | +18x | +
+ isolate(trigger_module(TRUE))+ |
+
| 231 | ++ | + + | +
| 232 | +18x | +
+ NULL+ |
+
| 233 | ++ |
+ })+ |
+
| 234 | ++ | + + | +
| 235 | ++ |
+ # collect arguments to run teal_module+ |
+
| 236 | +29x | +
+ args <- c(list(id = "module"), modules$server_args)+ |
+
| 237 | +29x | +
+ if (is_arg_used(modules$server, "reporter")) {
+ |
+
| 238 | +! | +
+ args <- c(args, list(reporter = reporter))+ |
+
| 239 | ++ |
+ }+ |
+
| 240 | ++ | + + | +
| 241 | +29x | +
+ if (is_arg_used(modules$server, "datasets")) {
+ |
+
| 242 | +2x | +
+ args <- c(args, datasets = datasets)+ |
+
| 243 | ++ |
+ }+ |
+
| 244 | ++ | + + | +
| 245 | +29x | +
+ if (is_arg_used(modules$server, "data")) {
+ |
+
| 246 | +8x | +
+ data <- .datasets_to_data(modules, datasets, trigger_data)+ |
+
| 247 | +8x | +
+ args <- c(args, data = list(data))+ |
+
| 248 | ++ |
+ }+ |
+
| 249 | ++ | + + | +
| 250 | +29x | +
+ if (is_arg_used(modules$server, "filter_panel_api")) {
+ |
+
| 251 | +2x | +
+ filter_panel_api <- teal.slice::FilterPanelAPI$new(datasets)+ |
+
| 252 | +2x | +
+ args <- c(args, filter_panel_api = filter_panel_api)+ |
+
| 253 | ++ |
+ }+ |
+
| 254 | ++ | + + | +
| 255 | +29x | +
+ if (is_arg_used(modules$server, "datasets") && is_arg_used(modules$server, "data")) {
+ |
+
| 256 | +1x | +
+ warning(+ |
+
| 257 | +1x | +
+ "Module '", modules$label, "' has `data` and `datasets` arguments in the formals.",+ |
+
| 258 | +1x | +
+ "\nIt's recommended to use `data` to work with filtered objects."+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | ++ | + + | +
| 262 | ++ |
+ # observe the trigger_module above to induce the module once the renderUI is triggered+ |
+
| 263 | +29x | +
+ observeEvent(+ |
+
| 264 | +29x | +
+ ignoreNULL = TRUE,+ |
+
| 265 | +29x | +
+ once = TRUE,+ |
+
| 266 | +29x | +
+ eventExpr = trigger_module(),+ |
+
| 267 | +29x | +
+ handlerExpr = {
+ |
+
| 268 | +18x | +
+ module_output <- if (is_arg_used(modules$server, "id")) {
+ |
+
| 269 | +18x | +
+ do.call(modules$server, args)+ |
+
| 270 | ++ |
+ } else {
+ |
+
| 271 | +! | +
+ do.call(callModule, c(args, list(module = modules$server)))+ |
+
| 272 | ++ |
+ }+ |
+
| 273 | ++ |
+ }+ |
+
| 274 | ++ |
+ )+ |
+
| 275 | ++ | + + | +
| 276 | +29x | +
+ reactive(modules)+ |
+
| 277 | ++ |
+ })+ |
+
| 278 | ++ |
+ }+ |
+
| 279 | ++ | + + | +
| 280 | ++ |
+ #' Convert `FilteredData` to reactive list of datasets of the `tdata` type.+ |
+
| 281 | ++ |
+ #'+ |
+
| 282 | ++ |
+ #' Converts `FilteredData` object to `tdata` object containing datasets needed for a specific module.+ |
+
| 283 | ++ |
+ #' Please note that if module needs dataset which has a parent, then parent will be also returned.+ |
+
| 284 | ++ |
+ #' A hash per `dataset` is calculated internally and returned in the code.+ |
+
| 285 | ++ |
+ #'+ |
+
| 286 | ++ |
+ #' @param module (`teal_module`) module where needed filters are taken from+ |
+
| 287 | ++ |
+ #' @param datasets (`FilteredData`) object where needed data are taken from+ |
+
| 288 | ++ |
+ #' @param trigger_data (`reactiveVal`) to trigger getting the filtered data+ |
+
| 289 | ++ |
+ #' @return list of reactive datasets with following attributes:+ |
+
| 290 | ++ |
+ #' - `code` (`character`) containing datasets reproducible code.+ |
+
| 291 | ++ |
+ #' - `join_keys` (`JoinKeys`) containing relationships between datasets.+ |
+
| 292 | ++ |
+ #' - `metadata` (`list`) containing metadata of datasets.+ |
+
| 293 | ++ |
+ #'+ |
+
| 294 | ++ |
+ #' @keywords internal+ |
+
| 295 | ++ |
+ .datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) {
+ |
+
| 296 | +13x | +
+ checkmate::assert_class(module, "teal_module")+ |
+
| 297 | +13x | +
+ checkmate::assert_class(datasets, "FilteredData")+ |
+
| 298 | +13x | +
+ checkmate::assert_class(trigger_data, "reactiveVal")+ |
+
| 299 | ++ | + + | +
| 300 | +12x | +
+ datanames <- if (is.null(module$datanames)) datasets$datanames() else module$datanames+ |
+
| 301 | ++ | + + | +
| 302 | ++ |
+ # list of reactive filtered data+ |
+
| 303 | +12x | +
+ data <- sapply(+ |
+
| 304 | +12x | +
+ datanames,+ |
+
| 305 | +12x | +
+ function(x) eventReactive(trigger_data(), datasets$get_data(x, filtered = TRUE)),+ |
+
| 306 | +12x | +
+ simplify = FALSE+ |
+
| 307 | ++ |
+ )+ |
+
| 308 | ++ | + + | +
| 309 | +12x | +
+ hashes <- calculate_hashes(datanames, datasets)+ |
+
| 310 | +12x | +
+ metadata <- lapply(datanames, datasets$get_metadata)+ |
+
| 311 | +12x | +
+ names(metadata) <- datanames+ |
+
| 312 | ++ | + + | +
| 313 | +12x | +
+ new_tdata(+ |
+
| 314 | +12x | +
+ data,+ |
+
| 315 | +12x | +
+ eventReactive(+ |
+
| 316 | +12x | +
+ trigger_data(),+ |
+
| 317 | +12x | +
+ c(+ |
+
| 318 | +12x | +
+ get_rcode_str_install(),+ |
+
| 319 | +12x | +
+ get_rcode_libraries(),+ |
+
| 320 | +12x | +
+ get_datasets_code(datanames, datasets, hashes),+ |
+
| 321 | +12x | +
+ teal.slice::get_filter_expr(datasets, datanames)+ |
+
| 322 | ++ |
+ )+ |
+
| 323 | ++ |
+ ),+ |
+
| 324 | +12x | +
+ datasets$get_join_keys(),+ |
+
| 325 | +12x | +
+ metadata+ |
+
| 326 | ++ |
+ )+ |
+
| 327 | ++ |
+ }+ |
+
| 328 | ++ | + + | +
| 329 | ++ |
+ #' Get the hash of a dataset+ |
+
| 330 | ++ |
+ #'+ |
+
| 331 | ++ |
+ #' @param datanames (`character`) names of datasets+ |
+
| 332 | ++ |
+ #' @param datasets (`FilteredData`) object holding the data+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' @return A list of hashes per dataset+ |
+
| 335 | ++ |
+ #' @keywords internal+ |
+
| 336 | ++ |
+ #'+ |
+
| 337 | ++ |
+ calculate_hashes <- function(datanames, datasets) {
+ |
+
| 338 | +16x | +
+ sapply(datanames, function(x) rlang::hash(datasets$get_data(x, filtered = FALSE)), simplify = FALSE)+ |
+
| 339 | ++ |
+ }+ |
+
| 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`)\cr+ |
+
| 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 A `tagList` of The main menu, place holders for filters and+ |
+
| 25 | ++ |
+ #' place holders for the teal modules+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @keywords internal+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @examples+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' mods <- teal:::example_modules()+ |
+
| 33 | ++ |
+ #' datasets <- teal:::example_datasets()+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' app <- shinyApp(+ |
+
| 36 | ++ |
+ #' ui = function() {
+ |
+
| 37 | ++ |
+ #' tagList(+ |
+
| 38 | ++ |
+ #' teal:::include_teal_css_js(),+ |
+
| 39 | ++ |
+ #' textOutput("info"),
+ |
+
| 40 | ++ |
+ #' fluidPage( # needed for nice tabs+ |
+
| 41 | ++ |
+ #' ui_tabs_with_filters("dummy", modules = mods, datasets = datasets)
+ |
+
| 42 | ++ |
+ #' )+ |
+
| 43 | ++ |
+ #' )+ |
+
| 44 | ++ |
+ #' },+ |
+
| 45 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 46 | ++ |
+ #' output$info <- renderText({
+ |
+
| 47 | ++ |
+ #' paste0("The currently active tab name is ", active_module()$label)
+ |
+
| 48 | ++ |
+ #' })+ |
+
| 49 | ++ |
+ #' active_module <- srv_tabs_with_filters(id = "dummy", datasets = datasets, modules = mods)+ |
+
| 50 | ++ |
+ #' }+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #' if (interactive()) {
+ |
+
| 53 | ++ |
+ #' runApp(app)+ |
+
| 54 | ++ |
+ #' }+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ NULL+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ #' @rdname module_tabs_with_filters+ |
+
| 59 | ++ |
+ ui_tabs_with_filters <- function(id, modules, datasets, filter = teal_slices()) {
+ |
+
| 60 | +1x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 61 | +1x | +
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ |
+
| 62 | +1x | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+
| 63 | ++ | + + | +
| 64 | +1x | +
+ ns <- NS(id)+ |
+
| 65 | +1x | +
+ is_module_specific <- isTRUE(attr(filter, "module_specific"))+ |
+
| 66 | ++ | + + | +
| 67 | +1x | +
+ teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific)
+ |
+
| 68 | +1x | +
+ filter_panel_btns <- tags$li(+ |
+
| 69 | +1x | +
+ class = "flex-grow",+ |
+
| 70 | +1x | +
+ tags$button(+ |
+
| 71 | +1x | +
+ class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger+ |
+
| 72 | +1x | +
+ href = "javascript:void(0)",+ |
+
| 73 | +1x | +
+ onclick = "toggleFilterPanel();", # see sidebar.js+ |
+
| 74 | +1x | +
+ title = "Toggle filter panels",+ |
+
| 75 | +1x | +
+ icon("fas fa-bars")
+ |
+
| 76 | ++ |
+ ),+ |
+
| 77 | +1x | +
+ filter_manager_modal_ui(ns("filter_manager"))
+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | +1x | +
+ teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btns)+ |
+
| 80 | ++ | + + | +
| 81 | +1x | +
+ if (!is_module_specific) {
+ |
+
| 82 | ++ |
+ # need to rearrange html so that filter panel is within tabset+ |
+
| 83 | +1x | +
+ tabset_bar <- teal_ui$children[[1]]+ |
+
| 84 | +1x | +
+ teal_modules <- teal_ui$children[[2]]+ |
+
| 85 | +1x | +
+ filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel"))
+ |
+
| 86 | +1x | +
+ list(+ |
+
| 87 | +1x | +
+ tabset_bar,+ |
+
| 88 | +1x | +
+ tags$hr(class = "my-2"),+ |
+
| 89 | +1x | +
+ fluidRow(+ |
+
| 90 | +1x | +
+ column(width = 9, teal_modules, class = "teal_primary_col"),+ |
+
| 91 | +1x | +
+ column(width = 3, filter_ui, class = "teal_secondary_col")+ |
+
| 92 | ++ |
+ )+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | ++ |
+ } else {
+ |
+
| 95 | +! | +
+ teal_ui+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ #' @rdname module_tabs_with_filters+ |
+
| 100 | ++ |
+ srv_tabs_with_filters <- function(id,+ |
+
| 101 | ++ |
+ datasets,+ |
+
| 102 | ++ |
+ modules,+ |
+
| 103 | ++ |
+ reporter = teal.reporter::Reporter$new(),+ |
+
| 104 | ++ |
+ filter = teal_slices()) {
+ |
+
| 105 | +6x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 106 | +6x | +
+ checkmate::assert_list(datasets, types = c("list", "FilteredData"))
+ |
+
| 107 | +6x | +
+ checkmate::assert_class(reporter, "Reporter")+ |
+
| 108 | +4x | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+
| 109 | ++ | + + | +
| 110 | +4x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 111 | +4x | +
+ logger::log_trace("srv_tabs_with_filters initializing the module.")
+ |
+
| 112 | ++ | + + | +
| 113 | +4x | +
+ is_module_specific <- isTRUE(attr(filter, "module_specific"))+ |
+
| 114 | +4x | +
+ manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter)
+ |
+
| 115 | ++ | + + | +
| 116 | +4x | +
+ active_module <- srv_nested_tabs(+ |
+
| 117 | +4x | +
+ id = "root",+ |
+
| 118 | +4x | +
+ datasets = datasets,+ |
+
| 119 | +4x | +
+ modules = modules,+ |
+
| 120 | +4x | +
+ reporter = reporter,+ |
+
| 121 | +4x | +
+ is_module_specific = is_module_specific+ |
+
| 122 | ++ |
+ )+ |
+
| 123 | ++ | + + | +
| 124 | +4x | +
+ if (!is_module_specific) {
+ |
+
| 125 | +4x | +
+ active_datanames <- reactive(active_module()$datanames)+ |
+
| 126 | +4x | +
+ singleton <- unlist(datasets)[[1]]+ |
+
| 127 | +4x | +
+ singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames)
+ |
+
| 128 | ++ | + + | +
| 129 | +4x | +
+ observeEvent(+ |
+
| 130 | +4x | +
+ eventExpr = active_datanames(),+ |
+
| 131 | +4x | +
+ handlerExpr = {
+ |
+
| 132 | +5x | +
+ script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) {
+ |
+
| 133 | ++ |
+ # hide the filter panel and disable the burger button+ |
+
| 134 | +1x | +
+ "handleNoActiveDatasets();"+ |
+
| 135 | ++ |
+ } else {
+ |
+
| 136 | ++ |
+ # show the filter panel and enable the burger button+ |
+
| 137 | +4x | +
+ "handleActiveDatasetsPresent();"+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | +5x | +
+ shinyjs::runjs(script)+ |
+
| 140 | ++ |
+ },+ |
+
| 141 | +4x | +
+ ignoreNULL = FALSE+ |
+
| 142 | ++ |
+ )+ |
+
| 143 | ++ |
+ }+ |
+
| 144 | ++ | + + | +
| 145 | +4x | +
+ showNotification("Data loaded - App fully started up")
+ |
+
| 146 | +4x | +
+ logger::log_trace("srv_tabs_with_filters initialized the module")
+ |
+
| 147 | +4x | +
+ return(active_module)+ |
+
| 148 | ++ |
+ })+ |
+
| 149 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Creates a `teal_modules` object.+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #' This function collects a list of `teal_modules` and `teal_module` objects and returns a `teal_modules` object+ |
+
| 5 | ++ |
+ #' containing the passed objects.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' This function dictates what modules are included in a `teal` application. The internal structure of `teal_modules`+ |
+
| 8 | ++ |
+ #' shapes the navigation panel of a `teal` application.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @param ... (`teal_module` or `teal_modules`) see [module()] and [modules()] for more details+ |
+
| 11 | ++ |
+ #' @param label (`character(1)`) label of modules collection (default `"root"`).+ |
+
| 12 | ++ |
+ #' If using the `label` argument then it must be explicitly named.+ |
+
| 13 | ++ |
+ #' For example `modules("lab", ...)` should be converted to `modules(label = "lab", ...)`
+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @export+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return object of class \code{teal_modules}. Object contains following fields
+ |
+
| 18 | ++ |
+ #' - `label`: taken from the `label` argument+ |
+
| 19 | ++ |
+ #' - `children`: a list containing objects passed in `...`. List elements are named after+ |
+
| 20 | ++ |
+ #' their `label` attribute converted to a valid `shiny` id.+ |
+
| 21 | ++ |
+ #' @examples+ |
+
| 22 | ++ |
+ #' library(shiny)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' app <- init(+ |
+
| 25 | ++ |
+ #' data = teal_data(dataset("iris", iris)),
+ |
+
| 26 | ++ |
+ #' modules = modules(+ |
+
| 27 | ++ |
+ #' label = "Modules",+ |
+
| 28 | ++ |
+ #' modules(+ |
+
| 29 | ++ |
+ #' label = "Module",+ |
+
| 30 | ++ |
+ #' module(+ |
+
| 31 | ++ |
+ #' label = "Inner module",+ |
+
| 32 | ++ |
+ #' server = function(id, data) {
+ |
+
| 33 | ++ |
+ #' moduleServer(+ |
+
| 34 | ++ |
+ #' id,+ |
+
| 35 | ++ |
+ #' module = function(input, output, session) {
+ |
+
| 36 | ++ |
+ #' output$data <- renderDataTable(data[["iris"]]())+ |
+
| 37 | ++ |
+ #' }+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #' },+ |
+
| 40 | ++ |
+ #' ui = function(id) {
+ |
+
| 41 | ++ |
+ #' ns <- NS(id)+ |
+
| 42 | ++ |
+ #' tagList(dataTableOutput(ns("data")))
+ |
+
| 43 | ++ |
+ #' },+ |
+
| 44 | ++ |
+ #' datanames = "all"+ |
+
| 45 | ++ |
+ #' )+ |
+
| 46 | ++ |
+ #' ),+ |
+
| 47 | ++ |
+ #' module(+ |
+
| 48 | ++ |
+ #' label = "Another module",+ |
+
| 49 | ++ |
+ #' server = function(id) {
+ |
+
| 50 | ++ |
+ #' moduleServer(+ |
+
| 51 | ++ |
+ #' id,+ |
+
| 52 | ++ |
+ #' module = function(input, output, session) {
+ |
+
| 53 | ++ |
+ #' output$text <- renderText("Another module")
+ |
+
| 54 | ++ |
+ #' }+ |
+
| 55 | ++ |
+ #' )+ |
+
| 56 | ++ |
+ #' },+ |
+
| 57 | ++ |
+ #' ui = function(id) {
+ |
+
| 58 | ++ |
+ #' ns <- NS(id)+ |
+
| 59 | ++ |
+ #' tagList(textOutput(ns("text")))
+ |
+
| 60 | ++ |
+ #' },+ |
+
| 61 | ++ |
+ #' datanames = NULL+ |
+
| 62 | ++ |
+ #' )+ |
+
| 63 | ++ |
+ #' )+ |
+
| 64 | ++ |
+ #' )+ |
+
| 65 | ++ |
+ #' if (interactive()) {
+ |
+
| 66 | ++ |
+ #' runApp(app)+ |
+
| 67 | ++ |
+ #' }+ |
+
| 68 | ++ |
+ modules <- function(..., label = "root") {
+ |
+
| 69 | +79x | +
+ checkmate::assert_string(label)+ |
+
| 70 | +77x | +
+ submodules <- list(...)+ |
+
| 71 | +77x | +
+ if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) {
+ |
+
| 72 | +2x | +
+ stop(+ |
+
| 73 | +2x | +
+ "The only character argument to modules() must be 'label' and it must be named, ",+ |
+
| 74 | +2x | +
+ "change modules('lab', ...) to modules(label = 'lab', ...)"
+ |
+
| 75 | ++ |
+ )+ |
+
| 76 | ++ |
+ }+ |
+
| 77 | ++ | + + | +
| 78 | +75x | +
+ checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+ |
+
| 79 | ++ |
+ # name them so we can more easily access the children+ |
+
| 80 | ++ |
+ # beware however that the label of the submodules should not be changed as it must be kept synced+ |
+
| 81 | +72x | +
+ labels <- vapply(submodules, function(submodule) submodule$label, character(1))+ |
+
| 82 | +72x | +
+ names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_")
+ |
+
| 83 | +72x | +
+ structure(+ |
+
| 84 | +72x | +
+ list(+ |
+
| 85 | +72x | +
+ label = label,+ |
+
| 86 | +72x | +
+ children = submodules+ |
+
| 87 | ++ |
+ ),+ |
+
| 88 | +72x | +
+ class = "teal_modules"+ |
+
| 89 | ++ |
+ )+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ #' Function which appends a teal_module onto the children of a teal_modules object+ |
+
| 93 | ++ |
+ #' @keywords internal+ |
+
| 94 | ++ |
+ #' @param modules `teal_modules`+ |
+
| 95 | ++ |
+ #' @param module `teal_module` object to be appended onto the children of `modules`+ |
+
| 96 | ++ |
+ #' @return `teal_modules` object with `module` appended+ |
+
| 97 | ++ |
+ append_module <- function(modules, module) {
+ |
+
| 98 | +7x | +
+ checkmate::assert_class(modules, "teal_modules")+ |
+
| 99 | +5x | +
+ checkmate::assert_class(module, "teal_module")+ |
+
| 100 | +3x | +
+ modules$children <- c(modules$children, list(module))+ |
+
| 101 | +3x | +
+ labels <- vapply(modules$children, function(submodule) submodule$label, character(1))+ |
+
| 102 | +3x | +
+ names(modules$children) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_")
+ |
+
| 103 | +3x | +
+ modules+ |
+
| 104 | ++ |
+ }+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ #' Does the object make use of the `arg`+ |
+
| 107 | ++ |
+ #'+ |
+
| 108 | ++ |
+ #' @param modules (`teal_module` or `teal_modules`) object+ |
+
| 109 | ++ |
+ #' @param arg (`character(1)`) names of the arguments to be checked against formals of `teal` modules.+ |
+
| 110 | ++ |
+ #' @return `logical` whether the object makes use of `arg`+ |
+
| 111 | ++ |
+ #' @rdname is_arg_used+ |
+
| 112 | ++ |
+ #' @keywords internal+ |
+
| 113 | ++ |
+ is_arg_used <- function(modules, arg) {
+ |
+
| 114 | +285x | +
+ checkmate::assert_string(arg)+ |
+
| 115 | +282x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 116 | +19x | +
+ any(unlist(lapply(modules$children, is_arg_used, arg)))+ |
+
| 117 | +263x | +
+ } else if (inherits(modules, "teal_module")) {
+ |
+
| 118 | +32x | +
+ is_arg_used(modules$server, arg) || is_arg_used(modules$ui, arg)+ |
+
| 119 | +231x | +
+ } else if (is.function(modules)) {
+ |
+
| 120 | +229x | +
+ isTRUE(arg %in% names(formals(modules)))+ |
+
| 121 | ++ |
+ } else {
+ |
+
| 122 | +2x | +
+ stop("is_arg_used function not implemented for this object")
+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | ++ | + + | +
| 126 | ++ | + + | +
| 127 | ++ |
+ #' Creates a `teal_module` object.+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 130 | ++ |
+ #' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module.+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ #' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except+ |
+
| 133 | ++ |
+ #' `"global_filters"` - read more in `mapping` argument of [teal::teal_slices].+ |
+
| 134 | ++ |
+ #' @param server (`function`) `shiny` module with following arguments:+ |
+
| 135 | ++ |
+ #' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]).+ |
+
| 136 | ++ |
+ #' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module.+ |
+
| 137 | ++ |
+ #' - `data` (optional) module will receive a `tdata` object, a list of reactive (filtered) data specified in+ |
+
| 138 | ++ |
+ #' the `filters` argument.+ |
+
| 139 | ++ |
+ #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ |
+
| 140 | ++ |
+ #' - `reporter` (optional) module will receive `Reporter`. (See [teal.reporter::Reporter]).+ |
+
| 141 | ++ |
+ # - `filter_panel_api` (optional) module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).+ |
+
| 142 | ++ |
+ #' - `...` (optional) `server_args` elements will be passed to the module named argument or to the `...`.+ |
+
| 143 | ++ |
+ #' @param ui (`function`) Shiny `ui` module function with following arguments:+ |
+
| 144 | ++ |
+ #' - `id` - teal will set proper shiny namespace for this module.+ |
+
| 145 | ++ |
+ #' - `data` (optional) module will receive list of reactive (filtered) data specified in the `filters` argument.+ |
+
| 146 | ++ |
+ #' - `datasets` (optional) module will receive `FilteredData`. (See `[teal.slice::FilteredData]`).+ |
+
| 147 | ++ |
+ #' - `...` (optional) `ui_args` elements will be passed to the module named argument or to the `...`.+ |
+
| 148 | ++ |
+ #' @param filters (`character`) Deprecated. Use `datanames` instead.+ |
+
| 149 | ++ |
+ #' @param datanames (`character`) A vector with `datanames` that are relevant for the item. The+ |
+
| 150 | ++ |
+ #' filter panel will automatically update the shown filters to include only+ |
+
| 151 | ++ |
+ #' filters in the listed datasets. `NULL` will hide the filter panel,+ |
+
| 152 | ++ |
+ #' and the keyword `'all'` will show filters of all datasets. `datanames` also determines+ |
+
| 153 | ++ |
+ #' a subset of datasets which are appended to the `data` argument in `server` function.+ |
+
| 154 | ++ |
+ #' @param server_args (named `list`) with additional arguments passed on to the+ |
+
| 155 | ++ |
+ #' `server` function.+ |
+
| 156 | ++ |
+ #' @param ui_args (named `list`) with additional arguments passed on to the+ |
+
| 157 | ++ |
+ #' `ui` function.+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @return object of class `teal_module`.+ |
+
| 160 | ++ |
+ #' @export+ |
+
| 161 | ++ |
+ #' @examples+ |
+
| 162 | ++ |
+ #' library(shiny)+ |
+
| 163 | ++ |
+ #'+ |
+
| 164 | ++ |
+ #' app <- init(+ |
+
| 165 | ++ |
+ #' data = teal_data(dataset("iris", iris)),
+ |
+
| 166 | ++ |
+ #' modules = list(+ |
+
| 167 | ++ |
+ #' module(+ |
+
| 168 | ++ |
+ #' label = "Module",+ |
+
| 169 | ++ |
+ #' server = function(id, data) {
+ |
+
| 170 | ++ |
+ #' moduleServer(+ |
+
| 171 | ++ |
+ #' id,+ |
+
| 172 | ++ |
+ #' module = function(input, output, session) {
+ |
+
| 173 | ++ |
+ #' output$data <- renderDataTable(data[["iris"]]())+ |
+
| 174 | ++ |
+ #' }+ |
+
| 175 | ++ |
+ #' )+ |
+
| 176 | ++ |
+ #' },+ |
+
| 177 | ++ |
+ #' ui = function(id) {
+ |
+
| 178 | ++ |
+ #' ns <- NS(id)+ |
+
| 179 | ++ |
+ #' tagList(dataTableOutput(ns("data")))
+ |
+
| 180 | ++ |
+ #' }+ |
+
| 181 | ++ |
+ #' )+ |
+
| 182 | ++ |
+ #' )+ |
+
| 183 | ++ |
+ #' )+ |
+
| 184 | ++ |
+ #' if (interactive()) {
+ |
+
| 185 | ++ |
+ #' runApp(app)+ |
+
| 186 | ++ |
+ #' }+ |
+
| 187 | ++ |
+ module <- function(label = "module",+ |
+
| 188 | ++ |
+ server = function(id, ...) {
+ |
+
| 189 | +1x | +
+ moduleServer(id, function(input, output, session) {}) # nolint
+ |
+
| 190 | ++ |
+ },+ |
+
| 191 | ++ |
+ ui = function(id, ...) {
+ |
+
| 192 | +1x | +
+ tags$p(paste0("This module has no UI (id: ", id, " )"))
+ |
+
| 193 | ++ |
+ },+ |
+
| 194 | ++ |
+ filters,+ |
+
| 195 | ++ |
+ datanames = "all",+ |
+
| 196 | ++ |
+ server_args = NULL,+ |
+
| 197 | ++ |
+ ui_args = NULL) {
+ |
+
| 198 | +109x | +
+ checkmate::assert_string(label)+ |
+
| 199 | +106x | +
+ checkmate::assert_function(server)+ |
+
| 200 | +106x | +
+ checkmate::assert_function(ui)+ |
+
| 201 | +106x | +
+ checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ |
+
| 202 | +105x | +
+ checkmate::assert_list(server_args, null.ok = TRUE, names = "named")+ |
+
| 203 | +103x | +
+ checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")+ |
+
| 204 | ++ | + + | +
| 205 | +101x | +
+ if (!missing(filters)) {
+ |
+
| 206 | +! | +
+ checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ |
+
| 207 | +! | +
+ datanames <- filters+ |
+
| 208 | +! | +
+ msg <-+ |
+
| 209 | +! | +
+ "The `filters` argument is deprecated and will be removed in the next release. Please use `datanames` instead."+ |
+
| 210 | +! | +
+ logger::log_warn(msg)+ |
+
| 211 | +! | +
+ warning(msg)+ |
+
| 212 | ++ |
+ }+ |
+
| 213 | ++ | + + | +
| 214 | +101x | +
+ if (label == "global_filters") {
+ |
+
| 215 | +1x | +
+ stop(+ |
+
| 216 | +1x | +
+ sprintf("module(label = \"%s\", ...\n ", label),
+ |
+
| 217 | +1x | +
+ "Label 'global_filters' is reserved in teal. Please change to something else.",+ |
+
| 218 | +1x | +
+ call. = FALSE+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ |
+ }+ |
+
| 221 | +100x | +
+ if (label == "Report previewer") {
+ |
+
| 222 | +! | +
+ stop(+ |
+
| 223 | +! | +
+ sprintf("module(label = \"%s\", ...\n ", label),
+ |
+
| 224 | +! | +
+ "Label 'Report previewer' is reserved in teal.",+ |
+
| 225 | +! | +
+ call. = FALSE+ |
+
| 226 | ++ |
+ )+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | +100x | +
+ server_formals <- names(formals(server))+ |
+
| 229 | +100x | +
+ if (!(+ |
+
| 230 | +100x | +
+ "id" %in% server_formals ||+ |
+
| 231 | +100x | +
+ all(c("input", "output", "session") %in% server_formals)
+ |
+
| 232 | ++ |
+ )) {
+ |
+
| 233 | +2x | +
+ stop(+ |
+
| 234 | +2x | +
+ "\nmodule() `server` argument requires a function with following arguments:",+ |
+
| 235 | +2x | +
+ "\n - id - teal will set proper shiny namespace for this module.",+ |
+
| 236 | +2x | +
+ "\n - input, output, session (not recommended) - then shiny::callModule will be used to call a module.",+ |
+
| 237 | +2x | +
+ "\n\nFollowing arguments can be used optionaly:",+ |
+
| 238 | +2x | +
+ "\n - `data` - module will receive list of reactive (filtered) data specified in the `filters` argument",+ |
+
| 239 | +2x | +
+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ |
+
| 240 | +2x | +
+ "\n - `reporter` - module will receive `Reporter`. See `help(teal.reporter::Reporter)`",+ |
+
| 241 | +2x | +
+ "\n - `filter_panel_api` - module will receive `FilterPanelAPI`. (See [teal.slice::FilterPanelAPI]).",+ |
+
| 242 | +2x | +
+ "\n - `...` server_args elements will be passed to the module named argument or to the `...`"+ |
+
| 243 | ++ |
+ )+ |
+
| 244 | ++ |
+ }+ |
+
| 245 | ++ | + + | +
| 246 | +98x | +
+ if (!is.element("data", server_formals) && !is.null(datanames)) {
+ |
+
| 247 | +64x | +
+ message(sprintf("module \"%s\" server function takes no data so \"datanames\" will be ignored", label))
+ |
+
| 248 | +64x | +
+ datanames <- NULL+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ | + + | +
| 251 | +98x | +
+ srv_extra_args <- setdiff(names(server_args), server_formals)+ |
+
| 252 | +98x | +
+ if (length(srv_extra_args) > 0 && !"..." %in% server_formals) {
+ |
+
| 253 | +1x | +
+ stop(+ |
+
| 254 | +1x | +
+ "\nFollowing `server_args` elements have no equivalent in the formals of the `server`:\n",+ |
+
| 255 | +1x | +
+ paste(paste(" -", srv_extra_args), collapse = "\n"),
+ |
+
| 256 | +1x | +
+ "\n\nUpdate the `server` arguments by including above or add `...`"+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | ++ |
+ }+ |
+
| 259 | ++ | + + | +
| 260 | +97x | +
+ ui_formals <- names(formals(ui))+ |
+
| 261 | +97x | +
+ if (!"id" %in% ui_formals) {
+ |
+
| 262 | +1x | +
+ stop(+ |
+
| 263 | +1x | +
+ "\nmodule() `ui` argument requires a function with following arguments:",+ |
+
| 264 | +1x | +
+ "\n - id - teal will set proper shiny namespace for this module.",+ |
+
| 265 | +1x | +
+ "\n\nFollowing arguments can be used optionaly:",+ |
+
| 266 | +1x | +
+ "\n - `data` - module will receive list of reactive (filtered) data specied in the `filters` argument",+ |
+
| 267 | +1x | +
+ "\n - `datasets` - module will receive `FilteredData`. See `help(teal.slice::FilteredData)`",+ |
+
| 268 | +1x | +
+ "\n - `...` ui_args elements will be passed to the module argument of the same name or to the `...`"+ |
+
| 269 | ++ |
+ )+ |
+
| 270 | ++ |
+ }+ |
+
| 271 | ++ | + + | +
| 272 | +96x | +
+ ui_extra_args <- setdiff(names(ui_args), ui_formals)+ |
+
| 273 | +96x | +
+ if (length(ui_extra_args) > 0 && !"..." %in% ui_formals) {
+ |
+
| 274 | +1x | +
+ stop(+ |
+
| 275 | +1x | +
+ "\nFollowing `ui_args` elements have no equivalent in the formals of `ui`:\n",+ |
+
| 276 | +1x | +
+ paste(paste(" -", ui_extra_args), collapse = "\n"),
+ |
+
| 277 | +1x | +
+ "\n\nUpdate the `ui` arguments by including above or add `...`"+ |
+
| 278 | ++ |
+ )+ |
+
| 279 | ++ |
+ }+ |
+
| 280 | ++ | + + | +
| 281 | +95x | +
+ structure(+ |
+
| 282 | +95x | +
+ list(+ |
+
| 283 | +95x | +
+ label = label,+ |
+
| 284 | +95x | +
+ server = server, ui = ui, datanames = datanames,+ |
+
| 285 | +95x | +
+ server_args = server_args, ui_args = ui_args+ |
+
| 286 | ++ |
+ ),+ |
+
| 287 | +95x | +
+ class = "teal_module"+ |
+
| 288 | ++ |
+ )+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | ++ | + + | +
| 291 | ++ | + + | +
| 292 | ++ |
+ #' Get module depth+ |
+
| 293 | ++ |
+ #'+ |
+
| 294 | ++ |
+ #' Depth starts at 0, so a single `teal.module` has depth 0.+ |
+
| 295 | ++ |
+ #' Nesting it increases overall depth by 1.+ |
+
| 296 | ++ |
+ #'+ |
+
| 297 | ++ |
+ #' @inheritParams init+ |
+
| 298 | ++ |
+ #' @param depth optional, integer determining current depth level+ |
+
| 299 | ++ |
+ #'+ |
+
| 300 | ++ |
+ #' @return depth level for given module+ |
+
| 301 | ++ |
+ #' @keywords internal+ |
+
| 302 | ++ |
+ #'+ |
+
| 303 | ++ |
+ #' @examples+ |
+
| 304 | ++ |
+ #' mods <- modules(+ |
+
| 305 | ++ |
+ #' label = "d1",+ |
+
| 306 | ++ |
+ #' modules(+ |
+
| 307 | ++ |
+ #' label = "d2",+ |
+
| 308 | ++ |
+ #' modules(+ |
+
| 309 | ++ |
+ #' label = "d3",+ |
+
| 310 | ++ |
+ #' module(label = "aaa1"), module(label = "aaa2"), module(label = "aaa3")+ |
+
| 311 | ++ |
+ #' ),+ |
+
| 312 | ++ |
+ #' module(label = "bbb")+ |
+
| 313 | ++ |
+ #' ),+ |
+
| 314 | ++ |
+ #' module(label = "ccc")+ |
+
| 315 | ++ |
+ #' )+ |
+
| 316 | ++ |
+ #' stopifnot(teal:::modules_depth(mods) == 3L)+ |
+
| 317 | ++ |
+ #'+ |
+
| 318 | ++ |
+ #' mods <- modules(+ |
+
| 319 | ++ |
+ #' label = "a",+ |
+
| 320 | ++ |
+ #' modules(+ |
+
| 321 | ++ |
+ #' label = "b1", module(label = "c")+ |
+
| 322 | ++ |
+ #' ),+ |
+
| 323 | ++ |
+ #' module(label = "b2")+ |
+
| 324 | ++ |
+ #' )+ |
+
| 325 | ++ |
+ #' stopifnot(teal:::modules_depth(mods) == 2L)+ |
+
| 326 | ++ |
+ modules_depth <- function(modules, depth = 0L) {
+ |
+
| 327 | +12x | +
+ checkmate::assert(+ |
+
| 328 | +12x | +
+ checkmate::check_class(modules, "teal_module"),+ |
+
| 329 | +12x | +
+ checkmate::check_class(modules, "teal_modules")+ |
+
| 330 | ++ |
+ )+ |
+
| 331 | +12x | +
+ checkmate::assert_int(depth, lower = 0)+ |
+
| 332 | +11x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 333 | +4x | +
+ max(vapply(modules$children, modules_depth, integer(1), depth = depth + 1L))+ |
+
| 334 | ++ |
+ } else {
+ |
+
| 335 | +7x | +
+ depth+ |
+
| 336 | ++ |
+ }+ |
+
| 337 | ++ |
+ }+ |
+
| 338 | ++ | + + | +
| 339 | ++ | + + | +
| 340 | ++ |
+ module_labels <- function(modules) {
+ |
+
| 341 | +! | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 342 | +! | +
+ lapply(modules$children, module_labels)+ |
+
| 343 | ++ |
+ } else {
+ |
+
| 344 | +! | +
+ modules$label+ |
+
| 345 | ++ |
+ }+ |
+
| 346 | ++ |
+ }+ |
+
| 347 | ++ | + + | +
| 348 | ++ |
+ #' Converts `teal_modules` to a string+ |
+
| 349 | ++ |
+ #'+ |
+
| 350 | ++ |
+ #' @param x (`teal_modules`) to print+ |
+
| 351 | ++ |
+ #' @param indent (`integer`) indent level;+ |
+
| 352 | ++ |
+ #' each `submodule` is indented one level more+ |
+
| 353 | ++ |
+ #' @param ... (optional) additional parameters to pass to recursive calls of `toString`+ |
+
| 354 | ++ |
+ #' @return (`character`)+ |
+
| 355 | ++ |
+ #' @export+ |
+
| 356 | ++ |
+ #' @rdname modules+ |
+
| 357 | ++ |
+ toString.teal_modules <- function(x, indent = 0, ...) { # nolint
+ |
+
| 358 | ++ |
+ # argument must be `x` to be consistent with base method+ |
+
| 359 | +! | +
+ paste(c(+ |
+
| 360 | +! | +
+ paste0(rep(" ", indent), "+ ", x$label),
+ |
+
| 361 | +! | +
+ unlist(lapply(x$children, toString, indent = indent + 1, ...))+ |
+
| 362 | +! | +
+ ), collapse = "\n")+ |
+
| 363 | ++ |
+ }+ |
+
| 364 | ++ | + + | +
| 365 | ++ |
+ #' Converts `teal_module` to a string+ |
+
| 366 | ++ |
+ #'+ |
+
| 367 | ++ |
+ #' @inheritParams toString.teal_modules+ |
+
| 368 | ++ |
+ #' @param x `teal_module`+ |
+
| 369 | ++ |
+ #' @param ... ignored+ |
+
| 370 | ++ |
+ #' @export+ |
+
| 371 | ++ |
+ #' @rdname module+ |
+
| 372 | ++ |
+ toString.teal_module <- function(x, indent = 0, ...) { # nolint
+ |
+
| 373 | +! | +
+ paste0(paste(rep(" ", indent), collapse = ""), "+ ", x$label, collapse = "")
+ |
+
| 374 | ++ |
+ }+ |
+
| 375 | ++ | + + | +
| 376 | ++ |
+ #' Prints `teal_modules`+ |
+
| 377 | ++ |
+ #' @param x `teal_modules`+ |
+
| 378 | ++ |
+ #' @param ... parameters passed to `toString`+ |
+
| 379 | ++ |
+ #' @export+ |
+
| 380 | ++ |
+ #' @rdname modules+ |
+
| 381 | ++ |
+ print.teal_modules <- function(x, ...) {
+ |
+
| 382 | +! | +
+ s <- toString(x, ...)+ |
+
| 383 | +! | +
+ cat(s)+ |
+
| 384 | +! | +
+ return(invisible(s))+ |
+
| 385 | ++ |
+ }+ |
+
| 386 | ++ | + + | +
| 387 | ++ |
+ #' Prints `teal_module`+ |
+
| 388 | ++ |
+ #' @param x `teal_module`+ |
+
| 389 | ++ |
+ #' @param ... parameters passed to `toString`+ |
+
| 390 | ++ |
+ #' @export+ |
+
| 391 | ++ |
+ #' @rdname module+ |
+
| 392 | ++ |
+ print.teal_module <- print.teal_modules+ |
+
| 1 | ++ |
+ #' Filter manager modal+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Opens modal containing the filter manager UI.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @name module_filter_manager_modal+ |
+
| 6 | ++ |
+ #' @inheritParams filter_manager_srv+ |
+
| 7 | ++ |
+ #' @examples+ |
+
| 8 | ++ |
+ #' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris)))+ |
+
| 9 | ++ |
+ #' fd2 <- teal.slice::init_filtered_data(+ |
+
| 10 | ++ |
+ #' list(iris = list(dataset = iris), mtcars = list(dataset = mtcars))+ |
+
| 11 | ++ |
+ #' )+ |
+
| 12 | ++ |
+ #' fd3 <- teal.slice::init_filtered_data(+ |
+
| 13 | ++ |
+ #' list(iris = list(dataset = iris), women = list(dataset = women))+ |
+
| 14 | ++ |
+ #' )+ |
+
| 15 | ++ |
+ #' filter <- teal_slices(+ |
+
| 16 | ++ |
+ #' teal.slice::teal_slice(dataname = "iris", varname = "Sepal.Length"),+ |
+
| 17 | ++ |
+ #' teal.slice::teal_slice(dataname = "iris", varname = "Species"),+ |
+
| 18 | ++ |
+ #' teal.slice::teal_slice(dataname = "mtcars", varname = "mpg"),+ |
+
| 19 | ++ |
+ #' teal.slice::teal_slice(dataname = "women", varname = "height"),+ |
+
| 20 | ++ |
+ #' mapping = list(+ |
+
| 21 | ++ |
+ #' module2 = c("mtcars mpg"),
+ |
+
| 22 | ++ |
+ #' module3 = c("women height"),
+ |
+
| 23 | ++ |
+ #' global_filters = "iris Species"+ |
+
| 24 | ++ |
+ #' )+ |
+
| 25 | ++ |
+ #' )+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' app <- shinyApp(+ |
+
| 28 | ++ |
+ #' ui = fluidPage(+ |
+
| 29 | ++ |
+ #' teal:::filter_manager_modal_ui("manager")
+ |
+
| 30 | ++ |
+ #' ),+ |
+
| 31 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 32 | ++ |
+ #' teal:::filter_manager_modal_srv(+ |
+
| 33 | ++ |
+ #' "manager",+ |
+
| 34 | ++ |
+ #' filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3),+ |
+
| 35 | ++ |
+ #' filter = filter+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #' }+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #' if (interactive()) {
+ |
+
| 40 | ++ |
+ #' runApp(app)+ |
+
| 41 | ++ |
+ #' }+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @keywords internal+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ NULL+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ #' @rdname module_filter_manager_modal+ |
+
| 48 | ++ |
+ filter_manager_modal_ui <- function(id) {
+ |
+
| 49 | +1x | +
+ ns <- NS(id)+ |
+
| 50 | +1x | +
+ tags$button(+ |
+
| 51 | +1x | +
+ id = ns("show"),
+ |
+
| 52 | +1x | +
+ class = "btn action-button filter_manager_button",+ |
+
| 53 | +1x | +
+ title = "Show filters manager modal",+ |
+
| 54 | +1x | +
+ icon("gear")
+ |
+
| 55 | ++ |
+ )+ |
+
| 56 | ++ |
+ }+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ #' @rdname module_filter_manager_modal+ |
+
| 59 | ++ |
+ filter_manager_modal_srv <- function(id, filtered_data_list, filter) {
+ |
+
| 60 | +4x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 61 | +4x | +
+ observeEvent(input$show, {
+ |
+
| 62 | +! | +
+ logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.")
+ |
+
| 63 | +! | +
+ showModal(+ |
+
| 64 | +! | +
+ modalDialog(+ |
+
| 65 | +! | +
+ filter_manager_ui(session$ns("filter_manager")),
+ |
+
| 66 | +! | +
+ size = "l",+ |
+
| 67 | +! | +
+ footer = NULL,+ |
+
| 68 | +! | +
+ easyClose = TRUE+ |
+
| 69 | ++ |
+ )+ |
+
| 70 | ++ |
+ )+ |
+
| 71 | ++ |
+ })+ |
+
| 72 | ++ | + + | +
| 73 | +4x | +
+ filter_manager_srv("filter_manager", filtered_data_list, filter)
+ |
+
| 74 | ++ |
+ })+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | ++ | + + | +
| 77 | ++ |
+ #' @rdname module_filter_manager+ |
+
| 78 | ++ |
+ filter_manager_ui <- function(id) {
+ |
+
| 79 | +! | +
+ ns <- NS(id)+ |
+
| 80 | +! | +
+ div(+ |
+
| 81 | +! | +
+ class = "filter_manager_content",+ |
+
| 82 | +! | +
+ tableOutput(ns("slices_table")),
+ |
+
| 83 | +! | +
+ snapshot_manager_ui(ns("snapshot_manager"))
+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ | + + | +
| 87 | ++ |
+ #' Manage multiple `FilteredData` objects+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' Oversee filter states in the whole application.+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' @rdname module_filter_manager+ |
+
| 92 | ++ |
+ #' @details+ |
+
| 93 | ++ |
+ #' This module observes the changes of the filters in each `FilteredData` object+ |
+
| 94 | ++ |
+ #' and keeps track of all filters used. A mapping of filters to modules+ |
+
| 95 | ++ |
+ #' is kept in the `mapping_matrix` object (which is actually a `data.frame`)+ |
+
| 96 | ++ |
+ #' that tracks which filters (rows) are active in which modules (columns).+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 99 | ++ |
+ #' `shiny` module id.+ |
+
| 100 | ++ |
+ #' @param filtered_data_list (`named list`)\cr+ |
+
| 101 | ++ |
+ #' A list, possibly nested, of `FilteredData` objects.+ |
+
| 102 | ++ |
+ #' Each `FilteredData` will be served to one module in the `teal` application.+ |
+
| 103 | ++ |
+ #' The structure of the list must reflect the nesting of modules in tabs+ |
+
| 104 | ++ |
+ #' and names of the list must be the same as labels of their respective modules.+ |
+
| 105 | ++ |
+ #' @inheritParams init+ |
+
| 106 | ++ |
+ #' @return A list of `reactive`s, each holding a `teal_slices`, as returned by `filter_manager_module_srv`.+ |
+
| 107 | ++ |
+ #' @keywords internal+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ filter_manager_srv <- function(id, filtered_data_list, filter) {
+ |
+
| 110 | +6x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 111 | +6x | +
+ logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.")
+ |
+
| 112 | ++ | + + | +
| 113 | +6x | +
+ is_module_specific <- isTRUE(attr(filter, "module_specific"))+ |
+
| 114 | ++ | + + | +
| 115 | ++ |
+ # Create global list of slices.+ |
+
| 116 | ++ |
+ # Contains all available teal_slice objects available to all modules.+ |
+
| 117 | ++ |
+ # Passed whole to instances of FilteredData used for individual modules.+ |
+
| 118 | ++ |
+ # Down there a subset that pertains to the data sets used in that module is applied and displayed.+ |
+
| 119 | +6x | +
+ slices_global <- reactiveVal(filter)+ |
+
| 120 | ++ | + + | +
| 121 | +6x | +
+ filtered_data_list <-+ |
+
| 122 | +6x | +
+ if (!is_module_specific) {
+ |
+
| 123 | ++ |
+ # Retrieve the first FilteredData from potentially nested list.+ |
+
| 124 | ++ |
+ # List of length one is named "global_filters" because that name is forbidden for a module label.+ |
+
| 125 | +5x | +
+ list(global_filters = unlist(filtered_data_list)[[1]])+ |
+
| 126 | ++ |
+ } else {
+ |
+
| 127 | ++ |
+ # Flatten potentially nested list of FilteredData objects while maintaining useful names.+ |
+
| 128 | ++ |
+ # Simply using `unlist` would result in concatenated names.+ |
+
| 129 | +1x | +
+ flatten_nested <- function(x, name = NULL) {
+ |
+
| 130 | +5x | +
+ if (inherits(x, "FilteredData")) {
+ |
+
| 131 | +3x | +
+ setNames(list(x), name)+ |
+
| 132 | ++ |
+ } else {
+ |
+
| 133 | +2x | +
+ unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name)))+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | +1x | +
+ flatten_nested(filtered_data_list)+ |
+
| 137 | ++ |
+ }+ |
+
| 138 | ++ | + + | +
| 139 | ++ |
+ # Create mapping fo filters to modules in matrix form (presented as data.frame).+ |
+
| 140 | ++ |
+ # Modules get NAs for filteres that cannot be set for them.+ |
+
| 141 | +6x | +
+ mapping_matrix <- reactive({
+ |
+
| 142 | +6x | +
+ state_ids_global <- vapply(slices_global(), `[[`, character(1L), "id")+ |
+
| 143 | +6x | +
+ mapping_smooth <- lapply(filtered_data_list, function(x) {
+ |
+
| 144 | +8x | +
+ state_ids_local <- vapply(x$get_filter_state(), `[[`, character(1L), "id")+ |
+
| 145 | +8x | +
+ state_ids_allowed <- vapply(x$get_available_teal_slices()(), `[[`, character(1L), "id")+ |
+
| 146 | +8x | +
+ states_active <- state_ids_global %in% state_ids_local+ |
+
| 147 | +8x | +
+ ifelse(state_ids_global %in% state_ids_allowed, states_active, NA)+ |
+
| 148 | ++ |
+ })+ |
+
| 149 | ++ | + + | +
| 150 | +6x | +
+ as.data.frame(mapping_smooth, row.names = state_ids_global, check.names = FALSE)+ |
+
| 151 | ++ |
+ })+ |
+
| 152 | ++ | + + | +
| 153 | +6x | +
+ output$slices_table <- renderTable(+ |
+
| 154 | +6x | +
+ expr = {
+ |
+
| 155 | ++ |
+ # Display logical values as UTF characters.+ |
+
| 156 | +3x | +
+ mm <- mapping_matrix()+ |
+
| 157 | +3x | +
+ mm[] <- lapply(mm, ifelse, yes = intToUtf8(9989), no = intToUtf8(10060))+ |
+
| 158 | +3x | +
+ mm[] <- lapply(mm, function(x) ifelse(is.na(x), intToUtf8(128306), x))+ |
+
| 159 | +3x | +
+ if (!is_module_specific) colnames(mm) <- "Global Filters"+ |
+
| 160 | ++ | + + | +
| 161 | ++ |
+ # Display placeholder if no filters defined.+ |
+
| 162 | +3x | +
+ if (nrow(mm) == 0L) {
+ |
+
| 163 | +3x | +
+ mm <- data.frame(`Filter manager` = "No filters specified.", check.names = FALSE)+ |
+
| 164 | +3x | +
+ rownames(mm) <- ""+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | ++ | + + | +
| 167 | ++ |
+ # Report Previewer will not be displayed.+ |
+
| 168 | +3x | +
+ mm[names(mm) != "Report previewer"]+ |
+
| 169 | ++ |
+ },+ |
+
| 170 | +6x | +
+ align = paste(c("l", rep("c", sum(names(filtered_data_list) != "Report previewer"))), collapse = ""),
+ |
+
| 171 | +6x | +
+ rownames = TRUE+ |
+
| 172 | ++ |
+ )+ |
+
| 173 | ++ | + + | +
| 174 | ++ |
+ # Create list of module calls.+ |
+
| 175 | +6x | +
+ modules_out <- lapply(names(filtered_data_list), function(module_name) {
+ |
+
| 176 | +8x | +
+ filter_manager_module_srv(+ |
+
| 177 | +8x | +
+ id = module_name,+ |
+
| 178 | +8x | +
+ module_fd = filtered_data_list[[module_name]],+ |
+
| 179 | +8x | +
+ slices_global = slices_global+ |
+
| 180 | ++ |
+ )+ |
+
| 181 | ++ |
+ })+ |
+
| 182 | ++ | + + | +
| 183 | ++ |
+ # Call snapshot manager.+ |
+
| 184 | +6x | +
+ snapshot_manager_srv("snapshot_manager", slices_global, mapping_matrix, filtered_data_list)
+ |
+
| 185 | ++ | + + | +
| 186 | +6x | +
+ modules_out # returned for testing purpose+ |
+
| 187 | ++ |
+ })+ |
+
| 188 | ++ |
+ }+ |
+
| 189 | ++ | + + | +
| 190 | ++ |
+ #' Module specific filter manager+ |
+
| 191 | ++ |
+ #'+ |
+
| 192 | ++ |
+ #' Track filter states in single module.+ |
+
| 193 | ++ |
+ #'+ |
+
| 194 | ++ |
+ #' This module tracks the state of a single `FilteredData` object and global `teal_slices`+ |
+
| 195 | ++ |
+ #' and updates both objects as necessary. Filter states added in different modules+ |
+
| 196 | ++ |
+ #' Filter states added any individual module are added to global `teal_slices`+ |
+
| 197 | ++ |
+ #' and from there become available in other modules+ |
+
| 198 | ++ |
+ #' by setting `private$available_teal_slices` in each `FilteredData`.+ |
+
| 199 | ++ |
+ #'+ |
+
| 200 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 201 | ++ |
+ #' `shiny` module id.+ |
+
| 202 | ++ |
+ #' @param module_fd (`FilteredData`)\cr+ |
+
| 203 | ++ |
+ #' object to filter data in the teal-module+ |
+
| 204 | ++ |
+ #' @param slices_global (`reactiveVal`)\cr+ |
+
| 205 | ++ |
+ #' stores `teal_slices` with all available filters; allows the following actions:+ |
+
| 206 | ++ |
+ #' - to disable/enable a specific filter in a module+ |
+
| 207 | ++ |
+ #' - to restore saved filter settings+ |
+
| 208 | ++ |
+ #' - to save current filter panel settings+ |
+
| 209 | ++ |
+ #' @return A `reactive` expression containing the slices active in this module.+ |
+
| 210 | ++ |
+ #' @keywords internal+ |
+
| 211 | ++ |
+ #'+ |
+
| 212 | ++ |
+ filter_manager_module_srv <- function(id, module_fd, slices_global) {
+ |
+
| 213 | +8x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 214 | ++ |
+ # Only operate on slices that refer to data sets present in this module.+ |
+
| 215 | +8x | +
+ module_fd$set_available_teal_slices(reactive(slices_global()))+ |
+
| 216 | ++ | + + | +
| 217 | ++ |
+ # Track filter state of this module.+ |
+
| 218 | +8x | +
+ slices_module <- reactive(module_fd$get_filter_state())+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ # Reactive values for comparing states.+ |
+
| 221 | +8x | +
+ previous_slices <- reactiveVal(isolate(slices_module()))+ |
+
| 222 | +8x | +
+ slices_added <- reactiveVal(NULL)+ |
+
| 223 | ++ | + + | +
| 224 | ++ |
+ # Observe changes in module filter state and trigger appropriate actions.+ |
+
| 225 | +8x | +
+ observeEvent(slices_module(), ignoreNULL = FALSE, {
+ |
+
| 226 | +3x | +
+ logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.")
+ |
+
| 227 | +3x | +
+ added <- setdiff_teal_slices(slices_module(), slices_global())+ |
+
| 228 | +! | +
+ if (length(added)) slices_added(added)+ |
+
| 229 | +3x | +
+ previous_slices(slices_module())+ |
+
| 230 | ++ |
+ })+ |
+
| 231 | ++ | + + | +
| 232 | +8x | +
+ observeEvent(slices_added(), ignoreNULL = TRUE, {
+ |
+
| 233 | +! | +
+ logger::log_trace("filter_manager_srv@2 added filter in module: { id }.")
+ |
+
| 234 | ++ |
+ # In case the new state has the same id as an existing state, add a suffix to it.+ |
+
| 235 | +! | +
+ global_ids <- vapply(slices_global(), `[[`, character(1L), "id")+ |
+
| 236 | +! | +
+ lapply(+ |
+
| 237 | +! | +
+ slices_added(),+ |
+
| 238 | +! | +
+ function(slice) {
+ |
+
| 239 | +! | +
+ if (slice$id %in% global_ids) {
+ |
+
| 240 | +! | +
+ slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1)+ |
+
| 241 | ++ |
+ }+ |
+
| 242 | ++ |
+ }+ |
+
| 243 | ++ |
+ )+ |
+
| 244 | +! | +
+ slices_global_new <- c(slices_global(), slices_added())+ |
+
| 245 | +! | +
+ slices_global(slices_global_new)+ |
+
| 246 | +! | +
+ slices_added(NULL)+ |
+
| 247 | ++ |
+ })+ |
+
| 248 | ++ | + + | +
| 249 | +8x | +
+ slices_module # returned for testing purpose+ |
+
| 250 | ++ |
+ })+ |
+
| 251 | ++ |
+ }+ |
+
| 1 | ++ |
+ # This file contains Shiny modules useful for debugging and developing teal.+ |
+
| 2 | ++ |
+ # We do not export the functions in this file. They are for+ |
+
| 3 | ++ |
+ # developers only and can be accessed via `:::`.+ |
+
| 4 | ++ | + + | +
| 5 | ++ |
+ #' Dummy module to show the filter calls generated by the right encoding panel+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' Please do not remove, this is useful for debugging teal without+ |
+
| 9 | ++ |
+ #' dependencies and simplifies `\link[devtools]{load_all}` which otherwise fails
+ |
+
| 10 | ++ |
+ #' and avoids session restarts!+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @param label `character` label of module+ |
+
| 13 | ++ |
+ #' @keywords internal+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' app <- init(+ |
+
| 17 | ++ |
+ #' data = list(iris = iris, mtcars = mtcars),+ |
+
| 18 | ++ |
+ #' modules = teal:::filter_calls_module(),+ |
+
| 19 | ++ |
+ #' header = "Simple teal app"+ |
+
| 20 | ++ |
+ #' )+ |
+
| 21 | ++ |
+ #' if (interactive()) {
+ |
+
| 22 | ++ |
+ #' runApp(app)+ |
+
| 23 | ++ |
+ #' }+ |
+
| 24 | ++ |
+ filter_calls_module <- function(label = "Filter Calls Module") { # nolint
+ |
+
| 25 | +! | +
+ checkmate::assert_string(label)+ |
+
| 26 | ++ | + + | +
| 27 | +! | +
+ module(+ |
+
| 28 | +! | +
+ label = label,+ |
+
| 29 | +! | +
+ server = function(input, output, session, data) {
+ |
+
| 30 | +! | +
+ checkmate::assert_class(data, "tdata")+ |
+
| 31 | ++ | + + | +
| 32 | +! | +
+ output$filter_calls <- renderText({
+ |
+
| 33 | +! | +
+ get_code_tdata(data)+ |
+
| 34 | ++ |
+ })+ |
+
| 35 | ++ |
+ },+ |
+
| 36 | +! | +
+ ui = function(id, ...) {
+ |
+
| 37 | +! | +
+ ns <- NS(id)+ |
+
| 38 | +! | +
+ div(+ |
+
| 39 | +! | +
+ h2("The following filter calls are generated:"),
+ |
+
| 40 | +! | +
+ verbatimTextOutput(ns("filter_calls"))
+ |
+
| 41 | ++ |
+ )+ |
+
| 42 | ++ |
+ },+ |
+
| 43 | +! | +
+ datanames = "all"+ |
+
| 44 | ++ |
+ )+ |
+
| 45 | ++ |
+ }+ |
+
| 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 doc 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 | ++ | + + | +
| 7 | ++ |
+ #' Create the Server and UI Function For the Shiny App+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 10 | ++ |
+ #' End-users: This is the most important function for you to start a+ |
+
| 11 | ++ |
+ #' teal app that is composed out of teal modules.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' **Notes for developers**:+ |
+
| 14 | ++ |
+ #' This is a wrapper function around the `module_teal.R` functions. Unless you are+ |
+
| 15 | ++ |
+ #' an end-user, don't use this function, but instead this module.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @param data (`TealData` or `TealDataset` or `TealDatasetConnector` or `list` or `data.frame`+ |
+
| 18 | ++ |
+ #' or `MultiAssayExperiment`)\cr+ |
+
| 19 | ++ |
+ #' `R6` object as returned by [teal.data::cdisc_data()], [teal.data::teal_data()],+ |
+
| 20 | ++ |
+ #' [teal.data::cdisc_dataset()], [teal.data::dataset()], [teal.data::dataset_connector()] or+ |
+
| 21 | ++ |
+ #' [teal.data::cdisc_dataset_connector()] or a single `data.frame` or a `MultiAssayExperiment`+ |
+
| 22 | ++ |
+ #' or a list of the previous objects or function returning a named list.+ |
+
| 23 | ++ |
+ #' NOTE: teal does not guarantee reproducibility of the code when names of the list elements+ |
+
| 24 | ++ |
+ #' do not match the original object names. To ensure reproducibility please use [teal.data::teal_data()]+ |
+
| 25 | ++ |
+ #' or [teal.data::cdisc_data()] with `check = TRUE` enabled.+ |
+
| 26 | ++ |
+ #' @param modules (`list`, `teal_modules` or `teal_module`)\cr+ |
+
| 27 | ++ |
+ #' nested list of `teal_modules` or `teal_module` objects or a single+ |
+
| 28 | ++ |
+ #' `teal_modules` or `teal_module` object. These are the specific output modules which+ |
+
| 29 | ++ |
+ #' will be displayed in the teal application. See [modules()] and [module()] for+ |
+
| 30 | ++ |
+ #' more details.+ |
+
| 31 | ++ |
+ #' @param title (`NULL` or `character`)\cr+ |
+
| 32 | ++ |
+ #' The browser window title (defaults to the host URL of the page).+ |
+
| 33 | ++ |
+ #' @param filter (`teal_slices`)\cr+ |
+
| 34 | ++ |
+ #' Specification of initial filter. Filters can be specified using [teal::teal_slices()].+ |
+
| 35 | ++ |
+ #' Old way of specifying filters through a list is deprecated and will be removed in the+ |
+
| 36 | ++ |
+ #' next release. Please fix your applications to use [teal::teal_slices()].+ |
+
| 37 | ++ |
+ #' @param header (`shiny.tag` or `character`) \cr+ |
+
| 38 | ++ |
+ #' the header of the app. Note shiny code placed here (and in the footer+ |
+
| 39 | ++ |
+ #' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function+ |
+
| 40 | ++ |
+ #' (such as loading `CSS` via [htmltools::htmlDependency()]) should be included here.+ |
+
| 41 | ++ |
+ #' @param footer (`shiny.tag` or `character`)\cr+ |
+
| 42 | ++ |
+ #' the footer of the app+ |
+
| 43 | ++ |
+ #' @param id (`character`)\cr+ |
+
| 44 | ++ |
+ #' module id to embed it, if provided,+ |
+
| 45 | ++ |
+ #' the server function must be called with [shiny::moduleServer()];+ |
+
| 46 | ++ |
+ #' See the vignette for an example. However, [ui_teal_with_splash()]+ |
+
| 47 | ++ |
+ #' is then preferred to this function.+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' @return named list with `server` and `ui` function+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' @export+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' @include modules.R+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @examples+ |
+
| 56 | ++ |
+ #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ |
+
| 57 | ++ |
+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' app <- init(+ |
+
| 60 | ++ |
+ #' data = teal_data(+ |
+
| 61 | ++ |
+ #' dataset("new_iris", new_iris),
+ |
+
| 62 | ++ |
+ #' dataset("new_mtcars", new_mtcars),
+ |
+
| 63 | ++ |
+ #' code = "+ |
+
| 64 | ++ |
+ #' new_iris <- transform(iris, id = seq_len(nrow(iris)))+ |
+
| 65 | ++ |
+ #' new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))+ |
+
| 66 | ++ |
+ #' "+ |
+
| 67 | ++ |
+ #' ),+ |
+
| 68 | ++ |
+ #' modules = modules(+ |
+
| 69 | ++ |
+ #' module(+ |
+
| 70 | ++ |
+ #' label = "data source",+ |
+
| 71 | ++ |
+ #' server = function(input, output, session, data) {},
+ |
+
| 72 | ++ |
+ #' ui = function(id, ...) div(p("information about data source")),
+ |
+
| 73 | ++ |
+ #' datanames = "all"+ |
+
| 74 | ++ |
+ #' ),+ |
+
| 75 | ++ |
+ #' example_module(label = "example teal module"),+ |
+
| 76 | ++ |
+ #' module(+ |
+
| 77 | ++ |
+ #' "Iris Sepal.Length histogram",+ |
+
| 78 | ++ |
+ #' server = function(input, output, session, data) {
+ |
+
| 79 | ++ |
+ #' output$hist <- renderPlot(+ |
+
| 80 | ++ |
+ #' hist(data[["new_iris"]]()$Sepal.Length)+ |
+
| 81 | ++ |
+ #' )+ |
+
| 82 | ++ |
+ #' },+ |
+
| 83 | ++ |
+ #' ui = function(id, ...) {
+ |
+
| 84 | ++ |
+ #' ns <- NS(id)+ |
+
| 85 | ++ |
+ #' plotOutput(ns("hist"))
+ |
+
| 86 | ++ |
+ #' },+ |
+
| 87 | ++ |
+ #' datanames = "new_iris"+ |
+
| 88 | ++ |
+ #' )+ |
+
| 89 | ++ |
+ #' ),+ |
+
| 90 | ++ |
+ #' title = "App title",+ |
+
| 91 | ++ |
+ #' filter = teal_slices(+ |
+
| 92 | ++ |
+ #' teal_slice(dataname = "new_iris", varname = "Species"),+ |
+
| 93 | ++ |
+ #' teal_slice(dataname = "new_iris", varname = "Sepal.Length"),+ |
+
| 94 | ++ |
+ #' teal_slice(dataname = "new_mtcars", varname = "cyl"),+ |
+
| 95 | ++ |
+ #' exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
+ |
+
| 96 | ++ |
+ #' mapping = list(+ |
+
| 97 | ++ |
+ #' `example teal module` = "new_iris Species",+ |
+
| 98 | ++ |
+ #' `Iris Sepal.Length histogram` = "new_iris Species",+ |
+
| 99 | ++ |
+ #' global_filters = "new_mtcars cyl"+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #' ),+ |
+
| 102 | ++ |
+ #' header = tags$h1("Sample App"),
+ |
+
| 103 | ++ |
+ #' footer = tags$p("Copyright 2017 - 2023")
+ |
+
| 104 | ++ |
+ #' )+ |
+
| 105 | ++ |
+ #' if (interactive()) {
+ |
+
| 106 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 107 | ++ |
+ #' }+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ init <- function(data,+ |
+
| 110 | ++ |
+ modules,+ |
+
| 111 | ++ |
+ title = NULL,+ |
+
| 112 | ++ |
+ filter = teal_slices(),+ |
+
| 113 | ++ |
+ header = tags$p(),+ |
+
| 114 | ++ |
+ footer = tags$p(),+ |
+
| 115 | ++ |
+ id = character(0)) {
+ |
+
| 116 | +38x | +
+ logger::log_trace("init initializing teal app with: data ({ class(data)[1] }).")
+ |
+
| 117 | +38x | +
+ data <- teal.data::to_relational_data(data = data)+ |
+
| 118 | ++ | + + | +
| 119 | +33x | +
+ checkmate::assert_class(data, "TealData")+ |
+
| 120 | +33x | +
+ checkmate::assert_multi_class(modules, c("teal_module", "list", "teal_modules"))
+ |
+
| 121 | +33x | +
+ checkmate::assert_string(title, null.ok = TRUE)+ |
+
| 122 | +33x | +
+ checkmate::assert(+ |
+
| 123 | +33x | +
+ checkmate::check_class(filter, "teal_slices"),+ |
+
| 124 | +33x | +
+ checkmate::check_list(filter, names = "named")+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | +32x | +
+ checkmate::assert_multi_class(header, c("shiny.tag", "character"))
+ |
+
| 127 | +32x | +
+ checkmate::assert_multi_class(footer, c("shiny.tag", "character"))
+ |
+
| 128 | +32x | +
+ checkmate::assert_character(id, max.len = 1, any.missing = FALSE)+ |
+
| 129 | ++ | + + | +
| 130 | +32x | +
+ teal.logger::log_system_info()+ |
+
| 131 | ++ | + + | +
| 132 | +32x | +
+ if (inherits(modules, "teal_module")) {
+ |
+
| 133 | +1x | +
+ modules <- list(modules)+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | +32x | +
+ if (inherits(modules, "list")) {
+ |
+
| 136 | +2x | +
+ modules <- do.call(teal::modules, modules)+ |
+
| 137 | ++ |
+ }+ |
+
| 138 | ++ | + + | +
| 139 | ++ |
+ # resolve modules datanames+ |
+
| 140 | +32x | +
+ datanames <- teal.data::get_dataname(data)+ |
+
| 141 | +32x | +
+ join_keys <- data$get_join_keys()+ |
+
| 142 | +32x | +
+ resolve_modules_datanames <- function(modules) {
+ |
+
| 143 | +240x | +
+ if (inherits(modules, "teal_modules")) {
+ |
+
| 144 | +90x | +
+ modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE)+ |
+
| 145 | +90x | +
+ modules+ |
+
| 146 | ++ |
+ } else {
+ |
+
| 147 | +150x | +
+ modules$datanames <- if (identical(modules$datanames, "all")) {
+ |
+
| 148 | +5x | +
+ datanames+ |
+
| 149 | +150x | +
+ } else if (is.character(modules$datanames)) {
+ |
+
| 150 | +145x | +
+ datanames_adjusted <- intersect(modules$datanames, datanames)+ |
+
| 151 | +145x | +
+ include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys)+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | +150x | +
+ modules+ |
+
| 154 | ++ |
+ }+ |
+
| 155 | ++ |
+ }+ |
+
| 156 | +32x | +
+ modules <- resolve_modules_datanames(modules = modules)+ |
+
| 157 | ++ | + + | +
| 158 | +32x | +
+ if (!inherits(filter, "teal_slices")) {
+ |
+
| 159 | +1x | +
+ checkmate::assert_subset(names(filter), choices = datanames)+ |
+
| 160 | ++ |
+ # list_to_teal_slices is lifted from teal.slice package, see zzz.R+ |
+
| 161 | ++ |
+ # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).+ |
+
| 162 | +1x | +
+ filter <- list_to_teal_slices(filter)+ |
+
| 163 | ++ |
+ }+ |
+
| 164 | ++ |
+ # convert teal.slice::teal_slices to teal::teal_slices+ |
+
| 165 | +32x | +
+ filter <- as.teal_slices(as.list(filter))+ |
+
| 166 | ++ | + + | +
| 167 | ++ |
+ # check teal_slices+ |
+
| 168 | +32x | +
+ for (i in seq_along(filter)) {
+ |
+
| 169 | +2x | +
+ dataname_i <- shiny::isolate(filter[[i]]$dataname)+ |
+
| 170 | +2x | +
+ if (!dataname_i %in% datanames) {
+ |
+
| 171 | +! | +
+ stop(+ |
+
| 172 | +! | +
+ sprintf(+ |
+
| 173 | +! | +
+ "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s",+ |
+
| 174 | +! | +
+ i,+ |
+
| 175 | +! | +
+ dataname_i,+ |
+
| 176 | +! | +
+ toString(datanames)+ |
+
| 177 | ++ |
+ )+ |
+
| 178 | ++ |
+ )+ |
+
| 179 | ++ |
+ }+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ | + + | +
| 182 | +32x | +
+ if (isTRUE(attr(filter, "module_specific"))) {
+ |
+
| 183 | +! | +
+ module_names <- unlist(c(module_labels(modules), "global_filters"))+ |
+
| 184 | +! | +
+ failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names)+ |
+
| 185 | +! | +
+ if (length(failed_mod_names)) {
+ |
+
| 186 | +! | +
+ stop(+ |
+
| 187 | +! | +
+ sprintf(+ |
+
| 188 | +! | +
+ "Some module names in the mapping arguments don't match module labels.\n %s not in %s",+ |
+
| 189 | +! | +
+ toString(failed_mod_names),+ |
+
| 190 | +! | +
+ toString(unique(module_names))+ |
+
| 191 | ++ |
+ )+ |
+
| 192 | ++ |
+ )+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | ++ | + + | +
| 195 | +! | +
+ if (anyDuplicated(module_names)) {
+ |
+
| 196 | ++ |
+ # In teal we are able to set nested modules with duplicated label.+ |
+
| 197 | ++ |
+ # Because mapping argument bases on the relationship between module-label and filter-id,+ |
+
| 198 | ++ |
+ # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label)+ |
+
| 199 | +! | +
+ stop(+ |
+
| 200 | +! | +
+ sprintf(+ |
+
| 201 | +! | +
+ "Module labels should be unique when teal_slices(mapping = TRUE). Duplicated labels:\n%s ",+ |
+
| 202 | +! | +
+ toString(module_names[duplicated(module_names)])+ |
+
| 203 | ++ |
+ )+ |
+
| 204 | ++ |
+ )+ |
+
| 205 | ++ |
+ }+ |
+
| 206 | ++ |
+ }+ |
+
| 207 | ++ | + + | +
| 208 | ++ |
+ # Note regarding case `id = character(0)`:+ |
+
| 209 | ++ |
+ # rather than using `callModule` and creating a submodule of this module, we directly modify+ |
+
| 210 | ++ |
+ # the `ui` and `server` with `id = character(0)` and calling the server function directly+ |
+
| 211 | ++ |
+ # rather than through `callModule`+ |
+
| 212 | +32x | +
+ res <- list(+ |
+
| 213 | +32x | +
+ ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),+ |
+
| 214 | +32x | +
+ server = function(input, output, session) {
+ |
+
| 215 | ++ |
+ # copy object so that load won't be shared between the session+ |
+
| 216 | +! | +
+ data <- data$copy(deep = TRUE)+ |
+
| 217 | +! | +
+ filter <- deep_copy_filter(filter)+ |
+
| 218 | +! | +
+ srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter)+ |
+
| 219 | ++ |
+ }+ |
+
| 220 | ++ |
+ )+ |
+
| 221 | +32x | +
+ logger::log_trace("init teal app has been initialized.")
+ |
+
| 222 | +32x | +
+ return(res)+ |
+
| 223 | ++ |
+ }+ |
+
| 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 | ++ |
+ #' @keywords internal+ |
+
| 120 | ++ |
+ # recursive object type test+ |
+
| 121 | ++ |
+ # returns logical of length 1+ |
+
| 122 | ++ |
+ is_validators <- function(x) {
+ |
+
| 123 | +118x | +
+ all(if (is.list(x)) unlist(lapply(x, is_validators)) else inherits(x, "InputValidator"))+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | ++ | + + | +
| 126 | ++ |
+ #' @keywords internal+ |
+
| 127 | ++ |
+ # test if an InputValidator object is enabled+ |
+
| 128 | ++ |
+ # returns logical of length 1+ |
+
| 129 | ++ |
+ # official method requested at https://github.com/rstudio/shinyvalidate/issues/64+ |
+
| 130 | ++ |
+ validator_enabled <- function(x) {
+ |
+
| 131 | +49x | +
+ x$.__enclos_env__$private$enabled+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ #' @keywords internal+ |
+
| 135 | ++ |
+ # recursively extract messages from validator list+ |
+
| 136 | ++ |
+ # returns character vector or a list of character vectors, possibly nested and named+ |
+
| 137 | ++ |
+ extract_validator <- function(iv, header) {
+ |
+
| 138 | +113x | +
+ if (inherits(iv, "InputValidator")) {
+ |
+
| 139 | +49x | +
+ add_header(gather_messages(iv), header)+ |
+
| 140 | ++ |
+ } else {
+ |
+
| 141 | +58x | +
+ if (is.null(names(iv))) names(iv) <- rep("", length(iv))
+ |
+
| 142 | +64x | +
+ mapply(extract_validator, iv = iv, header = names(iv), SIMPLIFY = FALSE)+ |
+
| 143 | ++ |
+ }+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | ++ | + + | +
| 146 | ++ |
+ #' @keywords internal+ |
+
| 147 | ++ |
+ # collate failing messages from validator+ |
+
| 148 | ++ |
+ # returns list+ |
+
| 149 | ++ |
+ gather_messages <- function(iv) {
+ |
+
| 150 | +49x | +
+ if (validator_enabled(iv)) {
+ |
+
| 151 | +46x | +
+ status <- iv$validate()+ |
+
| 152 | +46x | +
+ failing_inputs <- Filter(Negate(is.null), status)+ |
+
| 153 | +46x | +
+ unique(lapply(failing_inputs, function(x) x[["message"]]))+ |
+
| 154 | ++ |
+ } else {
+ |
+
| 155 | +3x | +
+ logger::log_warn("Validator is disabled and will be omitted.")
+ |
+
| 156 | +3x | +
+ list()+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ | + + | +
| 160 | ++ |
+ #' @keywords internal+ |
+
| 161 | ++ |
+ # add optional header to failing messages+ |
+
| 162 | ++ |
+ add_header <- function(messages, header = "") {
+ |
+
| 163 | +78x | +
+ ans <- unlist(messages)+ |
+
| 164 | +78x | +
+ if (length(ans) != 0L && isTRUE(nchar(header) > 0L)) {
+ |
+
| 165 | +31x | +
+ ans <- c(paste0(header, "\n"), ans, "\n")+ |
+
| 166 | ++ |
+ }+ |
+
| 167 | +78x | +
+ ans+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | ++ | + + | +
| 170 | ++ |
+ #' @keywords internal+ |
+
| 171 | ++ |
+ # recursively check if the object contains a named list+ |
+
| 172 | ++ |
+ any_names <- function(x) {
+ |
+
| 173 | +103x | +
+ any(+ |
+
| 174 | +103x | +
+ if (is.list(x)) {
+ |
+
| 175 | +58x | +
+ if (!is.null(names(x)) && any(names(x) != "")) TRUE else unlist(lapply(x, any_names))+ |
+
| 176 | ++ |
+ } else {
+ |
+
| 177 | +40x | +
+ FALSE+ |
+
| 178 | ++ |
+ }+ |
+
| 179 | ++ |
+ )+ |
+
| 180 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Get dummy `CDISC` data+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Get dummy `CDISC` data including `ADSL`, `ADAE` and `ADLB`.+ |
+
| 4 | ++ |
+ #' Some NAs are also introduced to stress test.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @return `cdisc_data`+ |
+
| 7 | ++ |
+ #' @keywords internal+ |
+
| 8 | ++ |
+ example_cdisc_data <- function() { # nolint
+ |
+
| 9 | +! | +
+ ADSL <- data.frame( # nolint+ |
+
| 10 | +! | +
+ STUDYID = "study",+ |
+
| 11 | +! | +
+ USUBJID = 1:10,+ |
+
| 12 | +! | +
+ SEX = sample(c("F", "M"), 10, replace = TRUE),
+ |
+
| 13 | +! | +
+ AGE = stats::rpois(10, 40)+ |
+
| 14 | ++ |
+ )+ |
+
| 15 | +! | +
+ ADTTE <- rbind(ADSL, ADSL, ADSL) # nolint+ |
+
| 16 | +! | +
+ ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10) # nolint
+ |
+
| 17 | +! | +
+ ADTTE$AVAL <- c( # nolint+ |
+
| 18 | +! | +
+ stats::rnorm(10, mean = 700, sd = 200), # dummy OS level+ |
+
| 19 | +! | +
+ stats::rnorm(10, mean = 400, sd = 100), # dummy EFS level+ |
+
| 20 | +! | +
+ stats::rnorm(10, mean = 450, sd = 200) # dummy PFS level+ |
+
| 21 | ++ |
+ )+ |
+
| 22 | ++ | + + | +
| 23 | +! | +
+ ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE) # nolint+ |
+
| 24 | +! | +
+ ADSL$SEX[c(2, 5)] <- NA # nolint+ |
+
| 25 | ++ | + + | +
| 26 | +! | +
+ cdisc_data_obj <- teal.data::cdisc_data(+ |
+
| 27 | +! | +
+ cdisc_dataset(dataname = "ADSL", x = ADSL),+ |
+
| 28 | +! | +
+ cdisc_dataset(dataname = "ADTTE", x = ADTTE)+ |
+
| 29 | ++ |
+ )+ |
+
| 30 | ++ | + + | +
| 31 | +! | +
+ res <- teal.data::cdisc_data(+ |
+
| 32 | +! | +
+ teal.data::cdisc_dataset(dataname = "ADSL", x = ADSL),+ |
+
| 33 | +! | +
+ teal.data::cdisc_dataset(dataname = "ADTTE", x = ADTTE),+ |
+
| 34 | +! | +
+ code = '+ |
+
| 35 | +! | +
+ ADSL <- data.frame(+ |
+
| 36 | +! | +
+ STUDYID = "study",+ |
+
| 37 | +! | +
+ USUBJID = 1:10,+ |
+
| 38 | +! | +
+ SEX = sample(c("F", "M"), 10, replace = TRUE),
+ |
+
| 39 | +! | +
+ AGE = rpois(10, 40)+ |
+
| 40 | ++ |
+ )+ |
+
| 41 | +! | +
+ ADTTE <- rbind(ADSL, ADSL, ADSL)+ |
+
| 42 | +! | +
+ ADTTE$PARAMCD <- rep(c("OS", "EFS", "PFS"), each = 10)
+ |
+
| 43 | +! | +
+ ADTTE$AVAL <- c(+ |
+
| 44 | +! | +
+ rnorm(10, mean = 700, sd = 200),+ |
+
| 45 | +! | +
+ rnorm(10, mean = 400, sd = 100),+ |
+
| 46 | +! | +
+ rnorm(10, mean = 450, sd = 200)+ |
+
| 47 | ++ |
+ )+ |
+
| 48 | ++ | + + | +
| 49 | +! | +
+ ADSL$logical_test <- sample(c(TRUE, FALSE, NA), size = nrow(ADSL), replace = TRUE)+ |
+
| 50 | +! | +
+ ADSL$SEX[c(2, 5)] <- NA+ |
+
| 51 | ++ |
+ '+ |
+
| 52 | ++ |
+ )+ |
+
| 53 | +! | +
+ return(res)+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | ++ | + + | +
| 56 | ++ |
+ #' Get datasets to go with example modules.+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' Creates a nested list, the structure of which matches the module hierarchy created by `example_modules`.+ |
+
| 59 | ++ |
+ #' Each list leaf is the same `FilteredData` object.+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' @return named list of `FilteredData` objects, each with `ADSL` set.+ |
+
| 62 | ++ |
+ #' @keywords internal+ |
+
| 63 | ++ |
+ example_datasets <- function() { # nolint
+ |
+
| 64 | +! | +
+ dummy_cdisc_data <- example_cdisc_data()+ |
+
| 65 | +! | +
+ datasets <- teal.slice::init_filtered_data(dummy_cdisc_data)+ |
+
| 66 | +! | +
+ list(+ |
+
| 67 | +! | +
+ "d2" = list(+ |
+
| 68 | +! | +
+ "d3" = list(+ |
+
| 69 | +! | +
+ "aaa1" = datasets,+ |
+
| 70 | +! | +
+ "aaa2" = datasets,+ |
+
| 71 | +! | +
+ "aaa3" = datasets+ |
+
| 72 | ++ |
+ ),+ |
+
| 73 | +! | +
+ "bbb" = datasets+ |
+
| 74 | ++ |
+ ),+ |
+
| 75 | +! | +
+ "ccc" = datasets+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | ++ |
+ }+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ #' An example `teal` module+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 82 | ++ |
+ #' @inheritParams module+ |
+
| 83 | ++ |
+ #' @return A `teal` module which can be included in the `modules` argument to [teal::init()].+ |
+
| 84 | ++ |
+ #' @examples+ |
+
| 85 | ++ |
+ #' app <- init(+ |
+
| 86 | ++ |
+ #' data = teal_data(+ |
+
| 87 | ++ |
+ #' dataset("IRIS", iris),
+ |
+
| 88 | ++ |
+ #' dataset("MTCARS", mtcars)
+ |
+
| 89 | ++ |
+ #' ),+ |
+
| 90 | ++ |
+ #' modules = example_module()+ |
+
| 91 | ++ |
+ #' )+ |
+
| 92 | ++ |
+ #' if (interactive()) {
+ |
+
| 93 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 94 | ++ |
+ #' }+ |
+
| 95 | ++ |
+ #' @export+ |
+
| 96 | ++ |
+ example_module <- function(label = "example teal module", datanames = "all") {
+ |
+
| 97 | +15x | +
+ checkmate::assert_string(label)+ |
+
| 98 | +15x | +
+ module(+ |
+
| 99 | +15x | +
+ label,+ |
+
| 100 | +15x | +
+ server = function(id, data) {
+ |
+
| 101 | +! | +
+ checkmate::assert_class(data, "tdata")+ |
+
| 102 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 103 | +! | +
+ output$text <- renderPrint(data[[input$dataname]]())+ |
+
| 104 | ++ |
+ })+ |
+
| 105 | ++ |
+ },+ |
+
| 106 | +15x | +
+ ui = function(id, data) {
+ |
+
| 107 | +! | +
+ ns <- NS(id)+ |
+
| 108 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 109 | +! | +
+ output = verbatimTextOutput(ns("text")),
+ |
+
| 110 | +! | +
+ encoding = selectInput(ns("dataname"), "Choose a dataset", choices = names(data))
+ |
+
| 111 | ++ |
+ )+ |
+
| 112 | ++ |
+ },+ |
+
| 113 | +15x | +
+ datanames = datanames+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | ++ | + + | +
| 118 | ++ |
+ #' Get example modules.+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #' Creates an example hierarchy of `teal_modules` from which a `teal` app can be created.+ |
+
| 121 | ++ |
+ #' @param datanames (`character`)\cr+ |
+
| 122 | ++ |
+ #' names of the datasets to be used in the example modules. Possible choices are `ADSL`, `ADTTE`.+ |
+
| 123 | ++ |
+ #' @return `teal_modules`+ |
+
| 124 | ++ |
+ #' @keywords internal+ |
+
| 125 | ++ |
+ example_modules <- function(datanames = c("ADSL", "ADTTE")) {
+ |
+
| 126 | +2x | +
+ checkmate::assert_subset(datanames, c("ADSL", "ADTTE"))
+ |
+
| 127 | +2x | +
+ mods <- modules(+ |
+
| 128 | +2x | +
+ label = "d1",+ |
+
| 129 | +2x | +
+ modules(+ |
+
| 130 | +2x | +
+ label = "d2",+ |
+
| 131 | +2x | +
+ modules(+ |
+
| 132 | +2x | +
+ label = "d3",+ |
+
| 133 | +2x | +
+ example_module(label = "aaa1", datanames = datanames),+ |
+
| 134 | +2x | +
+ example_module(label = "aaa2", datanames = datanames),+ |
+
| 135 | +2x | +
+ example_module(label = "aaa3", datanames = datanames)+ |
+
| 136 | ++ |
+ ),+ |
+
| 137 | +2x | +
+ example_module(label = "bbb", datanames = datanames)+ |
+
| 138 | ++ |
+ ),+ |
+
| 139 | +2x | +
+ example_module(label = "ccc", datanames = datanames)+ |
+
| 140 | ++ |
+ )+ |
+
| 141 | +2x | +
+ return(mods)+ |
+
| 142 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Generates library calls from current session info+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Function to create multiple library calls out of current session info to make reproducible code works.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @return Character object contain code+ |
+
| 6 | ++ |
+ #' @keywords internal+ |
+
| 7 | ++ |
+ get_rcode_libraries <- function() {
+ |
+
| 8 | +14x | +
+ vapply(+ |
+
| 9 | +14x | +
+ utils::sessionInfo()$otherPkgs,+ |
+
| 10 | +14x | +
+ function(x) {
+ |
+
| 11 | +238x | +
+ paste0("library(", x$Package, ")")
+ |
+
| 12 | ++ |
+ },+ |
+
| 13 | +14x | +
+ character(1)+ |
+
| 14 | ++ |
+ ) %>%+ |
+
| 15 | ++ |
+ # put it into reverse order to correctly simulate executed code+ |
+
| 16 | +14x | +
+ rev() %>%+ |
+
| 17 | +14x | +
+ paste0(sep = "\n") %>%+ |
+
| 18 | +14x | +
+ paste0(collapse = "")+ |
+
| 19 | ++ |
+ }+ |
+
| 20 | ++ | + + | +
| 21 | ++ | + + | +
| 22 | ++ | + + | +
| 23 | ++ |
+ get_rcode_str_install <- function() {
+ |
+
| 24 | +18x | +
+ code_string <- getOption("teal.load_nest_code")
+ |
+
| 25 | ++ | + + | +
| 26 | +18x | +
+ if (!is.null(code_string) && is.character(code_string)) {
+ |
+
| 27 | +2x | +
+ return(code_string)+ |
+
| 28 | ++ |
+ }+ |
+
| 29 | ++ | + + | +
| 30 | +16x | +
+ return("# Add any code to install/load your NEST environment here\n")
+ |
+
| 31 | ++ |
+ }+ |
+
| 32 | ++ | + + | +
| 33 | ++ |
+ #' Get datasets code+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' Get combined code from `FilteredData` and from `CodeClass` object.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @param datanames (`character`) names of datasets to extract code from+ |
+
| 38 | ++ |
+ #' @param datasets (`FilteredData`) object+ |
+
| 39 | ++ |
+ #' @param hashes named (`list`) of hashes per dataset+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @return `character(3)` containing following elements:+ |
+
| 42 | ++ |
+ #' - code from `CodeClass` (data loading code)+ |
+
| 43 | ++ |
+ #' - hash check of loaded objects+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @keywords internal+ |
+
| 46 | ++ |
+ get_datasets_code <- function(datanames, datasets, hashes) {
+ |
+
| 47 | +14x | +
+ str_code <- datasets$get_code(datanames)+ |
+
| 48 | +14x | +
+ if (length(str_code) == 0 || (length(str_code) == 1 && str_code == "")) {
+ |
+
| 49 | +! | +
+ str_code <- "message('Preprocessing is empty')"
+ |
+
| 50 | +14x | +
+ } else if (length(str_code) > 0) {
+ |
+
| 51 | +14x | +
+ str_code <- paste0(str_code, "\n\n")+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ | + + | +
| 54 | +14x | +
+ if (!datasets$get_check()) {
+ |
+
| 55 | +10x | +
+ check_note_string <- paste0(+ |
+
| 56 | +10x | +
+ c(+ |
+
| 57 | +10x | +
+ "message(paste(\"Reproducibility of data import and preprocessing was not explicitly checked\",",+ |
+
| 58 | +10x | +
+ " \" ('check = FALSE' is set). Contact app developer if this is an issue.\n\"))"
+ |
+
| 59 | ++ |
+ ),+ |
+
| 60 | +10x | +
+ collapse = "\n"+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | +10x | +
+ str_code <- paste0(str_code, "\n\n", check_note_string)+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | +14x | +
+ str_hash <- paste(+ |
+
| 66 | +14x | +
+ paste0(+ |
+
| 67 | +14x | +
+ vapply(+ |
+
| 68 | +14x | +
+ datanames,+ |
+
| 69 | +14x | +
+ function(dataname) {
+ |
+
| 70 | +17x | +
+ sprintf(+ |
+
| 71 | +17x | +
+ "stopifnot(%s == %s)",+ |
+
| 72 | +17x | +
+ deparse1(bquote(rlang::hash(.(as.name(dataname))))),+ |
+
| 73 | +17x | +
+ deparse1(hashes[[dataname]])+ |
+
| 74 | ++ |
+ )+ |
+
| 75 | ++ |
+ },+ |
+
| 76 | +14x | +
+ character(1)+ |
+
| 77 | ++ |
+ ),+ |
+
| 78 | +14x | +
+ collapse = "\n"+ |
+
| 79 | ++ |
+ ),+ |
+
| 80 | +14x | +
+ "\n\n"+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ | + + | +
| 83 | +14x | +
+ c(str_code, str_hash)+ |
+
| 84 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Create a `teal` module for previewing a report+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #' This function wraps [teal.reporter::reporter_previewer_ui()] and+ |
+
| 5 | ++ |
+ #' [teal.reporter::reporter_previewer_srv()] into a `teal_module` to be+ |
+
| 6 | ++ |
+ #' used in `teal` applications.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' If you are creating a `teal` application using [teal::init()] then this+ |
+
| 9 | ++ |
+ #' module will be added to your application automatically if any of your `teal modules`+ |
+
| 10 | ++ |
+ #' support report generation+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @inheritParams module+ |
+
| 13 | ++ |
+ #' @param server_args (`named list`)\cr+ |
+
| 14 | ++ |
+ #' Arguments passed to [teal.reporter::reporter_previewer_srv()].+ |
+
| 15 | ++ |
+ #' @return `teal_module` containing the `teal.reporter` previewer functionality+ |
+
| 16 | ++ |
+ #' @export+ |
+
| 17 | ++ |
+ reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
+ |
+
| 18 | +4x | +
+ checkmate::assert_string(label)+ |
+
| 19 | +2x | +
+ checkmate::assert_list(server_args, names = "named")+ |
+
| 20 | +2x | +
+ checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))+ |
+
| 21 | ++ | + + | +
| 22 | +2x | +
+ srv <- function(id, reporter, ...) {
+ |
+
| 23 | +! | +
+ teal.reporter::reporter_previewer_srv(id, reporter, ...)+ |
+
| 24 | ++ |
+ }+ |
+
| 25 | ++ | + + | +
| 26 | +2x | +
+ ui <- function(id, ...) {
+ |
+
| 27 | +! | +
+ teal.reporter::reporter_previewer_ui(id, ...)+ |
+
| 28 | ++ |
+ }+ |
+
| 29 | ++ | + + | +
| 30 | +2x | +
+ module <- module(+ |
+
| 31 | +2x | +
+ label = "temporary label",+ |
+
| 32 | +2x | +
+ server = srv, ui = ui,+ |
+
| 33 | +2x | +
+ server_args = server_args, ui_args = list(), datanames = NULL+ |
+
| 34 | ++ |
+ )+ |
+
| 35 | +2x | +
+ class(module) <- c("teal_module_previewer", class(module))
+ |
+
| 36 | +2x | +
+ module$label <- label+ |
+
| 37 | +2x | +
+ module+ |
+
| 38 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @title `TealReportCard`+ |
+
| 2 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 3 | ++ |
+ #' A child 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 invisibly self+ |
+
| 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 invisibly self+ |
+
| 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 invisibly self+ |
+
| 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 `TealSlicesBlock`+ |
+
| 88 | ++ |
+ #' @examples+ |
+
| 89 | ++ |
+ #' block <- teal:::TealSlicesBlock$new()+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ initialize = function(content = teal_slices(), style = "verbatim") {
+ |
+
| 92 | +10x | +
+ self$set_content(content)+ |
+
| 93 | +9x | +
+ self$set_style(style)+ |
+
| 94 | +9x | +
+ invisible(self)+ |
+
| 95 | ++ |
+ },+ |
+
| 96 | ++ | + + | +
| 97 | ++ |
+ #' @description Sets content of this `TealSlicesBlock`.+ |
+
| 98 | ++ |
+ #' Sets content as `YAML` text which represents a list generated from `teal_slices`.+ |
+
| 99 | ++ |
+ #' The list displays limited number of fields from `teal_slice` objects, but this list is+ |
+
| 100 | ++ |
+ #' sufficient to conclude which filters were applied.+ |
+
| 101 | ++ |
+ #' When `selected` field in `teal_slice` object is a range, then it is displayed as a "min"+ |
+
| 102 | ++ |
+ #'+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' @param content (`teal_slices`) object returned from [teal_slices()] function.+ |
+
| 105 | ++ |
+ #' @return invisibly self+ |
+
| 106 | ++ |
+ set_content = function(content) {
+ |
+
| 107 | +11x | +
+ checkmate::assert_class(content, "teal_slices")+ |
+
| 108 | +10x | +
+ if (length(content) != 0) {
+ |
+
| 109 | +7x | +
+ states_list <- lapply(content, function(x) {
+ |
+
| 110 | +7x | +
+ x_list <- shiny::isolate(as.list(x))+ |
+
| 111 | +7x | +
+ if (+ |
+
| 112 | +7x | +
+ inherits(x_list$choices, c("integer", "numeric", "Date", "POSIXct", "POSIXlt")) &&
+ |
+
| 113 | +7x | +
+ length(x_list$choices) == 2 &&+ |
+
| 114 | +7x | +
+ length(x_list$selected) == 2+ |
+
| 115 | ++ |
+ ) {
+ |
+
| 116 | +! | +
+ x_list$range <- paste(x_list$selected, collapse = " - ")+ |
+
| 117 | +! | +
+ x_list["selected"] <- NULL+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | +7x | +
+ if (!is.null(x_list$arg)) {
+ |
+
| 120 | +! | +
+ x_list$arg <- if (x_list$arg == "subset") "Genes" else "Samples"+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | ++ | + + | +
| 123 | +7x | +
+ x_list <- x_list[+ |
+
| 124 | +7x | +
+ c("dataname", "varname", "experiment", "arg", "expr", "selected", "range", "keep_na", "keep_inf")
+ |
+
| 125 | ++ |
+ ]+ |
+
| 126 | +7x | +
+ names(x_list) <- c(+ |
+
| 127 | +7x | +
+ "Dataset name", "Variable name", "Experiment", "Filtering by", "Applied expression",+ |
+
| 128 | +7x | +
+ "Selected Values", "Selected range", "Include NA values", "Include Inf values"+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ | + + | +
| 131 | +7x | +
+ Filter(Negate(is.null), x_list)+ |
+
| 132 | ++ |
+ })+ |
+
| 133 | ++ | + + | +
| 134 | +7x | +
+ if (requireNamespace("yaml", quietly = TRUE)) {
+ |
+
| 135 | +7x | +
+ super$set_content(yaml::as.yaml(states_list))+ |
+
| 136 | ++ |
+ } else {
+ |
+
| 137 | +! | +
+ stop("yaml package is required to format the filter state list")
+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ |
+ }+ |
+
| 140 | +10x | +
+ private$teal_slices <- content+ |
+
| 141 | +10x | +
+ invisible(self)+ |
+
| 142 | ++ |
+ },+ |
+
| 143 | ++ |
+ #' @description Create the `RcodeBlock` from a list.+ |
+
| 144 | ++ |
+ #' @param x `named list` with two fields `c("text", "params")`.
+ |
+
| 145 | ++ |
+ #' Use the `get_available_params` method to get all possible parameters.+ |
+
| 146 | ++ |
+ #' @return invisibly self+ |
+
| 147 | ++ |
+ from_list = function(x) {
+ |
+
| 148 | +1x | +
+ checkmate::assert_list(x)+ |
+
| 149 | +1x | +
+ checkmate::assert_names(names(x), must.include = c("teal_slices"))
+ |
+
| 150 | +1x | +
+ self$set_content(x$teal_slices)+ |
+
| 151 | +1x | +
+ invisible(self)+ |
+
| 152 | ++ |
+ },+ |
+
| 153 | ++ |
+ #' @description Convert the `RcodeBlock` to a list.+ |
+
| 154 | ++ |
+ #' @return `named list` with a text and `params`.+ |
+
| 155 | ++ | + + | +
| 156 | ++ |
+ to_list = function() {
+ |
+
| 157 | +2x | +
+ list(teal_slices = private$teal_slices)+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ |
+ ),+ |
+
| 160 | ++ |
+ private = list(+ |
+
| 161 | ++ |
+ style = "verbatim",+ |
+
| 162 | ++ |
+ teal_slices = NULL # teal_slices+ |
+
| 163 | ++ |
+ )+ |
+
| 164 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Validate that dataset has a minimum number of observations+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #' @param x a data.frame+ |
+
| 5 | ++ |
+ #' @param min_nrow minimum number of rows in \code{x}
+ |
+
| 6 | ++ |
+ #' @param complete \code{logical} default \code{FALSE} when set to \code{TRUE} then complete cases are checked.
+ |
+
| 7 | ++ |
+ #' @param allow_inf \code{logical} default \code{TRUE} when set to \code{FALSE} then error thrown if any values are
+ |
+
| 8 | ++ |
+ #' infinite.+ |
+
| 9 | ++ |
+ #' @param msg (`character(1)`) additional message to display alongside the default message.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @details This function is a wrapper for `shiny::validate`.+ |
+
| 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 | ++ |
+ #' df <- iris[iris$Sepal.Length <= input$len, ]+ |
+
| 27 | ++ |
+ #' validate_has_data(+ |
+
| 28 | ++ |
+ #' iris_f,+ |
+
| 29 | ++ |
+ #' min_nrow = 10,+ |
+
| 30 | ++ |
+ #' complete = FALSE,+ |
+
| 31 | ++ |
+ #' msg = "Please adjust Max Length of Sepal"+ |
+
| 32 | ++ |
+ #' )+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' hist(iris_f$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 | +
+ stopifnot(+ |
+
| 47 | +17x | +
+ "Please provide a character vector in msg argument of validate_has_data." = is.character(msg) || is.null(msg)+ |
+
| 48 | ++ |
+ )+ |
+
| 49 | +15x | +
+ validate(need(!is.null(x) && is.data.frame(x), "No data left."))+ |
+
| 50 | +15x | +
+ if (!is.null(min_nrow)) {
+ |
+
| 51 | +15x | +
+ if (complete) {
+ |
+
| 52 | +5x | +
+ complete_index <- stats::complete.cases(x)+ |
+
| 53 | +5x | +
+ validate(need(+ |
+
| 54 | +5x | +
+ sum(complete_index) > 0 && nrow(x[complete_index, , drop = FALSE]) >= min_nrow,+ |
+
| 55 | +5x | +
+ paste(c(paste("Number of complete cases is less than:", min_nrow), msg), collapse = "\n")
+ |
+
| 56 | ++ |
+ ))+ |
+
| 57 | ++ |
+ } else {
+ |
+
| 58 | +10x | +
+ validate(need(+ |
+
| 59 | +10x | +
+ nrow(x) >= min_nrow,+ |
+
| 60 | +10x | +
+ paste(+ |
+
| 61 | +10x | +
+ c(paste("Minimum number of records not met: >=", min_nrow, "records required."), msg),
+ |
+
| 62 | +10x | +
+ collapse = "\n"+ |
+
| 63 | ++ |
+ )+ |
+
| 64 | ++ |
+ ))+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | +10x | +
+ if (!allow_inf) {
+ |
+
| 68 | +6x | +
+ validate(need(+ |
+
| 69 | +6x | +
+ all(vapply(x, function(col) !is.numeric(col) || !any(is.infinite(col)), logical(1))),+ |
+
| 70 | +6x | +
+ "Dataframe contains Inf values which is not allowed."+ |
+
| 71 | ++ |
+ ))+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ #' Validate that dataset has unique rows for key variables+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 79 | ++ |
+ #' @param x a data.frame+ |
+
| 80 | ++ |
+ #' @param key a vector of ID variables from \code{x} that identify unique records
+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' @details This function is a wrapper for `shiny::validate`.+ |
+
| 83 | ++ |
+ #'+ |
+
| 84 | ++ |
+ #' @export+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' @examples+ |
+
| 87 | ++ |
+ #' iris$id <- rep(1:50, times = 3)+ |
+
| 88 | ++ |
+ #' ui <- fluidPage(+ |
+
| 89 | ++ |
+ #' selectInput(+ |
+
| 90 | ++ |
+ #' inputId = "species",+ |
+
| 91 | ++ |
+ #' label = "Select species",+ |
+
| 92 | ++ |
+ #' choices = c("setosa", "versicolor", "virginica"),
+ |
+
| 93 | ++ |
+ #' selected = "setosa",+ |
+
| 94 | ++ |
+ #' multiple = TRUE+ |
+
| 95 | ++ |
+ #' ),+ |
+
| 96 | ++ |
+ #' plotOutput("plot")
+ |
+
| 97 | ++ |
+ #' )+ |
+
| 98 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 99 | ++ |
+ #' output$plot <- renderPlot({
+ |
+
| 100 | ++ |
+ #' iris_f <- iris[iris$Species %in% input$species, ]+ |
+
| 101 | ++ |
+ #' validate_one_row_per_id(iris_f, key = c("id"))
+ |
+
| 102 | ++ |
+ #'+ |
+
| 103 | ++ |
+ #' hist(iris_f$Sepal.Length, breaks = 5)+ |
+
| 104 | ++ |
+ #' })+ |
+
| 105 | ++ |
+ #' }+ |
+
| 106 | ++ |
+ #' if (interactive()) {
+ |
+
| 107 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 108 | ++ |
+ #' }+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ validate_one_row_per_id <- function(x, key = c("USUBJID", "STUDYID")) {
+ |
+
| 111 | +! | +
+ validate(need(!any(duplicated(x[key])), paste("Found more than one row per id.")))
+ |
+
| 112 | ++ |
+ }+ |
+
| 113 | ++ | + + | +
| 114 | ++ |
+ #' Validates that vector includes all expected values+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 117 | ++ |
+ #' @param x values to test. All must be in \code{choices}
+ |
+
| 118 | ++ |
+ #' @param choices a vector to test for values of \code{x}
+ |
+
| 119 | ++ |
+ #' @param msg warning message to display+ |
+
| 120 | ++ |
+ #'+ |
+
| 121 | ++ |
+ #' @details This function is a wrapper for `shiny::validate`.+ |
+
| 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 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 154 | ++ |
+ #' @param x vector+ |
+
| 155 | ++ |
+ #' @param msg message to display+ |
+
| 156 | ++ |
+ #'+ |
+
| 157 | ++ |
+ #' @details This function is a wrapper for `shiny::validate`.+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @export+ |
+
| 160 | ++ |
+ #'+ |
+
| 161 | ++ |
+ #' @examples+ |
+
| 162 | ++ |
+ #' data <- data.frame(+ |
+
| 163 | ++ |
+ #' id = c(1:10, 11:20, 1:10),+ |
+
| 164 | ++ |
+ #' strata = rep(c("A", "B"), each = 15)
+ |
+
| 165 | ++ |
+ #' )+ |
+
| 166 | ++ |
+ #' ui <- fluidPage(+ |
+
| 167 | ++ |
+ #' selectInput("ref1", "Select strata1 to compare",
+ |
+
| 168 | ++ |
+ #' choices = c("A", "B", "C"), selected = "A"
+ |
+
| 169 | ++ |
+ #' ),+ |
+
| 170 | ++ |
+ #' selectInput("ref2", "Select strata2 to compare",
+ |
+
| 171 | ++ |
+ #' choices = c("A", "B", "C"), selected = "B"
+ |
+
| 172 | ++ |
+ #' ),+ |
+
| 173 | ++ |
+ #' verbatimTextOutput("arm_summary")
+ |
+
| 174 | ++ |
+ #' )+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 177 | ++ |
+ #' output$arm_summary <- renderText({
+ |
+
| 178 | ++ |
+ #' sample_1 <- data$id[data$strata == input$ref1]+ |
+
| 179 | ++ |
+ #' sample_2 <- data$id[data$strata == input$ref2]+ |
+
| 180 | ++ |
+ #'+ |
+
| 181 | ++ |
+ #' validate_has_elements(sample_1, "No subjects in strata1.")+ |
+
| 182 | ++ |
+ #' validate_has_elements(sample_2, "No subjects in strata2.")+ |
+
| 183 | ++ |
+ #'+ |
+
| 184 | ++ |
+ #' paste0(+ |
+
| 185 | ++ |
+ #' "Number of samples in: strata1=", length(sample_1),+ |
+
| 186 | ++ |
+ #' " comparions strata2=", length(sample_2)+ |
+
| 187 | ++ |
+ #' )+ |
+
| 188 | ++ |
+ #' })+ |
+
| 189 | ++ |
+ #' }+ |
+
| 190 | ++ |
+ #' if (interactive()) {
+ |
+
| 191 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 192 | ++ |
+ #' }+ |
+
| 193 | ++ |
+ validate_has_elements <- function(x, msg) {
+ |
+
| 194 | +! | +
+ validate(need(length(x) > 0, msg))+ |
+
| 195 | ++ |
+ }+ |
+
| 196 | ++ | + + | +
| 197 | ++ |
+ #' Validates no intersection between two vectors+ |
+
| 198 | ++ |
+ #'+ |
+
| 199 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 200 | ++ |
+ #' @param x vector+ |
+
| 201 | ++ |
+ #' @param y vector+ |
+
| 202 | ++ |
+ #' @param msg message to display if \code{x} and \code{y} intersect
+ |
+
| 203 | ++ |
+ #'+ |
+
| 204 | ++ |
+ #' @details This function is a wrapper for `shiny::validate`.+ |
+
| 205 | ++ |
+ #'+ |
+
| 206 | ++ |
+ #' @export+ |
+
| 207 | ++ |
+ #'+ |
+
| 208 | ++ |
+ #' @examples+ |
+
| 209 | ++ |
+ #' data <- data.frame(+ |
+
| 210 | ++ |
+ #' id = c(1:10, 11:20, 1:10),+ |
+
| 211 | ++ |
+ #' strata = rep(c("A", "B", "C"), each = 10)
+ |
+
| 212 | ++ |
+ #' )+ |
+
| 213 | ++ |
+ #'+ |
+
| 214 | ++ |
+ #' ui <- fluidPage(+ |
+
| 215 | ++ |
+ #' selectInput("ref1", "Select strata1 to compare",
+ |
+
| 216 | ++ |
+ #' choices = c("A", "B", "C"),
+ |
+
| 217 | ++ |
+ #' selected = "A"+ |
+
| 218 | ++ |
+ #' ),+ |
+
| 219 | ++ |
+ #' selectInput("ref2", "Select strata2 to compare",
+ |
+
| 220 | ++ |
+ #' choices = c("A", "B", "C"),
+ |
+
| 221 | ++ |
+ #' selected = "B"+ |
+
| 222 | ++ |
+ #' ),+ |
+
| 223 | ++ |
+ #' verbatimTextOutput("summary")
+ |
+
| 224 | ++ |
+ #' )+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 227 | ++ |
+ #' output$summary <- renderText({
+ |
+
| 228 | ++ |
+ #' sample_1 <- data$id[data$strata == input$ref1]+ |
+
| 229 | ++ |
+ #' sample_2 <- data$id[data$strata == input$ref2]+ |
+
| 230 | ++ |
+ #'+ |
+
| 231 | ++ |
+ #' validate_no_intersection(+ |
+
| 232 | ++ |
+ #' sample_1, sample_2,+ |
+
| 233 | ++ |
+ #' "subjects within strata1 and strata2 cannot overlap"+ |
+
| 234 | ++ |
+ #' )+ |
+
| 235 | ++ |
+ #' paste0(+ |
+
| 236 | ++ |
+ #' "Number of subject in: reference treatment=", length(sample_1),+ |
+
| 237 | ++ |
+ #' " comparions treatment=", length(sample_2)+ |
+
| 238 | ++ |
+ #' )+ |
+
| 239 | ++ |
+ #' })+ |
+
| 240 | ++ |
+ #' }+ |
+
| 241 | ++ |
+ #' if (interactive()) {
+ |
+
| 242 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 243 | ++ |
+ #' }+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ validate_no_intersection <- function(x, y, msg) {
+ |
+
| 246 | +! | +
+ validate(need(length(intersect(x, y)) == 0, msg))+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | ++ | + + | +
| 249 | ++ | + + | +
| 250 | ++ |
+ #' Validates that dataset contains specific variable+ |
+
| 251 | ++ |
+ #'+ |
+
| 252 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 253 | ++ |
+ #' @param data a data.frame+ |
+
| 254 | ++ |
+ #' @param varname name of variable in \code{data}
+ |
+
| 255 | ++ |
+ #' @param msg message to display if \code{data} does not include \code{varname}
+ |
+
| 256 | ++ |
+ #'+ |
+
| 257 | ++ |
+ #' @details This function is a wrapper for `shiny::validate`.+ |
+
| 258 | ++ |
+ #'+ |
+
| 259 | ++ |
+ #' @export+ |
+
| 260 | ++ |
+ #'+ |
+
| 261 | ++ |
+ #' @examples+ |
+
| 262 | ++ |
+ #' data <- data.frame(+ |
+
| 263 | ++ |
+ #' one = rep("a", length.out = 20),
+ |
+
| 264 | ++ |
+ #' two = rep(c("a", "b"), length.out = 20)
+ |
+
| 265 | ++ |
+ #' )+ |
+
| 266 | ++ |
+ #' ui <- fluidPage(+ |
+
| 267 | ++ |
+ #' selectInput(+ |
+
| 268 | ++ |
+ #' "var",+ |
+
| 269 | ++ |
+ #' "Select variable",+ |
+
| 270 | ++ |
+ #' choices = c("one", "two", "three", "four"),
+ |
+
| 271 | ++ |
+ #' selected = "one"+ |
+
| 272 | ++ |
+ #' ),+ |
+
| 273 | ++ |
+ #' verbatimTextOutput("summary")
+ |
+
| 274 | ++ |
+ #' )+ |
+
| 275 | ++ |
+ #'+ |
+
| 276 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 277 | ++ |
+ #' output$summary <- renderText({
+ |
+
| 278 | ++ |
+ #' validate_has_variable(data, input$var)+ |
+
| 279 | ++ |
+ #' paste0("Selected treatment variables: ", paste(input$var, collapse = ", "))
+ |
+
| 280 | ++ |
+ #' })+ |
+
| 281 | ++ |
+ #' }+ |
+
| 282 | ++ |
+ #' if (interactive()) {
+ |
+
| 283 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 284 | ++ |
+ #' }+ |
+
| 285 | ++ |
+ validate_has_variable <- function(data, varname, msg) {
+ |
+
| 286 | +! | +
+ if (length(varname) != 0) {
+ |
+
| 287 | +! | +
+ has_vars <- varname %in% names(data)+ |
+
| 288 | ++ | + + | +
| 289 | +! | +
+ if (!all(has_vars)) {
+ |
+
| 290 | +! | +
+ if (missing(msg)) {
+ |
+
| 291 | +! | +
+ msg <- sprintf(+ |
+
| 292 | +! | +
+ "%s does not have the required variables: %s.",+ |
+
| 293 | +! | +
+ deparse(substitute(data)),+ |
+
| 294 | +! | +
+ toString(varname[!has_vars])+ |
+
| 295 | ++ |
+ )+ |
+
| 296 | ++ |
+ }+ |
+
| 297 | +! | +
+ validate(need(FALSE, msg))+ |
+
| 298 | ++ |
+ }+ |
+
| 299 | ++ |
+ }+ |
+
| 300 | ++ |
+ }+ |
+
| 301 | ++ | + + | +
| 302 | ++ |
+ #' Validate that variables has expected number of levels+ |
+
| 303 | ++ |
+ #'+ |
+
| 304 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 305 | ++ |
+ #' @param x variable name. If \code{x} is not a factor, the unique values
+ |
+
| 306 | ++ |
+ #' are treated as levels.+ |
+
| 307 | ++ |
+ #' @param min_levels cutoff for minimum number of levels of \code{x}
+ |
+
| 308 | ++ |
+ #' @param max_levels cutoff for maximum number of levels of \code{x}
+ |
+
| 309 | ++ |
+ #' @param var_name name of variable being validated for use in+ |
+
| 310 | ++ |
+ #' validation message+ |
+
| 311 | ++ |
+ #'+ |
+
| 312 | ++ |
+ #' @details If the number of levels of \code{x} is less than \code{min_levels}
+ |
+
| 313 | ++ |
+ #' or greater than \code{max_levels} the validation will fail.
+ |
+
| 314 | ++ |
+ #' This function is a wrapper for `shiny::validate`.+ |
+
| 315 | ++ |
+ #'+ |
+
| 316 | ++ |
+ #' @export+ |
+
| 317 | ++ |
+ #' @examples+ |
+
| 318 | ++ |
+ #' data <- data.frame(+ |
+
| 319 | ++ |
+ #' one = rep("a", length.out = 20),
+ |
+
| 320 | ++ |
+ #' two = rep(c("a", "b"), length.out = 20),
+ |
+
| 321 | ++ |
+ #' three = rep(c("a", "b", "c"), length.out = 20),
+ |
+
| 322 | ++ |
+ #' four = rep(c("a", "b", "c", "d"), length.out = 20),
+ |
+
| 323 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 324 | ++ |
+ #' )+ |
+
| 325 | ++ |
+ #' ui <- fluidPage(+ |
+
| 326 | ++ |
+ #' selectInput(+ |
+
| 327 | ++ |
+ #' "var",+ |
+
| 328 | ++ |
+ #' "Select variable",+ |
+
| 329 | ++ |
+ #' choices = c("one", "two", "three", "four"),
+ |
+
| 330 | ++ |
+ #' selected = "one"+ |
+
| 331 | ++ |
+ #' ),+ |
+
| 332 | ++ |
+ #' verbatimTextOutput("summary")
+ |
+
| 333 | ++ |
+ #' )+ |
+
| 334 | ++ |
+ #'+ |
+
| 335 | ++ |
+ #' server <- function(input, output) {
+ |
+
| 336 | ++ |
+ #' output$summary <- renderText({
+ |
+
| 337 | ++ |
+ #' validate_n_levels(data[[input$var]], min_levels = 2, max_levels = 15, var_name = input$var)+ |
+
| 338 | ++ |
+ #' paste0(+ |
+
| 339 | ++ |
+ #' "Levels of selected treatment variable: ",+ |
+
| 340 | ++ |
+ #' paste(levels(data[[input$var]]),+ |
+
| 341 | ++ |
+ #' collapse = ", "+ |
+
| 342 | ++ |
+ #' )+ |
+
| 343 | ++ |
+ #' )+ |
+
| 344 | ++ |
+ #' })+ |
+
| 345 | ++ |
+ #' }+ |
+
| 346 | ++ |
+ #' if (interactive()) {
+ |
+
| 347 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 348 | ++ |
+ #' }+ |
+
| 349 | ++ |
+ validate_n_levels <- function(x, min_levels = 1, max_levels = 12, var_name) {
+ |
+
| 350 | +! | +
+ x_levels <- if (is.factor(x)) {
+ |
+
| 351 | +! | +
+ levels(x)+ |
+
| 352 | ++ |
+ } else {
+ |
+
| 353 | +! | +
+ unique(x)+ |
+
| 354 | ++ |
+ }+ |
+
| 355 | ++ | + + | +
| 356 | +! | +
+ if (!is.null(min_levels) && !(is.null(max_levels))) {
+ |
+
| 357 | +! | +
+ validate(need(+ |
+
| 358 | +! | +
+ length(x_levels) >= min_levels && length(x_levels) <= max_levels,+ |
+
| 359 | +! | +
+ sprintf(+ |
+
| 360 | +! | +
+ "%s variable needs minimum %s level(s) and maximum %s level(s).",+ |
+
| 361 | +! | +
+ var_name, min_levels, max_levels+ |
+
| 362 | ++ |
+ )+ |
+
| 363 | ++ |
+ ))+ |
+
| 364 | +! | +
+ } else if (!is.null(min_levels)) {
+ |
+
| 365 | +! | +
+ validate(need(+ |
+
| 366 | +! | +
+ length(x_levels) >= min_levels,+ |
+
| 367 | +! | +
+ sprintf("%s variable needs minimum %s levels(s)", var_name, min_levels)
+ |
+
| 368 | ++ |
+ ))+ |
+
| 369 | +! | +
+ } else if (!is.null(max_levels)) {
+ |
+
| 370 | +! | +
+ validate(need(+ |
+
| 371 | +! | +
+ length(x_levels) <= max_levels,+ |
+
| 372 | +! | +
+ sprintf("%s variable needs maximum %s level(s)", var_name, max_levels)
+ |
+
| 373 | ++ |
+ ))+ |
+
| 374 | ++ |
+ }+ |
+
| 375 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Get Client Timezone+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Local timezone in the browser may differ from the system timezone from the server.+ |
+
| 4 | ++ |
+ #' This script can be run to register a shiny input which contains information about+ |
+
| 5 | ++ |
+ #' the timezone in the browser.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param ns (`function`) namespace function passed from the `session` object in the+ |
+
| 8 | ++ |
+ #' Shiny server. For Shiny modules this will allow for proper name spacing of the+ |
+
| 9 | ++ |
+ #' registered input.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return (`Shiny`) input variable accessible with `input$tz` which is a (`character`)+ |
+
| 12 | ++ |
+ #' string containing the timezone of the browser/client.+ |
+
| 13 | ++ |
+ #' @keywords internal+ |
+
| 14 | ++ |
+ get_client_timezone <- function(ns) {
+ |
+
| 15 | +8x | +
+ script <- sprintf(+ |
+
| 16 | +8x | +
+ "Shiny.setInputValue(`%s`, Intl.DateTimeFormat().resolvedOptions().timeZone)",+ |
+
| 17 | +8x | +
+ ns("timezone")
+ |
+
| 18 | ++ |
+ )+ |
+
| 19 | +8x | +
+ shinyjs::runjs(script) # function does not return anything+ |
+
| 20 | +8x | +
+ return(invisible(NULL))+ |
+
| 21 | ++ |
+ }+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ #' Resolve the expected bootstrap theme+ |
+
| 24 | ++ |
+ #' @keywords internal+ |
+
| 25 | ++ |
+ get_teal_bs_theme <- function() {
+ |
+
| 26 | +36x | +
+ bs_theme <- getOption("teal.bs_theme")
+ |
+
| 27 | +36x | +
+ if (is.null(bs_theme)) {
+ |
+
| 28 | +33x | +
+ NULL+ |
+
| 29 | +3x | +
+ } else if (!inherits(bs_theme, "bs_theme")) {
+ |
+
| 30 | +2x | +
+ warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
+ |
+
| 31 | +2x | +
+ NULL+ |
+
| 32 | ++ |
+ } else {
+ |
+
| 33 | +1x | +
+ bs_theme+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | ++ |
+ }+ |
+
| 36 | ++ | + + | +
| 37 | ++ |
+ include_parent_datanames <- function(dataname, join_keys) {
+ |
+
| 38 | +145x | +
+ parents <- character(0)+ |
+
| 39 | +145x | +
+ for (i in dataname) {
+ |
+
| 40 | +25x | +
+ while (length(i) > 0) {
+ |
+
| 41 | +25x | +
+ parent_i <- join_keys$get_parent(i)+ |
+
| 42 | +25x | +
+ parents <- c(parent_i, parents)+ |
+
| 43 | +25x | +
+ i <- parent_i+ |
+
| 44 | ++ |
+ }+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | ++ | + + | +
| 47 | +145x | +
+ return(unique(c(parents, dataname)))+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | ++ | + + | +
| 50 | ++ |
+ #' Template Function for `TealReportCard` Creation and Customization+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' This function generates a report card with a title,+ |
+
| 53 | ++ |
+ #' an optional description, and the option to append the filter state list.+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @param title (`character(1)`) title of the card (unless overwritten by label)+ |
+
| 56 | ++ |
+ #' @param label (`character(1)`) label provided by the user when adding the card+ |
+
| 57 | ++ |
+ #' @param description (`character(1)`) optional additional description+ |
+
| 58 | ++ |
+ #' @param with_filter (`logical(1)`) flag indicating to add filter state+ |
+
| 59 | ++ |
+ #' @param filter_panel_api (`FilterPanelAPI`) object with API that allows the generation+ |
+
| 60 | ++ |
+ #' of the filter state in the report+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @return (`TealReportCard`) populated with a title, description and filter state+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @export+ |
+
| 65 | ++ |
+ report_card_template <- function(title, label, description = NULL, with_filter, filter_panel_api) {
+ |
+
| 66 | +2x | +
+ checkmate::assert_string(title)+ |
+
| 67 | +2x | +
+ checkmate::assert_string(label)+ |
+
| 68 | +2x | +
+ checkmate::assert_string(description, null.ok = TRUE)+ |
+
| 69 | +2x | +
+ checkmate::assert_flag(with_filter)+ |
+
| 70 | +2x | +
+ checkmate::assert_class(filter_panel_api, classes = "FilterPanelAPI")+ |
+
| 71 | ++ | + + | +
| 72 | +2x | +
+ card <- teal::TealReportCard$new()+ |
+
| 73 | +2x | +
+ title <- if (label == "") title else label+ |
+
| 74 | +2x | +
+ card$set_name(title)+ |
+
| 75 | +2x | +
+ card$append_text(title, "header2")+ |
+
| 76 | +1x | +
+ if (!is.null(description)) card$append_text(description, "header3")+ |
+
| 77 | +1x | +
+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ |
+
| 78 | +2x | +
+ card+ |
+
| 79 | ++ |
+ }+ |
+
| 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 | ++ |
+ # Use non-exported function(s) from teal.slice.+ |
+
| 27 | ++ |
+ # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0).+ |
+
| 28 | ++ |
+ list_to_teal_slices <- getFromNamespace("list_to_teal_slices", "teal.slice")
+ |
+
| 29 | ++ |
+ # This one is here because setdiff_teal_slice should not be exported from teal.slice.+ |
+
| 30 | ++ |
+ setdiff_teal_slices <- getFromNamespace("setdiff_teal_slices", "teal.slice")
+ |
+
| 31 | ++ |
+ # This one is here because it is needed by c.teal_slices but we don't want it exported from teal.slice.+ |
+
| 32 | ++ |
+ coalesce_r <- getFromNamespace("coalesce_r", "teal.slice")
+ |
+
| 33 | ++ |
+ # all *Block objects are private in teal.reporter+ |
+
| 34 | ++ |
+ RcodeBlock <- getFromNamespace("RcodeBlock", "teal.reporter") # nolint
+ |
+
| 1 | ++ |
+ #' Show R Code Modal+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @export+ |
+
| 4 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 5 | ++ |
+ #' Use the [shiny::showModal()] function to show the R code inside.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param title (`character(1)`)\cr+ |
+
| 8 | ++ |
+ #' Title of the modal, displayed in the first comment of the R-code.+ |
+
| 9 | ++ |
+ #' @param rcode (`character`)\cr+ |
+
| 10 | ++ |
+ #' vector with R code to show inside the modal.+ |
+
| 11 | ++ |
+ #' @param session (`ShinySession` optional)\cr+ |
+
| 12 | ++ |
+ #' `shiny` Session object, if missing then [shiny::getDefaultReactiveDomain()] is used.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @references [shiny::showModal()]+ |
+
| 15 | ++ |
+ show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) {
+ |
+
| 16 | +! | +
+ rcode <- paste(rcode, collapse = "\n")+ |
+
| 17 | ++ | + + | +
| 18 | +! | +
+ ns <- session$ns+ |
+
| 19 | +! | +
+ showModal(modalDialog(+ |
+
| 20 | +! | +
+ tagList(+ |
+
| 21 | +! | +
+ tags$div(+ |
+
| 22 | +! | +
+ actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ |
+
| 23 | +! | +
+ modalButton("Dismiss"),
+ |
+
| 24 | +! | +
+ style = "mb-4"+ |
+
| 25 | ++ |
+ ),+ |
+
| 26 | +! | +
+ tags$div(tags$pre(id = ns("r_code"), rcode)),
+ |
+
| 27 | ++ |
+ ),+ |
+
| 28 | +! | +
+ title = title,+ |
+
| 29 | +! | +
+ footer = tagList(+ |
+
| 30 | +! | +
+ actionButton(ns("copyRCode"), "Copy to Clipboard", `data-clipboard-target` = paste0("#", ns("r_code"))),
+ |
+
| 31 | +! | +
+ modalButton("Dismiss")
+ |
+
| 32 | ++ |
+ ),+ |
+
| 33 | +! | +
+ size = "l",+ |
+
| 34 | +! | +
+ easyClose = TRUE+ |
+
| 35 | ++ |
+ ))+ |
+
| 36 | ++ | + + | +
| 37 | +! | +
+ return(NULL)+ |
+
| 38 | ++ |
+ }+ |
+
"+y.value+"