From fde15a48ec060f20df2cdba86e2fa306b1e5c07d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Ka=C5=82=C4=99dkowski?= <6959016+gogonzo@users.noreply.github.com> Date: Fri, 16 Jun 2023 16:06:33 +0200 Subject: [PATCH] Module specific filter panels (#837) --- DESCRIPTION | 5 +- NAMESPACE | 1 + R/init.R | 162 ++++++------ R/module_filter_manager.R | 238 ++++++++++++++++++ R/module_nested_tabs.R | 142 ++++++----- R/module_tabs_with_filters.R | 123 ++++----- R/module_teal.R | 59 ++++- R/module_teal_with_splash.R | 2 +- R/modules.R | 24 +- R/show_rcode_modal.R | 5 +- R/teal_filters.R | 113 +++++++++ R/utils.R | 13 + R/validate_inputs.R | 1 - R/zzz.R | 4 + inst/css/sidebar.css | 10 +- inst/js/sidebar.js | 19 +- man/deep_copy_filter.Rd | 21 ++ man/filter_manager_module_srv.Rd | 35 +++ man/init.Rd | 93 ++----- man/module.Rd | 6 +- man/module_filter_manager.Rd | 34 +++ man/module_filter_manager_modal.Rd | 62 +++++ man/reporter_previewer_module.Rd | 3 +- man/show_rcode_modal.Rd | 5 +- man/srv_nested_tabs.Rd | 4 + man/srv_tabs_with_filters.Rd | 74 +----- man/srv_teal.Rd | 76 +----- man/srv_teal_with_splash.Rd | 76 +----- man/teal_filters.Rd | 78 ++++++ man/ui_nested_tabs.Rd | 12 +- man/ui_tabs_with_filters.Rd | 7 +- tests/testthat/test-filter_manager.R | 55 ++++ tests/testthat/test-init.R | 45 ++++ tests/testthat/test-module_nested_tabs.R | 119 ++++----- .../testthat/test-module_tabs_with_filters.R | 48 +++- tests/testthat/test-module_teal.R | 48 +++- tests/testthat/test-module_teal_with_splash.R | 4 +- tests/testthat/test-modules.R | 70 +++++- tests/testthat/test-validate_inputs.R | 13 +- vignettes/creating-custom-modules.Rmd | 1 - 40 files changed, 1300 insertions(+), 610 deletions(-) create mode 100644 R/module_filter_manager.R create mode 100644 R/teal_filters.R create mode 100644 man/deep_copy_filter.Rd create mode 100644 man/filter_manager_module_srv.Rd create mode 100644 man/module_filter_manager.Rd create mode 100644 man/module_filter_manager_modal.Rd create mode 100644 man/teal_filters.Rd create mode 100644 tests/testthat/test-filter_manager.R diff --git a/DESCRIPTION b/DESCRIPTION index 2b25512fae..1651484703 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,8 +34,6 @@ Imports: rlang, shinyjs, stats, - styler, - teal.code (>= 0.2.0), teal.logger (>= 0.1.1), teal.reporter (>= 0.1.1), teal.slice (>= 0.2.0), @@ -52,6 +50,7 @@ Suggests: scda (>= 0.1.5), scda.2022 (>= 0.1.3), shinyvalidate, + teal.code (>= 0.3.0), testthat (>= 3.1.5), withr, yaml @@ -82,6 +81,7 @@ Collate: 'include_css_js.R' 'modules.R' 'init.R' + 'module_filter_manager.R' 'module_nested_tabs.R' 'module_tabs_with_filters.R' 'module_teal.R' @@ -91,6 +91,7 @@ Collate: 'show_rcode_modal.R' 'tdata.R' 'teal.R' + 'teal_filters.R' 'utils.R' 'validate_inputs.R' 'validations.R' diff --git a/NAMESPACE b/NAMESPACE index 3628b5ac63..c75bbf6db7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,6 +32,7 @@ export(reporter_previewer_module) export(show_rcode_modal) export(srv_teal_with_splash) export(tdata2env) +export(teal_filters) export(ui_teal_with_splash) export(validate_has_data) export(validate_has_elements) diff --git a/R/init.R b/R/init.R index 3fd5ab4bc0..fa8169448e 100644 --- a/R/init.R +++ b/R/init.R @@ -30,72 +30,10 @@ #' more details. #' @param title (`NULL` or `character`)\cr #' The browser window title (defaults to the host URL of the page). -#' @param filter (`teal_slices` or `list`)\cr -#' You can define filters that show when the app starts. -#' There are two ways to specify the filter states: -#' 1) with a `teal_slices` object - see `?teal.slice::teal_slice` for details -#' 2) with a named list (deprecated) -#' -#' List names should be named according to `datanames` passed to the `data` argument. -#' In case of data.frame` the list should be composed as follows: -#' ``` -#' list( = list( = ..., = ...), -#' = list(...), -#' ...) -#' -#' ``` -#' -#' For example, filters for variable `Sepal.Length` in `iris` can be specified as -#' follows: -#' ``` -#' list(iris = list(Sepal.Length = list(selected = c(5.0, 7.0)))) -#' # or -#' list(iris = list(Sepal.Length = c(5.0, 7.0))) -#' ``` -#' -#' In case developer would like to include `NA` and `Inf` values in the -#' filtered dataset. -#' ``` -#' list(Species = list(selected = c(5.0, 7.0), keep_na = TRUE, keep_inf = TRUE)) -#' list(Species = c(c(5.0, 7.0), NA, Inf)) -#' ``` -#' -#' To initialize with specific variable filter with all values on start, one -#' can use -#' ``` -#' list(Species = list()) -#' ``` -#' `filter` should be set with respect to the class of the column: -#' * `numeric`: `selected` should be a two elements vector defining the range -#' of the filter. -#' * `Date`: `selected` should be a two elements vector defining the date-range -#' of the filter -#' * `POSIXct`: `selected` should be a two elements vector defining the -#' `datetime` range of the filter -#' * `character` and `factor`: `selected` should be a vector of any length -#' defining initial values selected to filter. -#' \cr -#' `filter` for `MultiAssayExperiment` objects should be specified in slightly -#' different way. Since it contains patient data with list of experiments, -#' `filter` list should be created as follows: -#' \cr -#' -#' ``` -#' list( -#' = list( -#' subjects = list( = ..., = ...), -#' = list( -#' subset = list( = ..., -#' = ...), -#' select = list( = ..., -#' = ...) -#' ) -#' ) -#' ) -#' ``` -#' By adding the `filterable` attribute it is possible to control which variables can be filtered for each -#' dataset. See the example below where `ADSL` can only be filtered by `AGE`, `SEX` or `RACE`. -#' +#' @param filter (`teal_slices`)\cr +#' Specification of initial filter. Filters can be specified using [teal::teal_filters()]. +#' Old way of specifying filters through a list is deprecated and will be removed in the +#' next release. Please fix your applications to use [teal::teal_filters()]. #' @param header (`shiny.tag` or `character`) \cr #' the header of the app. Note shiny code placed here (and in the footer #' argument) will be placed in the app's `ui` function so code which needs to be placed in the `ui` function @@ -126,12 +64,12 @@ #' ), #' modules = modules( #' module( -#' "data source", +#' label = "data source", #' server = function(input, output, session, data) {}, #' ui = function(id, ...) div(p("information about data source")), #' filters = "all" #' ), -#' example_module(), +#' example_module(label = "example teal module"), #' module( #' "ADSL AGE histogram", #' server = function(input, output, session, data) { @@ -147,9 +85,16 @@ #' ) #' ), #' title = "App title", -#' filter = teal.slice:::filter_settings( -#' teal.slice:::filter_var("ADSL", "AGE"), -#' exclude = list(ADSL = setdiff(names(ADSL), c("AGE", "SEX", "RACE"))) +#' filter = teal::teal_filters( +#' teal.slice::filter_var(dataname = "ADSL", varname = "AGE"), +#' teal.slice::filter_var(dataname = "ADSL", varname = "SEX"), +#' teal.slice::filter_var(dataname = "ADSL", varname = "RACE"), +#' exclude_varnames = list(ADSL = setdiff(names(ADSL), c("AGE", "SEX", "RACE"))), +#' mapping = list( +#' `example teal module` = "ADSL RACE", +#' `ADSL AGE histogram` = "ADSL AGE", +#' global_filters = "ADSL SEX" +#' ) #' ), #' header = tags$h1("Sample App"), #' footer = tags$p("Copyright 2017 - 2020") @@ -161,7 +106,7 @@ init <- function(data, modules, title = NULL, - filter = list(), + filter = teal_filters(), header = tags$p(), footer = tags$p(), id = character(0)) { @@ -175,9 +120,6 @@ init <- function(data, checkmate::check_class(filter, "teal_slices"), checkmate::check_list(filter, names = "named") ) - if (!teal.slice:::is.teal_slices(filter)) { - checkmate::assert_subset(names(filter), choices = teal.data::get_dataname(data)) - } checkmate::assert_multi_class(header, c("shiny.tag", "character")) checkmate::assert_multi_class(footer, c("shiny.tag", "character")) checkmate::assert_character(id, max.len = 1, any.missing = FALSE) @@ -191,6 +133,75 @@ init <- function(data, modules <- do.call(teal::modules, modules) } + # resolve modules datanames + datanames <- teal.data::get_dataname(data) + join_keys <- data$get_join_keys() + resolve_modules_datanames <- function(modules) { + if (inherits(modules, "teal_modules")) { + modules$children <- sapply(modules$children, resolve_modules_datanames, simplify = FALSE) + modules + } else { + modules$filters <- if (identical(modules$filters, "all")) { + datanames + } else if (is.character(modules$filters)) { + datanames_adjusted <- intersect(modules$filters, datanames) + include_parent_datanames(dataname = datanames_adjusted, join_keys = join_keys) + } + modules + } + } + modules <- resolve_modules_datanames(modules = modules) + + if (!inherits(filter, "teal_slices")) { + checkmate::assert_subset(names(filter), choices = datanames) + # as.teal_slices is lifted from teal.slice package, see zzz.R + # This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0). + filter <- as.teal_slices(filter) + } + + + + # check teal_slices + for (i in seq_along(filter)) { + dataname_i <- shiny::isolate(filter[[i]]$dataname) + if (!dataname_i %in% datanames) { + stop( + sprintf( + "filter[[%s]] has a different dataname than available in a 'data':\n %s not in %s", + i, + dataname_i, + toString(datanames) + ) + ) + } + } + + if (isTRUE(attr(filter, "module_specific"))) { + module_names <- unlist(c(module_labels(modules), "global_filters")) + failed_mod_names <- setdiff(names(attr(filter, "mapping")), module_names) + if (length(failed_mod_names)) { + stop( + sprintf( + "Some module names in the mapping arguments don't match module labels.\n %s not in %s", + toString(failed_mod_names), + toString(unique(module_names)) + ) + ) + } + + if (anyDuplicated(module_names)) { + # In teal we are able to set nested modules with duplicated label. + # Because mapping argument bases on the relationship between module-label and filter-id, + # it is possible that module-label in mapping might refer to multiple teal_module (identified by the same label) + stop( + sprintf( + "Module labels should be unique when teal_filters(mapping = TRUE). Duplicated labels:\n%s ", + toString(module_names[duplicated(module_names)]) + ) + ) + } + } + # Note regarding case `id = character(0)`: # rather than using `callModule` and creating a submodule of this module, we directly modify # the `ui` and `server` with `id = character(0)` and calling the server function directly @@ -200,6 +211,7 @@ init <- function(data, server = function(input, output, session) { # copy object so that load won't be shared between the session data <- data$copy(deep = TRUE) + filter <- deep_copy_filter(filter) srv_teal_with_splash(id = id, data = data, modules = modules, filter = filter) } ) diff --git a/R/module_filter_manager.R b/R/module_filter_manager.R new file mode 100644 index 0000000000..1278690779 --- /dev/null +++ b/R/module_filter_manager.R @@ -0,0 +1,238 @@ +#' @rdname module_filter_manager_modal +filter_manager_modal_ui <- function(id) { + ns <- NS(id) + tags$button( + id = ns("show"), + class = "btn action-button filter_manager_button", + title = "Show filters manager modal", + icon("gear") + ) +} + +#' Filter manager modal +#' +#' Filter manager modal +#' @rdname module_filter_manager_modal +#' @inheritParams filter_manager_srv +#' @examples +#' fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris))) +#' fd2 <- teal.slice::init_filtered_data( +#' list(iris = list(dataset = iris), mtcars = list(dataset = mtcars)) +#' ) +#' fd3 <- teal.slice::init_filtered_data( +#' list(iris = list(dataset = iris), women = list(dataset = women)) +#' ) +#' filter <- teal::teal_filters( +#' teal.slice::filter_var(dataname = "iris", varname = "Sepal.Length"), +#' teal.slice::filter_var(dataname = "iris", varname = "Species"), +#' teal.slice::filter_var(dataname = "mtcars", varname = "mpg"), +#' teal.slice::filter_var(dataname = "women", varname = "height"), +#' mapping = list( +#' module2 = c("mtcars mpg"), +#' module3 = c("women height"), +#' global_filters = "iris Species" +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp( +#' ui = fluidPage( +#' filter_manager_modal_ui("manager") +#' ), +#' server = function(input, output, session) { +#' filter_manager_modal_srv( +#' "manager", +#' filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3), +#' filter = filter +#' ) +#' } +#' ) +#' } +#' +filter_manager_modal_srv <- function(id, filtered_data_list, filter) { + moduleServer(id, function(input, output, session) { + observeEvent(input$show, { + logger::log_trace("filter_manager_modal_srv@1 show button has been clicked.") + showModal( + modalDialog( + filter_manager_ui(session$ns("filter_manager")), + size = "l", + easyClose = TRUE + ) + ) + }) + + filter_manager_srv("filter_manager", filtered_data_list, filter) + }) +} + +#' @rdname module_filter_manager +filter_manager_ui <- function(id) { + ns <- NS(id) + div( + tableOutput(ns("slices_table")) + ) +} + +#' Manage multiple `FilteredData` objects +#' +#' Manage multiple `FilteredData` objects +#' +#' @rdname module_filter_manager +#' @details +#' This module observes the changes of the filters in each `FilteredData` object +#' and keeps track of all filters used. Map of the filters is kept in so called +#' `slices_map` object where each `FilteredData` is linked with its active filters. +#' This map is represented in the UI as a matrix where rows are ids of the filters and +#' columns are names of the `filtered_data_list` (named after teal modules). +#' +#' @param id (`character(1)`)\cr +#' `shiny` module id. +#' @param filtered_data_list (`list` of `FilteredData`)\cr +#' Names of the list should be the same as `teal_module$label`. +#' @inheritParams init +#' @keywords internal +filter_manager_srv <- function(id, filtered_data_list, filter) { + moduleServer(id, function(input, output, session) { + logger::log_trace("filter_manager_srv initializing for: { paste(names(filtered_data_list), collapse = ', ')}.") + + # instead of unlist which unlist with concatenating nested names with '.' + flatten_nested <- function(x, name = NULL) { + if (inherits(x, "FilteredData")) { + setNames(list(x), name) + } else { + unlist(lapply(names(x), function(name) flatten_nested(x[[name]], name))) + } + } + filtered_data_list <- flatten_nested(filtered_data_list) + + # global list of slices (all available teal_slice) + slices_global <- reactiveVal(filter) + + # create a reactive map between modules and filters + slices_map <- sapply( + names(filtered_data_list), + function(module_name) { + shiny::reactiveVal( + unlist(attr(filter, "mapping")[c(module_name, "global_filters")], use.names = FALSE) + ) + } + ) + + modules_out <- lapply(names(filtered_data_list), function(module_name) { + filter_manager_module_srv( + id = module_name, + module_fd = filtered_data_list[[module_name]], + slices_map_module = slices_map[[module_name]], + slices_global = slices_global + ) + }) + + mapping_matrix <- reactive({ + module_names <- names(filtered_data_list) + filter_names <- vapply(X = slices_global(), `[[`, character(1), "id") + mapping_matrix <- matrix( + FALSE, + nrow = length(filter_names), + ncol = length(module_names), + dimnames = list(filter_names, module_names) + ) + for (i in module_names) { + mapping_matrix[slices_map[[i]](), i] <- TRUE + } + mapping_matrix + }) + + output$slices_table <- renderTable(rownames = TRUE, { + as.data.frame(mapping_matrix()) + }) + + modules_out # returned for testing purpose + }) +} + +#' Module specific filter manager +#' +#' This module compares filters between single `FilteredData` settings +#' and global `teal_slices`. Updates appropriate objects `module_fd`, +#' `slices_map_module`, `slices_global` to keep them consistent. +#' +#' @param id (`character(1)`)\cr +#' `shiny` module id. +#' @param module_fd (`FilteredData`)\cr +#' object to filter data in the teal-module +#' @param slices_map_module (`reactiveVal` of `character`)\cr +#' `id` of the `teal_slice` objects used in the module specific `FilteredData`. +#' @param slices_global (`reactiveVal` or `teal_slices`)\cr +#' stores a list of all available filters which can be utilized in several ways, for example: +#' - to disable/enable specific filter in the module +#' - to restore filter saved settings +#' - to save current filter settings panel +#' @return shiny module returning NULL +#' @keywords internal +filter_manager_module_srv <- function(id, module_fd, slices_map_module, slices_global) { + moduleServer(id, function(input, output, session) { + setdiff_teal_slices <- function(x, y) { + Filter( + function(xx) { + !any(vapply(y, function(yy) identical(yy, xx), logical(1))) + }, + x + ) + } + + available_slices <- reactive( + Filter(function(slice) slice$dataname %in% module_fd$datanames(), slices_global()) + ) + module_fd$set_available_teal_slices(available_slices) + slices_module <- reactive(module_fd$get_filter_state()) + + previous_slices <- reactiveVal(shiny::isolate(slices_module())) + slices_added <- reactiveVal(NULL) + slices_activated <- reactiveVal(NULL) + slices_deactivated <- reactiveVal(NULL) + + observeEvent(slices_module(), { + logger::log_trace("filter_manager_srv@1 detecting states deltas in module: { id }.") + added <- setdiff_teal_slices(slices_module(), slices_global()) + activated <- setdiff_teal_slices(slices_module(), previous_slices()) + deactivated <- setdiff_teal_slices(previous_slices(), slices_module()) + if (length(added)) slices_added(added) + if (length(activated)) slices_activated(activated) + if (length(deactivated)) slices_deactivated(deactivated) + previous_slices(slices_module()) + }) + + observeEvent(slices_added(), ignoreNULL = TRUE, { + logger::log_trace("filter_manager_srv@2 added filter in module: { id }.") + lapply( + slices_added(), + function(slice) { + global_ids <- vapply(slices_global(), function(x) x$id, character(1)) + if (slice$id %in% global_ids) { + slice$id <- utils::tail(make.unique(c(global_ids, slice$id), sep = "_"), 1) + } + } + ) + slices_global_new <- c(slices_global(), slices_added()) + slices_global(slices_global_new) + slices_added(NULL) + }) + + observeEvent(slices_activated(), ignoreNULL = TRUE, { + logger::log_trace("filter_manager_srv@3 activated filter in module: { id }.") + activated_ids <- vapply(slices_activated(), `[[`, character(1), "id") + slices_map_module(c(slices_map_module(), activated_ids)) + slices_activated(NULL) + }) + + observeEvent(slices_deactivated(), ignoreNULL = TRUE, { + logger::log_trace("filter_manager_srv@4 deactivated filter in module: { id }.") + deactivated_ids <- vapply(slices_deactivated(), `[[`, character(1), "id") + slices_map_module(setdiff(slices_map_module(), deactivated_ids)) + slices_deactivated(NULL) + }) + + slices_module # returned for testing purpose + }) +} diff --git a/R/module_nested_tabs.R b/R/module_nested_tabs.R index c7550f93f1..9f030b2b16 100644 --- a/R/module_nested_tabs.R +++ b/R/module_nested_tabs.R @@ -12,6 +12,9 @@ #' @inheritParams ui_tabs_with_filters #' @param depth (`integer(1)`)\cr #' number which helps to determine depth of the modules nesting. +#' @param is_module_specific (`logical(1)`)\cr +#' flag determinining if the filter panel is global or module-specific. When `module_specific` +#' is `TRUE` then a filter panel is called inside of each module tab. #' @return depending on class of `modules`: #' - `teal_module`: instantiated UI of the module #' - `teal_modules`: `tabsetPanel` with each tab corresponding to recursively @@ -44,23 +47,23 @@ #' runApp(app) #' } #' @keywords internal -ui_nested_tabs <- function(id, modules, datasets, depth = 0L) { - stopifnot(inherits(datasets, "FilteredData")) - stopifnot(inherits(depth, "integer") && length(depth) == 1) +ui_nested_tabs <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) { + checkmate::assert_int(depth) UseMethod("ui_nested_tabs", modules) } #' @rdname ui_nested_tabs #' @export #' @keywords internal -ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L) { +ui_nested_tabs.default <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) { stop("Modules class not supported: ", paste(class(modules), collapse = " ")) } #' @rdname ui_nested_tabs #' @export #' @keywords internal -ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L) { +ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) { + checkmate::assert_list(datasets, types = c("list", "FilteredData")) ns <- NS(id) do.call( tabsetPanel, @@ -72,11 +75,18 @@ ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L) { ), lapply( names(modules$children), - function(id) { + function(module_id) { + module_label <- modules$children[[module_id]]$label tabPanel( - title = modules$children[[id]]$label, - value = id, # when clicked this tab value changes input$ - ui_nested_tabs(id = ns(id), modules = modules$children[[id]], datasets, depth = depth + 1L) + title = module_label, + value = module_id, # when clicked this tab value changes input$ + ui_nested_tabs( + id = ns(module_id), + modules = modules$children[[module_id]], + datasets = datasets[[module_label]], + depth = depth + 1L, + is_module_specific = is_module_specific + ) ) } ) @@ -87,9 +97,10 @@ ui_nested_tabs.teal_modules <- function(id, modules, datasets, depth = 0L) { #' @rdname ui_nested_tabs #' @export #' @keywords internal -ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L) { +ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L, is_module_specific = FALSE) { + checkmate::assert_class(datasets, class = "FilteredData") ns <- NS(id) - checkmate::assert_class(datasets, "FilteredData") + args <- isolate(teal.transform::resolve_delayed(modules$ui_args, datasets)) args <- c(list(id = ns("module")), args) @@ -102,7 +113,7 @@ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L) { args <- c(args, data = list(data)) } - tags$div( + teal_ui <- tags$div( id = id, class = "teal_module", uiOutput(ns("data_reactive"), inline = TRUE), @@ -111,6 +122,19 @@ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L) { do.call(modules$ui, args) ) ) + + if (!is.null(modules$filter) && is_module_specific) { + fluidRow( + column(width = 9, teal_ui, class = "teal_primary_col"), + column( + width = 3, + datasets$ui_filter_panel(ns("module_filter_panel")), + class = "teal_secondary_col" + ) + ) + } else { + teal_ui + } } #' Server function that returns currently active module @@ -124,44 +148,52 @@ ui_nested_tabs.teal_module <- function(id, modules, datasets, depth = 0L) { #' #' @return `reactive` which returns the active module that corresponds to the selected tab #' @keywords internal -srv_nested_tabs <- function(id, datasets, modules, reporter = teal.reporter::Reporter$new()) { - stopifnot(inherits(datasets, "FilteredData")) - stopifnot(inherits(reporter, "Reporter")) +srv_nested_tabs <- function(id, datasets, modules, is_module_specific = FALSE, + reporter = teal.reporter::Reporter$new()) { + checkmate::assert_class(reporter, "Reporter") UseMethod("srv_nested_tabs", modules) } #' @rdname srv_nested_tabs #' @export #' @keywords internal -srv_nested_tabs.default <- function(id, datasets, modules, reporter = teal.reporter::Reporter$new()) { +srv_nested_tabs.default <- function(id, datasets, modules, is_module_specific = FALSE, + reporter = teal.reporter::Reporter$new()) { stop("Modules class not supported: ", paste(class(modules), collapse = " ")) } #' @rdname srv_nested_tabs #' @export #' @keywords internal -srv_nested_tabs.teal_modules <- function(id, datasets, modules, reporter = teal.reporter::Reporter$new()) { +srv_nested_tabs.teal_modules <- function(id, datasets, modules, is_module_specific = FALSE, + reporter = teal.reporter::Reporter$new()) { + checkmate::assert_list(datasets, types = c("list", "FilteredData")) moduleServer(id = id, module = function(input, output, session) { - logger::log_trace( - paste( - "srv_nested_tabs.teal_modules initializing the module with:", - "datasets { paste(datasets$datanames(), collapse = ' ') };", - "module { deparse1(modules$label) }." - ) - ) + logger::log_trace("srv_nested_tabs.teal_modules initializing the module { deparse1(modules$label) }.") - modules_reactive <- sapply(names(modules$children), USE.NAMES = TRUE, function(id) { - srv_nested_tabs(id = id, datasets = datasets, modules = modules$children[[id]], reporter = reporter) - }) + labels <- vapply(modules$children, `[[`, character(1), "label") + modules_reactive <- sapply( + names(modules$children), + function(module_id) { + srv_nested_tabs( + id = module_id, + datasets = datasets[[labels[module_id]]], + modules = modules$children[[module_id]], + is_module_specific = is_module_specific, + reporter = reporter + ) + } + ) + # when not ready input$active_tab would return NULL - this would fail next reactive + input_validated <- eventReactive(input$active_tab, input$active_tab, ignoreNULL = TRUE) get_active_module <- reactive({ if (length(modules$children) == 1L) { # single tab is active by default modules_reactive[[1]]() } else { # switch to active tab - req(input$active_tab) - modules_reactive[[input$active_tab]]() + modules_reactive[[input_validated()]]() } }) @@ -172,37 +204,24 @@ srv_nested_tabs.teal_modules <- function(id, datasets, modules, reporter = teal. #' @rdname srv_nested_tabs #' @export #' @keywords internal -srv_nested_tabs.teal_module <- function(id, datasets, modules, reporter = teal.reporter::Reporter$new()) { - logger::log_trace( - paste( - "srv_nested_tabs.teal_module initializing the module with:", - "datasets { paste(datasets$datanames(), collapse = ' ') };", - "module { deparse1(modules$label) }." - ) - ) +srv_nested_tabs.teal_module <- function(id, datasets, modules, is_module_specific = TRUE, + reporter = teal.reporter::Reporter$new()) { + checkmate::assert_class(datasets, class = "FilteredData") + logger::log_trace("srv_nested_tabs.teal_module initializing the module: { deparse1(modules$label) }.") moduleServer(id = id, module = function(input, output, session) { modules$server_args <- teal.transform::resolve_delayed(modules$server_args, datasets) - - args <- c(list(id = "module"), modules$server_args) - if (is_arg_used(modules$server, "reporter")) { - args <- c(args, list(reporter = reporter)) + if (!is.null(modules$filter) && is_module_specific) { + datasets$srv_filter_panel("module_filter_panel", active_datanames = reactive(modules$filter)) } - if (is_arg_used(modules$server, "datasets")) { - args <- c(args, datasets = datasets) - } - - datanames <- if (is.null(modules$filter)) { - datasets$datanames() - } else { - datasets$get_filterable_datanames(modules$filter) # get_filterable_datanames adds parents if present - } - - # trigger the data when the tab is selected + # Create two triggers to limit reactivity between filter-panel and modules. + # We want to recalculate only visible modules + # - trigger the data when the tab is selected + # - trigger module to be called when the tab is selected for the first time trigger_data <- reactiveVal(1L) trigger_module <- reactiveVal(NULL) output$data_reactive <- renderUI({ - lapply(datanames, function(x) { + lapply(datasets$datanames(), function(x) { datasets$get_data(x, filtered = TRUE) }) isolate(trigger_data(trigger_data() + 1)) @@ -211,6 +230,16 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, reporter = teal.r NULL }) + # collect arguments to run teal_module + args <- c(list(id = "module"), modules$server_args) + if (is_arg_used(modules$server, "reporter")) { + args <- c(args, list(reporter = reporter)) + } + + if (is_arg_used(modules$server, "datasets")) { + args <- c(args, datasets = datasets) + } + if (is_arg_used(modules$server, "data")) { data <- .datasets_to_data(modules, datasets, trigger_data) args <- c(args, data = list(data)) @@ -241,6 +270,7 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, reporter = teal.r } } ) + reactive(modules) }) } @@ -262,11 +292,7 @@ srv_nested_tabs.teal_module <- function(id, datasets, modules, reporter = teal.r #' @keywords internal .datasets_to_data <- function(module, datasets, trigger_data = reactiveVal(1L)) { checkmate::assert_class(trigger_data, "reactiveVal") - datanames <- if (is.null(module$filter)) { - datasets$datanames() - } else { - datasets$get_filterable_datanames(module$filter) # get_filterable_datanames adds parents if present - } + datanames <- if (is.null(module$filter)) datasets$datanames() else module$filter # list of reactive filtered data data <- sapply( diff --git a/R/module_tabs_with_filters.R b/R/module_tabs_with_filters.R index 50dafd653f..c89cfa45fa 100644 --- a/R/module_tabs_with_filters.R +++ b/R/module_tabs_with_filters.R @@ -96,48 +96,47 @@ #' \dontrun{ #' runApp(app) #' } -ui_tabs_with_filters <- function(id, modules, datasets) { - stopifnot( - # `teal_module` not supported because we insert the filters into the UI below - is(modules, "teal_modules"), - is(datasets, "FilteredData") - ) - ns <- NS(id) +ui_tabs_with_filters <- function(id, modules, datasets, filter) { + checkmate::assert_class(modules, "teal_modules") + checkmate::assert_list(datasets, types = c("list", "FilteredData")) - # use isolate because we assume that the number of datasets does not change over the course of the teal app - # this will just create placeholders which are shown only if non-empty - filter_and_info_ui <- datasets$ui_filter_panel(ns("filter_panel")) - - # modules must be teal_modules, not teal_module; otherwise we will get the UI and not a tabsetPanel of UIs - teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets) + ns <- NS(id) + is_module_specific <- isTRUE(attr(filter, "module_specific")) + teal_ui <- ui_nested_tabs(ns("root"), modules = modules, datasets, is_module_specific = is_module_specific) filter_panel_btn <- tags$li( class = "flex-grow", - tags$a( - id = "filter_hamburger", # see sidebar.css for style + tags$button( + class = "btn action-button filter_hamburger", # see sidebar.css for style filter_hamburger href = "javascript:void(0)", onclick = "toggleFilterPanel();", # see sidebar.js title = "Toggle filter panels", - tags$span(icon("fas fa-bars")) + icon("fas fa-bars") ) ) - stopifnot(length(teal_ui$children) == 2) - # teal_ui$children[[1]] contains links to tabs - # teal_ui$children[[2]] contains actual tab contents - - # adding filter_panel_btn to the tabsetPanel pills - teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btn) - - teal_ui$children <- list( - teal_ui$children[[1]], - tags$hr(class = "my-2"), - fluidRow( - column(width = 9, teal_ui$children[[2]], id = "teal_primary_col"), - column(width = 3, filter_and_info_ui, id = "teal_secondary_col") + if (!is_module_specific) { + # need to rearrange html so that filter panel is within tabset + tabset_bar <- tagAppendChild(teal_ui$children[[1]], filter_panel_btn) + teal_modules <- teal_ui$children[[2]] + filter_ui <- unlist(datasets)[[1]]$ui_filter_panel(ns("filter_panel")) + list( + tabset_bar, + tags$hr(class = "my-2"), + fluidRow( + column(width = 9, teal_modules, class = "teal_primary_col"), + column(width = 3, filter_ui, class = "teal_secondary_col") + ) ) - ) - return(teal_ui) + } else { + filter_panel_btn <- tagAppendChild( + filter_panel_btn, + filter_manager_modal_ui(ns("filter_manager")) + ) + # appending buttons to tabset bar + teal_ui$children[[1]] <- tagAppendChild(teal_ui$children[[1]], filter_panel_btn) + teal_ui + } } #' Server function @@ -150,40 +149,48 @@ ui_tabs_with_filters <- function(id, modules, datasets) { #' @return `reactive` currently selected active_module #' @keywords internal srv_tabs_with_filters <- function(id, datasets, modules, reporter = teal.reporter::Reporter$new(), filter) { - checkmate::assert_class(datasets, "FilteredData") + checkmate::assert_class(modules, "teal_modules") + checkmate::assert_list(datasets, types = c("list", "FilteredData")) checkmate::assert_class(reporter, "Reporter") moduleServer(id, function(input, output, session) { - logger::log_trace( - "srv_tabs_with_filters initializing the module with datasets { paste(datasets$datanames(), collapse = ' ') }." - ) + logger::log_trace("srv_tabs_with_filters initializing the module.") - # set filterable variables for each dataset - active_module <- srv_nested_tabs(id = "root", datasets = datasets, modules = modules, reporter = reporter) - active_datanames <- reactive(active_module()$filters) - datasets$srv_filter_panel(id = "filter_panel", active_datanames = active_datanames) + is_module_specific <- isTRUE(attr(filter, "module_specific")) + if (is_module_specific) { + manager_out <- filter_manager_modal_srv("filter_manager", filtered_data_list = datasets, filter = filter) + } - # to handle per module filter = NULL - observeEvent( - eventExpr = active_datanames(), - handlerExpr = { - script <- if (length(active_datanames()) == 0) { - # hide the filter panel and disable the burger button - "handleNoActiveDatasets();" - } else { - # show the filter panel and enable the burger button - "handleActiveDatasetsPresent();" - } - shinyjs::runjs(script) - }, - ignoreNULL = FALSE + active_module <- srv_nested_tabs( + id = "root", + datasets = datasets, + modules = modules, + reporter = reporter, + is_module_specific = is_module_specific ) - teal.slice::set_filter_state(datasets = datasets, filter = filter) - showNotification("Data loaded - App fully started up") + if (!is_module_specific) { + active_datanames <- reactive(active_module()$filters) + singleton <- unlist(datasets)[[1]] + singleton$srv_filter_panel("filter_panel", active_datanames = active_datanames) - logger::log_trace( - "srv_tabs_with_filters initialized the module with datasets { paste(datasets$datanames(), collapse = ' ') }." - ) + observeEvent( + eventExpr = active_datanames(), + handlerExpr = { + script <- if (length(active_datanames()) == 0 || is.null(active_datanames())) { + # hide the filter panel and disable the burger button + "handleNoActiveDatasets();" + } else { + # show the filter panel and enable the burger button + "handleActiveDatasetsPresent();" + } + shinyjs::runjs(script) + }, + ignoreNULL = FALSE + ) + } + + showNotification("Data loaded - App fully started up") + logger::log_trace("srv_tabs_with_filters initialized the module") return(active_module) }) } diff --git a/R/module_teal.R b/R/module_teal.R index 555a2ff7cd..e70a931414 100644 --- a/R/module_teal.R +++ b/R/module_teal.R @@ -127,7 +127,7 @@ ui_teal <- function(id, #' #' @return `reactive` which returns the currently active module #' @keywords internal -srv_teal <- function(id, modules, raw_data, filter = list()) { +srv_teal <- function(id, modules, raw_data, filter = teal_filters()) { stopifnot(is.reactive(raw_data)) moduleServer(id, function(input, output, session) { logger::log_trace("srv_teal initializing the module.") @@ -165,9 +165,56 @@ srv_teal <- function(id, modules, raw_data, filter = list()) { } env$progress <- shiny::Progress$new(session) env$progress$set(0.25, message = "Setting data") - # create the FilteredData object (here called 'datasets') whose class depends on the class of raw_data() - # this is placed in the module scope so that bookmarking can be used with FilteredData object - datasets <- teal.slice::init_filtered_data(raw_data()) + + # create a list of data following structure of the nested modules list structure. + # Because it's easier to unpack modules and datasets when they follow the same nested structure. + datasets_singleton <- teal.slice::init_filtered_data(raw_data()) + datasets_singleton$set_filter_state(filter) + module_datasets <- function(modules) { + if (inherits(modules, "teal_modules")) { + datasets <- lapply(modules$children, module_datasets) + labels <- vapply(modules$children, `[[`, character(1), "label") + names(datasets) <- labels + datasets + } else if (isTRUE(attr(filter, "module_specific"))) { + # we should create FilteredData even if modules$filter is null + # null controls a display of filter panel but data should be still passed + datanames <- if (is.null(modules$filter)) raw_data()$get_datanames() else modules$filter + data_objects <- sapply( + datanames, + simplify = FALSE, + FUN = function(dataname) { + dataset <- raw_data()$get_dataset(dataname) + list( + dataset = dataset$get_raw_data(), + metadata = dataset$get_metadata(), + label = dataset$get_dataset_label() + ) + } + ) + datasets_module <- teal.slice::init_filtered_data( + data_objects, + join_keys = raw_data()$get_join_keys(), + code = raw_data()$get_code_class(), + check = raw_data()$get_check() + ) + + # set initial filters + slices <- Filter(x = filter, f = function(x) { + x$id %in% unique(unlist(attr(filter, "mapping")[c(modules$label, "global_filters")])) && + x$dataname %in% datanames + }) + include_varnames <- attr(slices, "include_varnames")[names(attr(slices, "include_varnames")) %in% datanames] + exclude_varnames <- attr(slices, "exclude_varnames")[names(attr(slices, "exclude_varnames")) %in% datanames] + slices$include_varnames <- include_varnames + slices$exclude_varnames <- exclude_varnames + datasets_module$set_filter_state(slices) + datasets_module + } else { + datasets_singleton + } + } + datasets <- module_datasets(modules) logger::log_trace("srv_teal@4 Raw Data transferred to FilteredData.") datasets @@ -190,6 +237,7 @@ srv_teal <- function(id, modules, raw_data, filter = list()) { env$progress$set(0.5, message = "Setting up main UI") on.exit(env$progress$close()) # main_ui_container contains splash screen first and we remove it and replace it by the real UI + removeUI(sprintf("#%s:first-child", session$ns("main_ui_container"))) insertUI( selector = paste0("#", session$ns("main_ui_container")), @@ -199,7 +247,8 @@ srv_teal <- function(id, modules, raw_data, filter = list()) { ui = div(ui_tabs_with_filters( session$ns("main_ui"), modules = modules, - datasets = datasets_reactive() + datasets = datasets_reactive(), + filter = filter )), # needed so that the UI inputs are available and can be immediately updated, otherwise, updating may not # have any effect as they are ignored when not present diff --git a/R/module_teal_with_splash.R b/R/module_teal_with_splash.R index 0171cee56b..ac14a81455 100644 --- a/R/module_teal_with_splash.R +++ b/R/module_teal_with_splash.R @@ -54,7 +54,7 @@ ui_teal_with_splash <- function(id, #' @inheritParams shiny::moduleServer #' @return `reactive`, return value of [srv_teal()] #' @export -srv_teal_with_splash <- function(id, data, modules, filter = list()) { +srv_teal_with_splash <- function(id, data, modules, filter = teal_filters()) { stopifnot(is(data, "TealDataAbstract")) moduleServer(id, function(input, output, session) { logger::log_trace( diff --git a/R/modules.R b/R/modules.R index 90bd996456..c927ba0dd8 100644 --- a/R/modules.R +++ b/R/modules.R @@ -68,7 +68,6 @@ modules <- function(..., label = "root") { checkmate::assert_string(label) submodules <- list(...) - if (any(vapply(submodules, is.character, FUN.VALUE = logical(1)))) { stop( "The only character argument to modules() must be 'label' and it must be named, ", @@ -77,11 +76,10 @@ modules <- function(..., label = "root") { } checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules")) - # name them so we can more easily access the children # beware however that the label of the submodules should not be changed as it must be kept synced labels <- vapply(submodules, function(submodule) submodule$label, character(1)) - names(submodules) <- make.unique(gsub("[^[:alnum:]]", "_", tolower(labels)), sep = "_") + names(submodules) <- make.unique(gsub("[^[:alnum:]]+", "_", labels), sep = "_") structure( list( label = label, @@ -91,8 +89,6 @@ modules <- function(..., label = "root") { ) } - - #' Function which appends a teal_module onto the children of a teal_modules object #' @keywords internal #' @param modules `teal_modules` @@ -152,7 +148,8 @@ is_arg_used.function <- function(modules, arg) { #' @description `r lifecycle::badge("stable")` #' This function embeds a `shiny` module inside a `teal` application. One `teal_module` maps to one `shiny` module. #' -#' @param label (`character(1)`) Label shown in the navigation item for the module. +#' @param label (`character(1)`) Label shown in the navigation item for the module. Any label possible except +#' `"global_filters"` - read more in `mapping` argument of [teal::teal_filters]. #' @param server (`function`) `shiny` module with following arguments: #' - `id` - teal will set proper shiny namespace for this module (see [shiny::moduleServer()]). #' - `input`, `output`, `session` - (not recommended) then [shiny::callModule()] will be used to call a module. @@ -170,7 +167,8 @@ is_arg_used.function <- function(modules, arg) { #' @param filters (`character`) A vector with `datanames` that are relevant for the item. The #' filter panel will automatically update the shown filters to include only #' filters in the listed datasets. `NULL` will hide the filter panel, -#' and the keyword `'all'` will show the filters of all datasets. +#' and the keyword `'all'` will show the filters of all datasets. `filters` determines also +#' a subset of datasets which are appended to the `data` argument in `server` function. #' @param server_args (named `list`) with additional arguments passed on to the #' `server` function. #' @param ui_args (named `list`) with additional arguments passed on to the @@ -221,6 +219,9 @@ module <- function(label = "module", checkmate::assert_list(server_args, null.ok = TRUE, names = "named") checkmate::assert_list(ui_args, null.ok = TRUE, names = "named") + if (label == "global_filters") { + stop("Label 'global_filters' is reserved in teal. Please change to something else.") + } server_formals <- names(formals(server)) if (!( "id" %in% server_formals || @@ -327,6 +328,15 @@ modules_depth <- function(modules, depth = 0L) { } } + +module_labels <- function(modules) { + if (inherits(modules, "teal_modules")) { + lapply(modules$children, module_labels) + } else { + modules$label + } +} + #' Converts `teal_modules` to a string #' #' @param x (`teal_modules`) to print diff --git a/R/show_rcode_modal.R b/R/show_rcode_modal.R index c6333d4442..4161a17a9a 100644 --- a/R/show_rcode_modal.R +++ b/R/show_rcode_modal.R @@ -7,12 +7,11 @@ #' @param title (`character(1)`)\cr #' Title of the modal, displayed in the first comment of the R-code. #' @param rcode (`character`)\cr -#' vector with R code to show inside the modal. You can use [teal.code::get_code()] to derive this R -#' code inside a module. +#' vector with R code to show inside the modal. #' @param session (`ShinySession` optional)\cr #' `shiny` Session object, if missing then [shiny::getDefaultReactiveDomain()] is used. #' -#' @references [shiny::showModal()] [teal.code::get_code()] +#' @references [shiny::showModal()] show_rcode_modal <- function(title = NULL, rcode, session = getDefaultReactiveDomain()) { rcode <- paste(rcode, collapse = "\n") diff --git a/R/teal_filters.R b/R/teal_filters.R new file mode 100644 index 0000000000..57a6f92a2a --- /dev/null +++ b/R/teal_filters.R @@ -0,0 +1,113 @@ + +#' Filter settings for teal applications +#' +#' Filter settings for teal applications +#' +#' @inheritParams teal.slice::filter_settings +#' @param mapping (`named list`)\cr +#' Each element of the list should contain character vector of `teal_slices` `id` (see +#' [teal.slice::filter_var()]). Filters referred in list elements will be set on the startup of a +#' `teal` application. +#' Names of the list should correspond to `teal_module` `label` set in [module()] function. +#' +#' @param module_specific (`logical(1)`)\cr +#' - `TRUE` when filter panel should be module-specific. All modules can have different set +#' of filters specified - see `mapping` argument. +#' - `FALSE` when one filter panel needed to all modules. All filters will be shared +#' by all modules. +#' +#' @examples +#' filter <- teal::teal_filters( +#' teal.slice::filter_var(dataname = "iris", varname = "Species", id = "species"), +#' teal.slice::filter_var(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"), +#' teal.slice::filter_expr( +#' dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5" +#' ), +#' teal.slice::filter_var(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"), +#' mapping = list( +#' module1 = c("species", "sepal_length"), +#' module2 = c("mtcars_mpg"), +#' global_filters = "long_petals" +#' ) +#' ) +#' +#' app <- teal::init( +#' modules = list( +#' module("module1"), +#' module("module2") +#' ), +#' data = list(iris, mtcars), +#' filter = filter +#' ) +#' +#' if (interactive()) { +#' shiny::runApp(app) +#' } +#' +#' @export +teal_filters <- function(..., + exclude_varnames = NULL, + include_varnames = NULL, + count_type = NULL, + mapping = list(), + module_specific = length(mapping) > 0) { + shiny::isolate({ + checkmate::assert_list(mapping, names = "named") + checkmate::assert_flag(module_specific) + modules_mapped <- setdiff(names(mapping), "global_filters") + if (length(modules_mapped) && !module_specific) { + stop( + "`mapping` is specified for modules (", toString(modules_mapped), ") even though `module_specific` isn't TRUE.", + "Please set module_specific to `TRUE` or specify filters without mapping." + ) + } + + fs <- teal.slice::filter_settings( + ..., + exclude_varnames = exclude_varnames, + include_varnames = include_varnames, + count_type = count_type + ) + + all_slice_id <- vapply(fs, `[[`, character(1), "id") + for (i in names(mapping)) { + failed_slice_id <- setdiff(mapping[[i]], all_slice_id) + if (length(failed_slice_id)) { + stop(sprintf( + "id of filters in mapping '%s' don't match any available filter.\n %s not in %s", + i, + toString(failed_slice_id), + toString(all_slice_id) + )) + } + } + + attr(fs, "mapping") <- mapping + attr(fs, "module_specific") <- module_specific + class(fs) <- c("modules_filter_settings", class(fs)) + fs + }) +} + +#' Deep copy `teal_slices` +#' +#' it's important to create a new copy of `teal_slices` when +#' starting a new `shiny` session. Otherwise, object will be shared +#' by multiple users as it is created in global environment before +#' `shiny` session starts. +#' @param filter (`teal_slices`) +#' @return `teal_slices` +#' @keywords internal +deep_copy_filter <- function(filter) { + shiny::isolate({ + filter_copy <- lapply(filter, function(slice) { + if (inherits(slice, "teal_slice_expr")) { + do.call(teal.slice::filter_expr, args = reactiveValuesToList(slice)) + } else { + do.call(teal.slice::filter_var, args = reactiveValuesToList(slice)) + } + }) + attributes(filter_copy) <- attributes(filter) + return(filter_copy) + }) +} diff --git a/R/utils.R b/R/utils.R index c133d94ad9..9d284e5054 100644 --- a/R/utils.R +++ b/R/utils.R @@ -33,3 +33,16 @@ get_teal_bs_theme <- function() { bs_theme } } + +include_parent_datanames <- function(dataname, join_keys) { + parents <- character(0) + for (i in dataname) { + while (length(i) > 0) { + parent_i <- join_keys$get_parent(i) + parents <- c(parent_i, parents) + i <- parent_i + } + } + + return(unique(c(parents, dataname))) +} diff --git a/R/validate_inputs.R b/R/validate_inputs.R index cd2667468b..403188334a 100644 --- a/R/validate_inputs.R +++ b/R/validate_inputs.R @@ -1,4 +1,3 @@ - #' Send input validation messages to output. #' #' Captures messages from `InputValidator` objects and collates them diff --git a/R/zzz.R b/R/zzz.R index ac6177d791..c3754735e0 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -22,3 +22,7 @@ read.dcf(system.file("DESCRIPTION", package = "teal"))[, "Version"] ) } + +# Use non-exported function from teal.slice. +# This is a temporary measure and will be removed two release cycles from now (now meaning 0.13.0). +as.teal_slices <- getFromNamespace("as.teal_slices", "teal.slice") # nolint diff --git a/inst/css/sidebar.css b/inst/css/sidebar.css index f05ac701d3..dbcda10ae2 100644 --- a/inst/css/sidebar.css +++ b/inst/css/sidebar.css @@ -1,7 +1,15 @@ /* teal sidebar css */ + +.filter_manager_button { + font-size: 16px; + padding: 8px !important; + float: right !important; + background-color: transparent !important; +} + /* filter hamburger btn */ -#filter_hamburger { +.filter_hamburger { font-size: 16px; padding: 8px !important; float: right !important; diff --git a/inst/js/sidebar.js b/inst/js/sidebar.js index b892abd023..9672f16c14 100644 --- a/inst/js/sidebar.js +++ b/inst/js/sidebar.js @@ -1,19 +1,16 @@ // used to collapse and expand the filter panel in teal apps var filter_open = true; const hideSidebar = () => { - $("#teal_secondary_col").fadeOut(1); - $("#teal_primary_col").attr("class", "col-sm-12").resize(); + $(".teal_secondary_col").fadeOut(1); + $(".teal_primary_col").attr("class", "teal_primary_col col-sm-12").resize(); }; const showSidebar = () => { - $("#teal_primary_col").attr("class", "col-sm-9").resize(); - $("#teal_secondary_col").delay(600).fadeIn(50); + debugger; + $(".teal_primary_col").attr("class", "teal_primary_col col-sm-9").resize(); + $(".teal_secondary_col").delay(600).fadeIn(50); }; const toggleFilterPanel = () => { - if ( - filter_open && - getComputedStyle(document.getElementById("teal_secondary_col")).display === - "none" - ) { + if (filter_open && !$(".teal_secondary_col").is(':visible')) { showSidebar(); return; } @@ -24,11 +21,11 @@ const toggleFilterPanel = () => { // Function to hide filter panel and disable the burger button const handleNoActiveDatasets = () => { - $("#filter_hamburger").addClass("disabled"); + $(".filter_hamburger").addClass("hidden"); hideSidebar(); }; // Function to show filter panel and enable the burger button const handleActiveDatasetsPresent = () => { - $("#filter_hamburger").removeClass("disabled"); + $(".filter_hamburger").removeClass("hidden"); if (filter_open) showSidebar(); } diff --git a/man/deep_copy_filter.Rd b/man/deep_copy_filter.Rd new file mode 100644 index 0000000000..5cf2522e61 --- /dev/null +++ b/man/deep_copy_filter.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_filters.R +\name{deep_copy_filter} +\alias{deep_copy_filter} +\title{Deep copy \code{teal_slices}} +\usage{ +deep_copy_filter(filter) +} +\arguments{ +\item{filter}{(\code{teal_slices})} +} +\value{ +\code{teal_slices} +} +\description{ +it's important to create a new copy of \code{teal_slices} when +starting a new \code{shiny} session. Otherwise, object will be shared +by multiple users as it is created in global environment before +\code{shiny} session starts. +} +\keyword{internal} diff --git a/man/filter_manager_module_srv.Rd b/man/filter_manager_module_srv.Rd new file mode 100644 index 0000000000..5f945929a9 --- /dev/null +++ b/man/filter_manager_module_srv.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/module_filter_manager.R +\name{filter_manager_module_srv} +\alias{filter_manager_module_srv} +\title{Module specific filter manager} +\usage{ +filter_manager_module_srv(id, module_fd, slices_map_module, slices_global) +} +\arguments{ +\item{id}{(\code{character(1)})\cr +\code{shiny} module id.} + +\item{module_fd}{(\code{FilteredData})\cr +object to filter data in the teal-module} + +\item{slices_map_module}{(\code{reactiveVal} of \code{character})\cr +\code{id} of the \code{teal_slice} objects used in the module specific \code{FilteredData}.} + +\item{slices_global}{(\code{reactiveVal} or \code{teal_slices})\cr +stores a list of all available filters which can be utilized in several ways, for example: +\itemize{ +\item to disable/enable specific filter in the module +\item to restore filter saved settings +\item to save current filter settings panel +}} +} +\value{ +shiny module returning NULL +} +\description{ +This module compares filters between single \code{FilteredData} settings +and global \code{teal_slices}. Updates appropriate objects \code{module_fd}, +\code{slices_map_module}, \code{slices_global} to keep them consistent. +} +\keyword{internal} diff --git a/man/init.Rd b/man/init.Rd index 20744ef652..fddaa94456 100644 --- a/man/init.Rd +++ b/man/init.Rd @@ -8,7 +8,7 @@ init( data, modules, title = NULL, - filter = list(), + filter = teal_filters(), header = tags$p(), footer = tags$p(), id = character(0) @@ -34,76 +34,10 @@ more details.} \item{title}{(\code{NULL} or \code{character})\cr The browser window title (defaults to the host URL of the page).} -\item{filter}{(\code{teal_slices} or \code{list})\cr -You can define filters that show when the app starts. -There are two ways to specify the filter states: -\enumerate{ -\item with a \code{teal_slices} object - see \code{?teal.slice::teal_slice} for details -\item with a named list (deprecated) -} - -List names should be named according to \code{datanames} passed to the \code{data} argument. -In case of data.frame` the list should be composed as follows: - -\if{html}{\out{
}}\preformatted{list( = list( = ..., = ...), - = list(...), - ...) - -}\if{html}{\out{
}} - -For example, filters for variable \code{Sepal.Length} in \code{iris} can be specified as -follows: - -\if{html}{\out{
}}\preformatted{list(iris = list(Sepal.Length = list(selected = c(5.0, 7.0)))) -# or -list(iris = list(Sepal.Length = c(5.0, 7.0))) -}\if{html}{\out{
}} - -In case developer would like to include \code{NA} and \code{Inf} values in the -filtered dataset. - -\if{html}{\out{
}}\preformatted{list(Species = list(selected = c(5.0, 7.0), keep_na = TRUE, keep_inf = TRUE)) -list(Species = c(c(5.0, 7.0), NA, Inf)) -}\if{html}{\out{
}} - -To initialize with specific variable filter with all values on start, one -can use - -\if{html}{\out{
}}\preformatted{list(Species = list()) -}\if{html}{\out{
}} - -\code{filter} should be set with respect to the class of the column: -\itemize{ -\item \code{numeric}: \code{selected} should be a two elements vector defining the range -of the filter. -\item \code{Date}: \code{selected} should be a two elements vector defining the date-range -of the filter -\item \code{POSIXct}: \code{selected} should be a two elements vector defining the -\code{datetime} range of the filter -\item \code{character} and \code{factor}: \code{selected} should be a vector of any length -defining initial values selected to filter. -\cr -\code{filter} for \code{MultiAssayExperiment} objects should be specified in slightly -different way. Since it contains patient data with list of experiments, -\code{filter} list should be created as follows: -\cr -} - -\if{html}{\out{
}}\preformatted{list( - = list( - subjects = list( = ..., = ...), - = list( - subset = list( = ..., - = ...), - select = list( = ..., - = ...) - ) - ) -) -}\if{html}{\out{
}} - -By adding the \code{filterable} attribute it is possible to control which variables can be filtered for each -dataset. See the example below where \code{ADSL} can only be filtered by \code{AGE}, \code{SEX} or \code{RACE}.} +\item{filter}{(\code{teal_slices})\cr +Specification of initial filter. Filters can be specified using \code{\link[=teal_filters]{teal_filters()}}. +Old way of specifying filters through a list is deprecated and will be removed in the +next release. Please fix your applications to use \code{\link[=teal_filters]{teal_filters()}}.} \item{header}{(\code{shiny.tag} or \code{character}) \cr the header of the app. Note shiny code placed here (and in the footer @@ -143,12 +77,12 @@ app <- init( ), modules = modules( module( - "data source", + label = "data source", server = function(input, output, session, data) {}, ui = function(id, ...) div(p("information about data source")), filters = "all" ), - example_module(), + example_module(label = "example teal module"), module( "ADSL AGE histogram", server = function(input, output, session, data) { @@ -164,9 +98,16 @@ app <- init( ) ), title = "App title", - filter = teal.slice:::filter_settings( - teal.slice:::filter_var("ADSL", "AGE"), - exclude = list(ADSL = setdiff(names(ADSL), c("AGE", "SEX", "RACE"))) + filter = teal::teal_filters( + teal.slice::filter_var(dataname = "ADSL", varname = "AGE"), + teal.slice::filter_var(dataname = "ADSL", varname = "SEX"), + teal.slice::filter_var(dataname = "ADSL", varname = "RACE"), + exclude_varnames = list(ADSL = setdiff(names(ADSL), c("AGE", "SEX", "RACE"))), + mapping = list( + `example teal module` = "ADSL RACE", + `ADSL AGE histogram` = "ADSL AGE", + global_filters = "ADSL SEX" + ) ), header = tags$h1("Sample App"), footer = tags$p("Copyright 2017 - 2020") diff --git a/man/module.Rd b/man/module.Rd index 8736a9cce6..2f48222556 100644 --- a/man/module.Rd +++ b/man/module.Rd @@ -27,7 +27,8 @@ module( \method{print}{teal_module}(x, ...) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module. Any label possible except +\code{"global_filters"} - read more in \code{mapping} argument of \link{teal_filters}.} \item{server}{(\code{function}) \code{shiny} module with following arguments: \itemize{ @@ -51,7 +52,8 @@ the \code{filters} argument. \item{filters}{(\code{character}) A vector with \code{datanames} that are relevant for the item. The filter panel will automatically update the shown filters to include only filters in the listed datasets. \code{NULL} will hide the filter panel, -and the keyword \code{'all'} will show the filters of all datasets.} +and the keyword \code{'all'} will show the filters of all datasets. \code{filters} determines also +a subset of datasets which are appended to the \code{data} argument in \code{server} function.} \item{server_args}{(named \code{list}) with additional arguments passed on to the \code{server} function.} diff --git a/man/module_filter_manager.Rd b/man/module_filter_manager.Rd new file mode 100644 index 0000000000..7975f5caea --- /dev/null +++ b/man/module_filter_manager.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/module_filter_manager.R +\name{filter_manager_ui} +\alias{filter_manager_ui} +\alias{filter_manager_srv} +\title{Manage multiple \code{FilteredData} objects} +\usage{ +filter_manager_ui(id) + +filter_manager_srv(id, filtered_data_list, filter) +} +\arguments{ +\item{id}{(\code{character(1)})\cr +\code{shiny} module id.} + +\item{filtered_data_list}{(\code{list} of \code{FilteredData})\cr +Names of the list should be the same as \code{teal_module$label}.} + +\item{filter}{(\code{teal_slices})\cr +Specification of initial filter. Filters can be specified using \code{\link[=teal_filters]{teal_filters()}}. +Old way of specifying filters through a list is deprecated and will be removed in the +next release. Please fix your applications to use \code{\link[=teal_filters]{teal_filters()}}.} +} +\description{ +Manage multiple \code{FilteredData} objects +} +\details{ +This module observes the changes of the filters in each \code{FilteredData} object +and keeps track of all filters used. Map of the filters is kept in so called +\code{slices_map} object where each \code{FilteredData} is linked with its active filters. +This map is represented in the UI as a matrix where rows are ids of the filters and +columns are names of the \code{filtered_data_list} (named after teal modules). +} +\keyword{internal} diff --git a/man/module_filter_manager_modal.Rd b/man/module_filter_manager_modal.Rd new file mode 100644 index 0000000000..7c34726330 --- /dev/null +++ b/man/module_filter_manager_modal.Rd @@ -0,0 +1,62 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/module_filter_manager.R +\name{filter_manager_modal_ui} +\alias{filter_manager_modal_ui} +\alias{filter_manager_modal_srv} +\title{Filter manager modal} +\usage{ +filter_manager_modal_ui(id) + +filter_manager_modal_srv(id, filtered_data_list, filter) +} +\arguments{ +\item{id}{(\code{character(1)})\cr +\code{shiny} module id.} + +\item{filtered_data_list}{(\code{list} of \code{FilteredData})\cr +Names of the list should be the same as \code{teal_module$label}.} + +\item{filter}{(\code{teal_slices})\cr +Specification of initial filter. Filters can be specified using \code{\link[=teal_filters]{teal_filters()}}. +Old way of specifying filters through a list is deprecated and will be removed in the +next release. Please fix your applications to use \code{\link[=teal_filters]{teal_filters()}}.} +} +\description{ +Filter manager modal +} +\examples{ +fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris))) +fd2 <- teal.slice::init_filtered_data( + list(iris = list(dataset = iris), mtcars = list(dataset = mtcars)) +) +fd3 <- teal.slice::init_filtered_data( + list(iris = list(dataset = iris), women = list(dataset = women)) +) +filter <- teal::teal_filters( + teal.slice::filter_var(dataname = "iris", varname = "Sepal.Length"), + teal.slice::filter_var(dataname = "iris", varname = "Species"), + teal.slice::filter_var(dataname = "mtcars", varname = "mpg"), + teal.slice::filter_var(dataname = "women", varname = "height"), + mapping = list( + module2 = c("mtcars mpg"), + module3 = c("women height"), + global_filters = "iris Species" + ) +) + +if (interactive()) { + shinyApp( + ui = fluidPage( + filter_manager_modal_ui("manager") + ), + server = function(input, output, session) { + filter_manager_modal_srv( + "manager", + filtered_data_list = list(module1 = fd1, module2 = fd2, module3 = fd3), + filter = filter + ) + } + ) +} + +} diff --git a/man/reporter_previewer_module.Rd b/man/reporter_previewer_module.Rd index dbd8912c2e..74e86190b0 100644 --- a/man/reporter_previewer_module.Rd +++ b/man/reporter_previewer_module.Rd @@ -7,7 +7,8 @@ reporter_previewer_module(label = "Report previewer") } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module. Any label possible except +\code{"global_filters"} - read more in \code{mapping} argument of \link{teal_filters}.} } \value{ \code{teal_module} containing the \code{teal.reporter} previewer functionality diff --git a/man/show_rcode_modal.Rd b/man/show_rcode_modal.Rd index 7f03222fea..228aec1036 100644 --- a/man/show_rcode_modal.Rd +++ b/man/show_rcode_modal.Rd @@ -11,8 +11,7 @@ show_rcode_modal(title = NULL, rcode, session = getDefaultReactiveDomain()) Title of the modal, displayed in the first comment of the R-code.} \item{rcode}{(\code{character})\cr -vector with R code to show inside the modal. You can use \code{\link[teal.code:get_code]{teal.code::get_code()}} to derive this R -code inside a module.} +vector with R code to show inside the modal.} \item{session}{(\code{ShinySession} optional)\cr \code{shiny} Session object, if missing then \code{\link[shiny:domains]{shiny::getDefaultReactiveDomain()}} is used.} @@ -22,5 +21,5 @@ code inside a module.} Use the \code{\link[shiny:showModal]{shiny::showModal()}} function to show the R code inside. } \references{ -\code{\link[shiny:showModal]{shiny::showModal()}} \code{\link[teal.code:get_code]{teal.code::get_code()}} +\code{\link[shiny:showModal]{shiny::showModal()}} } diff --git a/man/srv_nested_tabs.Rd b/man/srv_nested_tabs.Rd index e6944607cf..d6508b57c4 100644 --- a/man/srv_nested_tabs.Rd +++ b/man/srv_nested_tabs.Rd @@ -11,6 +11,7 @@ srv_nested_tabs( id, datasets, modules, + is_module_specific = FALSE, reporter = teal.reporter::Reporter$new() ) @@ -18,6 +19,7 @@ srv_nested_tabs( id, datasets, modules, + is_module_specific = FALSE, reporter = teal.reporter::Reporter$new() ) @@ -25,6 +27,7 @@ srv_nested_tabs( id, datasets, modules, + is_module_specific = FALSE, reporter = teal.reporter::Reporter$new() ) @@ -32,6 +35,7 @@ srv_nested_tabs( id, datasets, modules, + is_module_specific = TRUE, reporter = teal.reporter::Reporter$new() ) } diff --git a/man/srv_tabs_with_filters.Rd b/man/srv_tabs_with_filters.Rd index 2d46a35257..5191fa67f7 100644 --- a/man/srv_tabs_with_filters.Rd +++ b/man/srv_tabs_with_filters.Rd @@ -29,76 +29,10 @@ more details.} \item{reporter}{(\code{Reporter}) object from \code{teal.reporter}} -\item{filter}{(\code{teal_slices} or \code{list})\cr -You can define filters that show when the app starts. -There are two ways to specify the filter states: -\enumerate{ -\item with a \code{teal_slices} object - see \code{?teal.slice::teal_slice} for details -\item with a named list (deprecated) -} - -List names should be named according to \code{datanames} passed to the \code{data} argument. -In case of data.frame` the list should be composed as follows: - -\if{html}{\out{
}}\preformatted{list( = list( = ..., = ...), - = list(...), - ...) - -}\if{html}{\out{
}} - -For example, filters for variable \code{Sepal.Length} in \code{iris} can be specified as -follows: - -\if{html}{\out{
}}\preformatted{list(iris = list(Sepal.Length = list(selected = c(5.0, 7.0)))) -# or -list(iris = list(Sepal.Length = c(5.0, 7.0))) -}\if{html}{\out{
}} - -In case developer would like to include \code{NA} and \code{Inf} values in the -filtered dataset. - -\if{html}{\out{
}}\preformatted{list(Species = list(selected = c(5.0, 7.0), keep_na = TRUE, keep_inf = TRUE)) -list(Species = c(c(5.0, 7.0), NA, Inf)) -}\if{html}{\out{
}} - -To initialize with specific variable filter with all values on start, one -can use - -\if{html}{\out{
}}\preformatted{list(Species = list()) -}\if{html}{\out{
}} - -\code{filter} should be set with respect to the class of the column: -\itemize{ -\item \code{numeric}: \code{selected} should be a two elements vector defining the range -of the filter. -\item \code{Date}: \code{selected} should be a two elements vector defining the date-range -of the filter -\item \code{POSIXct}: \code{selected} should be a two elements vector defining the -\code{datetime} range of the filter -\item \code{character} and \code{factor}: \code{selected} should be a vector of any length -defining initial values selected to filter. -\cr -\code{filter} for \code{MultiAssayExperiment} objects should be specified in slightly -different way. Since it contains patient data with list of experiments, -\code{filter} list should be created as follows: -\cr -} - -\if{html}{\out{
}}\preformatted{list( - = list( - subjects = list( = ..., = ...), - = list( - subset = list( = ..., - = ...), - select = list( = ..., - = ...) - ) - ) -) -}\if{html}{\out{
}} - -By adding the \code{filterable} attribute it is possible to control which variables can be filtered for each -dataset. See the example below where \code{ADSL} can only be filtered by \code{AGE}, \code{SEX} or \code{RACE}.} +\item{filter}{(\code{teal_slices})\cr +Specification of initial filter. Filters can be specified using \code{\link[=teal_filters]{teal_filters()}}. +Old way of specifying filters through a list is deprecated and will be removed in the +next release. Please fix your applications to use \code{\link[=teal_filters]{teal_filters()}}.} } \value{ \code{reactive} currently selected active_module diff --git a/man/srv_teal.Rd b/man/srv_teal.Rd index 7627cd3230..079c53fff1 100644 --- a/man/srv_teal.Rd +++ b/man/srv_teal.Rd @@ -4,7 +4,7 @@ \alias{srv_teal} \title{Server function corresponding to teal} \usage{ -srv_teal(id, modules, raw_data, filter = list()) +srv_teal(id, modules, raw_data, filter = teal_filters()) } \arguments{ \item{id}{(\code{character})\cr @@ -22,76 +22,10 @@ more details.} \item{raw_data}{(\code{reactive})\cr returns the \code{TealData}, only evaluated once, \code{NULL} value is ignored} -\item{filter}{(\code{teal_slices} or \code{list})\cr -You can define filters that show when the app starts. -There are two ways to specify the filter states: -\enumerate{ -\item with a \code{teal_slices} object - see \code{?teal.slice::teal_slice} for details -\item with a named list (deprecated) -} - -List names should be named according to \code{datanames} passed to the \code{data} argument. -In case of data.frame` the list should be composed as follows: - -\if{html}{\out{
}}\preformatted{list( = list( = ..., = ...), - = list(...), - ...) - -}\if{html}{\out{
}} - -For example, filters for variable \code{Sepal.Length} in \code{iris} can be specified as -follows: - -\if{html}{\out{
}}\preformatted{list(iris = list(Sepal.Length = list(selected = c(5.0, 7.0)))) -# or -list(iris = list(Sepal.Length = c(5.0, 7.0))) -}\if{html}{\out{
}} - -In case developer would like to include \code{NA} and \code{Inf} values in the -filtered dataset. - -\if{html}{\out{
}}\preformatted{list(Species = list(selected = c(5.0, 7.0), keep_na = TRUE, keep_inf = TRUE)) -list(Species = c(c(5.0, 7.0), NA, Inf)) -}\if{html}{\out{
}} - -To initialize with specific variable filter with all values on start, one -can use - -\if{html}{\out{
}}\preformatted{list(Species = list()) -}\if{html}{\out{
}} - -\code{filter} should be set with respect to the class of the column: -\itemize{ -\item \code{numeric}: \code{selected} should be a two elements vector defining the range -of the filter. -\item \code{Date}: \code{selected} should be a two elements vector defining the date-range -of the filter -\item \code{POSIXct}: \code{selected} should be a two elements vector defining the -\code{datetime} range of the filter -\item \code{character} and \code{factor}: \code{selected} should be a vector of any length -defining initial values selected to filter. -\cr -\code{filter} for \code{MultiAssayExperiment} objects should be specified in slightly -different way. Since it contains patient data with list of experiments, -\code{filter} list should be created as follows: -\cr -} - -\if{html}{\out{
}}\preformatted{list( - = list( - subjects = list( = ..., = ...), - = list( - subset = list( = ..., - = ...), - select = list( = ..., - = ...) - ) - ) -) -}\if{html}{\out{
}} - -By adding the \code{filterable} attribute it is possible to control which variables can be filtered for each -dataset. See the example below where \code{ADSL} can only be filtered by \code{AGE}, \code{SEX} or \code{RACE}.} +\item{filter}{(\code{teal_slices})\cr +Specification of initial filter. Filters can be specified using \code{\link[=teal_filters]{teal_filters()}}. +Old way of specifying filters through a list is deprecated and will be removed in the +next release. Please fix your applications to use \code{\link[=teal_filters]{teal_filters()}}.} } \value{ \code{reactive} which returns the currently active module diff --git a/man/srv_teal_with_splash.Rd b/man/srv_teal_with_splash.Rd index d11ae4cf5d..a7beb3be7a 100644 --- a/man/srv_teal_with_splash.Rd +++ b/man/srv_teal_with_splash.Rd @@ -5,7 +5,7 @@ \title{Server function that loads the data through reactive loading and then delegates to \code{\link[=srv_teal]{srv_teal()}}.} \usage{ -srv_teal_with_splash(id, data, modules, filter = list()) +srv_teal_with_splash(id, data, modules, filter = teal_filters()) } \arguments{ \item{id}{(\code{character})\cr @@ -28,76 +28,10 @@ or \code{\link[teal.data:cdisc_data]{teal.data::cdisc_data()}} with \code{check will be displayed in the teal application. See \code{\link[=modules]{modules()}} and \code{\link[=module]{module()}} for more details.} -\item{filter}{(\code{teal_slices} or \code{list})\cr -You can define filters that show when the app starts. -There are two ways to specify the filter states: -\enumerate{ -\item with a \code{teal_slices} object - see \code{?teal.slice::teal_slice} for details -\item with a named list (deprecated) -} - -List names should be named according to \code{datanames} passed to the \code{data} argument. -In case of data.frame` the list should be composed as follows: - -\if{html}{\out{
}}\preformatted{list( = list( = ..., = ...), - = list(...), - ...) - -}\if{html}{\out{
}} - -For example, filters for variable \code{Sepal.Length} in \code{iris} can be specified as -follows: - -\if{html}{\out{
}}\preformatted{list(iris = list(Sepal.Length = list(selected = c(5.0, 7.0)))) -# or -list(iris = list(Sepal.Length = c(5.0, 7.0))) -}\if{html}{\out{
}} - -In case developer would like to include \code{NA} and \code{Inf} values in the -filtered dataset. - -\if{html}{\out{
}}\preformatted{list(Species = list(selected = c(5.0, 7.0), keep_na = TRUE, keep_inf = TRUE)) -list(Species = c(c(5.0, 7.0), NA, Inf)) -}\if{html}{\out{
}} - -To initialize with specific variable filter with all values on start, one -can use - -\if{html}{\out{
}}\preformatted{list(Species = list()) -}\if{html}{\out{
}} - -\code{filter} should be set with respect to the class of the column: -\itemize{ -\item \code{numeric}: \code{selected} should be a two elements vector defining the range -of the filter. -\item \code{Date}: \code{selected} should be a two elements vector defining the date-range -of the filter -\item \code{POSIXct}: \code{selected} should be a two elements vector defining the -\code{datetime} range of the filter -\item \code{character} and \code{factor}: \code{selected} should be a vector of any length -defining initial values selected to filter. -\cr -\code{filter} for \code{MultiAssayExperiment} objects should be specified in slightly -different way. Since it contains patient data with list of experiments, -\code{filter} list should be created as follows: -\cr -} - -\if{html}{\out{
}}\preformatted{list( - = list( - subjects = list( = ..., = ...), - = list( - subset = list( = ..., - = ...), - select = list( = ..., - = ...) - ) - ) -) -}\if{html}{\out{
}} - -By adding the \code{filterable} attribute it is possible to control which variables can be filtered for each -dataset. See the example below where \code{ADSL} can only be filtered by \code{AGE}, \code{SEX} or \code{RACE}.} +\item{filter}{(\code{teal_slices})\cr +Specification of initial filter. Filters can be specified using \code{\link[=teal_filters]{teal_filters()}}. +Old way of specifying filters through a list is deprecated and will be removed in the +next release. Please fix your applications to use \code{\link[=teal_filters]{teal_filters()}}.} } \value{ \code{reactive}, return value of \code{\link[=srv_teal]{srv_teal()}} diff --git a/man/teal_filters.Rd b/man/teal_filters.Rd new file mode 100644 index 0000000000..5de55f0880 --- /dev/null +++ b/man/teal_filters.Rd @@ -0,0 +1,78 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_filters.R +\name{teal_filters} +\alias{teal_filters} +\title{Filter settings for teal applications} +\usage{ +teal_filters( + ..., + exclude_varnames = NULL, + include_varnames = NULL, + count_type = NULL, + mapping = list(), + module_specific = length(mapping) > 0 +) +} +\arguments{ +\item{...}{for \code{filter_var} and \code{filter_expr} any number of additional fields given as \code{name:value} pairs\cr +for \code{filter_settings} any number of \code{teal_slice} objects\cr +for other functions arguments passed to other methods} + +\item{include_varnames, exclude_varnames}{\verb{named list}s of \code{character} vectors where list names +match names of data sets and vector elements match variable names in respective data sets; +specify which variables are allowed to be filtered; see \code{Details}} + +\item{count_type}{\code{character(1)} string specifying how observations are tallied by these filter states. +Possible options: +\itemize{ +\item \code{"all"} to have counts of single \code{FilterState} to show number of observation in filtered +and unfiltered dataset. +\item \code{"none"} to have counts of single \code{FilterState} to show unfiltered number only. +}} + +\item{mapping}{(\verb{named list})\cr +Each element of the list should contain character vector of \code{teal_slices} \code{id} (see +\code{\link[teal.slice:teal_slice]{teal.slice::filter_var()}}). Filters referred in list elements will be set on the startup of a +\code{teal} application. +Names of the list should correspond to \code{teal_module} \code{label} set in \code{\link[=module]{module()}} function.} + +\item{module_specific}{(\code{logical(1)})\cr +\itemize{ +\item \code{TRUE} when filter panel should be module-specific. All modules can have different set +of filters specified - see \code{mapping} argument. +\item \code{FALSE} when one filter panel needed to all modules. All filters will be shared +by all modules. +}} +} +\description{ +Filter settings for teal applications +} +\examples{ +filter <- teal::teal_filters( + teal.slice::filter_var(dataname = "iris", varname = "Species", id = "species"), + teal.slice::filter_var(dataname = "iris", varname = "Sepal.Length", id = "sepal_length"), + teal.slice::filter_expr( + dataname = "iris", id = "long_petals", title = "Long petals", expr = "Petal.Length > 5" + ), + teal.slice::filter_var(dataname = "mtcars", varname = "mpg", id = "mtcars_mpg"), + mapping = list( + module1 = c("species", "sepal_length"), + module2 = c("mtcars_mpg"), + global_filters = "long_petals" + ) +) + +app <- teal::init( + modules = list( + module("module1"), + module("module2") + ), + data = list(iris, mtcars), + filter = filter +) + +if (interactive()) { + shiny::runApp(app) +} + +} diff --git a/man/ui_nested_tabs.Rd b/man/ui_nested_tabs.Rd index 9c86fcf67b..70976c0d8a 100644 --- a/man/ui_nested_tabs.Rd +++ b/man/ui_nested_tabs.Rd @@ -7,13 +7,13 @@ \alias{ui_nested_tabs.teal_module} \title{Create a UI of nested tabs of \code{teal_modules}} \usage{ -ui_nested_tabs(id, modules, datasets, depth = 0L) +ui_nested_tabs(id, modules, datasets, depth = 0L, is_module_specific = FALSE) -\method{ui_nested_tabs}{default}(id, modules, datasets, depth = 0L) +\method{ui_nested_tabs}{default}(id, modules, datasets, depth = 0L, is_module_specific = FALSE) -\method{ui_nested_tabs}{teal_modules}(id, modules, datasets, depth = 0L) +\method{ui_nested_tabs}{teal_modules}(id, modules, datasets, depth = 0L, is_module_specific = FALSE) -\method{ui_nested_tabs}{teal_module}(id, modules, datasets, depth = 0L) +\method{ui_nested_tabs}{teal_module}(id, modules, datasets, depth = 0L, is_module_specific = FALSE) } \arguments{ \item{id}{(\code{character(1)})\cr @@ -28,6 +28,10 @@ details see \code{\link[teal.slice:FilteredData]{teal.slice::FilteredData}}} \item{depth}{(\code{integer(1)})\cr number which helps to determine depth of the modules nesting.} + +\item{is_module_specific}{(\code{logical(1)})\cr +flag determinining if the filter panel is global or module-specific. When \code{module_specific} +is \code{TRUE} then a filter panel is called inside of each module tab.} } \value{ depending on class of \code{modules}: diff --git a/man/ui_tabs_with_filters.Rd b/man/ui_tabs_with_filters.Rd index f0641913d5..32f3b5a7e9 100644 --- a/man/ui_tabs_with_filters.Rd +++ b/man/ui_tabs_with_filters.Rd @@ -4,7 +4,7 @@ \alias{ui_tabs_with_filters} \title{Add right filter panel into each of the top-level \code{teal_modules} UIs.} \usage{ -ui_tabs_with_filters(id, modules, datasets) +ui_tabs_with_filters(id, modules, datasets, filter) } \arguments{ \item{id}{(\code{character(1)})\cr @@ -16,6 +16,11 @@ See \code{\link[=modules]{modules()}} and \code{\link[=module]{module()}} for mo \item{datasets}{(\code{FilteredData})\cr object to store filter state and filtered datasets, shared across modules. For more details see \code{\link[teal.slice:FilteredData]{teal.slice::FilteredData}}} + +\item{filter}{(\code{teal_slices})\cr +Specification of initial filter. Filters can be specified using \code{\link[=teal_filters]{teal_filters()}}. +Old way of specifying filters through a list is deprecated and will be removed in the +next release. Please fix your applications to use \code{\link[=teal_filters]{teal_filters()}}.} } \value{ A \code{tagList} of The main menu, place holders for filters and diff --git a/tests/testthat/test-filter_manager.R b/tests/testthat/test-filter_manager.R new file mode 100644 index 0000000000..143d9ebbce --- /dev/null +++ b/tests/testthat/test-filter_manager.R @@ -0,0 +1,55 @@ +filter <- teal::teal_filters( + teal.slice::filter_var(dataname = "iris", varname = "Sepal.Length"), + teal.slice::filter_var(dataname = "iris", varname = "Species"), + teal.slice::filter_var(dataname = "mtcars", varname = "mpg"), + teal.slice::filter_var(dataname = "women", varname = "height"), + mapping = list( + m1 = c("iris Sepal.Length"), + m3 = c("women height"), + global_filters = "iris Species" + ) +) + +testthat::test_that("filter_manager_srv initializes objects based on initial filter configuration", { + fd1 <- teal.slice::init_filtered_data(list(iris = list(dataset = iris))) + fd2 <- teal.slice::init_filtered_data( + list(iris = list(dataset = iris), mtcars = list(dataset = mtcars)) + ) + fd3 <- teal.slice::init_filtered_data( + list(iris = list(dataset = iris), women = list(dataset = women)) + ) + filtered_data_list <- list( + m1 = fd1, + tab = list(m2 = fd2, m3 = fd3) + ) + + shiny::testServer( + app = filter_manager_srv, + args = list( + id = "test", + filtered_data_list = filtered_data_list, + filter = filter + ), + expr = { + testthat::expect_named(filtered_data_list, c("m1", "m2", "m3")) + + testthat::expect_identical(slices_map$m1(), c("iris Sepal.Length", "iris Species")) + testthat::expect_identical(slices_map$m2(), "iris Species") + testthat::expect_identical(slices_map$m3(), c("women height", "iris Species")) + + testthat::expect_identical(slices_global(), filter) + + testthat::expect_identical( + mapping_matrix(), + as.matrix( + data.frame( + m1 = c(TRUE, TRUE, FALSE, FALSE), + m2 = c(FALSE, TRUE, FALSE, FALSE), + m3 = c(FALSE, TRUE, FALSE, TRUE), + row.names = c("iris Sepal.Length", "iris Species", "mtcars mpg", "women height") + ) + ) + ) + } + ) +}) diff --git a/tests/testthat/test-init.R b/tests/testthat/test-init.R index 0f739455cd..66e5c1b6f9 100644 --- a/tests/testthat/test-init.R +++ b/tests/testthat/test-init.R @@ -158,3 +158,48 @@ testthat::test_that("init filter accepts named list or `teal_slices`", { testthat::expect_no_error(init(data = dataset_1, modules = mods, filter = fs)) testthat::expect_error(init(data = dataset_1, modules = mods, filter = unclass(fs)), "Assertion failed") }) + +testthat::test_that("init filter fails when filters don't refer to available data names", { + testthat::expect_error( + init( + data = list(iris = iris), + modules = teal:::get_dummy_modules(), + filter = teal.slice::filter_settings( + teal.slice::filter_var(dataname = "inexisting", varname = "varname") + ) + ), + "inexisting not in iris" + ) +}) + +testthat::test_that("init filter fails when mapping don't refer to available module labels", { + testthat::expect_error( + init( + data = list(iris = iris), + modules = teal:::get_dummy_modules(), + filter = teal_filters( + teal.slice::filter_var(dataname = "iris", varname = "varname", id = "iris varname"), + mapping = list( + inexisting = c("iris varname") + ) + ) + ), + "inexisting not in aaa1, aaa2, aaa3" + ) +}) + +testthat::test_that("init filter fails when mapping don't refer to available filter id", { + testthat::expect_error( + init( + data = list(iris = iris), + modules = teal:::get_dummy_modules(), + filter = teal_filters( + teal.slice::filter_var(dataname = "iris", varname = "varname", id = "iris varname"), + mapping = list( + aaa1 = "inexisting" + ) + ) + ), + "inexisting not in iris varname" + ) +}) diff --git a/tests/testthat/test-module_nested_tabs.R b/tests/testthat/test-module_nested_tabs.R index 12423a49c4..8efe9e1bbf 100644 --- a/tests/testthat/test-module_nested_tabs.R +++ b/tests/testthat/test-module_nested_tabs.R @@ -30,7 +30,7 @@ test_module4 <- module( testthat::test_that("srv_nested_tabs throws error if reporter is not inherited from class Reporter", { testthat::expect_error( srv_nested_tabs(id, datasets = filtered_data, modules = modules(test_module1), reporter = list()), - "inherits\\(reporter, \"Reporter\"\\) is not TRUE" + "Must inherit from class 'Reporter'" ) }) @@ -42,7 +42,7 @@ testthat::test_that("passed shiny module is initialized only when the UI is trig app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(test1 = filtered_data), modules = modules(test_module1), reporter = teal.reporter::Reporter$new() ), @@ -56,7 +56,7 @@ testthat::test_that("passed shiny module is initialized only when the UI is trig app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(test1 = filtered_data), modules = modules(test_module1), reporter = teal.reporter::Reporter$new() ), @@ -75,7 +75,10 @@ testthat::test_that("nested teal-modules are initialized when the UI is triggere app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list( + tab1 = list(test1 = filtered_data, test2 = filtered_data), + tab2 = list(test3 = filtered_data, test4 = filtered_data) + ), modules = modules( modules(label = "tab1", test_module1, test_module2), modules(label = "tab2", test_module3, test_module4) @@ -92,7 +95,10 @@ testthat::test_that("nested teal-modules are initialized when the UI is triggere app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list( + tab1 = list(test1 = filtered_data, test2 = filtered_data), + tab2 = list(test3 = filtered_data, test4 = filtered_data) + ), modules = modules( modules(label = "tab1", test_module1, test_module2), modules(label = "tab2", test_module3, test_module4) @@ -111,7 +117,10 @@ out <- shiny::testServer( app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list( + tab1 = list(test1 = filtered_data, test2 = filtered_data), + tab2 = list(test3 = filtered_data, test4 = filtered_data) + ), modules = modules( modules(label = "tab1", test_module1, test_module2), modules(label = "tab2", test_module3, test_module4) @@ -156,42 +165,37 @@ out <- shiny::testServer( testthat::test_that("srv_nested_tabs.teal_module does not pass data if not in the args explicitly", { module <- module(server = function(id, ...) { moduleServer(id, function(input, output, session) { - checkmate::assert_false( - tryCatch( - checkmate::test_class(data, "tdata"), - error = function(cond) FALSE - ) - ) + testthat::expect_null(list(...)$data) }) }) - testthat::expect_no_error( - shiny::testServer( - app = srv_nested_tabs, - args = list( - id = "test", - datasets = filtered_data, - modules = modules(module), - reporter = teal.reporter::Reporter$new() - ), - expr = { - session$setInputs() - } - ) + shiny::testServer( + app = srv_nested_tabs, + args = list( + id = "test", + datasets = list(module = filtered_data), + modules = modules(module), + reporter = teal.reporter::Reporter$new() + ), + expr = { + session$setInputs() + } ) }) testthat::test_that("srv_nested_tabs.teal_module does pass data if in the args explicitly", { - module <- module(server = function(id, data, ...) { - moduleServer(id, function(input, output, session) checkmate::assert_class(data, "tdata")) - }) - + module <- module( + server = function(id, data, ...) { + moduleServer(id, function(input, output, session) checkmate::assert_class(data, "tdata")) + }, + filters = NULL + ) testthat::expect_no_error( shiny::testServer( app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(module = filtered_data), modules = modules(module), reporter = teal.reporter::Reporter$new() ), @@ -203,7 +207,7 @@ testthat::test_that("srv_nested_tabs.teal_module does pass data if in the args e }) testthat::test_that("srv_nested_tabs.teal_module passes data to the server module", { - module <- module(server = function(id, data) { + module <- module(filters = NULL, server = function(id, data) { moduleServer(id, function(input, output, session) checkmate::assert_list(data, "reactive")) }) @@ -212,7 +216,7 @@ testthat::test_that("srv_nested_tabs.teal_module passes data to the server modul app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(module = filtered_data), modules = modules(module), reporter = teal.reporter::Reporter$new() ), @@ -232,7 +236,7 @@ testthat::test_that("srv_nested_tabs.teal_module passes datasets to the server m app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(module = filtered_data), modules = modules(module), reporter = teal.reporter::Reporter$new() ), @@ -253,7 +257,7 @@ testthat::test_that("srv_nested_tabs.teal_module passes server_args to the ...", app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(module = filtered_data), modules = modules(module), reporter = teal.reporter::Reporter$new() ), @@ -264,7 +268,7 @@ testthat::test_that("srv_nested_tabs.teal_module passes server_args to the ...", }) testthat::test_that("srv_nested_tabs.teal_module warns if both data and datasets are passed", { - module <- module(label = "test module", server = function(id, datasets, data) { + module <- module(filters = NULL, label = "test module", server = function(id, datasets, data) { moduleServer(id, function(input, output, session) NULL) }) @@ -273,7 +277,7 @@ testthat::test_that("srv_nested_tabs.teal_module warns if both data and datasets app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(`test module` = filtered_data), modules = modules(module), reporter = teal.reporter::Reporter$new() ), @@ -301,7 +305,7 @@ testthat::test_that("srv_nested_tabs.teal_module doesn't pass filter_panel_api i app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(module = filtered_data), modules = modules(module), reporter = teal.reporter::Reporter$new() ), @@ -324,7 +328,7 @@ testthat::test_that("srv_nested_tabs.teal_module passes filter_panel_api when pa app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(module = filtered_data), modules = modules(module), reporter = teal.reporter::Reporter$new() ), @@ -345,7 +349,7 @@ testthat::test_that("srv_nested_tabs.teal_module passes filter_panel_api to the app = srv_nested_tabs, args = list( id = "test", - datasets = filtered_data, + datasets = list(module = filtered_data), modules = modules(module), reporter = teal.reporter::Reporter$new() ), @@ -377,23 +381,23 @@ get_example_filtered_data <- function() { testthat::test_that(".datasets_to_data accepts a reactiveVal as trigger_data input", { datasets <- get_example_filtered_data() - shiny::isolate(datasets$set_filter_state( + datasets$set_filter_state( teal.slice:::filter_settings( teal.slice:::filter_var(dataname = "d1", varname = "val", selected = c(1, 2)) ) - )) - module <- list(filter = "all") + ) + module <- list(filter = c("d1", "d2")) trigger_data <- reactiveVal(1L) testthat::expect_silent(shiny::isolate(.datasets_to_data(module, datasets, trigger_data))) }) testthat::test_that(".datasets_to_data throws error if trigger_data is not a reactiveVal function", { datasets <- get_example_filtered_data() - shiny::isolate(datasets$set_filter_state( + datasets$set_filter_state( teal.slice:::filter_settings( teal.slice:::filter_var(dataname = "d1", varname = "val", selected = c(1, 2)) ) - )) + ) module <- list(filter = "all") trigger_data <- 1 testthat::expect_error( @@ -404,12 +408,12 @@ testthat::test_that(".datasets_to_data throws error if trigger_data is not a rea testthat::test_that(".datasets_to_data returns data which is filtered", { datasets <- get_example_filtered_data() - shiny::isolate(datasets$set_filter_state( + datasets$set_filter_state( teal.slice:::filter_settings( teal.slice:::filter_var(dataname = "d1", varname = "val", selected = c(1, 2)) ) - )) - module <- list(filter = "all") + ) + module <- list(filter = c("d1", "d2")) trigger_data <- reactiveVal(1L) data <- shiny::isolate(.datasets_to_data(module, datasets, trigger_data)) @@ -430,7 +434,7 @@ testthat::test_that(".datasets_to_data returns only data requested by modules$fi testthat::test_that(".datasets_to_data returns tdata object", { datasets <- get_example_filtered_data() - module <- list(filter = "all") + module <- list(filter = c("d1", "d2")) trigger_data <- reactiveVal(1L) data <- .datasets_to_data(module, datasets, trigger_data) @@ -466,25 +470,6 @@ testthat::test_that(".datasets_to_data returns tdata object", { testthat::expect_null(get_metadata(data, "d2")) }) -testthat::test_that(".datasets_to_data returns parent datasets for CDISC data", { - adsl <- data.frame(STUDYID = 1, USUBJID = 1) - adae <- data.frame(STUDYID = 1, USUBJID = 1, ASTDTM = 1, AETERM = 1, AESEQ = 1) - adtte <- data.frame(STUDYID = 1, USUBJID = 1, PARAMCD = 1) - - datasets <- teal.slice::init_filtered_data( - teal.data::cdisc_data( - teal.data::cdisc_dataset("ADSL", adsl), - teal.data::cdisc_dataset("ADAE", adae), - teal.data::cdisc_dataset("ADTTE", adtte) - ) - ) - - module <- list(filter = "ADAE") - trigger_data <- reactiveVal(1L) - data <- .datasets_to_data(module, datasets, trigger_data) - testthat::expect_setequal(shiny::isolate(names(data)), c("ADSL", "ADAE")) -}) - testthat::test_that("calculate_hashes takes a FilteredData and vector of datanames as input", { adsl <- data.frame(STUDYID = 1, USUBJID = 1) adae <- data.frame(STUDYID = 1, USUBJID = 1, ASTDTM = 1, AETERM = 1, AESEQ = 1) diff --git a/tests/testthat/test-module_tabs_with_filters.R b/tests/testthat/test-module_tabs_with_filters.R index 8d10c242ae..d3791992fa 100644 --- a/tests/testthat/test-module_tabs_with_filters.R +++ b/tests/testthat/test-module_tabs_with_filters.R @@ -16,7 +16,46 @@ test_module2 <- module( testthat::test_that("srv_tabs_with_filters throws error if reporter is not of class Reporter", { testthat::expect_error( - srv_tabs_with_filters(id, datasets = filtered_data, modules = modules(test_module1), reporter = list()), + srv_tabs_with_filters( + id, + datasets = list(`iris tab` = filtered_data), + modules = modules(test_module1), + reporter = list() + ), + "Assertion on 'reporter' failed" + ) +}) + +testthat::test_that("active_module() returns module specs from active tab when filter.module_specific = FALSE", { + shiny::testServer( + app = srv_tabs_with_filters, + args = list( + id = "test", + datasets = list(`iris tab` = filtered_data, `mtcars tab` = filtered_data), + modules = modules(test_module1, test_module2), + filter = teal_filters(module_specific = FALSE), + reporter = teal.reporter::Reporter$new() + ), + expr = { + test_module1$server_args <- NULL # because empty server_args are dropped from object in srv_nested_tabs + test_module2$server_args <- NULL + + session$setInputs(`root-active_tab` = "iris_tab") + testthat::expect_identical(active_module(), test_module1) + session$setInputs(`root-active_tab` = "mtcars_tab") + testthat::expect_identical(active_module(), test_module2) + } + ) +}) + +testthat::test_that("srv_tabs_with_filters throws error if reporter is not of class Reporter", { + testthat::expect_error( + srv_tabs_with_filters( + id, + datasets = list(`iris tab` = filtered_data), + modules = modules(test_module1), + reporter = list() + ), "Assertion on 'reporter' failed" ) }) @@ -26,10 +65,9 @@ testthat::test_that("active_datanames() returns dataname from single tab", { app = srv_tabs_with_filters, args = list( id = "test", - datasets = filtered_data, + datasets = list(`iris tab` = filtered_data), modules = modules(test_module1), - filter = list(), - reporter = teal.reporter::Reporter$new() + filter = list() ), expr = { testthat::expect_identical(active_datanames(), "iris") @@ -42,7 +80,7 @@ testthat::test_that("active_datanames() returns dataname from active tab after c app = srv_tabs_with_filters, args = list( id = "test", - datasets = filtered_data, + datasets = list(`iris tab` = filtered_data, `mtcars tab` = filtered_data), modules = modules(test_module1, test_module2), filter = list(), reporter = teal.reporter::Reporter$new() diff --git a/tests/testthat/test-module_teal.R b/tests/testthat/test-module_teal.R index 3d41e2db10..fefeb4c0ca 100644 --- a/tests/testthat/test-module_teal.R +++ b/tests/testthat/test-module_teal.R @@ -37,25 +37,59 @@ testthat::test_that("srv_teal initializes the data when raw_data changes", { expr = { testthat::expect_null(datasets_reactive()) raw_data(data) - testthat::expect_is(datasets_reactive(), "FilteredData") + testthat::expect_named(datasets_reactive(), "iris_tab") } ) }) -testthat::test_that("srv_teal initialized FilteredData based on the raw_data input", { - filtered_data <- teal.slice::init_filtered_data(data) +testthat::test_that("srv_teal initialized data list structure reflects modules", { + shiny::testServer( + app = srv_teal, + args = list( + id = "test", + raw_data = reactiveVal(data), + modules = modules(test_module1, modules(label = "tab", test_module1, test_module2)) + ), + expr = { + raw_data(data) + testthat::expect_named(datasets_reactive(), c("iris_tab", "tab")) + testthat::expect_named(datasets_reactive()$tab, c("iris_tab", "mtcars_tab")) + } + ) +}) +testthat::test_that("srv_teal initialized data containing same FilteredData when the filter is global", { shiny::testServer( app = srv_teal, args = list( id = "test", raw_data = reactiveVal(data), - modules = modules(test_module1) + modules = modules(test_module1, modules(label = "tab", test_module1, test_module2)), + filter = teal_filters(module_specific = FALSE) ), expr = { - testthat::expect_identical(datasets_reactive()$datanames(), filtered_data$datanames()) - testthat::expect_identical(datasets_reactive()$get_data("iris"), filtered_data$get_data(dataname = "iris")) - testthat::expect_identical(datasets_reactive()$get_data("mtcars"), filtered_data$get_data(dataname = "mtcars")) + raw_data(data) + unlisted_fd <- unlist(datasets_reactive(), use.names = FALSE) + testthat::expect_identical(unlisted_fd[[1]], unlisted_fd[[2]]) + testthat::expect_identical(unlisted_fd[[2]], unlisted_fd[[3]]) + } + ) +}) + +testthat::test_that("srv_teal initialized data containing different FilteredData when the filter is module_specific", { + shiny::testServer( + app = srv_teal, + args = list( + id = "test", + raw_data = reactiveVal(data), + modules = modules(test_module1, modules(label = "tab", test_module1, test_module2)), + filter = teal_filters(module_specific = TRUE) + ), + expr = { + raw_data(data) + unlisted_fd <- unlist(datasets_reactive(), use.names = FALSE) + testthat::expect_false(identical(unlisted_fd[[1]], unlisted_fd[[2]])) + testthat::expect_false(identical(unlisted_fd[[2]], unlisted_fd[[3]])) } ) }) diff --git a/tests/testthat/test-module_teal_with_splash.R b/tests/testthat/test-module_teal_with_splash.R index 57ea24b9f9..e77e889b12 100644 --- a/tests/testthat/test-module_teal_with_splash.R +++ b/tests/testthat/test-module_teal_with_splash.R @@ -38,7 +38,7 @@ testthat::test_that("srv_teal_with_splash creates raw_data based on DDL returns testthat::test_that("srv_teal_with_splash creates raw_data based on DDL returns pulled data when loaded", { teal.logger::suppress_logs() - x <- dataset_connector(dataname = "test_dataset", pull_callable = callable_code("iris")) + x <- dataset_connector(dataname = "iris", pull_callable = callable_code("iris")) delayed_data <- teal_data(x) shiny::testServer( app = srv_teal_with_splash, @@ -51,7 +51,7 @@ testthat::test_that("srv_teal_with_splash creates raw_data based on DDL returns testthat::expect_null(raw_data()) session$setInputs(`startapp_module-submit` = TRUE) # DDL has independent session id (without ns) testthat::expect_is(raw_data(), "TealData") - testthat::expect_identical(raw_data()$get_dataset("test_dataset")$get_raw_data(), iris) + testthat::expect_identical(raw_data()$get_dataset("iris")$get_raw_data(), iris) } ) }) diff --git a/tests/testthat/test-modules.R b/tests/testthat/test-modules.R index 1fbb771ef3..bf781295df 100644 --- a/tests/testthat/test-modules.R +++ b/tests/testthat/test-modules.R @@ -23,7 +23,7 @@ testthat::test_that("Calling module() does not throw", { testthat::expect_error(module(), NA) }) -testthat::test_that("module requires label argument to be a string", { +testthat::test_that("module requires label argument to be a string different than 'global_filters'", { testthat::expect_error(module(label = "label"), NA) testthat::expect_error(module(label = NULL), "Assertion on 'label' failed.+'NULL'") @@ -31,6 +31,8 @@ testthat::test_that("module requires label argument to be a string", { testthat::expect_error(module(label = c("label", "label")), "Assertion on 'label' failed: Must have length 1.") testthat::expect_error(module(label = 1L), "Assertion on 'label' failed.+not 'integer'") + + testthat::expect_error(module(label = "global_filters"), "is reserved in teal") }) testthat::test_that("module expects server being a shiny server module with any argument", { @@ -248,7 +250,7 @@ testthat::test_that("modules returns useful error message if label argument not ui = ui_fun1, filters = "" ) - expect_error(modules("module", test_module), "The only character argument to modules\\(\\) must be 'label'") + testthat::expect_error(modules("module", test_module), "The only character argument to modules\\(\\) must be 'label'") }) @@ -510,3 +512,67 @@ testthat::test_that("append_module produces teal_modules with unique named child mod_names <- names(appended_mods$children) testthat::expect_equal(mod_names, unique(mod_names)) }) + +testthat::test_that("teal_filters fails when inexisting teal_slice id is specified in mapping", { + testthat::expect_error( + teal_filters( + teal.slice::filter_var(dataname = "data", varname = "var", id = "test"), + mapping = list( + module = "inexisting" + ) + ) + ) +}) + +testthat::test_that("teal_filters returns modules_filter_settings", { + testthat::expect_s3_class( + teal_filters( + teal.slice::filter_var(dataname = "data", varname = "var", id = "test") + ), + "modules_filter_settings" + ) +}) + +testthat::test_that("teal_filters mapping should be an empty list or a named list", { + testthat::expect_no_error( + teal_filters( + teal.slice::filter_var(dataname = "data", varname = "var", id = "test"), + mapping = list() + ) + ) + testthat::expect_no_error( + teal_filters( + teal.slice::filter_var(dataname = "data", varname = "var", id = "test"), + mapping = list(module = c()) + ) + ) + testthat::expect_error( + teal_filters( + teal.slice::filter_var(dataname = "data", varname = "var", id = "test"), + mapping = list(1, 2, 3) + ) + ) +}) + +testthat::test_that("teal_filters fails when inexisting teal_slice id is specified in mapping", { + testthat::expect_error( + teal_filters( + teal.slice::filter_var(dataname = "data", varname = "var", id = "test"), + mapping = list( + module = "inexisting" + ) + ), + "inexisting not in test" + ) +}) + +testthat::test_that("teal_filters fails when mapping is specified with module_specific = FALSE", { + testthat::expect_error( + teal_filters( + teal.slice::filter_var(dataname = "data", varname = "var", id = "test"), + mapping = list(module = "test"), + module_specific = FALSE + ), + "`mapping` is specified .+ even though `module_specific` isn't TRUE" + ) +}) diff --git a/tests/testthat/test-validate_inputs.R b/tests/testthat/test-validate_inputs.R index b9ed3e66aa..bb23cc55fe 100644 --- a/tests/testthat/test-validate_inputs.R +++ b/tests/testthat/test-validate_inputs.R @@ -1,9 +1,12 @@ - testthat::test_that("invalid arguments raise errors", { - testthat::expect_error(validate_inputs("string"), - "validate_inputs accepts validators or a list thereof") - testthat::expect_error(validate_inputs(list("name" = "string")), - "validate_inputs accepts validators or a list thereof") + testthat::expect_error( + validate_inputs("string"), + "validate_inputs accepts validators or a list thereof" + ) + testthat::expect_error( + validate_inputs(list("name" = "string")), + "validate_inputs accepts validators or a list thereof" + ) }) diff --git a/vignettes/creating-custom-modules.Rmd b/vignettes/creating-custom-modules.Rmd index 32f640b26b..8c0cc06461 100644 --- a/vignettes/creating-custom-modules.Rmd +++ b/vignettes/creating-custom-modules.Rmd @@ -182,7 +182,6 @@ An example `teal` application using this module is shown below: ```{r} - library(teal) app <- init(