diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index 8f239ffd2..5ced5df01 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -36,6 +36,7 @@ jobs: with: additional-env-vars: | _R_CHECK_CRAN_INCOMING_REMOTE_=false + _R_CHECK_EXAMPLE_TIMING_THRESHOLD_=10 additional-r-cmd-check-params: --as-cran enforce-note-blocklist: true note-blocklist: | diff --git a/.gitignore b/.gitignore index eedcebdf4..991dc5e92 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.Rcheck +.Rprofile *.html *.rprof *.sas.txt diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 5d10743ea..7a05b991a 100755 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -26,7 +26,6 @@ repos: - methods - bioc::MultiAssayExperiment - R6 - - rlang - rtables - shinyjs - shinyWidgets diff --git a/DESCRIPTION b/DESCRIPTION index d698ab98b..1bf71a514 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,15 +2,20 @@ Type: Package Package: teal.slice Title: Filter Module for `teal` Applications Version: 0.3.0.9005 -Date: 2023-06-29 +Date: 2023-07-14 Authors@R: c( - person("Dawid", "Kaledkowski", , "dawid.kaledkowski@roche.com", role = c("aut", "cre")), - person("Pawel", "Rucki", , "pawel.rucki@roche.com", role = "aut"), - person("Nikolas", "Burkoff", , "nikolas.burkoff@roche.com", role = "aut"), - person("Mahmoud", "Hallal", , "mahmoud.hallal@roche.com", role = "aut"), - person("Maciej", "Nasinski", , "maciej.nasinski@contractors.roche.com", role = "aut"), - person("Konrad", "Pagacz", , "konrad.pagacz@contractors.roche.com", role = "aut"), - person("Junlue", "Zhao", , "zhaoj88@gene.com", role = "aut"), + person("Dawid", "Kaledkowski", email = "dawid.kaledkowski@roche.com", role = c("aut", "cre")), + person("Pawel", "Rucki", email = "pawel.rucki@roche.com", role = "aut"), + person("Aleksander", "Chlebowski", email = "aleksander.chlebowski@contractors.roche.com", role = "aut"), + person("Kartikeya", "Kirar", email = "kartikeya.kirar@businesspartner.roche.com", role = "aut"), + person("Marcin", "Kosinski", email = "marcin.kosinski.mk1@roche.com", role = "aut"), + person("Chendi", "Liao", email = "chendi.liao@roche.com", role = "rev"), + person("Dony", "Unardi", email = "unardid@gene.com", role = "rev"), + person("Mahmoud", "Hallal", role = "aut"), + person("Nikolas", "Burkoff", role = "aut"), + person("Maciej", "Nasinski", role = "aut"), + person("Konrad", "Pagacz", role = "aut"), + person("Junlue", "Zhao", role = "aut"), person("F. Hoffmann-La Roche AG", role = c("cph", "fnd")) ) Description: Filter module for teal applications. @@ -19,22 +24,24 @@ Depends: R (>= 4.0), shiny Imports: + bslib (>= 0.4.0), checkmate, dplyr, - ggplot2, grDevices, + jsonlite, + htmltools, lifecycle, logger (>= 0.2.0), methods, + plotly, R6, + shinycssloaders, shinyjs, - shinyWidgets (>= 0.5.0), - stats, + shinyWidgets (>= 0.6.2), teal.data (>= 0.1.2.9011), teal.logger (>= 0.1.1), teal.widgets (>= 0.2.0) Suggests: - bslib, formatters (>= 0.3.1), knitr, MultiAssayExperiment, diff --git a/NAMESPACE b/NAMESPACE index e99063929..eeb10ae0b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,11 @@ # Generated by roxygen2: do not edit by hand -S3method(get_supported_filter_varnames,FilteredDataset) -S3method(get_supported_filter_varnames,MAEFilteredDataset) +S3method("[",teal_slices) +S3method(as.list,teal_slice) +S3method(c,teal_slices) +S3method(format,teal_slice) +S3method(format,teal_slices) +S3method(get_supported_filter_varnames,MultiAssayExperiment) S3method(get_supported_filter_varnames,default) S3method(get_supported_filter_varnames,matrix) S3method(init_filter_state,Date) @@ -20,33 +24,30 @@ S3method(init_filtered_data,TealData) S3method(init_filtered_data,default) S3method(init_filtered_dataset,MultiAssayExperiment) S3method(init_filtered_dataset,data.frame) -S3method(resolve_state,default) -S3method(resolve_state,default_filter) -S3method(resolve_state,list) +S3method(print,teal_slice) +S3method(print,teal_slices) S3method(variable_types,DFrame) S3method(variable_types,DataTable) S3method(variable_types,data.frame) S3method(variable_types,default) S3method(variable_types,matrix) export(FilterPanelAPI) +export(as.teal_slice) +export(as.teal_slices) export(clear_filter_states) export(get_filter_expr) export(get_filter_state) export(init_filter_states) export(init_filtered_data) export(init_filtered_dataset) +export(is.teal_slice) +export(is.teal_slices) export(remove_filter_state) export(set_filter_state) +export(slices_restore) +export(slices_store) +export(teal_slice) +export(teal_slices) import(R6) import(shiny) -importFrom(dplyr,filter) -importFrom(ggplot2,ggplot) -importFrom(grDevices,rgb) -importFrom(lifecycle,badge) -importFrom(logger,log_trace) importFrom(methods,is) -importFrom(shinyWidgets,pickerOptions) -importFrom(shinyjs,hide) -importFrom(stats,setNames) -importFrom(teal.data,dataset) -importFrom(teal.widgets,optionalSelectInput) diff --git a/NEWS.md b/NEWS.md index d7c32a6de..c921b1429 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,23 @@ # teal.slice 0.3.0.9005 -* Remove `scda` from dependencies. +### New features + +* API is based now on `teal_slices` and `teal_slice` objects. +* Implemented reactive counts of single filter card to compare filtered and unfiltered variable distributions. See `count_type` in `teal_slices`. +* Possible now to specify filter based on arbitrary logical expression. See `expr` argument in `teal_slice`. +* Possible now to limit choices in single filter card. See `choices` argument in `teal_slice`. +* Possible now to initialize filter panel without "Add filter variables" panel through `module_add` in `teal_slices`. +* Possible now to set filter which can't be removed by app user. See `anchored` argument in `teal_slice`. +* Possible now to set filter which selection remains the same. See `fixed` argument in `teal_slice`. +* Possible now to limit variable by single level only. See `multuple` argument in `teal_slice` +* Changed appearance of filter cards to collapsible accordion. +* Replaced `sliderInput` with interactive `plotly` to be able to zoom variable distribution. + +### Breaking changes + +* Setting filters using a list is now deprecated. Use `teal_slices` and `teal_slice` instead. +* Removed `CDISCFilteredData` and `CDISCFilteredDataset` and implementing `JoinKeys` handling in their parent classes (`FilteredData` and `DefaultFilteredDataset`). +* Specifying set of filterable columns is done through `include_varnames` and `exclude_varnames`. Specifying `attr(, "filterable")` is hard deprecated. # teal.slice 0.3.0 @@ -13,6 +30,7 @@ * Added a global turn on/off button for the Filter Panel. * Added ability to collapse Active Filter Display panel. * Added ability to collapse all filters of an individual dataset. +* Added fixed filter states. ### Enhancements @@ -22,12 +40,14 @@ * Fixed an error where the `RangeFilterState` produced an error when using `bootstrap 4`. * Fixed a bug that caused the range slider to omit values selected programmatically through the filter API. +* Fixed a bug where setting incorrect values for Date and Date time ranges caused the app to crash. ### Miscellaneous * Calculation of step in slider for `RangeFilterState` now uses `checkmate::test_integerish` instead of `is.integer`. * Updated `init_filtered_data` to take into account the removal of `CDISCTealData` from `teal.data` package. -* Added examples apps for `ChoicesFilterState` and `DFFilterStates`. +* Added `shinyvalidate` validation for Date and Date time ranges. +* Added examples apps for `FilterState` child classes and `DFFilterStates`. # teal.slice 0.2.0 @@ -47,10 +67,10 @@ ### Enhancements * Redesigned the count bars for filter panel check box inputs. -* Redesigned the filter panel input for dates to use CSS flexbox. +* Redesigned the filter panel input for dates to use `CSS flexbox`. * Update icons to be compatible with Font Awesome 6. * Updates the `FilteredData` method `get_formatted_filter_state` so it no longer appends empty filters. -* Added clearer installation instructions to README. +* Added clearer installation instructions to `README`. ### Breaking changes diff --git a/R/FilterPanelAPI.R b/R/FilterPanelAPI.R index 3391b754b..0dc974a29 100644 --- a/R/FilterPanelAPI.R +++ b/R/FilterPanelAPI.R @@ -21,10 +21,10 @@ #' isolate(fpa$get_filter_state()) #' #' # set a filter state -#' isolate( -#' set_filter_state( -#' fpa, -#' list(iris = list(Species = list(selected = "setosa", keep_na = TRUE))) +#' set_filter_state( +#' fpa, +#' teal_slices( +#' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE) #' ) #' ) #' @@ -32,7 +32,7 @@ #' isolate(fpa$get_filter_state()) #' #' # remove all_filter_states -#' fpa$remove_all_filter_states() +#' fpa$clear_filter_states() #' #' # get the actual filter state --> empty named list #' isolate(fpa$get_filter_state()) @@ -44,6 +44,7 @@ FilterPanelAPI <- R6::R6Class( # nolint #' @description #' Initialize a `FilterPanelAPI` object #' @param datasets (`FilteredData`) object. + #' initialize = function(datasets) { checkmate::assert_class(datasets, "FilteredData") private$filtered_data <- datasets @@ -56,78 +57,52 @@ FilterPanelAPI <- R6::R6Class( # nolint #' The output list is a compatible input to `set_filter_state`. #' #' @return `list` with named elements corresponding to `FilteredDataset` objects with active filters. + #' get_filter_state = function() { private$filtered_data$get_filter_state() }, #' @description #' Sets active filter states. - #' @param filter (`named list`)\cr - #' nested list of filter selections applied to datasets. + #' @param filter (`teal_slices`) + #' + #' @return `NULL` invisibly #' - #' @return `NULL` set_filter_state = function(filter) { - if (private$filtered_data$get_filter_panel_active()) { - private$filtered_data$set_filter_state(filter) - } else { - warning(private$deactivated_msg) - } + private$filtered_data$set_filter_state(filter) invisible(NULL) }, #' @description #' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object. - #' @param filter (`named list`)\cr - #' nested list of filter selections applied to datasets. #' - #' @return `NULL` + #' @param filter (`teal_slices`)\cr + #' specifying `FilterState` objects to remove; + #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored + #' + #' @return `NULL` invisibly + #' remove_filter_state = function(filter) { - if (private$filtered_data$get_filter_panel_active()) { - private$filtered_data$remove_filter_state(filter) - } else { - warning(private$deactivated_msg) - } + private$filtered_data$remove_filter_state(filter) invisible(NULL) }, #' @description Remove all `FilterStates` of the `FilteredData` object. #' #' @param datanames (`character`)\cr - #' datanames to remove their `FilterStates`; + #' `datanames` to remove their `FilterStates`; #' omit to remove all `FilterStates` in the `FilteredData` object #' - #' @return `NULL` - #' - remove_all_filter_states = function(datanames) { - if (private$filtered_data$get_filter_panel_active()) { - datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames - private$filtered_data$remove_all_filter_states(datanames = datanames_to_remove) - } else { - warning(private$deactivated_msg) - } - invisible(NULL) - }, - #' @description - #' Toggle the state of the global Filter Panel button by running `javascript` code - #' to click the toggle button with the `filter_panel_active` id suffix. - #' The button id is prefixed with the Filter Panel shiny namespace. - #' This button is observed in `srv_filter_panel` method that executes - #' `filter_panel_enable()` or `filter_panel_disable()` method depending on the toggle state. + #' @return `NULL` invisibly #' - #' @return `NULL` - filter_panel_toggle = function() { - shinyjs::runjs( - sprintf( - '$("#%s-filter_turn_onoff").click();', - private$filtered_data$get_filter_panel_ui_id() - ) - ) + clear_filter_states = function(datanames) { + datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames + private$filtered_data$clear_filter_states(datanames = datanames_to_remove) invisible(NULL) } ), ## __Private Methods ==== private = list( - filtered_data = NULL, - deactivated_msg = "Filter Panel is deactivated so the action can not be applied with api." + filtered_data = NULL ) ) diff --git a/R/FilterState-utils.R b/R/FilterState-utils.R index 1b1ec8812..072ee57f2 100644 --- a/R/FilterState-utils.R +++ b/R/FilterState-utils.R @@ -3,42 +3,39 @@ #' Initializes `FilterState` depending on a variable class.\cr #' @param x (`vector`)\cr #' values of the variable used in filter -#' -#' @param varname (`character(1)`)\cr -#' name of the variable. -#' -#' @param varlabel (`character(0)`, `character(1)` or `NULL`)\cr -#' label of the variable (optional). -#' -#' @param dataname (`character(1)`)\cr -#' optional name of dataset where `x` is taken from. Must be specified -#' if `extract_type` argument is not empty. -#' +#' @param x_reactive (`reactive`)\cr +#' returning vector of the same type as `x`. Is used to update +#' counts following the change in values of the filtered dataset. +#' If it is set to `reactive(NULL)` then counts based on filtered +#' dataset are not shown. +#' @param slice (`teal_slice`)\cr +#' object created using [teal_slice()]. #' @param extract_type (`character(0)`, `character(1)`)\cr -#' whether condition calls should be prefixed by dataname. Possible values: +#' specifying whether condition calls should be prefixed by `dataname`. Possible values: #' \itemize{ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed} #' \item{`"list"`}{ `varname` in the condition call will be returned as `$`} #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `[, ]`} #' } +#' @param ... additional arguments to be saved as a list in `private$extras` field +#' #' @keywords internal #' #' @examples -#' filter_state <- teal.slice:::RangeFilterState$new( -#' c(1:10, NA, Inf), -#' varname = "x", -#' varlabel = "Pretty name", -#' dataname = "dataname", +#' filter_state <- teal.slice:::init_filter_state( +#' x = c(1:10, NA, Inf), +#' x_reactive = reactive(c(1:10, NA, Inf)), +#' slice = teal_slice( +#' varname = "x", +#' dataname = "dataname" +#' ), #' extract_type = "matrix" #' ) #' -#' filter_state$get_varname() -#' filter_state$get_varlabel() -#' isolate(filter_state$get_call()) -#' \dontrun{ -#' shinyApp( +#' shiny::isolate(filter_state$get_call()) +#' app <- shinyApp( #' ui = fluidPage( -#' isolate(filter_state$ui(id = "app")), +#' filter_state$ui(id = "app"), #' verbatimTextOutput("call") #' ), #' server = function(input, output, session) { @@ -49,70 +46,59 @@ #' ) #' } #' ) +#' if (interactive()) { +#' runApp(app) #' } #' @return `FilterState` object init_filter_state <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - checkmate::assert_string(varname) - checkmate::assert_character(varlabel, max.len = 1L, any.missing = FALSE, null.ok = TRUE) - checkmate::assert_string(dataname, null.ok = TRUE) - checkmate::assert_character(extract_type, max.len = 1L, any.missing = FALSE) + checkmate::assert_class(x_reactive, "reactive") + checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE) + checkmate::assert_class(slice, "teal_slice") if (length(extract_type) == 1) { checkmate::assert_choice(extract_type, choices = c("list", "matrix")) } - if (length(extract_type) == 1 && is.null(dataname)) { - stop("if extract_type is specified, dataname must also be specified") - } - - if (is.null(varlabel)) varlabel <- character(0L) if (all(is.na(x))) { - return( - EmptyFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + EmptyFilterState$new( + x = x, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type ) + } else { + UseMethod("init_filter_state") } - UseMethod("init_filter_state") } #' @keywords internal #' @export init_filter_state.default <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - if (is.null(varlabel)) varlabel <- character(0) - FilterState$new( + args <- list( x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type + x_reactive = x_reactive, + extract_type = extract_type, + slice ) + + do.call(FilterState$new, args) } #' @keywords internal #' @export init_filter_state.logical <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - if (is.null(varlabel)) varlabel <- character(0) LogicalFilterState$new( x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, + x_reactive = x_reactive, + slice = slice, extract_type = extract_type ) } @@ -120,43 +106,33 @@ init_filter_state.logical <- function(x, #' @keywords internal #' @export init_filter_state.numeric <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - if (is.null(varlabel)) varlabel <- character(0) + args <- list( + x = x, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type + ) + if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) { - ChoicesFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + do.call(ChoicesFilterState$new, args) } else { - RangeFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + do.call(RangeFilterState$new, args) } } #' @keywords internal #' @export init_filter_state.factor <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - if (is.null(varlabel)) varlabel <- character(0) ChoicesFilterState$new( x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, + x_reactive = x_reactive, + slice = slice, extract_type = extract_type ) } @@ -164,16 +140,13 @@ init_filter_state.factor <- function(x, #' @keywords internal #' @export init_filter_state.character <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - if (is.null(varlabel)) varlabel <- character(0) ChoicesFilterState$new( x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, + x_reactive = x_reactive, + slice = slice, extract_type = extract_type ) } @@ -181,84 +154,80 @@ init_filter_state.character <- function(x, #' @keywords internal #' @export init_filter_state.Date <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - if (is.null(varlabel)) varlabel <- character(0) + args <- list( + x = x, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type + ) + if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) { - ChoicesFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + do.call(ChoicesFilterState$new, args) } else { - DateFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + do.call(DateFilterState$new, args) } } #' @keywords internal #' @export init_filter_state.POSIXct <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - if (is.null(varlabel)) varlabel <- character(0) + args <- list( + x = x, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type + ) + if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) { - ChoicesFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + do.call(ChoicesFilterState$new, args) } else { - DatetimeFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + do.call(DatetimeFilterState$new, args) } } #' @keywords internal #' @export init_filter_state.POSIXlt <- function(x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - if (is.null(varlabel)) varlabel <- character(0) + args <- list( + x = x, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type + ) + if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) { - ChoicesFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + do.call(ChoicesFilterState$new, args) } else { - DatetimeFilterState$new( - x = x, - varname = varname, - varlabel = varlabel, - dataname = dataname, - extract_type = extract_type - ) + do.call(DatetimeFilterState$new, args) } } + +#' Initialize a `FilterStateExpr` object +#' +#' Initialize a `FilterStateExpr` object +#' @param slice (`teal_slice_expr`)\cr +#' object created using [teal_slice()]. `teal_slice` is stored +#' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state` +#' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice` +#' is a `reactiveValues` which means that changes in particular object are automatically +#' reflected in all places which refer to the same `teal_slice`. +#' +#' @return `FilterStateExpr` object +#' @keywords internal +init_filter_state_expr <- function(slice) { + FilterStateExpr$new(slice) +} + #' Check that a given range is valid #' #' @param subinterval (`numeric` or `date`)\cr vector of length 2 to be compared against the full range. @@ -269,13 +238,13 @@ init_filter_state.POSIXlt <- function(x, #' @keywords internal #' #' @examples -#' \dontrun{ -#' check_in_range(c(3, 1), c(1, 3)) -#' check_in_range(c(0, 3), c(1, 3)) -#' check_in_range( -#' c(as.Date("2020-01-01"), as.Date("2020-01-20")), -#' c(as.Date("2020-01-01"), as.Date("2020-01-02")) -#' ) +#' if (interactive()) { +#' teal.slice:::check_in_range(c(3, 1), c(1, 3)) +#' teal.slice:::check_in_range(c(0, 3), c(1, 3)) +#' teal.slice:::check_in_range( +#' c(as.Date("2020-01-01"), as.Date("2020-01-20")), +#' c(as.Date("2020-01-01"), as.Date("2020-01-02")) +#' ) #' } check_in_range <- function(subinterval, range, pre_msg = "") { epsilon <- .Machine$double.eps^0.5 # needed for floating point arithmetic; same value as in base::all.equal() @@ -311,22 +280,22 @@ check_in_range <- function(subinterval, range, pre_msg = "") { #' #' Raises an error message if not and says which elements are not in the allowed `choices`. #' -#' @param subset `collection-like` should be a subset of the second argument `choices` -#' @param choices `collection-like` superset +#' @param subset,choices atomic vectors #' @param pre_msg `character` message to print before error should there be any errors #' @keywords internal #' #' @examples -#' \dontrun{ -#' check_in_subset <- check_in_subset -#' check_in_subset(c("a", "b"), c("a", "b", "c")) -#' \dontrun{ -#' check_in_subset(c("a", "b"), c("b", "c"), pre_msg = "Error: ") -#' # truncated because too long -#' check_in_subset("a", LETTERS, pre_msg = "Error: ") +#' \donttest{ +#' teal.slice:::check_in_subset(c("a", "b"), c("a", "b", "c")) +#' if (interactive()) { +#' teal.slice:::check_in_subset(c("a", "b"), c("b", "c"), pre_msg = "Error: ") +#' # truncated because too long +#' teal.slice:::check_in_subset("a", LETTERS, pre_msg = "Error: ") #' } #' } check_in_subset <- function(subset, choices, pre_msg = "") { + checkmate::assert_atomic(subset) + checkmate::assert_atomic(choices) checkmate::assert_string(pre_msg) subset <- unique(subset) @@ -343,45 +312,63 @@ check_in_subset <- function(subset, choices, pre_msg = "") { return(invisible(NULL)) } -#' Find containing limits for interval. -#' -#' Given an interval and a numeric vector, -#' find the smallest interval within the numeric vector that contains the interval. -#' -#' This is a helper function for `RangeFilterState` that modifies slider selection -#' so that the _subsetting call_ includes the value specified by the filter API call. + +#' Get hex code of the current Bootstrap theme color. #' -#' Regardless of the underlying numeric data, the slider always presents 100 steps. -#' The ticks on the slider do not represent actual observations but rather borders between virtual bins. -#' Since the value selected on the slider is passed to `private$selected` and that in turn -#' updates the slider selection, programmatic selection of arbitrary values may inadvertently shift -#' the selection to the closest tick, thereby dropping the actual value set (if it exists in the data). +#' Determines the color specification for the currently active Bootstrap color theme and returns one queried color. #' -#' This function purposely shifts the selection to the closest ticks whose values form an interval -#' that will contain the interval defined by the filter API call. +#' @param color `character(1)` naming one of the available theme colors +#' @param alpha either a `numeric(1)` or `character(1)` specifying transparency +#' in the range of `0-1` or a hexadecimal value `00-ff`, respectively; +#' set to NULL to omit adding the alpha channel #' -#' @param x `numeric(2)` interval to contain -#' @param range `numeric(>=2)` vector of values to contain `x` in +#' @return Named `character(1)` containing a hexadecimal color representation. #' -#' @return Numeric vector of length 2 that lies within `range`. +#' @examples +#' teal.slice:::fetch_bs_color("primary") +#' teal.slice:::fetch_bs_color("danger", 0.35) +#' teal.slice:::fetch_bs_color("danger", "80") #' #' @keywords internal #' -#' @examples -#' \dontrun{ -#' ticks <- 1:10 -#' values1 <- c(3, 5) -#' contain_interval(values1, ticks) -#' values2 <- c(3.1, 5.7) -#' contain_interval(values2, ticks) -#' values3 <- c(0, 20) -#' contain_interval(values3, ticks) -#'} -contain_interval <- function(x, range) { - checkmate::assert_numeric(x, len = 2L, any.missing = FALSE, sorted = TRUE) - checkmate::assert_numeric(range, min.len = 2L, any.missing = FALSE, sorted = TRUE) +fetch_bs_color <- function(color, alpha = NULL) { + checkmate::assert_string(color) + checkmate::assert( + checkmate::check_number(alpha, lower = 0, upper = 1, null.ok = TRUE), + checkmate::check_string(alpha, pattern = "[0-9a-f]{2}", null.ok = TRUE) + ) + + # locate file that describes the current theme + ## TODO this is not ideal + sass_file <- bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]] + sass_file <- attr(sass_file, "sass_file_path") + + # load scss file that encodes variables + variables_file <- readLines(sass_file) + # locate theme color variables + ind <- grep("// scss-docs-(start|end) theme-color-variables", variables_file) + color_definitions <- variables_file[(ind[1] + 1L):(ind[2] - 1L)] + + # extract colors names + color_names <- sub("(\\$)(\\w.+)(:.+)", "\\2", color_definitions) + + # verify that an available color was requested + checkmate::assert_choice(color, color_names) + + # extract color references + color_references <- sub("(\\$)(\\w.+)(:\\s.+\\$)(\\w.+)(\\s.+)", "\\4", color_definitions) + + # translate references to color codes + color_specification <- structure(color_references, names = color_names) + color_specification <- vapply(color_specification, function(x) { + line <- grep(sprintf("^\\$%s:\\s+#\\w{6}\\s+!default", x), variables_file, value = TRUE) + code <- sub("(.+)(#\\w{6})(\\s+.+)", "\\2", line) + code + }, character(1L)) + + if (!is.null(alpha)) { + if (is.numeric(alpha)) alpha <- as.hexmode(ceiling(255 * alpha)) + } - x[1] <- Find(function(i) i <= x[1], range, nomatch = min(range), right = TRUE) - x[2] <- Find(function(i) i >= x[2], range, nomatch = max(range)) - x + paste0(color_specification[color], alpha) } diff --git a/R/FilterState.R b/R/FilterState.R index e142a7e1b..78a885eb8 100644 --- a/R/FilterState.R +++ b/R/FilterState.R @@ -2,9 +2,9 @@ #' @docType class #' #' -#' @title FilterState Abstract Class +#' @title `FilterState` Abstract Class #' -#' @description Abstract class to encapsulate filter states +#' @description Abstract class to encapsulate single filter state #' #' @details #' This class is responsible for managing single filter item within @@ -26,18 +26,17 @@ #' variable type specific fields (`keep_inf`, `inf_count`, `timezone`). #' Object contains also shiny module (`ui` and `server`) which manages #' state of the filter through reactive values `selected`, `keep_na`, `keep_inf` -#' which trigger `get_call()` and every R function call up in reactive -#' chain. +#' which trigger `get_call()` and every R function call up in reactive chain. #' \cr #' \cr #' @section Modifying state: #' Modifying a `FilterState` object is possible in three scenarios: -#' * In the interactive session by directly specifying values of `selected`, -#' `keep_na` or `keep_inf` using `set_state` method (to update all at once), -#' or using `set_selected`, `set_keep_na` or `set_keep_inf` -#' * In a running application by changing appropriate inputs -#' * In a running application by using [filter_state_api] which directly uses `set_state` method -#' of the `FilterState` object. +#' * In the interactive session by passing an appropriate `teal_slice` +#' to the `set_state` method, or using +#' `set_selected`, `set_keep_na` or `set_keep_inf` methods. +#' * In a running application by changing appropriate inputs. +#' * In a running application by using [filter_state_api] which directly uses +#' `set_state` method of the `InteractiveFilterState` object. #' #' @keywords internal FilterState <- R6::R6Class( # nolint @@ -45,414 +44,496 @@ FilterState <- R6::R6Class( # nolint # public methods ---- public = list( + #' @description #' Initialize a `FilterState` object #' @param x (`vector`)\cr #' values of the variable used in filter - #' @param varname (`character`)\cr - #' name of the variable - #' @param varlabel (`character(1)`)\cr - #' label of the variable (optional). - #' @param dataname (`character(1)`)\cr - #' name of dataset where `x` is taken from. Must be specified if `extract_type` argument - #' is not empty. + #' @param x_reactive (`reactive`)\cr + #' returning vector of the same type as `x`. Is used to update + #' counts following the change in values of the filtered dataset. + #' If it is set to `reactive(NULL)` then counts based on filtered + #' dataset are not shown. + #' @param slice (`teal_slice`)\cr + #' object created by [teal_slice()] #' @param extract_type (`character(0)`, `character(1)`)\cr - #' whether condition calls should be prefixed by dataname. Possible values: + #' specifying whether condition calls should be prefixed by `dataname`. Possible values: #' \itemize{ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed} #' \item{`"list"`}{ `varname` in the condition call will be returned as `$`} #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `[, ]`} #' } + #' @param ... additional arguments to be saved as a list in `private$extras` field #' #' @return self invisibly #' initialize = function(x, - varname, - varlabel = character(0), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - checkmate::assert_string(varname) - checkmate::assert_character(varlabel, max.len = 1, any.missing = FALSE) - checkmate::assert_string(dataname, null.ok = TRUE) + checkmate::assert_class(x_reactive, "reactive") + checkmate::assert_class(slice, "teal_slice") checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE) if (length(extract_type) == 1) { checkmate::assert_choice(extract_type, choices = c("list", "matrix")) } - if (length(extract_type) == 1 && is.null(dataname)) { - stop("if extract_type is specified, dataname must also be specified") - } - private$dataname <- dataname - private$varname <- varname - private$varlabel <- if (identical(varlabel, as.character(varname))) { - # to not display duplicated label - character(0) - } else { - varlabel - } - private$extract_type <- extract_type - private$selected <- reactiveVal(NULL) + # Set data properties. + private$x <- x + private$x_reactive <- x_reactive + # Set derived data properties. private$na_count <- sum(is.na(x)) - private$keep_na <- reactiveVal(FALSE) - logger::log_trace( - sprintf( - "Instantiated %s with variable %s, dataname: %s", - class(self)[1], - private$varname, - private$dataname - ) + private$filtered_na_count <- reactive( + if (!is.null(private$x_reactive())) { + sum(is.na(private$x_reactive())) + } ) - invisible(self) - }, + # Set extract type. + private$extract_type <- extract_type - #' @description - #' Destroy observers stored in `private$observers`. - #' - #' @return NULL invisibly - #' - destroy_observers = function() { - lapply(private$observers, function(x) x$destroy()) - return(invisible(NULL)) + # Set state properties. + if (is.null(shiny::isolate(slice$keep_na)) && anyNA(x)) slice$keep_na <- TRUE + private$teal_slice <- slice + # Obtain variable label. + varlabel <- attr(x, "label") + # Display only when different from varname. + private$varlabel <- + if (is.null(varlabel) || identical(varlabel, private$get_varname())) { + character(0) + } else { + varlabel + } + + logger::log_trace("Instantiated FilterState object id: { private$get_id() }") + + invisible(self) }, #' @description - #' Returns a formatted string representing this `FilterState`. + #' Returns a formatted string representing this `FilterState` object. #' - #' @param indent (`numeric(1)`) - #' number of spaces before after each new line character of the formatted string; - #' defaults to 0 - #' @param wrap_width (`numeric(1)`) - #' number of characters to wrap lines at in the printed output; - #' allowed range is 30 to 120; defaults to 76 + #' @param show_all `logical(1)` passed to `format.teal_slice` + #' @param trim_lines `logical(1)` passed to `format.teal_slice` #' #' @return `character(1)` the formatted string #' - format = function(indent = 0L, wrap_width = 76L) { - checkmate::assert_number(indent, finite = TRUE, lower = 0L) - checkmate::assert_number(wrap_width, finite = TRUE, lower = 30L, upper = 120L) - - # List all selected values separated by commas. - values <- paste(format(self$get_selected(), nsmall = 3L, justify = "none"), collapse = ", ") - paste(c( - strwrap( - sprintf("Filtering on: %s", private$varname), - width = wrap_width, - indent = indent - ), - # Add wrapping and progressive indent to values enumeration as it is likely to be long. - strwrap( - sprintf("Selected values: %s", values), - width = wrap_width, - indent = indent + 2L, - exdent = indent + 4L - ), - strwrap( - sprintf("Include missing values: %s", self$get_keep_na()), - width = wrap_width, - indent = indent + 2L - ) - ), collapse = "\n") + format = function(show_all = FALSE, trim_lines = TRUE) { + sprintf( + "%s:\n%s", + class(self)[1], + format(self$get_state(), show_all = show_all, trim_lines = trim_lines) + ) }, #' @description - #' Returns reproducible condition call for current selection relevant - #' for selected variable type. - #' Method is using internal reactive values which makes it reactive - #' and must be executed in reactive or isolated context. + #' Prints this `FilterState` object. #' - get_call = function() { - NULL + #' @param ... additional arguments + #' + print = function(...) { + cat(shiny::isolate(self$format(...))) }, #' @description - #' Returns dataname or "NULL" if dataname is NULL. + #' Sets filtering state. + #' - `fixed` state is prevented from changing state + #' - `locked` state is prevented from removing state #' - #' @return `character(1)` + #' @param state a `teal_slice` object #' - get_dataname = function() { - if (!is.null(private$dataname)) { - private$dataname + #' @return `self` invisibly + #' + set_state = function(state) { + checkmate::assert_class(state, "teal_slice") + if (private$is_fixed()) { + logger::log_warn("attempt to set state on fixed filter aborted id: { private$get_id() }") } else { - character(1) + logger::log_trace("{ class(self)[1] }$set_state setting state of filter id: { private$get_id() }") + shiny::isolate({ + if (!is.null(state$selected)) { + private$set_selected(state$selected) + } + if (!is.null(state$keep_na)) { + private$set_keep_na(state$keep_na) + } + if (!is.null(state$keep_inf)) { + private$set_keep_inf(state$keep_inf) + } + current_state <- sprintf( + "selected: %s; keep_na: %s; keep_inf: %s", + toString(private$get_selected()), + private$get_keep_na(), + private$get_keep_inf() + ) + }) } - }, - #' @description - #' Returns current `keep_na` selection. - #' - #' @return `logical(1)` - #' - get_keep_na = function() { - private$keep_na() + invisible(self) }, - #' @description - #' Returns variable label. - #' - #' @return `character(1)` - #' - get_varlabel = function() { - private$varlabel - }, #' @description - #' Get variable name. + #' Returns filtering state. #' - #' @return `character(1)` + #' @return A `teal_slice` object. #' - get_varname = function() { - private$varname + get_state = function() { + private$teal_slice }, #' @description - #' Get selected values from `FilterState`. - #' - #' @return class of the returned object depends of class of the `FilterState` + #' Returns reproducible condition call for current selection relevant + #' for selected variable type. + #' Method is using internal reactive values which makes it reactive + #' and must be executed in reactive or isolated context. #' - get_selected = function() { - private$selected() + get_call = function() { + stop("this is a virtual method") }, #' @description - #' Returns the filtering state. + #' Shiny module server. #' - #' @return `list` containing values taken from the reactive fields: - #' * `selected` (`atomic`) length depends on a `FilterState` variant. - #' * `keep_na` (`logical(1)`) whether `NA` should be kept. + #' @param id (`character(1)`)\cr + #' shiny module instance id #' - get_state = function() { - list( - selected = self$get_selected(), - keep_na = self$get_keep_na() + #' @return `moduleServer` function which returns reactive value + #' signaling that remove button has been clicked + #' + server = function(id) { + moduleServer( + id = id, + function(input, output, session) { + logger::log_trace("FilterState$server initializing module for slice: { private$get_id() } ") + private$server_summary("summary") + if (private$is_fixed()) { + private$server_inputs_fixed("inputs") + } else { + private$server_inputs("inputs") + } + + private$destroy_shiny <- function() { + logger::log_trace("Destroying FilterState inputs and observers; id: { private$get_id() }") + # remove values from the input list + lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) + + # remove observers + lapply(private$observers, function(x) x$destroy()) + } + + reactive(input$remove) + } ) }, #' @description - #' Prints this `FilterState` object. - #' - #' @param ... additional arguments to this method + #' Shiny module UI. #' - print = function(...) { - cat(shiny::isolate(self$format()), "\n") + #' @param id (`character(1)`)\cr + #' shiny element (module instance) id; + #' the UI for this class contains simple message stating that it is not supported + #' @param parent_id (`character(1)`) id of the `FilterStates` card container + ui = function(id, parent_id = "cards") { + ns <- NS(id) + + tags$div( + id = id, + class = "panel filter-card", + include_js_files("count-bar-labels.js"), + tags$div( + class = "filter-card-header", + tags$div( + # header properties + class = "filter-card-title", + `data-toggle` = "collapse", + `data-bs-toggle` = "collapse", + href = paste0("#", ns("body")), + # header elements + if (private$is_locked()) icon("lock") else NULL, + if (private$is_fixed()) icon("burst") else NULL, + tags$span(tags$strong(private$get_varname())), + tags$span(private$get_varlabel(), class = "filter-card-varlabel") + ), + if (isFALSE(private$is_locked())) { + actionLink( + inputId = ns("remove"), + label = icon("circle-xmark", lib = "font-awesome"), + class = "filter-card-remove" + ) + }, + tags$div( + class = "filter-card-summary", + `data-toggle` = "collapse", + `data-bs-toggle` = "collapse", + href = paste0("#", ns("body")), + private$ui_summary(ns("summary")) + ) + ), + tags$div( + id = ns("body"), + class = "collapse out", + `data-parent` = paste0("#", parent_id), + `data-bs-parent` = paste0("#", parent_id), + tags$div( + class = "filter-card-body", + if (private$is_fixed()) { + private$ui_inputs_fixed(ns("inputs")) + } else { + private$ui_inputs(ns("inputs")) + } + ) + ) + ) }, #' @description - #' Set whether to keep NAs. - #' - #' @param value `logical(1)`\cr - #' value(s) which come from the filter selection. Value is set in `server` - #' modules after selecting check-box-input in the shiny interface. Values are set to - #' `private$keep_na` which is reactive. + #' Destroy observers stored in `private$observers`. #' #' @return NULL invisibly #' - set_keep_na = function(value) { - checkmate::assert_flag(value) - private$keep_na(value) + destroy_observers = function() { + if (!is.null(private$destroy_shiny)) { + private$destroy_shiny() + } + } + ), + + # private members ---- + private = list( + # set by constructor + x = NULL, # the filtered variable + x_reactive = NULL, # reactive containing the filtered variable, used for updating counts and histograms + teal_slice = shiny::reactiveValues(), # stores all transferable properties of this filter state + extract_type = character(0), # used by private$get_varname_prefixed + na_count = integer(0), + filtered_na_count = NULL, # reactive containing the count of NA in the filtered dataset + varlabel = character(0), # taken from variable labels in data; displayed in filter cards + destroy_shiny = NULL, # function is set in server + # other + is_choice_limited = FALSE, # flag whether number of possible choices was limited when specifying filter + na_rm = FALSE, + observers = list(), # stores observers + + # private methods ---- + + ## setters for state features ---- + + # @description + # Set values that can be selected from. + set_choices = function(choices) { + stop("this is a virtual method") + }, + + # @description + # Set selection. + # + # @param value (`vector`)\cr + # value(s) that come from filter selection; values are set in the + # module server after a selection is made in the app interface; + # values are stored in `teal_slice$selected` which is reactive; + # value types have to be the same as `private$get_choices()` + # + # @return NULL invisibly + set_selected = function(value) { logger::log_trace( sprintf( - "%s$set_keep_na set for variable %s to %s.", + "%s$set_selected setting selection of id: %s", class(self)[1], - private$varname, - value + private$get_id() + ) + ) + shiny::isolate({ + value <- private$cast_and_validate(value) + value <- private$remove_out_of_bound_values(value) + value <- private$check_multiple(value) + private$validate_selection(value) + private$teal_slice$selected <- value + }) + logger::log_trace( + sprintf( + "%s$set_selected selection of id: %s", + class(self)[1], + private$get_id() ) ) - invisible(NULL) - }, - #' @description - #' Some methods need an additional `!is.na(varame)` condition to drop - #' missing values. When `private$na_rm = TRUE`, `self$get_call` returns - #' condition extended by `!is.na`. - #' - #' @param value `logical(1)`\cr - #' when `TRUE`, `FilterState$get_call` appends an expression - #' removing `NA` values to the filter expression returned by `get_call` - #' - #' @return NULL invisibly - #' - set_na_rm = function(value) { - checkmate::assert_flag(value) - private$na_rm <- value invisible(NULL) }, - #' @description - #' Set selection. - #' - #' @param value (`vector`)\cr - #' value(s) that come from filter selection; values are set in the - #' module server after a selection is made in the app interface; - #' values are stored in `private$selected` which is reactive; - #' value types have to be the same as `private$choices` - #' - #' @return NULL invisibly - #' - set_selected = function(value) { + # @description + # Set whether to keep NAs. + # + # @param value `logical(1)`\cr + # value(s) which come from the filter selection. Value is set in `server` + # modules after selecting check-box-input in the shiny interface. Values are set to + # `private$teal_slice$keep_na` + # + # @return NULL invisibly + # + set_keep_na = function(value) { + checkmate::assert_flag(value) + private$teal_slice$keep_na <- value logger::log_trace( sprintf( - "%s$set_selected setting selection of variable %s, dataname: %s.", + "%s$set_keep_na set for filter %s to %s.", class(self)[1], - private$varname, - private$dataname + private$get_id(), + value ) ) - value <- private$cast_and_validate(value) - value <- private$remove_out_of_bound_values(value) - private$validate_selection(value) - private$selected(value) - logger::log_trace(sprintf( - "%s$set_selected selection of variable %s set, dataname: %s", - class(self)[1], - private$varname, - private$dataname - )) + private$set_na_rm(!value) invisible(NULL) }, - #' @description - #' Set state. - #' - #' @param state (`list`)\cr - #' contains fields relevant for a specific class: - #' \itemize{ - #' \item{`selected`}{ defines initial selection} - #' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values} - #' } - #' - #' @return NULL invisibly - #' - set_state = function(state) { - logger::log_trace(sprintf( - "%s$set_state, dataname: %s setting state of variable %s to: selected=%s, keep_na=%s", - class(self)[1], - private$dataname, - private$varname, - paste(state$selected, collapse = " "), - state$keep_na - )) - stopifnot(is.list(state) && all(names(state) %in% c("selected", "keep_na"))) - if (!is.null(state$keep_na)) { - self$set_keep_na(state$keep_na) - } - if (!is.null(state$selected)) { - self$set_selected(state$selected) - } + # @description + # Set whether to keep Infs + # + # @param value (`logical(1)`)\cr + # Value(s) which come from the filter selection. Value is set in `server` + # modules after selecting check-box-input in the shiny interface. Values are set to + # `private$teal_slice$keep_inf` + # + set_keep_inf = function(value) { + checkmate::assert_flag(value) + private$teal_slice$keep_inf <- value logger::log_trace( sprintf( - "%s$set_state, dataname: %s done setting state for variable %s", + "%s$set_keep_inf of filter %s set to %s", class(self)[1], - private$dataname, - private$varname + private$get_id(), + value ) ) + invisible(NULL) }, - #' @description - #' Shiny module server. - #' - #' @param id (`character(1)`)\cr - #' shiny module instance id - #' - #' @return `moduleServer` function which returns reactive value - #' signaling that remove button has been clicked - #' - server = function(id) { - moduleServer( - id = id, - function(input, output, session) { - private$server_inputs("inputs") - reactive(input$remove) # back to parent to remove self - } - ) + # @description + # Some methods need an additional `!is.na(varame)` condition to drop + # missing values. When `private$na_rm = TRUE`, `self$get_call` returns + # condition extended by `!is.na`. + # + # @param value `logical(1)`\cr + # when `TRUE`, `FilterState$get_call` appends an expression + # removing `NA` values to the filter expression returned by `get_call` + # + # @return NULL invisibly + # + set_na_rm = function(value) { + checkmate::assert_flag(value) + private$na_rm <- value + invisible(NULL) }, - #' @description - #' Shiny module UI. - #' - #' @param id (`character(1)`)\cr - #' shiny element (module instance) id; - #' the UI for this class contains simple message stating that it is not supported - #' - ui = function(id) { - ns <- NS(id) - fluidPage( - theme = get_teal_bs_theme(), - fluidRow( - column( - width = 10, - class = "no-left-right-padding", - tags$div( - tags$span(private$varname, - class = "filter_panel_varname" - ), - if (checkmate::test_character(self$get_varlabel(), min.len = 1) && - tolower(private$varname) != tolower(self$get_varlabel())) { - tags$span(self$get_varlabel(), class = "filter_panel_varlabel") - } - ) - ), - column( - width = 2, - class = "no-left-right-padding", - actionLink( - ns("remove"), - label = "", - icon = icon("circle-xmark", lib = "font-awesome"), - class = "remove pull-right" - ) - ) - ), - private$ui_inputs(ns("inputs")) - ) - } - ), + ## getters for state features ---- - # private members ---- - private = list( - choices = NULL, # because each class has different choices type - dataname = character(0), - keep_na = NULL, # reactiveVal logical() - na_count = integer(0), - na_rm = FALSE, # it's logical(1) - observers = NULL, # here observers are stored - selected = NULL, # because it holds reactiveVal and each class has different choices type - varname = character(0), - varlabel = character(0), - extract_type = logical(0), + # @description + # Returns dataname. + # @return `character(1)` + get_dataname = function() { + shiny::isolate(private$teal_slice$dataname) + }, - # private methods ---- + # @description + # Get variable name. + # @return `character(1)` + get_varname = function() { + shiny::isolate(private$teal_slice$varname) + }, + + # @description + # Get id of the teal_slice. + # @return `character(1)` + get_id = function() { + shiny::isolate(private$teal_slice$id) + }, + + # @description + # Get allowed values from `FilterState`. + # @return class of the returned object depends of class of the `FilterState` + get_choices = function() { + shiny::isolate(private$teal_slice$choices) + }, # @description - # Return variable name prefixed by dataname to be evaluated as extracted object, + # Get selected values from `FilterState`. + # @return class of the returned object depends of class of the `FilterState` + get_selected = function() { + private$teal_slice$selected + }, + + # @description + # Returns current `keep_na` selection. + # @return `logical(1)` + get_keep_na = function() { + private$teal_slice$keep_na + }, + + # @description + # Returns current `keep_inf` selection. + # @return (`logical(1)`) + get_keep_inf = function() { + private$teal_slice$keep_inf + }, + + # Check whether this filter is fixed (cannot be changed). + # @return `logical(1)` + is_fixed = function() { + shiny::isolate(isTRUE(private$teal_slice$fixed)) + }, + + # Check whether this filter is locked (cannot be removed). + # @return `logical(1)` + is_locked = function() { + shiny::isolate(isTRUE(private$teal_slice$locked)) + }, + + # Check whether this filter is capable of selecting multiple values. + # @return `logical(1)` + is_multiple = function() { + shiny::isolate(isTRUE(private$teal_slice$multiple)) + }, + + ## other ---- + + # @description + # Returns variable label. + # @return `character(1)` + get_varlabel = function() { + private$varlabel + }, + + # @description + # Return variable name prefixed by `dataname` to be evaluated as extracted object, # for example `data$var` # @return a character string representation of a subset call # that extracts the variable from the dataset - get_varname_prefixed = function() { + get_varname_prefixed = function(dataname) { ans <- if (isTRUE(private$extract_type == "list")) { - sprintf("%s$%s", private$dataname, private$varname) + sprintf("%s$%s", dataname, private$get_varname()) } else if (isTRUE(private$extract_type == "matrix")) { - sprintf("%s[, \"%s\"]", private$dataname, private$varname) + sprintf("%s[, \"%s\"]", dataname, private$get_varname()) } else { - private$varname + private$get_varname() } str2lang(ans) }, # @description # Adds `is.na(varname)` before existing condition calls if `keep_na` is selected. - # Otherwise, if missings are found in the variable `!is.na` will be added + # Otherwise, if missing values are found in the variable `!is.na` will be added # only if `private$na_rm = TRUE` + # @param filter_call `call` raw filter call, as defined by selection + # @param dataname `character(1)` name of data set to prepend to variables # @return a `call` - add_keep_na_call = function(filter_call) { - if (isTRUE(self$get_keep_na())) { - call("|", call("is.na", private$get_varname_prefixed()), filter_call) + add_keep_na_call = function(filter_call, dataname) { + if (isTRUE(private$get_keep_na())) { + call("|", call("is.na", private$get_varname_prefixed(dataname)), filter_call) } else if (isTRUE(private$na_rm) && private$na_count > 0L) { call( "&", - call("!", call("is.na", private$get_varname_prefixed())), + call("!", call("is.na", private$get_varname_prefixed(dataname))), filter_call ) } else { @@ -460,55 +541,77 @@ FilterState <- R6::R6Class( # nolint } }, - # Sets `keep_na` field according to observed `input$keep_na` - # If `keep_na = TRUE` `is.na(varname)` is added to the returned call. - # Otherwise returned call excludes `NA` when executed. - observe_keep_na = function(input) { + # Converts values to the type fitting this `FilterState` and validates + # whether the elements of the resulting vector satisfy the requirements of this `FilterState`. + # Raises error if casting does not execute successfully. + # + # @param values vector of values + # + # @return vector converted to appropriate class + cast_and_validate = function(values) { + values + }, + # Filters out erroneous values from vector. + # + # @param values vector of values + # + # @return vector in which values that cannot be set in this FilterState have been dropped + remove_out_of_bound_values = function(values) { + values }, - # @description - # Set choices is supposed to be executed once in the constructor - # to define set/range which selection is made from. - # parameter choices (`vector`)\cr - # class of the vector depends on the `FilterState` class. - # @return `NULL` - set_choices = function(choices) { - private$choices <- choices - invisible(NULL) + # Checks whether multiple choices are allowed. + # If not value is of length 2 or more, drops all but first item with a warning. + check_multiple = function(value) { + value }, # Checks if the selection is valid in terms of class and length. - # It should not return anything but throw an error if selection + # It should not return anything but raise an error if selection # has a wrong class or is outside of possible choices validate_selection = function(value) { invisible(NULL) }, - # Filters out erroneous values from an array. - # - # @param values the array of values - # - # @return the array of values without elements, which are outside of - # the accepted set for this FilterState - remove_out_of_bound_values = function(values) { - values + # @description + # Answers the question of whether the current settings and values selected actually filters out any values. + # @return logical scalar + is_any_filtered = function() { + if (private$is_choice_limited) { + TRUE + } else if (!setequal(private$get_selected(), private$get_choices())) { + TRUE + } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) { + TRUE + } else { + FALSE + } }, - # Casts an array of values to the type fitting this `FilterState` - # and validates the elements of the casted array - # satisfy the requirements of this `FilterState`. - # - # @param values the array of values - # - # @return the casted array - # - # @note throws an error if the casting did not execute successfully. - cast_and_validate = function(values) { - values + ## shiny modules ----- + + # @description + # Server module to display filter summary + # @param id `shiny` id parameter + ui_summary = function(id) { + ns <- NS(id) + uiOutput(ns("summary"), class = "filter-card-summary") + }, + + # @description + # UI module to display filter summary + # @param shiny `id` parameter passed to `moduleServer` + # renders text describing current state + server_summary = function(id) { + moduleServer( + id = id, + function(input, output, session) { + output$summary <- renderUI(private$content_summary()) + } + ) }, - # shiny modules ----- # module with inputs ui_inputs = function(id) { stop("abstract class") @@ -518,6 +621,27 @@ FilterState <- R6::R6Class( # nolint stop("abstract class") }, + # @description + # module displaying inputs in a fixed filter state + # there are no input widgets, only selection visualizations + # @param id + # character string specifying this `shiny` module instance + ui_inputs_fixed = function(id) { + ns <- NS(id) + div( + class = "choices_state", + uiOutput(ns("selection")) + ) + }, + + # @description + # module creating the display of a fixed filter state + # @param id + # character string specifying this `shiny` module instance + server_inputs_fixed = function(id) { + stop("abstract class") + }, + # @description # module displaying input to keep or remove NA in the FilterState call # @param id `shiny` id parameter @@ -526,11 +650,26 @@ FilterState <- R6::R6Class( # nolint keep_na_ui = function(id) { ns <- NS(id) if (private$na_count > 0) { - checkboxInput( - ns("value"), - sprintf("Keep NA (%s)", private$na_count), - value = self$get_keep_na() - ) + shiny::isolate({ + countmax <- private$na_count + countnow <- private$filtered_na_count() + ui_input <- checkboxInput( + inputId = ns("value"), + label = tags$span( + id = ns("count_label"), + make_count_text( + label = "Keep NA", + countmax = countmax, + countnow = countnow + ) + ), + value = private$get_keep_na() + ) + div( + uiOutput(ns("trigger_visible"), inline = TRUE), + ui_input + ) + }) } else { NULL } @@ -544,18 +683,33 @@ FilterState <- R6::R6Class( # nolint # changed through the api keep_na_srv = function(id) { moduleServer(id, function(input, output, session) { + # 1. renderUI is used here as an observer which triggers only if output is visible + # and if the reactive changes - reactive triggers only if the output is visible. + # 2. We want to trigger change of the labels only if reactive count changes (not underlying data) + output$trigger_visible <- renderUI({ + updateCountText( + inputId = "count_label", + label = "Keep NA", + countmax = private$na_count, + countnow = private$filtered_na_count() + ) + NULL + }) + # this observer is needed in the situation when private$keep_inf has been # changed directly by the api - then it's needed to rerender UI element # to show relevant values private$observers$keep_na_api <- observeEvent( + eventExpr = private$get_keep_na(), ignoreNULL = FALSE, # nothing selected is possible for NA ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state - eventExpr = self$get_keep_na(), handlerExpr = { - if (!setequal(self$get_keep_na(), input$value)) { + if (!setequal(private$get_keep_na(), input$value)) { + logger::log_trace("FilterState$keep_na_srv@1 changed reactive value, id: { private$get_id() }") updateCheckboxInput( inputId = "value", - value = self$get_keep_na() + label = sprintf("Keep NA (%s/%s)", private$filtered_na_count(), private$na_count), + value = private$get_keep_na() ) } } @@ -565,21 +719,13 @@ FilterState <- R6::R6Class( # nolint ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state eventExpr = input$value, handlerExpr = { + logger::log_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }") keep_na <- if (is.null(input$value)) { FALSE } else { input$value } - self$set_keep_na(keep_na) - logger::log_trace( - sprintf( - "%s$server keep_na of variable %s set to: %s, dataname: %s", - class(self)[1], - private$varname, - deparse1(input$value), - private$dataname - ) - ) + private$set_keep_na(keep_na) } ) invisible(NULL) diff --git a/R/FilterStateChoices.R b/R/FilterStateChoices.R index b545b3c95..adf3eebaa 100644 --- a/R/FilterStateChoices.R +++ b/R/FilterStateChoices.R @@ -7,32 +7,40 @@ #' #' @examples #' filter_state <- teal.slice:::ChoicesFilterState$new( -#' c(LETTERS, NA), -#' varname = "x", -#' dataname = "data", -#' extract_type = character(0) +#' x = c(LETTERS, NA), +#' slice = teal_slice(varname = "x", dataname = "data") #' ) -#' isolate(filter_state$get_call()) -#' isolate(filter_state$set_selected("B")) -#' isolate(filter_state$set_keep_na(TRUE)) -#' isolate(filter_state$get_call()) +#' shiny::isolate(filter_state$get_call()) +#' filter_state$set_state( +#' teal_slice( +#' dataname = "data", +#' varname = "x", +#' selected = "A", +#' keep_na = TRUE +#' ) +#' ) +#' shiny::isolate(filter_state$get_call()) #' -#' \dontrun{ #' # working filter in an app #' library(shiny) +#' library(shinyjs) #' #' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA) -#' filter_state_choices <- ChoicesFilterState$new( +#' attr(data_choices, "label") <- "lowercase letters" +#' fs <- teal.slice:::ChoicesFilterState$new( #' x = data_choices, -#' varname = "variable", -#' varlabel = "label" +#' slice = teal_slice( +#' dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE +#' ) #' ) -#' filter_state_choices$set_state(list(selected = c("a", "c"), keep_na = TRUE)) #' #' ui <- fluidPage( +#' useShinyjs(), +#' teal.slice:::include_css_files(pattern = "filter-panel"), +#' teal.slice:::include_js_files(pattern = "count-bar-labels"), #' column(4, div( #' h4("ChoicesFilterState"), -#' isolate(filter_state_choices$ui("fs")) +#' fs$ui("fs") #' )), #' column(4, div( #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState @@ -46,35 +54,53 @@ #' h4("Programmatic filter control"), #' actionButton("button1_choices", "set drop NA", width = "100%"), br(), #' actionButton("button2_choices", "set keep NA", width = "100%"), br(), -#' actionButton("button3_choices", "set a selection", width = "100%"), br(), +#' actionButton("button3_choices", "set selection: a, b", width = "100%"), br(), #' actionButton("button4_choices", "deselect all", width = "100%"), br(), #' actionButton("button0_choices", "set initial state", width = "100%"), br() #' )) #' ) #' #' server <- function(input, output, session) { -#' filter_state_choices$server("fs") -#' output$condition_choices <- renderPrint(filter_state_choices$get_call()) -#' output$formatted_choices <- renderText(filter_state_choices$format()) -#' output$unformatted_choices <- renderPrint(filter_state_choices$get_state()) +#' fs$server("fs") +#' output$condition_choices <- renderPrint(fs$get_call()) +#' output$formatted_choices <- renderText(fs$format()) +#' output$unformatted_choices <- renderPrint(fs$get_state()) #' # modify filter state programmatically -#' observeEvent(input$button1_choices, filter_state_choices$set_keep_na(FALSE)) -#' observeEvent(input$button2_choices, filter_state_choices$set_keep_na(TRUE)) +#' observeEvent( +#' input$button1_choices, +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "variable", keep_na = FALSE) +#' ) +#' ) +#' observeEvent( +#' input$button2_choices, +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "variable", keep_na = TRUE) +#' ) +#' ) #' observeEvent( #' input$button3_choices, -#' filter_state_choices$set_selected(c("b", "c")) +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "variable", selected = c("a", "b")) +#' ) +#' ) +#' observeEvent( +#' input$button4_choices, +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE) +#' ) #' ) -#' observeEvent(input$button4_choices, filter_state_choices$set_selected(c())) #' observeEvent( #' input$button0_choices, -#' filter_state_choices$set_state(list(selected = c("a", "c"), keep_na = TRUE)) +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE) +#' ) #' ) #' } #' #' if (interactive()) { #' shinyApp(ui, server) #' } -#' } #' ChoicesFilterState <- R6::R6Class( # nolint "ChoicesFilterState", @@ -85,70 +111,78 @@ ChoicesFilterState <- R6::R6Class( # nolint public = list( #' @description - #' Initialize a `FilterState` object - #' @param x (`character` or `factor`)\cr + #' Initialize a `InteractiveFilterState` object + #' + #' @param x (`vector`)\cr #' values of the variable used in filter - #' @param varname (`character`)\cr - #' name of the variable - #' @param varlabel (`character(1)`)\cr - #' label of the variable (optional). - #' @param dataname (`character(1)`)\cr - #' optional name of dataset where `x` is taken from + #' @param x_reactive (`reactive`)\cr + #' returning vector of the same type as `x`. Is used to update + #' counts following the change in values of the filtered dataset. + #' If it is set to `reactive(NULL)` then counts based on filtered + #' dataset are not shown. + #' @param slice (`teal_slice`)\cr + #' object created using [teal_slice()]. `teal_slice` is stored + #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state` + #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice` + #' is a `reactiveValues` which means that changes in particular object are automatically + #' reflected in all places which refer to the same `teal_slice`. #' @param extract_type (`character(0)`, `character(1)`)\cr - #' whether condition calls should be prefixed by dataname. Possible values: + #' whether condition calls should be prefixed by `dataname`. Possible values: #' \itemize{ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed} #' \item{`"list"`}{ `varname` in the condition call will be returned as `$`} #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `[, ]`} #' } + #' @param ... additional arguments to be saved as a list in `private$extras` field + #' initialize = function(x, - varname, - varlabel = character(0), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - checkmate::assert( - is.character(x), - is.factor(x), - length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"), - combine = "or" - ) - super$initialize(x, varname, varlabel, dataname, extract_type) - - private$data_class <- class(x)[1L] - if (inherits(x, "POSIXt")) { - private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone")) - } - - if (!is.factor(x)) { - x <- factor(as.character(x), levels = as.character(sort(unique(x)))) - } - x <- droplevels(x) - tbl <- table(x) - choices <- names(tbl) - names(choices) <- tbl - + shiny::isolate({ + checkmate::assert( + is.character(x), + is.factor(x), + length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"), + combine = "or" + ) - private$set_choices(as.list(choices)) - self$set_selected(unname(choices)) - private$histogram_data <- data.frame( - x = levels(x), - y = tabulate(x) - ) + x_factor <- if (!is.factor(x)) { + structure( + factor(as.character(x), levels = as.character(sort(unique(x)))), + label = attr(x, "label") + ) + } else { + x + } - return(invisible(self)) - }, + super$initialize( + x = x_factor, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type + ) + private$set_choices(slice$choices) + if (is.null(slice$selected) && slice$multiple) { + slice$selected <- private$get_choices() + } else if (is.null(slice$selected)) { + slice$selected <- private$get_choices()[1] + } else if (length(slice$selected) > 1 && !slice$multiple) { + warning( + "ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ", + "Only the first value will be used." + ) + slice$selected <- slice$selected[1] + } + private$set_selected(slice$selected) + private$data_class <- class(x)[1L] + if (inherits(x, "POSIXt")) { + private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone")) + } - #' @description - #' Answers the question of whether the current settings and values selected actually filters out any values. - #' @return logical scalar - is_any_filtered = function() { - if (!setequal(self$get_selected(), private$choices)) { - TRUE - } else if (!isTRUE(self$get_keep_na()) && private$na_count > 0) { - TRUE - } else { - FALSE - } + private$set_choices_counts(unname(table(x_factor))) + }) + invisible(self) }, #' @description @@ -156,90 +190,114 @@ ChoicesFilterState <- R6::R6Class( # nolint #' For this class returned call looks like #' ` %in% c()` with #' optional `is.na()`. - #' @return (`call`) - get_call = function() { - varname <- private$get_varname_prefixed() - choices <- self$get_selected() + #' @param dataname name of data set; defaults to `private$get_dataname()` + #' @return (`call`) or `NULL` + #' + get_call = function(dataname) { + if (isFALSE(private$is_any_filtered())) { + return(NULL) + } + if (missing(dataname)) dataname <- private$get_dataname() + varname <- private$get_varname_prefixed(dataname) + choices <- private$get_selected() if (private$data_class != "factor") { choices <- do.call(sprintf("as.%s", private$data_class), list(x = choices)) } fun_compare <- if (length(choices) == 1L) "==" else "%in%" + filter_call <- if (inherits(choices, "Date")) { - call(fun_compare, varname, call("as.Date", as.character(choices))) + call(fun_compare, varname, call("as.Date", make_c_call(as.character(choices)))) } else if (inherits(choices, c("POSIXct", "POSIXlt"))) { class <- class(choices)[1L] - date_fun <- as.name(switch(class, - "POSIXct" = "as.POSIXct", - "POSIXlt" = "as.POSIXlt" - )) - call(fun_compare, varname, as.call(list(date_fun, as.character(choices), tz = private$tzone))) + date_fun <- as.name( + switch(class, + "POSIXct" = "as.POSIXct", + "POSIXlt" = "as.POSIXlt" + ) + ) + call( + fun_compare, + varname, + as.call(list(date_fun, make_c_call(as.character(choices)), tz = private$tzone)) + ) } else { # This handles numerics, characters, and factors. - call(fun_compare, varname, choices) + call(fun_compare, varname, make_c_call(choices)) } - private$add_keep_na_call(filter_call) - }, - - #' @description - #' Set state - #' @param state (`list`)\cr - #' contains fields relevant for a specific class - #' \itemize{ - #' \item{`selected`}{ defines initial selection} - #' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values} - #' } - set_state = function(state) { - if (!is.null(state$selected)) { - state$selected <- as.character(state$selected) - } - super$set_state(state) - invisible(NULL) - }, - - #' @description - #' Sets the selected values of this `ChoicesFilterState`. - #' - #' @param value (`character`) the array of the selected choices. - #' Must not contain NA values. - #' - #' @return invisibly `NULL` - #' - #' @note Casts the passed object to `character` before validating the input - #' making it possible to pass any object coercible to `character` to this method. - #' - #' @examples - #' filter <- teal.slice:::ChoicesFilterState$new(c("a", "b", "c"), varname = "name") - #' filter$set_selected(c("c", "a")) - set_selected = function(value) { - super$set_selected(value) + private$add_keep_na_call(filter_call, dataname) } ), # private members ---- - private = list( - histogram_data = data.frame(), + x = NULL, + choices_counts = integer(0), data_class = character(0), # stores class of filtered variable so that it can be restored in $get_call tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call # private methods ---- - validate_selection = function(value) { - if (!is.character(value)) { - stop( - sprintf( - "Values of the selection for `%s` in `%s` should be an array of character.", - self$get_varname(), - self$get_dataname() + + # @description + # Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices + # are limited by default from the start. + set_choices = function(choices) { + if (is.null(choices)) { + choices <- levels(private$x) + } else { + choices <- as.character(choices) + choices_adjusted <- choices[choices %in% private$x] + if (length(setdiff(choices, choices_adjusted)) > 0L) { + warning( + sprintf( + "Some choices not found in data. Adjusting. Filter id: %s.", + private$get_id() + ) ) - ) + choices <- choices_adjusted + } + if (length(choices) == 0) { + warning( + sprintf( + "None of the choices were found in data. Setting defaults. Filter id: %s.", + private$get_id() + ) + ) + choices <- levels(private$x) + } } - pre_msg <- sprintf( - "data '%s', variable '%s': ", - self$get_dataname(), - self$get_varname() - ) - check_in_subset(value, private$choices, pre_msg = pre_msg) + private$set_is_choice_limited(private$x, choices) + private$teal_slice$choices <- choices + private$x <- private$x[(private$x %in% private$get_choices()) | is.na(private$x)] + private$x <- droplevels(private$x) + invisible(NULL) + }, + # @description + # Check whether the initial choices filter out some values of x and set the flag in case. + set_is_choice_limited = function(x, choices) { + xl <- x[!is.na(x)] + private$is_choice_limited <- length(setdiff(xl, choices)) > 0L + invisible(NULL) + }, + # @description + # Sets choices_counts private field. + set_choices_counts = function(choices_counts) { + private$choices_counts <- choices_counts + invisible(NULL) + }, + # @description + # Checks how many counts of each choice is present in the data. + get_choices_counts = function() { + if (!is.null(private$x_reactive)) { + table(factor(private$x_reactive(), levels = private$get_choices())) + } else { + NULL + } + }, + # @description + # Checks whether the input should be rendered as a checkboxgroup/radiobutton or a drop-down. + is_checkboxgroup = function() { + length(private$get_choices()) <= getOption("teal.threshold_slider_vs_checkboxgroup") }, cast_and_validate = function(values) { tryCatch( @@ -252,15 +310,42 @@ ChoicesFilterState <- R6::R6Class( # nolint values }, remove_out_of_bound_values = function(values) { - in_choices_mask <- values %in% private$choices + in_choices_mask <- values %in% private$get_choices() if (length(values[!in_choices_mask]) > 0) { warning(paste( - "Values:", strtrim(paste(values[!in_choices_mask], collapse = ", "), 360), - "are not in choices of column", private$varname, "in dataset", private$dataname, "." + "Values:", toString(values[!in_choices_mask], width = 360), + "are not in choices of column", private$get_varname(), "in dataset", private$get_dataname(), "." )) } values[in_choices_mask] }, + check_multiple = function(value) { + if (!private$is_multiple() && length(value) > 1) { + warning( + sprintf("Selection: %s is not a vector of length one. ", toString(value, width = 360)), + "Maintaining previous selection." + ) + value <- shiny::isolate(private$get_selected()) + } + value + }, + validate_selection = function(value) { + if (!is.character(value)) { + stop( + sprintf( + "Values of the selection for `%s` in `%s` should be an array of character.", + private$get_varname(), + private$get_dataname() + ) + ) + } + pre_msg <- sprintf( + "data '%s', variable '%s': ", + private$get_dataname(), + private$get_varname() + ) + check_in_subset(value, private$get_choices(), pre_msg = pre_msg) + }, # shiny modules ---- @@ -272,51 +357,71 @@ ChoicesFilterState <- R6::R6Class( # nolint # id of shiny element ui_inputs = function(id) { ns <- NS(id) - div( - if (length(private$choices) <= getOption("teal.threshold_slider_vs_checkboxgroup")) { - l_counts <- as.numeric(names(private$choices)) - l_counts[is.na(l_counts)] <- 0 - l_freqs <- l_counts / sum(l_counts) - labels <- lapply(seq_along(private$choices), function(i) { - div( - class = "choices_state_label", - style = sprintf("width:%s%%", l_freqs[i] * 100), - span( - class = "choices_state_label_text", - sprintf( - "%s (%s)", - private$choices[i], - l_counts[i] - ) - ) - ) - }) + + # we need to isolate UI to not rettrigger renderUI + shiny::isolate({ + countsmax <- private$choices_counts + countsnow <- if (!is.null(private$x_reactive())) { + unname(table(factor(private$x_reactive(), levels = private$get_choices()))) + } else { + NULL + } + + ui_input <- if (private$is_checkboxgroup()) { + labels <- countBars( + inputId = ns("labels"), + choices = private$get_choices(), + countsnow = countsnow, + countsmax = countsmax + ) div( class = "choices_state", - checkboxGroupInput( - ns("selection"), - label = NULL, - selected = self$get_selected(), - choiceNames = labels, - choiceValues = as.character(private$choices), - width = "100%" - ) + if (private$is_multiple()) { + checkboxGroupInput( + inputId = ns("selection"), + label = NULL, + selected = private$get_selected(), + choiceNames = labels, + choiceValues = private$get_choices(), + width = "100%" + ) + } else { + radioButtons( + inputId = ns("selection"), + label = NULL, + selected = private$get_selected(), + choiceNames = labels, + choiceValues = private$get_choices(), + width = "100%" + ) + } ) } else { + labels <- mapply( + FUN = make_count_text, + label = private$get_choices(), + countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow, + countmax = countsmax + ) + teal.widgets::optionalSelectInput( inputId = ns("selection"), - choices = stats::setNames(private$choices, sprintf("%s (%s)", private$choices, names(private$choices))), - selected = self$get_selected(), - multiple = TRUE, + choices = stats::setNames(private$get_choices(), labels), + selected = private$get_selected(), + multiple = private$is_multiple(), options = shinyWidgets::pickerOptions( actionsBox = TRUE, - liveSearch = (length(private$choices) > 10), + liveSearch = (length(private$get_choices()) > 10), noneSelectedText = "Select a value" ) ) - }, - private$keep_na_ui(ns("keep_na")) - ) + } + div( + uiOutput(ns("trigger_visible")), + ui_input, + private$keep_na_ui(ns("keep_na")) + ) + }) }, # @description @@ -328,51 +433,197 @@ ChoicesFilterState <- R6::R6Class( # nolint moduleServer( id = id, function(input, output, session) { - logger::log_trace("ChoicesFilterState$server initializing, dataname: { private$dataname }") + logger::log_trace("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }") - # this observer is needed in the situation when private$selected has been - # changed directly by the api - then it's needed to rerender UI element - # to show relevant values - private$observers$selection_api <- observeEvent( - ignoreNULL = FALSE, # it's possible that nothing is selected - ignoreInit = TRUE, - eventExpr = self$get_selected(), - handlerExpr = { - if (!setequal(self$get_selected(), input$selection)) { - updateCheckboxInput( + # 1. renderUI is used here as an observer which triggers only if output is visible + # and if the reactive changes - reactive triggers only if the output is visible. + # 2. We want to trigger change of the labels only if reactive count changes (not underlying data) + non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive())) + output$trigger_visible <- renderUI({ + logger::log_trace("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }") + + countsnow <- if (!is.null(private$x_reactive())) { + unname(table(factor(non_missing_values(), levels = private$get_choices()))) + } else { + NULL + } + + # update should be based on a change of counts only + shiny::isolate({ + if (private$is_checkboxgroup()) { + updateCountBars( + inputId = "labels", + choices = private$get_choices(), + countsmax = private$choices_counts, + countsnow = countsnow + ) + } else { + labels <- mapply( + FUN = make_count_text, + label = private$get_choices(), + countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow, + countmax = private$choices_counts + ) + teal.widgets::updateOptionalSelectInput( session = session, inputId = "selection", - value = self$get_selected() + choices = stats::setNames(private$get_choices(), labels), + selected = private$get_selected() ) - logger::log_trace(sprintf( - "ChoicesFilterState$server@1 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname - )) } - } - ) + NULL + }) + }) + + if (private$is_checkboxgroup()) { + private$observers$selection <- observeEvent( + ignoreNULL = FALSE, + ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state + eventExpr = input$selection, + handlerExpr = { + logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }") + + selection <- if (is.null(input$selection) && private$is_multiple()) { + character(0) + } else { + input$selection + } + + private$set_selected(selection) + } + ) + } else { + private$observers$selection <- observeEvent( + ignoreNULL = FALSE, + ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state + eventExpr = input$selection_open, # observe click on a dropdown + handlerExpr = { + if (!isTRUE(input$selection_open)) { # only when the dropdown got closed + logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }") + + selection <- if (is.null(input$selection) && private$is_multiple()) { + character(0) + } else if (isTRUE(length(input$selection) != 1) && !private$is_multiple()) { + # In optionalSelectInput user is able to select mutliple options. But if FilterState is not multiple + # we should prevent this selection to be processed further. + # This is why notification is thrown and dropdown is changed back to latest selected. + showNotification(paste( + "This filter exclusively supports single selection.", + "Any additional choices made will be disregarded." + )) + teal.widgets::updateOptionalSelectInput( + session, "selection", + selected = private$get_selected() + ) + return(NULL) + } else { + input$selection + } + private$set_selected(selection) + } + } + ) + } + - private$observers$selection <- observeEvent( - ignoreNULL = FALSE, # it's possible that nothing is selected - ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state - eventExpr = input$selection, - handlerExpr = { - selection <- if (is.null(input$selection)) character(0) else input$selection - self$set_selected(selection) - logger::log_trace(sprintf( - "ChoicesFilterState$server@2 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname - )) - } - ) private$keep_na_srv("keep_na") - logger::log_trace("ChoicesFilterState$server initialized, dataname: { private$dataname }") + # this observer is needed in the situation when teal_slice$selected has been + # changed directly by the api - then it's needed to rerender UI element + # to show relevant values + private$observers$selection_api <- observeEvent(private$get_selected(), { + # it's important to not retrigger when the input$selection is the same as reactive values + # kept in the teal_slice$selected + if (!setequal(input$selection, private$get_selected())) { + logger::log_trace("ChoicesFilterState$server@1 state changed, id: { private$get_id() }") + if (private$is_checkboxgroup()) { + if (private$is_multiple()) { + updateCheckboxGroupInput( + inputId = "selection", + selected = private$get_selected() + ) + } else { + updateRadioButtons( + inputId = "selection", + selected = private$get_selected() + ) + } + } else { + teal.widgets::updateOptionalSelectInput( + session, "selection", + selected = private$get_selected() + ) + } + } + }) + + logger::log_trace("ChoicesFilterState$server_inputs initialized, id: { private$get_id() }") NULL } ) + }, + server_inputs_fixed = function(id) { + moduleServer( + id = id, + function(input, output, session) { + logger::log_trace("ChoicesFilterState$server_inputs_fixed initializing, id: { private$get_id() }") + + output$selection <- renderUI({ + countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices()))) + countsmax <- private$choices_counts + + ind <- private$get_choices() %in% shiny::isolate(private$get_selected()) + countBars( + inputId = session$ns("labels"), + choices = shiny::isolate(private$get_selected()), + countsnow = countsnow[ind], + countsmax = countsmax[ind] + ) + }) + + logger::log_trace("ChoicesFilterState$server_inputs_fixed initialized, id: { private$get_id() }") + NULL + } + ) + }, + + # @description + # UI module to display filter summary + # renders text describing number of selected levels + # and if NA are included also + content_summary = function(id) { + selected <- private$get_selected() + selected_length <- nchar(paste0(selected, collapse = "")) + if (selected_length <= 40) { + selected_text <- paste0(selected, collapse = ", ") + } else { + n_selected <- length(selected) + selected_text <- paste(n_selected, "levels selected") + } + tagList( + tags$span( + class = "filter-card-summary-value", + selected_text + ), + tags$span( + class = "filter-card-summary-controls", + if (isTRUE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("check") + ) + } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("xmark") + ) + } else { + NULL + } + ) + ) } ) ) diff --git a/R/FilterStateDate.R b/R/FilterStateDate.R index 7b1b0eb1a..6e7aa2456 100644 --- a/R/FilterStateDate.R +++ b/R/FilterStateDate.R @@ -7,34 +7,41 @@ #' #' @examples #' filter_state <- teal.slice:::DateFilterState$new( -#' c(Sys.Date() + seq(1:10), NA), -#' varname = "x", -#' dataname = "data", +#' x = c(Sys.Date() + seq(1:10), NA), +#' slice = teal_slice(varname = "x", dataname = "data"), #' extract_type = character(0) #' ) -#' isolate(filter_state$get_call()) -#' -#' isolate(filter_state$set_selected(c(Sys.Date() + 3L, Sys.Date() + 8L))) -#' isolate(filter_state$set_keep_na(TRUE)) -#' isolate(filter_state$get_call()) +#' shiny::isolate(filter_state$get_call()) +#' filter_state$set_state( +#' teal_slice( +#' dataname = "data", +#' varname = "x", +#' selected = c(Sys.Date() + 3L, Sys.Date() + 8L), +#' keep_na = TRUE +#' ) +#' ) +#' shiny::isolate(filter_state$get_call()) #' -#' \dontrun{ #' # working filter in an app #' library(shiny) +#' library(shinyjs) #' #' dates <- c(Sys.Date() - 100, Sys.Date()) #' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA) -#' filter_state_date <- DateFilterState$new( +#' fs <- teal.slice:::DateFilterState$new( #' x = data_date, -#' varname = "variable", -#' varlabel = "label" +#' slice = teal_slice( +#' dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE +#' ) #' ) -#' filter_state_date$set_state(list(selected = data_date[c(47, 98)], keep_na = TRUE)) #' #' ui <- fluidPage( +#' useShinyjs(), +#' teal.slice:::include_css_files(pattern = "filter-panel"), +#' teal.slice:::include_js_files(pattern = "count-bar-labels"), #' column(4, div( #' h4("DateFilterState"), -#' isolate(filter_state_date$ui("fs")) +#' fs$ui("fs") #' )), #' column(4, div( #' id = "outputs", # div id is needed for toggling the element @@ -56,28 +63,38 @@ #' ) #' #' server <- function(input, output, session) { -#' filter_state_date$server("fs") -#' output$condition_date <- renderPrint(filter_state_date$get_call()) -#' output$formatted_date <- renderText(filter_state_date$format()) -#' output$unformatted_date <- renderPrint(filter_state_date$get_state()) +#' fs$server("fs") +#' output$condition_date <- renderPrint(fs$get_call()) +#' output$formatted_date <- renderText(fs$format()) +#' output$unformatted_date <- renderPrint(fs$get_state()) #' # modify filter state programmatically -#' observeEvent(input$button1_date, filter_state_date$set_keep_na(FALSE)) -#' observeEvent(input$button2_date, filter_state_date$set_keep_na(TRUE)) +#' observeEvent( +#' input$button1_date, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) +#' ) +#' observeEvent( +#' input$button2_date, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) +#' ) #' observeEvent( #' input$button3_date, -#' filter_state_date$set_selected(data_date[c(34, 56)]) +#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)])) +#' ) +#' observeEvent( +#' input$button4_date, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates)) #' ) -#' observeEvent(input$button4_date, filter_state_date$set_selected(dates)) #' observeEvent( #' input$button0_date, -#' filter_state_date$set_state(list(selected = data_date[c(47, 98)], keep_na = TRUE)) +#' fs$set_state( +#' teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE) +#' ) #' ) #' } #' #' if (interactive()) { #' shinyApp(ui, server) #' } -#' } #' DateFilterState <- R6::R6Class( # nolint "DateFilterState", @@ -89,68 +106,50 @@ DateFilterState <- R6::R6Class( # nolint #' @description #' Initialize a `FilterState` object + #' #' @param x (`Date`)\cr #' values of the variable used in filter - #' @param varname (`character`, `name`)\cr - #' name of the variable - #' @param varlabel (`character(1)`)\cr - #' label of the variable (optional). - #' @param dataname (`character(1)`)\cr - #' optional name of dataset where `x` is taken from + #' @param x_reactive (`reactive`)\cr + #' returning vector of the same type as `x`. Is used to update + #' counts following the change in values of the filtered dataset. + #' If it is set to `reactive(NULL)` then counts based on filtered + #' dataset are not shown. + #' @param slice (`teal_slice`)\cr + #' object created using [teal_slice()]. `teal_slice` is stored + #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state` + #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice` + #' is a `reactiveValues` which means that changes in particular object are automatically + #' reflected in all places which refer to the same `teal_slice`. #' @param extract_type (`character(0)`, `character(1)`)\cr - #' whether condition calls should be prefixed by dataname. Possible values: + #' whether condition calls should be prefixed by `dataname`. Possible values: #' \itemize{ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed} #' \item{`"list"`}{ `varname` in the condition call will be returned as `$`} #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `[, ]`} #' } + #' @param ... additional arguments to be saved as a list in `private$extras` field + #' initialize = function(x, - varname, - varlabel = character(0), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0)) { - stopifnot(is(x, "Date")) - super$initialize(x, varname, varlabel, dataname, extract_type) - - var_range <- range(x, na.rm = TRUE) - private$set_choices(var_range) - self$set_selected(var_range) - - return(invisible(self)) - }, + shiny::isolate({ + checkmate::assert_date(x) + checkmate::assert_class(x_reactive, "reactive") - #' @description - #' Returns a formatted string representing this `DateFilterState`. - #' - #' @param indent (`numeric(1)`) the number of spaces before after each new line character of the formatted string. - #' Default: 0 - #' @return `character(1)` the formatted string - #' - format = function(indent = 0) { - checkmate::assert_number(indent, finite = TRUE, lower = 0) - - vals <- self$get_selected() - sprintf( - "%sFiltering on: %s\n%1$s Selected range: %s - %s\n%1$s Include missing values: %s", - format("", width = indent), - private$varname, - format(vals[1], nsmall = 3), - format(vals[2], nsmall = 3), - format(self$get_keep_na()) - ) - }, + super$initialize( + x = x, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type + ) + checkmate::assert_date(slice$choices, null.ok = TRUE) + private$set_choices(slice$choices) + if (is.null(slice$selected)) slice$selected <- slice$choices + private$set_selected(slice$selected) + }) - #' @description - #' Answers the question of whether the current settings and values selected actually filters out any values. - #' @return logical scalar - is_any_filtered = function() { - if (!setequal(self$get_selected(), private$choices)) { - TRUE - } else if (!isTRUE(self$get_keep_na()) && private$na_count > 0) { - TRUE - } else { - FALSE - } + invisible(self) }, #' @description @@ -158,65 +157,81 @@ DateFilterState <- R6::R6Class( # nolint #' For this class returned call looks like #' ` >= & <= ` with #' optional `is.na()`. + #' @param dataname `character(1)` containing possibly prefixed name of data set #' @return (`call`) - get_call = function() { - choices <- as.character(self$get_selected()) + #' + get_call = function(dataname) { + if (isFALSE(private$is_any_filtered())) { + return(NULL) + } + choices <- as.character(private$get_selected()) filter_call <- call( "&", - call(">=", private$get_varname_prefixed(), call("as.Date", choices[1L])), - call("<=", private$get_varname_prefixed(), call("as.Date", choices[2L])) + call(">=", private$get_varname_prefixed(dataname), call("as.Date", choices[1L])), + call("<=", private$get_varname_prefixed(dataname), call("as.Date", choices[2L])) ) private$add_keep_na_call(filter_call) - }, - - #' @description - #' Sets the selected time frame of this `DateFilterState`. - #' - #' @param value (`Date(2)`) the lower and the upper bound of the selected - #' time frame. Must not contain NA values. - #' - #' @return invisibly `NULL`. - #' - #' @note Casts the passed object to `Date` before validating the input - #' making it possible to pass any object coercible to `Date` to this method. - #' - #' @examples - #' date <- as.Date("13/09/2021") - #' filter <- teal.slice:::DateFilterState$new( - #' c(date, date + 1, date + 2, date + 3), - #' varname = "name" - #' ) - #' filter$set_selected(c(date + 1, date + 2)) - set_selected = function(value) { - super$set_selected(value) } ), # private methods ---- private = list( + set_choices = function(choices) { + if (is.null(choices)) { + choices <- range(private$x, na.rm = TRUE) + } else { + choices_adjusted <- c(max(choices[1L], min(private$x)), min(choices[2L], max(private$x))) + if (any(choices != choices_adjusted)) { + warning(sprintf( + "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", + private$get_varname(), private$get_dataname() + )) + choices <- choices_adjusted + } + if (choices[1L] >= choices[2L]) { + warning(sprintf( + "Invalid choices: lower is higher / equal to upper, or not in range of variable values. + Setting defaults. Varname: %s, dataname: %s.", + private$get_varname(), private$get_dataname() + )) + choices <- range(private$x, na.rm = TRUE) + } + } + private$set_is_choice_limited(private$x, choices) + private$x <- private$x[(private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x)] + private$teal_slice$choices <- choices + invisible(NULL) + }, + + # @description + # Check whether the initial choices filter out some values of x and set the flag in case. + set_is_choice_limited = function(xl, choices) { + private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE)) + invisible(NULL) + }, validate_selection = function(value) { if (!is(value, "Date")) { stop( sprintf( "value of the selection for `%s` in `%s` should be a Date", - self$get_varname(), - self$get_dataname() + private$get_varname(), + private$get_dataname() ) ) } pre_msg <- sprintf( "dataset '%s', variable '%s': ", - self$get_dataname(), - self$get_varname() + private$get_dataname(), + private$get_varname() ) - check_in_range(value, private$choices, pre_msg = pre_msg) + check_in_range(value, private$get_choices(), pre_msg = pre_msg) }, cast_and_validate = function(values) { tryCatch( expr = { - values <- as.Date(values) + values <- as.Date(values, origin = "1970-01-01") if (any(is.na(values))) stop() }, error = function(error) stop("The array of set values must contain values coercible to Date.") @@ -225,20 +240,35 @@ DateFilterState <- R6::R6Class( # nolint values }, remove_out_of_bound_values = function(values) { - if (values[1] < private$choices[1]) { - warning(paste( - "Value:", values[1], "is outside of the possible range for column", private$varname, - "of dataset", private$dataname, "." - )) - values[1] <- private$choices[1] + choices <- private$get_choices() + if (values[1] < choices[1L] | values[1] > choices[2L]) { + warning( + sprintf( + "Value: %s is outside of the possible range for column %s of dataset %s, setting minimum possible value.", + values[1], private$get_varname(), private$get_dataname() + ) + ) + values[1] <- choices[1L] } - if (values[2] > private$choices[2]) { - warning(paste( - "Value:", values[2], "is outside of the possible range for column", private$varname, - "of dataset", private$dataname, "." - )) - values[2] <- private$choices[2] + if (values[2] > choices[2L] | values[2] < choices[1L]) { + warning( + sprintf( + "Value: %s is outside of the possible range for column %s of dataset %s, setting maximum possible value.", + values[2], private$get_varname(), private$get_dataname() + ) + ) + values[2] <- choices[2L] + } + + if (values[1] > values[2]) { + warning( + sprintf( + "Start date %s is set after the end date %s, the values will be replaced with a default date range.", + values[1], values[2] + ) + ) + values <- c(choices[1L], choices[2L]) } values }, @@ -253,36 +283,38 @@ DateFilterState <- R6::R6Class( # nolint # id of shiny element ui_inputs = function(id) { ns <- NS(id) - div( + shiny::isolate({ div( - class = "flex", - actionButton( - class = "date_reset_button", - inputId = ns("start_date_reset"), - label = NULL, - icon = icon("fas fa-undo") - ), div( - class = "w-80 filter_datelike_input", - dateRangeInput( - inputId = ns("selection"), + class = "flex", + actionButton( + class = "date_reset_button", + inputId = ns("start_date_reset"), + label = NULL, + icon = icon("fas fa-undo") + ), + div( + class = "w-80 filter_datelike_input", + dateRangeInput( + inputId = ns("selection"), + label = NULL, + start = private$get_selected()[1], + end = private$get_selected()[2], + min = private$get_choices()[1L], + max = private$get_choices()[2L], + width = "100%" + ) + ), + actionButton( + class = "date_reset_button", + inputId = ns("end_date_reset"), label = NULL, - start = self$get_selected()[1], - end = self$get_selected()[2], - min = private$choices[1], - max = private$choices[2], - width = "100%" + icon = icon("fas fa-undo") ) ), - actionButton( - class = "date_reset_button", - inputId = ns("end_date_reset"), - label = NULL, - icon = icon("fas fa-undo") - ) - ), - private$keep_na_ui(ns("keep_na")) - ) + private$keep_na_ui(ns("keep_na")) + ) + }) }, # @description @@ -294,28 +326,24 @@ DateFilterState <- R6::R6Class( # nolint moduleServer( id = id, function(input, output, session) { - logger::log_trace("DateFilterState$server initializing, dataname: { private$dataname }") + logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }") - # this observer is needed in the situation when private$selected has been + # this observer is needed in the situation when teal_slice$selected has been # changed directly by the api - then it's needed to rerender UI element # to show relevant values private$observers$seletion_api <- observeEvent( ignoreNULL = TRUE, # dates needs to be selected ignoreInit = TRUE, - eventExpr = self$get_selected(), + eventExpr = private$get_selected(), handlerExpr = { - if (!setequal(self$get_selected(), input$selection)) { + if (!setequal(private$get_selected(), input$selection)) { + logger::log_trace("DateFilterState$server@1 state changed, id: { private$get_id() }") updateDateRangeInput( session = session, inputId = "selection", - start = self$get_selected()[1], - end = self$get_selected()[2] + start = private$get_selected()[1], + end = private$get_selected()[2] ) - logger::log_trace(sprintf( - "DateFilterState$server@1 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname - )) } } ) @@ -325,15 +353,16 @@ DateFilterState <- R6::R6Class( # nolint ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state eventExpr = input$selection, handlerExpr = { + logger::log_trace("DateFilterState$server@2 selection changed, id: { private$get_id() }") start_date <- input$selection[1] end_date <- input$selection[2] - - self$set_selected(c(start_date, end_date)) - logger::log_trace(sprintf( - "DateFilterState$server@2 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname - )) + if (start_date > end_date) { + showNotification( + "Start date must not be greater than the end date. Setting back to default values.", + type = "warning" + ) + } + private$set_selected(c(start_date, end_date)) } ) @@ -341,34 +370,80 @@ DateFilterState <- R6::R6Class( # nolint private$keep_na_srv("keep_na") private$observers$reset1 <- observeEvent(input$start_date_reset, { + logger::log_trace("DateFilterState$server@3 reset start date, id: { private$get_id() }") updateDateRangeInput( session = session, inputId = "selection", - start = private$choices[1] + start = private$get_choices()[1L] ) - logger::log_trace(sprintf( - "DateFilterState$server@3 reset start date of variable %s, dataname: %s", - private$varname, - private$dataname - )) }) private$observers$reset2 <- observeEvent(input$end_date_reset, { + logger::log_trace("DateFilterState$server@4 reset end date, id: { private$get_id() }") updateDateRangeInput( session = session, inputId = "selection", - end = private$choices[2] + end = private$get_choices()[2L] ) - logger::log_trace(sprintf( - "DateFilterState$server@4 reset end date of variable %s, dataname: %s", - private$varname, - private$dataname - )) }) - logger::log_trace("DateFilterState$server initialized, dataname: { private$dataname }") + + logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }") + NULL + } + ) + }, + server_inputs_fixed = function(id) { + moduleServer( + id = id, + function(input, output, session) { + logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }") + + output$selection <- renderUI({ + vals <- format(private$get_selected(), nsmall = 3) + div( + div(icon("calendar-days"), vals[1]), + div(span(" - "), icon("calendar-days"), vals[2]) + ) + }) + + logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }") NULL } ) + }, + + # @description + # Server module to display filter summary + # renders text describing selected date range and + # if NA are included also + content_summary = function(id) { + selected <- as.character(private$get_selected()) + min <- selected[1] + max <- selected[2] + tagList( + tags$span( + class = "filter-card-summary-value", + shiny::HTML(min, "–", max) + ), + tags$span( + class = "filter-card-summary-controls", + if (isTRUE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("check") + ) + } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("xmark") + ) + } else { + NULL + } + ) + ) } ) ) diff --git a/R/FilterStateDatettime.R b/R/FilterStateDatettime.R index fe62c2c22..934c323ad 100644 --- a/R/FilterStateDatettime.R +++ b/R/FilterStateDatettime.R @@ -7,34 +7,41 @@ #' #' @examples #' filter_state <- teal.slice:::DatetimeFilterState$new( -#' c(Sys.time() + seq(0, by = 3600, length.out = 10), NA), -#' varname = "x", -#' dataname = "data", +#' x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA), +#' slice = teal_slice(varname = "x", dataname = "data"), #' extract_type = character(0) #' ) +#' shiny::isolate(filter_state$get_call()) +#' filter_state$set_state( +#' teal_slice( +#' dataname = "data", +#' varname = "x", +#' selected = c(Sys.time() + 3L, Sys.time() + 8L), +#' keep_na = TRUE +#' ) +#' ) +#' shiny::isolate(filter_state$get_call()) #' -#' isolate(filter_state$get_call()) -#' isolate(filter_state$set_selected(c(Sys.time() + 3L, Sys.time() + 8L))) -#' isolate(filter_state$set_keep_na(TRUE)) -#' isolate(filter_state$get_call()) -#' -#' \dontrun{ #' # working filter in an app #' library(shiny) +#' library(shinyjs) #' #' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00")) #' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA) -#' filter_state_datetime <- DatetimeFilterState$new( +#' fs <- teal.slice:::DatetimeFilterState$new( #' x = data_datetime, -#' varname = "variable", -#' varlabel = "label" +#' slice = teal_slice( +#' varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE +#' ) #' ) -#' filter_state_datetime$set_state(list(selected = data_datetime[c(47, 98)], keep_na = TRUE)) #' #' ui <- fluidPage( +#' useShinyjs(), +#' teal.slice:::include_css_files(pattern = "filter-panel"), +#' teal.slice:::include_js_files(pattern = "count-bar-labels"), #' column(4, div( #' h4("DatetimeFilterState"), -#' isolate(filter_state_datetime$ui("fs")) +#' fs$ui("fs") #' )), #' column(4, div( #' id = "outputs", # div id is needed for toggling the element @@ -56,28 +63,44 @@ #' ) #' #' server <- function(input, output, session) { -#' filter_state_datetime$server("fs") -#' output$condition_datetime <- renderPrint(filter_state_datetime$get_call()) -#' output$formatted_datetime <- renderText(filter_state_datetime$format()) -#' output$unformatted_datetime <- renderPrint(filter_state_datetime$get_state()) +#' fs$server("fs") +#' output$condition_datetime <- renderPrint(fs$get_call()) +#' output$formatted_datetime <- renderText(fs$format()) +#' output$unformatted_datetime <- renderPrint(fs$get_state()) #' # modify filter state programmatically -#' observeEvent(input$button1_datetime, filter_state_datetime$set_keep_na(FALSE)) -#' observeEvent(input$button2_datetime, filter_state_datetime$set_keep_na(TRUE)) +#' observeEvent( +#' input$button1_datetime, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) +#' ) +#' observeEvent( +#' input$button2_datetime, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) +#' ) #' observeEvent( #' input$button3_datetime, -#' filter_state_datetime$set_selected(data_datetime[c(34, 56)]) +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)]) +#' ) +#' ) +#' observeEvent( +#' input$button4_datetime, +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "x", selected = datetimes) +#' ) #' ) -#' observeEvent(input$button4_datetime, filter_state_datetime$set_selected(datetimes)) #' observeEvent( #' input$button0_datetime, -#' filter_state_datetime$set_state(list(selected = data_datetime[c(47, 98)], keep_na = TRUE)) +#' fs$set_state( +#' teal_slice( +#' dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE +#' ) +#' ) #' ) #' } #' #' if (interactive()) { #' shinyApp(ui, server) #' } -#' } #' DatetimeFilterState <- R6::R6Class( # nolint "DatetimeFilterState", @@ -93,69 +116,50 @@ DatetimeFilterState <- R6::R6Class( # nolint #' default. However, in case when using this module in `teal` app, one needs #' timezone of the app user. App user timezone is taken from `session$userData$timezone` #' and is set only if object is initialized in `shiny`. + #' #' @param x (`POSIXct` or `POSIXlt`)\cr #' values of the variable used in filter - #' @param varname (`character`, `name`)\cr - #' name of the variable - #' @param varlabel (`character(1)`)\cr - #' label of the variable (optional). - #' @param dataname (`character(1)`)\cr - #' optional name of dataset where `x` is taken from + #' @param x_reactive (`reactive`)\cr + #' returning vector of the same type as `x`. Is used to update + #' counts following the change in values of the filtered dataset. + #' If it is set to `reactive(NULL)` then counts based on filtered + #' dataset are not shown. + #' @param slice (`teal_slice`)\cr + #' object created using [teal_slice()]. `teal_slice` is stored + #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state` + #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice` + #' is a `reactiveValues` which means that changes in particular object are automatically + #' reflected in all places which refer to the same `teal_slice`. #' @param extract_type (`character(0)`, `character(1)`)\cr - #' whether condition calls should be prefixed by dataname. Possible values: + #' whether condition calls should be prefixed by `dataname`. Possible values: #' \itemize{ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed} #' \item{`"list"`}{ `varname` in the condition call will be returned as `$`} #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `[, ]`} #' } + #' @param ... additional arguments to be saved as a list in `private$extras` field + #' initialize = function(x, - varname, - varlabel = character(0), - dataname = NULL, - extract_type = character(0)) { - checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt")) - super$initialize(x, varname, varlabel, dataname, extract_type) - - var_range <- as.POSIXct(trunc(range(x, na.rm = TRUE), units = "secs")) - private$set_choices(var_range) - self$set_selected(var_range) - - return(invisible(self)) - }, + x_reactive = reactive(NULL), + extract_type = character(0), + slice) { + shiny::isolate({ + checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt")) + checkmate::assert_class(x_reactive, "reactive") - #' @description - #' Returns a formatted string representing this `DatetimeFilterState`. - #' - #' @param indent (`numeric(1)`) the number of spaces before after each new line character of the formatted string. - #' Default: 0 - #' @return `character(1)` the formatted string - #' - format = function(indent = 0) { - checkmate::assert_number(indent, finite = TRUE, lower = 0) - - - vals <- self$get_selected() - sprintf( - "%sFiltering on: %s\n%1$s Selected range: %s - %s\n%1$s Include missing values: %s", - format("", width = indent), - private$varname, - format(vals[1], nsmall = 3), - format(vals[2], nsmall = 3), - format(self$get_keep_na()) - ) - }, + super$initialize( + x = x, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type + ) + checkmate::assert_multi_class(slice$choices, c("POSIXct", "POSIXlt"), null.ok = TRUE) + private$set_choices(slice$choices) + if (is.null(slice$selected)) slice$selected <- slice$choices + private$set_selected(slice$selected) + }) - #' @description - #' Answers the question of whether the current settings and values selected actually filters out any values. - #' @return logical scalar - is_any_filtered = function() { - if (!setequal(self$get_selected(), private$choices)) { - TRUE - } else if (!isTRUE(self$get_keep_na()) && private$na_count > 0) { - TRUE - } else { - FALSE - } + invisible(self) }, #' @description @@ -163,52 +167,39 @@ DatetimeFilterState <- R6::R6Class( # nolint #' For this class returned call looks like #' ` >= as.POSIXct() & <= )` #' with optional `is.na()`. - get_call = function() { - choices <- self$get_selected() + #' @param dataname name of data set; defaults to `private$get_dataname()` + #' @return (`call`) + #' + get_call = function(dataname) { + if (isFALSE(private$is_any_filtered())) { + return(NULL) + } + if (missing(dataname)) dataname <- private$get_dataname() + choices <- private$get_selected() tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone")) class <- class(choices)[1L] - date_fun <- as.name(switch(class, - "POSIXct" = "as.POSIXct", - "POSIXlt" = "as.POSIXlt" - )) + date_fun <- as.name( + switch(class, + "POSIXct" = "as.POSIXct", + "POSIXlt" = "as.POSIXlt" + ) + ) choices <- as.character(choices + c(0, 1)) filter_call <- call( "&", call( ">=", - private$get_varname_prefixed(), + private$get_varname_prefixed(dataname), as.call(list(date_fun, choices[1L], tz = tzone)) ), call( "<", - private$get_varname_prefixed(), + private$get_varname_prefixed(dataname), as.call(list(date_fun, choices[2L], tz = tzone)) ) ) - private$add_keep_na_call(filter_call) - }, - - #' @description - #' Sets the selected time frame of this `DatetimeFilterState`. - #' - #' @param value (`POSIX(2)`) the lower and the upper bound of the selected - #' time frame. Must not contain NA values. - #' - #' @return invisibly `NULL`. - #' - #' @note Casts the passed object to `POSIXct` before validating the input - #' making it possible to pass any object coercible to `POSIXct` to this method. - #' - #' @examples - #' date <- as.POSIXct(1, origin = "01/01/1970") - #' filter <- teal.slice:::DatetimeFilterState$new( - #' c(date, date + 1, date + 2, date + 3), - #' varname = "name" - #' ) - #' filter$set_selected(c(date + 1, date + 2)) - set_selected = function(value) { - super$set_selected(value) + private$add_keep_na_call(filter_call, dataname) } ), @@ -216,28 +207,69 @@ DatetimeFilterState <- R6::R6Class( # nolint private = list( # private methods ---- + set_choices = function(choices) { + if (is.null(choices)) { + choices <- as.POSIXct(trunc(range(private$x, na.rm = TRUE), units = "secs")) + } else { + choices <- as.POSIXct(choices, units = "secs") + choices_adjusted <- c( + max(choices[1L], min(as.POSIXct(private$x), na.rm = TRUE)), + min(choices[2L], max(as.POSIXct(private$x), na.rm = TRUE)) + ) + if (any(choices != choices_adjusted)) { + warning(sprintf( + "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", + private$get_varname(), private$get_dataname() + )) + choices <- choices_adjusted + } + if (choices[1L] >= choices[2L]) { + warning(sprintf( + "Invalid choices: lower is higher / equal to upper, or not in range of variable values. + Setting defaults. Varname: %s, dataname: %s.", + private$get_varname(), private$get_dataname() + )) + choices <- range(private$x, na.rm = TRUE) + } + } + + private$set_is_choice_limited(private$x, choices) + private$x <- private$x[ + (as.POSIXct(trunc(private$x, units = "secs")) >= choices[1L] & + as.POSIXct(trunc(private$x, units = "secs")) <= choices[2L]) | is.na(private$x) + ] + private$teal_slice$choices <- choices + invisible(NULL) + }, + + # @description + # Check whether the initial choices filter out some values of x and set the flag in case. + set_is_choice_limited = function(xl, choices = NULL) { + private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE)) + invisible(NULL) + }, validate_selection = function(value) { if (!(is(value, "POSIXct") || is(value, "POSIXlt"))) { stop( sprintf( "value of the selection for `%s` in `%s` should be a POSIXct or POSIXlt", - self$get_varname(), - self$get_dataname() + private$get_varname(), + private$get_dataname() ) ) } pre_msg <- sprintf( "dataset '%s', variable '%s': ", - self$get_dataname(), - self$get_varname() + private$get_dataname(), + private$get_varname() ) - check_in_range(value, private$choices, pre_msg = pre_msg) + check_in_range(value, private$get_choices(), pre_msg = pre_msg) }, cast_and_validate = function(values) { tryCatch( expr = { - values <- as.POSIXct(values) + values <- as.POSIXct(values, origin = "1970-01-01 00:00:00") if (any(is.na(values))) stop() }, error = function(error) stop("The array of set values must contain values coercible to POSIX.") @@ -246,20 +278,35 @@ DatetimeFilterState <- R6::R6Class( # nolint values }, remove_out_of_bound_values = function(values) { - if (values[1] < private$choices[1]) { - warning(paste( - "Value:", values[1], "is outside of the possible range for column", private$varname, - "of dataset", private$dataname, "." - )) - values[1] <- private$choices[1] + choices <- private$get_choices() + if (values[1] < choices[1L] || values[1] > choices[2L]) { + warning( + sprintf( + "Value: %s is outside of the range for the column '%s' in dataset '%s', setting minimum possible value.", + values[1], private$get_varname(), toString(private$get_dataname()) + ) + ) + values[1] <- choices[1L] } - if (values[2] > private$choices[2]) { - warning(paste( - "Value:", values[2], "is outside of the possible range for column", private$varname, - "of dataset", private$dataname, "." - )) - values[2] <- private$choices[2] + if (values[2] > choices[2L] | values[2] < choices[1L]) { + warning( + sprintf( + "Value: '%s' is outside of the range for the column '%s' in dataset '%s', setting maximum possible value.", + values[2], private$get_varname(), toString(private$get_dataname()) + ) + ) + values[2] <- choices[2L] + } + + if (values[1] > values[2]) { + warning( + sprintf( + "Start date '%s' is set after the end date '%s', the values will be replaced by a default datetime range.", + values[1], values[2] + ) + ) + values <- c(choices[1L], choices[2L]) } values }, @@ -274,62 +321,64 @@ DatetimeFilterState <- R6::R6Class( # nolint # id of shiny element ui_inputs = function(id) { ns <- NS(id) - div( + + shiny::isolate({ + ui_input_1 <- shinyWidgets::airDatepickerInput( + inputId = ns("selection_start"), + value = private$get_selected()[1], + startView = private$get_selected()[1], + timepicker = TRUE, + minDate = private$get_choices()[1L], + maxDate = private$get_choices()[2L], + update_on = "close", + addon = "none", + position = "bottom right" + ) + ui_input_2 <- shinyWidgets::airDatepickerInput( + inputId = ns("selection_end"), + value = private$get_selected()[2], + startView = private$get_selected()[2], + timepicker = TRUE, + minDate = private$get_choices()[1L], + maxDate = private$get_choices()[2L], + update_on = "close", + addon = "none", + position = "bottom right" + ) + ui_reset_1 <- actionButton( + class = "date_reset_button", + inputId = ns("start_date_reset"), + label = NULL, + icon = icon("fas fa-undo") + ) + ui_reset_2 <- actionButton( + class = "date_reset_button", + inputId = ns("end_date_reset"), + label = NULL, + icon = icon("fas fa-undo") + ) + ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm")) + ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm")) + div( - class = "flex", - actionButton( - class = "date_reset_button", - inputId = ns("start_date_reset"), - label = NULL, - icon = icon("fas fa-undo") - ), div( - class = "flex w-80 filter_datelike_input", - div(class = "w-45 text-center", { - x <- shinyWidgets::airDatepickerInput( - inputId = ns("selection_start"), - value = self$get_selected()[1], - startView = self$get_selected()[1], - timepicker = TRUE, - minDate = private$choices[1], - maxDate = private$choices[2], - update_on = "close", - addon = "none", - position = "bottom right" - ) - x$children[[2]]$attribs <- c(x$children[[2]]$attribs, list(class = "input-sm")) - x - }), - span( - class = "input-group-addon w-10", - span(class = "input-group-text w-100 justify-content-center", "to"), - title = "Times are displayed in the local timezone and are converted to UTC in the analysis" + class = "flex", + ui_reset_1, + div( + class = "flex w-80 filter_datelike_input", + div(class = "w-45 text-center", ui_input_1), + span( + class = "input-group-addon w-10", + span(class = "input-group-text w-100 justify-content-center", "to"), + title = "Times are displayed in the local timezone and are converted to UTC in the analysis" + ), + div(class = "w-45 text-center", ui_input_2) ), - div(class = "w-45 text-center", { - x <- shinyWidgets::airDatepickerInput( - inputId = ns("selection_end"), - value = self$get_selected()[2], - startView = self$get_selected()[2], - timepicker = TRUE, - minDate = private$choices[1], - maxDate = private$choices[2], - update_on = "close", - addon = "none", - position = "bottom right" - ) - x$children[[2]]$attribs <- c(x$children[[2]]$attribs, list(class = "input-sm")) - x - }) + ui_reset_2 ), - actionButton( - class = "date_reset_button", - inputId = ns("end_date_reset"), - label = NULL, - icon = icon("fas fa-undo") - ) - ), - private$keep_na_ui(ns("keep_na")) - ) + private$keep_na_ui(ns("keep_na")) + ) + }) }, # @description @@ -341,73 +390,92 @@ DatetimeFilterState <- R6::R6Class( # nolint moduleServer( id = id, function(input, output, session) { - logger::log_trace("DatetimeFilterState$server initializing, dataname: { private$dataname }") - - # this observer is needed in the situation when private$selected has been + logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }") + # this observer is needed in the situation when teal_slice$selected has been # changed directly by the api - then it's needed to rerender UI element # to show relevant values private$observers$selection_api <- observeEvent( ignoreNULL = TRUE, # dates needs to be selected ignoreInit = TRUE, # on init selected == default, so no need to trigger - eventExpr = self$get_selected(), + eventExpr = private$get_selected(), handlerExpr = { start_date <- input$selection_start end_date <- input$selection_end - if (!all(self$get_selected() == c(start_date, end_date))) { - if (self$get_selected()[1] != start_date) { + if (!all(private$get_selected() == c(start_date, end_date))) { + logger::log_trace("DatetimeFilterState$server@1 state changed, id: { private$get_id() }") + if (private$get_selected()[1] != start_date) { shinyWidgets::updateAirDateInput( session = session, inputId = "selection_start", - value = self$get_selected()[1] + value = private$get_selected()[1] ) } - if (self$get_selected()[2] != end_date) { + if (private$get_selected()[2] != end_date) { shinyWidgets::updateAirDateInput( session = session, inputId = "selection_end", - value = self$get_selected()[2] + value = private$get_selected()[2] ) } - - logger::log_trace(sprintf( - "DatetimeFilterState$server@1 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname - )) } } ) - private$observers$selection <- observeEvent( + private$observers$selection_start <- observeEvent( ignoreNULL = TRUE, # dates needs to be selected ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state - eventExpr = { - input$selection_start - input$selection_end - }, + eventExpr = input$selection_start, handlerExpr = { + logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }") start_date <- input$selection_start - end_date <- input$selection_end - tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$choices), "tzone")) + end_date <- private$get_selected()[[2]] + tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone")) attr(start_date, "tzone") <- tzone - attr(end_date, "tzone") <- tzone - if (start_date < private$choices[1]) { - start_date <- private$choices[1] + if (start_date > end_date) { + showNotification( + "Start date must not be greater than the end date. Ignoring selection.", + type = "warning" + ) + shinyWidgets::updateAirDateInput( + session = session, + inputId = "selection_start", + value = private$get_selected()[1] # sets back to latest selected value + ) + return(NULL) } - if (end_date > private$choices[2]) { - end_date <- private$choices[2] + private$set_selected(c(start_date, end_date)) + } + ) + + private$observers$selection_end <- observeEvent( + ignoreNULL = TRUE, # dates needs to be selected + ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state + eventExpr = input$selection_end, + handlerExpr = { + start_date <- private$get_selected()[1] + end_date <- input$selection_end + tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone")) + attr(end_date, "tzone") <- tzone + + if (start_date > end_date) { + showNotification( + "End date must not be lower than the start date. Ignoring selection.", + type = "warning" + ) + shinyWidgets::updateAirDateInput( + session = session, + inputId = "selection_end", + value = private$get_selected()[2] # sets back to latest selected value + ) + return(NULL) } - self$set_selected(c(start_date, end_date)) - logger::log_trace(sprintf( - "DatetimeFilterState$server@2 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname - )) + private$set_selected(c(start_date, end_date)) + logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }") } ) @@ -421,13 +489,9 @@ DatetimeFilterState <- R6::R6Class( # nolint shinyWidgets::updateAirDateInput( session = session, inputId = "selection_start", - value = private$choices[1] + value = private$get_choices()[1L] ) - logger::log_trace(sprintf( - "DatetimeFilterState$server@2 reset start date of variable %s, dataname: %s", - private$varname, - private$dataname - )) + logger::log_trace("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }") } ) private$observers$reset2 <- observeEvent( @@ -438,19 +502,69 @@ DatetimeFilterState <- R6::R6Class( # nolint shinyWidgets::updateAirDateInput( session = session, inputId = "selection_end", - value = private$choices[2] + value = private$get_choices()[2L] ) - logger::log_trace(sprintf( - "DatetimeFilterState$server@3 reset end date of variable %s, dataname: %s", - private$varname, - private$dataname - )) + logger::log_trace("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }") } ) - logger::log_trace("DatetimeFilterState$server initialized, dataname: { private$dataname }") + + logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }") + NULL + } + ) + }, + server_inputs_fixed = function(id) { + moduleServer( + id = id, + function(input, output, session) { + logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }") + + output$selection <- renderUI({ + vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3) + div( + div(icon("clock"), vals[1]), + div(span(" - "), icon("clock"), vals[2]) + ) + }) + + logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }") NULL } ) + }, + + # @description + # UI module to display filter summary + # renders text describing selected date range and + # if NA are included also + content_summary = function(id) { + selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S") + min <- selected[1] + max <- selected[2] + tagList( + tags$span( + class = "filter-card-summary-value", + shiny::HTML(min, "–", max) + ), + tags$span( + class = "filter-card-summary-controls", + if (isTRUE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("check") + ) + } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("xmark") + ) + } else { + NULL + } + ) + ) } ) ) diff --git a/R/FilterStateEmpty.R b/R/FilterStateEmpty.R index e1903c0c3..8de190e03 100644 --- a/R/FilterStateEmpty.R +++ b/R/FilterStateEmpty.R @@ -7,15 +7,13 @@ #' #' @examples #' filter_state <- teal.slice:::EmptyFilterState$new( -#' NA, -#' varname = "x", -#' dataname = "data", +#' x = NA, +#' slice = teal_slice(varname = "x", dataname = "data"), #' extract_type = character(0) #' ) -#' isolate(filter_state$get_call()) -#' isolate(filter_state$set_selected(TRUE)) -#' isolate(filter_state$set_keep_na(TRUE)) -#' isolate(filter_state$get_call()) +#' shiny::isolate(filter_state$get_call()) +#' filter_state$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) +#' shiny::isolate(filter_state$get_call()) #' EmptyFilterState <- R6::R6Class( # nolint "EmptyFilterState", @@ -23,44 +21,48 @@ EmptyFilterState <- R6::R6Class( # nolint # public methods ---- public = list( + #' @description #' Initialize `EmptyFilterState` object. #' #' @param x (`vector`)\cr #' values of the variable used in filter - #' @param varname (`character`, `name`)\cr - #' name of the variable - #' @param varlabel (`character(1)`)\cr - #' label of the variable (optional). - #' @param dataname (`character(1)`)\cr - #' optional name of dataset where `x` is taken from + #' @param x_reactive (`reactive`)\cr + #' returning vector of the same type as `x`. Is used to update + #' counts following the change in values of the filtered dataset. + #' If it is set to `reactive(NULL)` then counts based on filtered + #' dataset are not shown. + #' @param slice (`teal_slice`)\cr + #' object created using [teal_slice()]. `teal_slice` is stored + #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state` + #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice` + #' is a `reactiveValues` which means that changes in particular object are automatically + #' reflected in all places which refer to the same `teal_slice`. #' @param extract_type (`character(0)`, `character(1)`)\cr - #' whether condition calls should be prefixed by dataname. Possible values: + #' whether condition calls should be prefixed by `dataname`. Possible values: #' \itemize{ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed} #' \item{`"list"`}{ `varname` in the condition call will be returned as `$`} #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `[, ]`} #' } + #' @param ... additional arguments to be saved as a list in `private$extras` field #' initialize = function(x, - varname, - varlabel = character(0), - dataname = NULL, - extract_type = character(0)) { - super$initialize(x, varname, varlabel, dataname, extract_type) - private$set_choices(list()) - self$set_selected(list()) + x_reactive = reactive(NULL), + extract_type = character(0), + slice) { + shiny::isolate({ + super$initialize( + x = x, + x_reactive = x_reactive, + slice = slice, + extract_type = extract_type + ) + private$set_choices(slice$choices) + private$set_selected(slice$selected) + }) - return(invisible(self)) - }, - - #' @description - #' Reports whether the current state filters out any values.(?) - #' - #' @return `logical(1)` - #' - is_any_filtered = function() { - !isTRUE(self$get_keep_na()) + invisible(self) }, #' @description @@ -68,59 +70,50 @@ EmptyFilterState <- R6::R6Class( # nolint #' for selected variable type. #' Uses internal reactive values, hence must be called #' in reactive or isolated context. - #' + #' @param dataname name of data set; defaults to `private$get_dataname()` #' @return `logical(1)` #' - get_call = function() { - filter_call <- if (isTRUE(self$get_keep_na())) { - call("is.na", private$get_varname_prefixed()) + get_call = function(dataname) { + if (isFALSE(private$is_any_filtered())) { + return(NULL) + } + if (missing(dataname)) dataname <- private$get_dataname() + filter_call <- if (isTRUE(private$get_keep_na())) { + call("is.na", private$get_varname_prefixed(dataname)) } else { - FALSE + substitute(!is.na(varname), list(varname = private$get_varname_prefixed(dataname))) } - }, + } + ), - #' @description - #' Returns the filtering state. - #' - #' @return `list` containing values taken from the reactive fields: - #' * `keep_na` (`logical(1)`) whether `NA` should be kept. - #' - get_state = function() { - list( - keep_na = self$get_keep_na() + # private members ---- + private = list( + cache_state = function() { + private$cache <- private$get_state() + self$set_state( + list( + keep_na = NULL + ) ) }, + set_choices = function(choices) { + private$teal_slice$choices <- choices + invisible(NULL) + }, - #' @description - #' Set state. - #' - #' @param state (`list`)\cr - #' contains fields relevant for specific class: - #' \itemize{ - #' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values} - #' } - #' - #' @return NULL invisibly - set_state = function(state) { - if (!is.null(state$selected)) { - stop( - sprintf( - "All values in variable '%s' are `NA`. Unable to apply filter values \n %s", - private$varname, - paste(state$selected, collapse = ", ") - ) - ) - } - stopifnot(is.list(state) && all(names(state) == "keep_na")) - if (!is.null(state$keep_na)) { - self$set_keep_na(state$keep_na) + + # Reports whether the current state filters out any values.(?) + # + # @return `logical(1)` + # + is_any_filtered = function() { + if (private$is_choice_limited) { + TRUE + } else { + !isTRUE(private$get_keep_na()) } - invisible(NULL) - } - ), + }, - # private members ---- - private = list( # @description # UI Module for `EmptyFilterState`. # This UI element contains a checkbox input to filter or keep missing values. @@ -130,15 +123,17 @@ EmptyFilterState <- R6::R6Class( # nolint # ui_inputs = function(id) { ns <- NS(id) - fluidRow( - div( - class = "relative", + shiny::isolate({ + fluidRow( div( - span("Variable contains missing values only"), - private$keep_na_ui(ns("keep_na")) + class = "relative", + div( + span("Variable contains missing values only"), + private$keep_na_ui(ns("keep_na")) + ) ) ) - ) + }) }, # @description @@ -156,6 +151,29 @@ EmptyFilterState <- R6::R6Class( # nolint private$keep_na_srv("keep_na") } ) + }, + server_inputs_fixed = function(id) { + moduleServer( + id = id, + function(input, output, session) { + output$selection <- renderUI({ + div( + class = "relative", + div( + span("Variable contains missing values only") + ) + ) + }) + NULL + } + ) + }, + + # @description + # Server module to display filter summary + # Doesn't render anything + content_summary = function(id) { + tags$span("All empty") } ) ) diff --git a/R/FilterStateExpr.R b/R/FilterStateExpr.R new file mode 100644 index 000000000..6b9fad13d --- /dev/null +++ b/R/FilterStateExpr.R @@ -0,0 +1,234 @@ +#' @name FilterStateExpr +#' @docType class +#' +#' +#' @title `FilterStateExpr` Class +#' +#' @description Class to handle filter expression. +#' +#' +#' @details +#' This class is responsible for displaying filter card and returning filter expression +#' +#' @keywords internal +#' +#' @examples +#' filter_state <- teal.slice:::FilterStateExpr$new( +#' slice = teal_slice( +#' dataname = "x", +#' id = "FA", +#' title = "Adult females", +#' expr = "sex == 'F' & age >= 18" +#' ) +#' ) +#' filter_state$get_call() +#' +#' # working filter in an app +#' library(shiny) +#' library(shinyjs) +#' +#' ui <- fluidPage( +#' useShinyjs(), +#' teal.slice:::include_css_files(pattern = "filter-panel"), +#' teal.slice:::include_js_files(pattern = "count-bar-labels"), +#' column(4, div( +#' h4("ChoicesFilterState"), +#' filter_state$ui("fs") +#' )), +#' column(8, div( +#' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState +#' textOutput("condition_choices"), br(), +#' h4("Unformatted state"), # display raw filter state +#' textOutput("unformatted_choices"), br(), +#' h4("Formatted state"), # display human readable filter state +#' textOutput("formatted_choices"), br() +#' )) +#' ) +#' +#' server <- function(input, output, session) { +#' filter_state$server("fs") +#' output$condition_choices <- renderPrint(filter_state$get_call()) +#' output$formatted_choices <- renderText(filter_state$format()) +#' output$unformatted_choices <- renderPrint(filter_state$get_state()) +#' } +#' +#' if (interactive()) { +#' shinyApp(ui, server) +#' } +FilterStateExpr <- R6::R6Class( # nolint + classname = "FilterStateExpr", + # public methods ---- + public = list( + #' @description + #' Initialize a `FilterStateExpr` object + #' @param slice (`teal_slice_expr`)\cr + #' object created by [teal_slice()] + #' @return `FilterStateExpr` + initialize = function(slice) { + checkmate::assert_class(slice, "teal_slice_expr") + private$teal_slice <- slice + invisible(self) + }, + + #' @description + #' Returns a formatted string representing this `FilterStateExpr` object. + #' + #' @param show_all `logical(1)` passed to `format.teal_slice` + #' @param trim_lines `logical(1)` passed to `format.teal_slice` + #' + #' @return `character(1)` the formatted string + #' + format = function(show_all = FALSE, trim_lines = TRUE) { + sprintf( + "%s:\n%s", + class(self)[1], + format(self$get_state(), show_all = show_all, trim_lines = trim_lines) + ) + }, + + #' @description + #' Prints this `FilterStateExpr` object. + #' + #' @param ... additional arguments + print = function(...) { + cat(shiny::isolate(self$format(...))) + }, + + #' @description + #' Returns filtering state. + #' + #' @return A `teal_slice` object. + #' + get_state = function() { + private$teal_slice + }, + + #' @description + #' Sets filtering state. + #' + #' @param state a `teal_slice` object + #' + #' @return `self` invisibly + #' + set_state = function(state) { + checkmate::assert_class(state, "teal_slice_expr") + invisible(NULL) + }, + + #' @description + #' Get reproducible call + #' + #' @param dataname (`ignored`) for a consistency with `FilterState` + #' + #' Returns reproducible condition call for current selection relevant + #' for selected variable type. + #' Method is using internal reactive values which makes it reactive + #' and must be executed in reactive or isolated context. + #' @return `language` + get_call = function(dataname) { + shiny::isolate(str2lang(private$teal_slice$expr)) + }, + + #' @description + #' Destroy observers stored in `private$observers`. + #' + #' @return NULL invisibly + #' + destroy_observers = function() { + lapply(private$observers, function(x) x$destroy()) + invisible(NULL) + }, + + # public shiny modules ---- + + #' @description + #' Shiny module server. + #' + #' @param id (`character(1)`)\cr + #' shiny module instance id + #' + #' @return `moduleServer` function which returns reactive value + #' signaling that remove button has been clicked + #' + server = function(id) { + moduleServer( + id = id, + function(input, output, session) { + private$server_summary("summary") + out <- reactive(input$remove) # back to parent to remove self + out + } + ) + }, + + #' @description + #' Shiny module UI. + #' + #' @param id (`character(1)`)\cr + #' shiny element (module instance) id; + #' the UI for this class contains simple message stating that it is not supported + #' @param parent_id (`character(1)`) id of the `FilterStates` card container + ui = function(id, parent_id = "cards") { + ns <- NS(id) + shiny::isolate({ + tags$div( + id = id, + class = "panel filter-card", + include_js_files("count-bar-labels.js"), + tags$div( + class = "filter-card-header", + tags$div( + class = "filter-card-title", + icon("lock"), + tags$span(tags$strong(private$teal_slice$id)), + tags$span(private$teal_slice$title, class = "filter-card-varlabel") + ), + tags$div( + class = "filter-card-controls", + actionLink( + inputId = ns("remove"), + label = icon("circle-xmark", lib = "font-awesome"), + class = "filter-card-remove" + ) + ), + tags$div( + class = "filter-card-summary", + private$ui_summary(ns("summary")) + ) + ) + ) + }) + } + ), + + # private members ---- + + private = list( + observers = NULL, # stores observers + teal_slice = NULL, # stores reactiveValues + + # @description + # Server module to display filter summary + # @param id `shiny` id parameter + ui_summary = function(id) { + ns <- NS(id) + uiOutput(ns("summary"), class = "filter-card-summary") + }, + + # @description + # UI module to display filter summary + # @param shiny `id` parametr passed to moduleServer + # renders text describing current state + server_summary = function(id) { + moduleServer( + id = id, + function(input, output, session) { + private$content_summary() + } + ) + }, + content_summary = function() { + shiny::isolate(private$teal_slice$expr) + } + ) +) diff --git a/R/FilterStateLogical.R b/R/FilterStateLogical.R index 77782a2ea..b20bc3764 100644 --- a/R/FilterStateLogical.R +++ b/R/FilterStateLogical.R @@ -7,33 +7,32 @@ #' #' @examples #' filter_state <- teal.slice:::LogicalFilterState$new( -#' sample(c(TRUE, FALSE, NA), 10, replace = TRUE), -#' varname = "x", -#' dataname = "data", -#' extract_type = character(0) +#' x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE), +#' slice = teal_slice(varname = "x", dataname = "data") #' ) -#' isolate(filter_state$get_call()) -#' -#' isolate(filter_state$set_selected(TRUE)) -#' isolate(filter_state$set_keep_na(TRUE)) -#' isolate(filter_state$get_call()) +#' shiny::isolate(filter_state$get_call()) +#' filter_state$set_state( +#' teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE) +#' ) +#' shiny::isolate(filter_state$get_call()) #' -#' \dontrun{ #' # working filter in an app #' library(shiny) +#' library(shinyjs) #' #' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA) -#' filter_state_logical <- LogicalFilterState$new( +#' fs <- teal.slice:::LogicalFilterState$new( #' x = data_logical, -#' varname = "variable", -#' varlabel = "label" +#' slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE) #' ) -#' filter_state_logical$set_state(list(selected = FALSE, keep_na = TRUE)) #' #' ui <- fluidPage( +#' useShinyjs(), +#' teal.slice:::include_css_files(pattern = "filter-panel"), +#' teal.slice:::include_js_files(pattern = "count-bar-labels"), #' column(4, div( #' h4("LogicalFilterState"), -#' isolate(filter_state_logical$ui("fs")) +#' fs$ui("fs") #' )), #' column(4, div( #' id = "outputs", # div id is needed for toggling the element @@ -54,24 +53,34 @@ #' ) #' #' server <- function(input, output, session) { -#' filter_state_logical$server("fs") -#' output$condition_logical <- renderPrint(filter_state_logical$get_call()) -#' output$formatted_logical <- renderText(filter_state_logical$format()) -#' output$unformatted_logical <- renderPrint(filter_state_logical$get_state()) +#' fs$server("fs") +#' output$condition_logical <- renderPrint(fs$get_call()) +#' output$formatted_logical <- renderText(fs$format()) +#' output$unformatted_logical <- renderPrint(fs$get_state()) #' # modify filter state programmatically -#' observeEvent(input$button1_logical, filter_state_logical$set_keep_na(FALSE)) -#' observeEvent(input$button2_logical, filter_state_logical$set_keep_na(TRUE)) -#' observeEvent(input$button3_logical, filter_state_logical$set_selected(TRUE)) +#' observeEvent( +#' input$button1_logical, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) +#' ) +#' observeEvent( +#' input$button2_logical, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) +#' ) +#' observeEvent( +#' input$button3_logical, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE)) +#' ) #' observeEvent( #' input$button0_logical, -#' filter_state_logical$set_state(list(selected = FALSE, keep_na = TRUE)) +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE) +#' ) #' ) #' } #' #' if (interactive()) { #' shinyApp(ui, server) #' } -#' } #' LogicalFilterState <- R6::R6Class( # nolint "LogicalFilterState", @@ -82,128 +91,95 @@ LogicalFilterState <- R6::R6Class( # nolint #' @description #' Initialize a `FilterState` object + #' #' @param x (`logical`)\cr #' values of the variable used in filter - #' @param varname (`character`, `name`)\cr - #' label of the variable (optional). - #' @param varlabel (`character(1)`)\cr - #' label of the variable (optional). - #' @param dataname (`character(1)`)\cr - #' optional name of dataset where `x` is taken from + #' @param x_reactive (`reactive`)\cr + #' returning vector of the same type as `x`. Is used to update + #' counts following the change in values of the filtered dataset. + #' If it is set to `reactive(NULL)` then counts based on filtered + #' dataset are not shown. + #' @param slice (`teal_slice`)\cr + #' object created using [teal_slice()]. `teal_slice` is stored + #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state` + #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice` + #' is a `reactiveValues` which means that changes in particular object are automatically + #' reflected in all places which refer to the same `teal_slice`. #' @param extract_type (`character(0)`, `character(1)`)\cr - #' whether condition calls should be prefixed by dataname. Possible values: + #' whether condition calls should be prefixed by `dataname`. Possible values: #' \itemize{ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed} #' \item{`"list"`}{ `varname` in the condition call will be returned as `$`} #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `[, ]`} #' } + #' @param ... additional arguments to be saved as a list in `private$extras` field + #' initialize = function(x, - varname, - varlabel = character(0), - dataname = NULL, - extract_type = character(0)) { - stopifnot(is.logical(x)) - super$initialize(x, varname, varlabel, dataname, extract_type) - df <- as.factor(x) - if (length(levels(df)) != 2) { - if (levels(df) %in% c(TRUE, FALSE)) { - choices_not_included <- c(TRUE, FALSE)[!c(TRUE, FALSE) %in% levels(df)] - levels(df) <- c(levels(df), choices_not_included) - } - } - - tbl <- table(df) - - choices <- as.logical(names(tbl)) - names(choices) <- tbl - private$set_choices(as.list(choices)) - self$set_selected(unname(choices)[1]) - private$histogram_data <- data.frame( - x = sprintf( - "%s (%s)", - choices, - names(choices) - ), - y = as.vector(tbl) - ) + x_reactive = reactive(NULL), + extract_type = character(0), + slice) { + shiny::isolate({ + checkmate::assert_logical(x) + checkmate::assert_logical(slice$selected, null.ok = TRUE) + super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type) + private$set_choices(slice$choices) + if (is.null(slice$multiple)) slice$multiple <- FALSE + if (is.null(slice$selected) && slice$multiple) { + slice$selected <- private$get_choices() + } else if (length(slice$selected) != 1 && !slice$multiple) { + slice$selected <- TRUE + } + private$set_selected(slice$selected) + df <- factor(x, levels = c(TRUE, FALSE)) + tbl <- table(df) + private$set_choices_counts(tbl) + }) invisible(self) }, - #' @description - #' Answers the question of whether the current settings and values selected actually filters out any values. - #' @return logical scalar - is_any_filtered = function() { - if (!isTRUE(self$get_keep_na()) && private$na_count > 0) { - TRUE - } else if (all(private$histogram_data$y > 0)) { - TRUE - } else if (self$get_selected() == FALSE && "FALSE (0)" %in% private$histogram_data$x) { - TRUE - } else if (self$get_selected() == TRUE && "TRUE (0)" %in% private$histogram_data$x) { - TRUE - } else { - FALSE - } - }, - #' @description #' Returns reproducible condition call for current selection. #' For `LogicalFilterState` it's a `!` or `` and optionally #' `is.na()` - get_call = function() { + #' @param dataname name of data set; defaults to `private$get_dataname()` + #' @return (`call`) + #' + get_call = function(dataname) { + if (isFALSE(private$is_any_filtered())) { + return(NULL) + } + if (missing(dataname)) dataname <- private$get_dataname() + varname <- private$get_varname_prefixed(dataname) + choices <- private$get_selected() + n_choices <- length(choices) + filter_call <- - if (self$get_selected()) { - private$get_varname_prefixed() + if (n_choices == 1 && choices) { + private$get_varname_prefixed(dataname) + } else if (n_choices == 1 && !choices) { + call("!", private$get_varname_prefixed(dataname)) } else { - call("!", private$get_varname_prefixed()) + call("%in%", private$get_varname_prefixed(dataname), make_c_call(choices)) } - private$add_keep_na_call(filter_call) - }, - - #' @description - #' Sets the selected values of this `LogicalFilterState`. - #' - #' @param value (`logical(1)`)\cr - #' the value to set. Must not contain the NA value. - #' - #' @returns invisibly `NULL`. - #' - #' @note Casts the passed object to `logical` before validating the input - #' making it possible to pass any object coercible to `logical` to this method. - #' - #' @examples - #' filter <- teal.slice:::LogicalFilterState$new(c(TRUE), varname = "name") - #' filter$set_selected(TRUE) - set_selected = function(value) { - super$set_selected(value) + private$add_keep_na_call(filter_call, dataname) } ), - # private fields ---- - + # private members ---- private = list( - histogram_data = data.frame(), + choices_counts = integer(0), # private methods ---- - - validate_selection = function(value) { - if (!(checkmate::test_logical(value, max.len = 1, any.missing = FALSE))) { - stop( - sprintf( - "value of the selection for `%s` in `%s` should be a logical scalar (TRUE or FALSE)", - self$get_varname(), - self$get_dataname() - ) - ) - } - - pre_msg <- sprintf( - "dataset '%s', variable '%s': ", - self$get_dataname(), - self$get_varname() - ) - check_in_subset(value, private$choices, pre_msg = pre_msg) + set_choices = function(choices) { + private$teal_slice$choices <- c(TRUE, FALSE) + invisible(NULL) + }, + # @description + # Sets choices_counts private field + set_choices_counts = function(choices_counts) { + private$choices_counts <- choices_counts + invisible(NULL) }, cast_and_validate = function(values) { tryCatch( @@ -215,6 +191,44 @@ LogicalFilterState <- R6::R6Class( # nolint ) values_logical }, + check_multiple = function(value) { + if (!private$is_multiple() && length(value) > 1) { + warning( + sprintf("Selection: %s is not a vector of length one. ", toString(value, width = 360)), + "Maintaining previous selection." + ) + value <- shiny::isolate(private$get_selected()) + } + value + }, + validate_selection = function(value) { + if (!is.logical(value)) { + stop( + sprintf( + "value of the selection for `%s` in `%s` should be a logical vector of length <= 2", + private$get_varname(), + private$get_dataname() + ) + ) + } + }, + + # Answers the question of whether the current settings and values selected actually filters out any values. + # @return logical scalar + is_any_filtered = function() { + if (private$is_choice_limited) { + TRUE + } else if (all(private$choices_counts > 0)) { + TRUE + } else if (setequal(private$get_selected(), private$get_choices()) && + !anyNA(private$get_selected(), private$get_choices())) { + TRUE + } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) { + TRUE + } else { + FALSE + } + }, # shiny modules ---- @@ -226,37 +240,48 @@ LogicalFilterState <- R6::R6Class( # nolint # id of shiny element ui_inputs = function(id) { ns <- NS(id) - l_counts <- as.numeric(names(private$choices)) - l_counts[is.na(l_counts)] <- 0 - l_freqs <- l_counts / sum(l_counts) - labels <- lapply(seq_along(private$choices), function(i) { - div( - class = "choices_state_label", - style = sprintf("width:%s%%", l_freqs[i] * 100), - span( - class = "choices_state_label_text", - sprintf( - "%s (%s)", - private$choices[i], - l_counts[i] - ) - ) + shiny::isolate({ + countsmax <- private$choices_counts + countsnow <- if (!is.null(private$x_reactive())) { + unname(table(factor(private$x_reactive(), levels = private$get_choices()))) + } else { + NULL + } + + labels <- countBars( + inputId = ns("labels"), + choices = as.character(private$get_choices()), + countsnow = countsnow, + countsmax = countsmax ) - }) - div( - div( - class = "choices_state", + ui_input <- if (private$is_multiple()) { + checkboxGroupInput( + inputId = ns("selection"), + label = NULL, + selected = shiny::isolate(as.character(private$get_selected())), + choiceNames = labels, + choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")), + width = "100%" + ) + } else { radioButtons( - ns("selection"), + inputId = ns("selection"), label = NULL, + selected = shiny::isolate(as.character(private$get_selected())), choiceNames = labels, - choiceValues = as.character(private$choices), - selected = as.character(self$get_selected()), + choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")), width = "100%" ) - ), - private$keep_na_ui(ns("keep_na")) - ) + } + div( + div( + class = "choices_state", + uiOutput(ns("trigger_visible"), inline = TRUE), + ui_input + ), + private$keep_na_ui(ns("keep_na")) + ) + }) }, # @description @@ -269,55 +294,131 @@ LogicalFilterState <- R6::R6Class( # nolint moduleServer( id = id, function(input, output, session) { - # this observer is needed in the situation when private$selected has been + # this observer is needed in the situation when teal_slice$selected has been # changed directly by the api - then it's needed to rerender UI element # to show relevant values + non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive())) + output$trigger_visible <- renderUI({ + logger::log_trace("LogicalFilterState$server@1 updating count labels, id: { private$get_id() }") + + countsnow <- if (!is.null(private$x_reactive())) { + unname(table(factor(non_missing_values(), levels = private$get_choices()))) + } else { + NULL + } + + updateCountBars( + inputId = "labels", + choices = as.character(private$get_choices()), + countsmax = private$choices_counts, + countsnow = countsnow + ) + NULL + }) + private$observers$seleted_api <- observeEvent( - ignoreNULL = TRUE, # this is radio button so something have to be selected + ignoreNULL = !private$is_multiple(), ignoreInit = TRUE, - eventExpr = self$get_selected(), + eventExpr = private$get_selected(), handlerExpr = { - if (!setequal(self$get_selected(), input$selection)) { - updateRadioButtons( - session = session, - inputId = "selection", - selected = self$get_selected() - ) - logger::log_trace(sprintf( - "LogicalFilterState$server@1 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname - )) + if (!setequal(private$get_selected(), input$selection)) { + logger::log_trace("LogicalFilterState$server@1 state changed, id: { private$get_id() }") + if (private$is_multiple()) { + updateCheckboxGroupInput( + inputId = "selection", + selected = private$get_selected() + ) + } else { + updateRadioButtons( + inputId = "selection", + selected = private$get_selected() + ) + } } } ) private$observers$selection <- observeEvent( - ignoreNULL = TRUE, # in radio button something has to be selected to input$selection can't be NULL + ignoreNULL = FALSE, ignoreInit = TRUE, eventExpr = input$selection, handlerExpr = { - selection_state <- as.logical(input$selection) + logger::log_trace("LogicalFilterState$server@2 selection changed, id: { private$get_id() }") + # for private$is_multiple() == TRUE input$selection will always have value + if (is.null(input$selection) && isFALSE(private$is_multiple())) { + selection_state <- private$get_selected() + } else { + selection_state <- as.logical(input$selection) + } + if (is.null(selection_state)) { selection_state <- logical(0) } - self$set_selected(selection_state) - logger::log_trace( - sprintf( - "LogicalFilterState$server@2 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname - ) - ) + private$set_selected(selection_state) } ) private$keep_na_srv("keep_na") - logger::log_trace("LogicalFilterState$server initialized, dataname: { private$dataname }") + logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }") NULL } ) + }, + server_inputs_fixed = function(id) { + moduleServer( + id = id, + function(input, output, session) { + logger::log_trace("LogicalFilterState$server initializing, id: { private$get_id() }") + + output$selection <- renderUI({ + countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices()))) + countsmax <- private$choices_counts + + ind <- private$get_choices() %in% private$get_selected() + countBars( + inputId = session$ns("labels"), + choices = private$get_selected(), + countsnow = countsnow[ind], + countsmax = countsmax[ind] + ) + }) + + logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }") + NULL + } + ) + }, + + # @description + # Server module to display filter summary + # renders text describing whether TRUE or FALSE is selected + # and if NA are included also + content_summary = function(id) { + tagList( + tags$span( + class = "filter-card-summary-value", + toString(private$get_selected()) + ), + tags$span( + class = "filter-card-summary-controls", + if (isTRUE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("check") + ) + } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("xmark") + ) + } else { + NULL + } + ) + ) } ) ) diff --git a/R/FilterStateRange.R b/R/FilterStateRange.R index 0d58c0972..b173855bc 100644 --- a/R/FilterStateRange.R +++ b/R/FilterStateRange.R @@ -7,33 +7,44 @@ #' #' @examples #' filter_state <- teal.slice:::RangeFilterState$new( -#' c(NA, Inf, seq(1:10)), -#' varname = "x", -#' dataname = "data", -#' extract_type = character(0) +#' x = c(NA, Inf, seq(1:10)), +#' slice = teal_slice(varname = "x", dataname = "data") #' ) -#' isolate(filter_state$get_call()) -#' isolate(filter_state$set_selected(c(3L, 8L))) -#' isolate(filter_state$set_keep_na(TRUE)) -#' isolate(filter_state$set_keep_inf(TRUE)) -#' isolate(filter_state$get_call()) +#' shiny::isolate(filter_state$get_call()) +#' filter_state$set_state( +#' teal_slice( +#' dataname = "data", +#' varname = "x", +#' selected = c(3L, 8L), +#' keep_na = TRUE, +#' keep_inf = TRUE +#' ) +#' ) +#' shiny::isolate(filter_state$get_call()) #' -#' \dontrun{ #' # working filter in an app #' library(shiny) +#' library(shinyjs) #' #' data_range <- c(runif(100, 0, 1), NA, Inf) -#' filter_state_range <- RangeFilterState$new( +#' fs <- teal.slice:::RangeFilterState$new( #' x = data_range, -#' varname = "variable", -#' varlabel = "label" +#' slice = teal_slice( +#' dataname = "data", +#' varname = "x", +#' selected = c(0.15, 0.93), +#' keep_na = TRUE, +#' keep_inf = TRUE +#' ) #' ) -#' filter_state_range$set_state(list(selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)) #' #' ui <- fluidPage( +#' useShinyjs(), +#' teal.slice:::include_css_files(pattern = "filter-panel"), +#' teal.slice:::include_js_files(pattern = "count-bar-labels"), #' column(4, div( #' h4("RangeFilterState"), -#' isolate(filter_state_range$ui("fs")) +#' fs$ui("fs") #' )), #' column(4, div( #' id = "outputs", # div id is needed for toggling the element @@ -57,27 +68,48 @@ #' ) #' #' server <- function(input, output, session) { -#' filter_state_range$server("fs") -#' output$condition_range <- renderPrint(filter_state_range$get_call()) -#' output$formatted_range <- renderText(filter_state_range$format()) -#' output$unformatted_range <- renderPrint(filter_state_range$get_state()) +#' fs$server("fs") +#' output$condition_range <- renderPrint(fs$get_call()) +#' output$formatted_range <- renderText(fs$format()) +#' output$unformatted_range <- renderPrint(fs$get_state()) #' # modify filter state programmatically -#' observeEvent(input$button1_range, filter_state_range$set_keep_na(FALSE)) -#' observeEvent(input$button2_range, filter_state_range$set_keep_na(TRUE)) -#' observeEvent(input$button3_range, filter_state_range$set_keep_inf(FALSE)) -#' observeEvent(input$button4_range, filter_state_range$set_keep_inf(TRUE)) -#' observeEvent(input$button5_range, filter_state_range$set_selected(c(0.2, 0.74))) -#' observeEvent(input$button6_range, filter_state_range$set_selected(c(0, 1))) +#' observeEvent( +#' input$button1_range, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) +#' ) +#' observeEvent( +#' input$button2_range, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) +#' ) +#' observeEvent( +#' input$button3_range, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = FALSE)) +#' ) +#' observeEvent( +#' input$button4_range, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = TRUE)) +#' ) +#' observeEvent( +#' input$button5_range, +#' fs$set_state( +#' teal_slice(dataname = "data", varname = "x", selected = c(0.2, 0.74)) +#' ) +#' ) +#' observeEvent( +#' input$button6_range, +#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = c(0, 1))) +#' ) #' observeEvent( #' input$button0_range, -#' filter_state_range$set_state(list(selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)) +#' fs$set_state( +#' teal_slice("data", "variable", selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE) +#' ) #' ) #' } #' #' if (interactive()) { #' shinyApp(ui, server) #' } -#' } #' RangeFilterState <- R6::R6Class( # nolint "RangeFilterState", @@ -87,96 +119,107 @@ RangeFilterState <- R6::R6Class( # nolint public = list( #' @description - #' Initialize a `FilterState` object + #' Initialize a `FilterState` object for range selection #' @param x (`numeric`)\cr #' values of the variable used in filter - #' @param varname (`character`, `name`)\cr - #' name of the variable - #' @param varlabel (`character(1)`)\cr - #' label of the variable (optional). - #' @param dataname (`character(1)`)\cr - #' optional name of dataset where `x` is taken from + #' @param x_reactive (`reactive`)\cr + #' returning vector of the same type as `x`. Is used to update + #' counts following the change in values of the filtered dataset. + #' If it is set to `reactive(NULL)` then counts based on filtered + #' dataset are not shown. + #' @param slice (`teal_slice`)\cr + #' object created using [teal_slice()]. `teal_slice` is stored + #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state` + #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice` + #' is a `reactiveValues` which means that changes in particular object are automatically + #' reflected in all places which refer to the same `teal_slice`. #' @param extract_type (`character(0)`, `character(1)`)\cr - #' whether condition calls should be prefixed by dataname. Possible values: + #' whether condition calls should be prefixed by `dataname`. Possible values: #' \itemize{ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed} #' \item{`"list"`}{ `varname` in the condition call will be returned as `$`} #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `[, ]`} #' } + #' @param ... additional arguments to be saved as a list in `private$extras` field + #' initialize = function(x, - varname, - varlabel = character(0), - dataname = NULL, - extract_type = character(0)) { - checkmate::assert_numeric(x, all.missing = FALSE) - if (!any(is.finite(x))) stop("\"x\" contains no finite values") - - super$initialize(x, varname, varlabel, dataname, extract_type) - private$inf_count <- sum(is.infinite(x)) - private$is_integer <- checkmate::test_integerish(x) - private$keep_inf <- reactiveVal(FALSE) - - x_range <- range(x, finite = TRUE) - x_pretty <- pretty(x_range, 100L) - - if (identical(diff(x_range), 0)) { - private$set_choices(x_range) - private$slider_ticks <- signif(x_range, digits = 10) - private$slider_step <- NULL - self$set_selected(x_range) - } else { - private$set_choices(range(x_pretty)) - private$slider_ticks <- signif(x_pretty, digits = 10) - private$slider_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10) - self$set_selected(range(x_pretty)) - } - - private$histogram_data <- if (sum(is.finite(x)) >= 2) { - as.data.frame( - stats::density(x, na.rm = TRUE, n = 100)[c("x", "y")] # 100 bins only + x_reactive = reactive(NULL), + extract_type = character(0), + slice) { + shiny::isolate({ + checkmate::assert_numeric(x, all.missing = FALSE) + if (!any(is.finite(x))) stop("\"x\" contains no finite values") + super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type) + private$is_integer <- checkmate::test_integerish(x) + private$inf_count <- sum(is.infinite(x)) + private$inf_filtered_count <- reactive( + if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive())) ) - } else { - data.frame(x = NA_real_, y = NA_real_) - } - return(invisible(self)) - }, + checkmate::assert_numeric(slice$choices, null.ok = TRUE) + if (is.null(slice$keep_inf) && any(is.infinite(x))) slice$keep_inf <- TRUE - #' @description - #' Returns a formatted string representing this `RangeFilterState`. - #' - #' @param indent (`numeric(1)`) - #' the number of spaces before after each new line character of the formatted string. - #' Default: 0 - #' @return `character(1)` the formatted string - #' - format = function(indent = 0) { - checkmate::assert_number(indent, finite = TRUE, lower = 0) - - vals <- self$get_selected() - sprintf( - "%sFiltering on: %s\n%1$s Selected range: %s - %s\n%1$s Include missing values: %s", - format("", width = indent), - private$varname, - format(vals[1], nsmall = 3), - format(vals[2], nsmall = 3), - format(self$get_keep_na()) - ) - }, + private$set_choices(slice$choices) + if (is.null(slice$selected)) slice$selected <- slice$choices + private$set_selected(slice$selected) - #' @description - #' Answers the question of whether the current settings and values selected actually filters out any values. - #' @return logical scalar - is_any_filtered = function() { - if (!isTRUE(all.equal(self$get_selected(), private$choices))) { - TRUE - } else if (!isTRUE(self$get_keep_inf()) && private$inf_count > 0) { - TRUE - } else if (!isTRUE(self$get_keep_na()) && private$na_count > 0) { - TRUE - } else { - FALSE - } + private$is_integer <- checkmate::test_integerish(x) + private$inf_filtered_count <- reactive( + if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive())) + ) + private$inf_count <- sum(is.infinite(x)) + + private$plot_data <- list( + type = "histogram", + nbinsx = 50, + x = Filter(Negate(is.na), Filter(is.finite, private$x)), + color = I(fetch_bs_color("secondary")), + alpha = 0.2, + bingroup = 1, + showlegend = FALSE, + hoverinfo = "none" + ) + private$plot_mask <- list(list( + type = "rect", fillcolor = rgb(1, 1, 1, .65), line = list(width = 0), + x0 = -0.5, x1 = 1.5, y0 = -0.5, y1 = 1.5, xref = "paper", yref = "paper" + )) + private$plot_layout <- reactive({ + shapes <- private$get_shape_properties(private$get_selected()) + list( + barmode = "overlay", + xaxis = list( + range = private$get_choices(), + rangeslider = list(thickness = 0), + showticklabels = TRUE, + ticks = "outside", + ticklen = 2, + tickmode = "auto", + nticks = 10 + ), + yaxis = list(showgrid = FALSE, showticklabels = FALSE), + margin = list(b = 17, l = 0, r = 0, t = 0, autoexpand = FALSE), + plot_bgcolor = "#FFFFFF00", + paper_bgcolor = "#FFFFFF00", + shapes = shapes + ) + }) + private$plot_config <- reactive({ + list( + doubleClick = "reset", + displayModeBar = FALSE, + edits = list(shapePosition = TRUE) + ) + }) + private$plot_filtered <- reactive({ + finite_values <- Filter(is.finite, private$x_reactive()) + list( + x = finite_values, + bingroup = 1, + color = I(fetch_bs_color("primary")) + ) + }) + invisible(self) + }) }, #' @description @@ -184,112 +227,101 @@ RangeFilterState <- R6::R6Class( # nolint #' For this class returned call looks like #' ` >= & <= ` with #' optional `is.na()` and `is.finite()`. + #' @param dataname name of data set; defaults to `private$get_dataname()` #' @return (`call`) - get_call = function() { + #' + get_call = function(dataname) { + if (isFALSE(private$is_any_filtered())) { + return(NULL) + } + if (missing(dataname)) dataname <- private$get_dataname() filter_call <- call( "&", - call(">=", private$get_varname_prefixed(), self$get_selected()[1L]), - call("<=", private$get_varname_prefixed(), self$get_selected()[2L]) + call(">=", private$get_varname_prefixed(dataname), private$get_selected()[1L]), + call("<=", private$get_varname_prefixed(dataname), private$get_selected()[2L]) ) - private$add_keep_na_call(private$add_keep_inf_call(filter_call)) + private$add_keep_na_call(private$add_keep_inf_call(filter_call, dataname), dataname) }, #' @description #' Returns current `keep_inf` selection #' @return (`logical(1)`) get_keep_inf = function() { - private$keep_inf() - }, - - #' @description - #' Returns the filtering state. - #' - #' @return `list` containing values taken from the reactive fields: - #' * `selected` (`numeric(2)`) range of the filter. - #' * `keep_na` (`logical(1)`) whether `NA` should be kept. - #' * `keep_inf` (`logical(1)`) whether `Inf` should be kept. - get_state = function() { - list( - selected = self$get_selected(), - keep_na = self$get_keep_na(), - keep_inf = self$get_keep_inf() - ) - }, - - #' @description - #' Set if `Inf` should be kept - #' @param value (`logical(1)`)\cr - #' Value(s) which come from the filter selection. Value is set in `server` - #' modules after selecting check-box-input in the shiny interface. Values are set to - #' `private$keep_inf` which is reactive. - set_keep_inf = function(value) { - checkmate::assert_flag(value) - private$keep_inf(value) - logger::log_trace( - sprintf( - "%s$set_keep_inf of variable %s set to %s, dataname: %s.", - class(self)[1], - private$varname, - value, - private$dataname - ) - ) - }, - - #' @description - #' Set state - #' @param state (`list`)\cr - #' contains fields relevant for a specific class - #' \itemize{ - #' \item{`selected`}{ defines initial selection} - #' \item{`keep_na` (`logical`)}{ defines whether to keep or remove `NA` values} - #' \item{`keep_inf` (`logical`)}{ defines whether to keep or remove `Inf` values} - #' } - set_state = function(state) { - stopifnot(is.list(state) && all(names(state) %in% c("selected", "keep_na", "keep_inf"))) - if (!is.null(state$keep_inf)) { - self$set_keep_inf(state$keep_inf) - } - super$set_state(state[names(state) %in% c("selected", "keep_na")]) - invisible(NULL) - }, - - #' @description - #' Sets the selected values of this `RangeFilterState`. - #' - #' @param value (`numeric(2)`) the two-elements array of the lower and upper bound - #' of the selected range. Must not contain NA values. - #' - #' @returns invisibly `NULL` - #' - #' @note Casts the passed object to `numeric` before validating the input - #' making it possible to pass any object coercible to `numeric` to this method. - #' - #' @examples - #' filter <- teal.slice:::RangeFilterState$new(c(1, 2, 3, 4), varname = "name") - #' filter$set_selected(c(2, 3)) - #' - set_selected = function(value) { - super$set_selected(value) + private$teal_slice$keep_inf } ), # private fields---- private = list( - histogram_data = data.frame(), - keep_inf = NULL, # because it holds reactiveVal inf_count = integer(0), + inf_filtered_count = NULL, is_integer = logical(0), - slider_step = numeric(0), # step for the slider input widget, calculated from input data (x) - slider_ticks = numeric(0), # allowed values for the slider input widget, calculated from input data (x) + numeric_step = numeric(0), # step for the slider input widget, calculated from input data (x) + plot_data = NULL, + plot_mask = list(), + plot_layout = NULL, + plot_config = NULL, + plot_filtered = NULL, # private methods ---- + + set_choices = function(choices) { + x <- private$x[is.finite(private$x)] + if (is.null(choices)) { + choices <- range(x) + } else { + choices_adjusted <- c(max(choices[1L], min(x)), min(choices[2L], max(x))) + if (any(choices != choices_adjusted)) { + warning(sprintf( + "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", + private$get_varname(), private$get_dataname() + )) + choices <- choices_adjusted + } + if (choices[1L] > choices[2L]) { + warning(sprintf( + "Invalid choices: lower is higher / equal to upper, or not in range of variable values. + Setting defaults. Varname: %s, dataname: %s.", + private$get_varname(), private$get_dataname() + )) + choices <- range(x) + } + } + + private$set_is_choice_limited(private$x, choices) + private$x <- private$x[ + (private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x) | !is.finite(private$x) + ] + + x_range <- range(private$x, finite = TRUE) + + # Required for displaying ticks on the slider, can modify choices! + if (identical(diff(x_range), 0)) { + choices <- x_range + } else { + x_pretty <- pretty(x_range, 100L) + choices <- range(x_pretty) + private$numeric_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10) + } + private$teal_slice$choices <- choices + invisible(NULL) + }, + + # @description + # Check whether the initial choices filter out some values of x and set the flag in case. + set_is_choice_limited = function(xl, choices) { + xl <- xl[!is.na(xl)] + xl <- xl[is.finite(xl)] + private$is_choice_limited <- (any(xl < choices[1L]) | any(xl > choices[2L])) + invisible(NULL) + }, + # Adds is.infinite(varname) before existing condition calls if keep_inf is selected # returns a call - add_keep_inf_call = function(filter_call) { - if (isTRUE(self$get_keep_inf())) { - call("|", call("is.infinite", private$get_varname_prefixed()), filter_call) + add_keep_inf_call = function(filter_call, dataname) { + if (isTRUE(private$get_keep_inf())) { + call("|", call("is.infinite", private$get_varname_prefixed(dataname)), filter_call) } else { filter_call } @@ -316,8 +348,8 @@ RangeFilterState <- R6::R6Class( # nolint stop( sprintf( "value of the selection for `%s` in `%s` should be a numeric", - self$get_varname(), - self$get_dataname() + private$get_varname(), + private$get_dataname() ) ) } @@ -329,26 +361,44 @@ RangeFilterState <- R6::R6Class( # nolint cast_and_validate = function(values) { if (!is.atomic(values)) stop("Values to set must be an atomic vector.") values <- as.numeric(values) - if (any(is.na(values))) stop("The array of set values must contain values coercible to numeric.") - if (length(values) != 2) stop("The array of set values must have length two.") - - values_adjusted <- contain_interval(values, private$slider_ticks) - if (!isTRUE(all.equal(values, values_adjusted))) { - logger::log_warn(sprintf( - paste( - "Programmatic range specification on %s was adjusted to existing slider ticks.", - "It is now broader in order to contain the specified values." - ), - private$varname - )) - } - values_adjusted + if (any(is.na(values))) stop("Vector of set values must contain values coercible to numeric.") + if (length(values) != 2) stop("Vector of set values must have length two.") + if (values[1L] > values[2L]) stop("Vector of set values must be sorted.") + + values }, - # for numeric ranges selecting out of bound values is allowed + # Trim selection to limits imposed by private$get_choices() remove_out_of_bound_values = function(values) { + if (values[1L] < private$get_choices()[1L]) values[1L] <- private$get_choices()[1L] + if (values[2L] > private$get_choices()[2L]) values[2L] <- private$get_choices()[2L] values }, + # Answers the question of whether the current settings and values selected actually filters out any values. + # @return logical scalar + is_any_filtered = function() { + if (private$is_choice_limited) { + TRUE + } else if (!isTRUE(all.equal(private$get_selected(), private$get_choices()))) { + TRUE + } else if (!isTRUE(private$get_keep_inf()) && private$inf_count > 0) { + TRUE + } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) { + TRUE + } else { + FALSE + } + }, + + # obtain shape determination for histogram + # returns a list that is passed to plotly's layout.shapes property + get_shape_properties = function(values) { + list( + list(type = "line", x0 = values[1], x1 = values[1], y0 = -100, y1 = 100, yref = "paper"), + list(type = "line", x0 = values[2], x1 = values[2], y0 = -100, y1 = 100, yref = "paper") + ) + }, + # shiny modules ---- # UI Module for `RangeFilterState`. @@ -358,26 +408,70 @@ RangeFilterState <- R6::R6Class( # nolint # id of shiny element ui_inputs = function(id) { ns <- NS(id) - fluidRow( - div( - class = "filterPlotOverlayRange", - plotOutput(ns("plot"), height = "100%") - ), - div( - class = "filterRangeSlider", - teal.widgets::optionalSliderInput( - inputId = ns("selection"), - label = NULL, - min = private$choices[1], - max = private$choices[2], - value = isolate(private$selected()), - step = private$slider_step, - width = "100%" + shiny::isolate({ + ui_input <- shinyWidgets::numericRangeInput( + inputId = ns("selection_manual"), + label = NULL, + min = private$get_choices()[1L], + max = private$get_choices()[2L], + value = private$get_selected(), + step = private$numeric_step, + width = "100%" + ) + tagList( + div( + class = "choices_state", + tags$head(tags$script( + # Inline JS code for popover functionality. + # Adding the script inline because when added from a file with include_js_files(), + # it only works in the first info_button instance and not others. + HTML( + '$(document).ready(function() { + $("[data-toggle=\'popover\']").popover(); + + $(document).on("click", function (e) { + if (!$("[data-toggle=\'popover\']").is(e.target) && + $("[data-toggle=\'popover\']").has(e.target).length === 0 && + $(".popover").has(e.target).length === 0) { + $("[data-toggle=\'popover\']").popover("hide"); + } + }); + });' + ) + )), + div( + actionLink( + ns("plotly_info"), + label = NULL, + icon = icon("question-circle"), + "data-toggle" = "popover", + "data-html" = "true", + "data-placement" = "left", + "data-trigger" = "click", + "data-title" = "Plot actions", + "data-content" = "

+ Drag vertical lines to set selection.
+ Drag across plot to zoom in.
+ Drag axis to pan.
+ Double click to zoom out." + ), + style = "text-align: right; font-size: 0.7em; margin-bottom: -1em; position: relative; z-index: 9;" + ), + shinycssloaders::withSpinner( + plotly::plotlyOutput(ns("plot"), height = "50px"), + type = 4, + size = 0.25, + hide.ui = FALSE + ), + ui_input + ), + div( + class = "filter-card-body-keep-na-inf", + private$keep_inf_ui(ns("keep_inf")), + private$keep_na_ui(ns("keep_na")) ) - ), - private$keep_inf_ui(ns("keep_inf")), - private$keep_na_ui(ns("keep_na")) - ) + ) + }) }, # @description @@ -389,69 +483,202 @@ RangeFilterState <- R6::R6Class( # nolint moduleServer( id = id, function(input, output, session) { - logger::log_trace("RangeFilterState$server initializing, dataname: { private$dataname }") - - output$plot <- renderPlot( - bg = "transparent", - height = 25, - expr = { - ggplot2::ggplot(private$histogram_data) + - ggplot2::aes_string(x = "x", y = "y") + - ggplot2::geom_area( - fill = grDevices::rgb(66 / 255, 139 / 255, 202 / 255), - color = NA, - alpha = 0.2 - ) + - ggplot2::theme_void() + - ggplot2::scale_y_continuous(expand = c(0, 0)) + - ggplot2::scale_x_continuous(expand = c(0, 0)) - } - ) + logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }") + + # Capture manual input with debounce. + selection_manual <- debounce(reactive(input$selection_manual), 200) + + # Prepare for histogram construction. + plot_data <- c(private$plot_data, source = session$ns("histogram_plot")) + + # Display histogram, adding a second trace that contains filtered data. + output$plot <- plotly::renderPlotly({ + histogram <- do.call(plotly::plot_ly, plot_data) + histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout())) + histogram <- do.call(plotly::config, c(list(p = histogram), private$plot_config())) + histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered())) + histogram + }) + + # Dragging shapes (lines) on plot updates selection. + private$observers$relayout <- + observeEvent( + ignoreNULL = FALSE, + ignoreInit = TRUE, + eventExpr = plotly::event_data("plotly_relayout", source = session$ns("histogram_plot")), + handlerExpr = { + logger::log_trace("RangeFilterState$server@1 selection changed, id: { private$get_id() }") + event <- plotly::event_data("plotly_relayout", source = session$ns("histogram_plot")) + if (any(grepl("shapes", names(event)))) { + line_positions <- private$get_selected() + if (any(grepl("shapes[0]", names(event), fixed = TRUE))) { + line_positions[1] <- event[["shapes[0].x0"]] + } else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) { + line_positions[2] <- event[["shapes[1].x0"]] + } + # If one line was dragged past the other, abort action and reset lines. + if (line_positions[1] > line_positions[2]) { + showNotification( + "Numeric range start value must be less than end value.", + type = "warning" + ) + plotly::plotlyProxyInvoke( + plotly::plotlyProxy("plot"), + "relayout", + shapes = private$get_shape_properties(private$get_selected()) + ) + return(NULL) + } + + private$set_selected(signif(line_positions, digits = 4L)) + } + } + ) - # this observer is needed in the situation when private$selected has been - # changed directly by the api - then it's needed to rerender UI element - # to show relevant values - private$observers$selection_api <- observeEvent( + # Change in selection updates shapes (lines) on plot and numeric input. + private$observers$selection_api <- + observeEvent( + ignoreNULL = FALSE, + ignoreInit = TRUE, + eventExpr = private$get_selected(), + handlerExpr = { + logger::log_trace("RangeFilterState$server@2 state changed, id: {private$get_id() }") + if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) { + shinyWidgets::updateNumericRangeInput( + session = session, + inputId = "selection_manual", + value = private$get_selected() + ) + } + } + ) + + # Manual input updates selection. + private$observers$selection_manual <- observeEvent( ignoreNULL = FALSE, ignoreInit = TRUE, - eventExpr = self$get_selected(), + eventExpr = selection_manual(), handlerExpr = { - if (!isTRUE(all.equal(input$selection, self$get_selected()))) { - updateSliderInput( + selection <- selection_manual() + # Abort and reset if non-numeric values is entered. + if (any(is.na(selection))) { + showNotification( + "Numeric range values must be numbers.", + type = "warning" + ) + shinyWidgets::updateNumericRangeInput( session = session, - inputId = "selection", - value = private$selected() + inputId = "selection_manual", + value = private$get_selected() ) + return(NULL) } - } - ) - private$observers$selection <- observeEvent( - ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in `selectInput` - ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state - eventExpr = input$selection, - handlerExpr = { - if (!isTRUE(all.equal(input$selection, self$get_selected()))) { - self$set_selected(input$selection) - } - logger::log_trace( - sprintf( - "RangeFilterState$server@3 selection of variable %s changed, dataname: %s", - private$varname, - private$dataname + # Abort and reset if reversed choices are specified. + if (selection[1] > selection[2]) { + showNotification( + "Numeric range start value must be less than end value.", + type = "warning" ) - ) + shinyWidgets::updateNumericRangeInput( + session = session, + inputId = "selection_manual", + value = private$get_selected() + ) + return(NULL) + } + + + if (!isTRUE(all.equal(selection, private$get_selected()))) { + logger::log_trace("RangeFilterState$server@3 manual selection changed, id: { private$get_id() }") + private$set_selected(selection) + } } ) private$keep_inf_srv("keep_inf") private$keep_na_srv("keep_na") - logger::log_trace("RangeFilterState$server initialized, dataname: { private$dataname }") + logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }") NULL } ) }, + server_inputs_fixed = function(id) { + moduleServer( + id = id, + function(input, output, session) { + logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }") + + plot_config <- private$plot_config() + plot_config$staticPlot <- TRUE + + output$plot <- plotly::renderPlotly({ + histogram <- do.call(plotly::plot_ly, private$plot_data) + histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout())) + histogram <- do.call(plotly::config, c(list(p = histogram), plot_config)) + histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered())) + histogram + }) + + output$selection <- renderUI({ + shinycssloaders::withSpinner( + plotly::plotlyOutput(session$ns("plot"), height = "50px"), + type = 4, + size = 0.25 + ) + }) + + logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }") + NULL + } + ) + }, + + # @description + # Server module to display filter summary + # renders text describing selected range and + # if NA or Inf are included also + # @return `shiny.tag` to include in the `ui_summary` + content_summary = function() { + selection <- private$get_selected() + tagList( + tags$span(shiny::HTML(selection[1], "–", selection[2]), class = "filter-card-summary-value"), + tags$span( + class = "filter-card-summary-controls", + if (isTRUE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("check") + ) + } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) { + tags$span( + class = "filter-card-summary-na", + "NA", + shiny::icon("xmark") + ) + } else { + NULL + }, + if (isTRUE(private$get_keep_inf()) && private$inf_count > 0) { + tags$span( + class = "filter-card-summary-inf", + "Inf", + shiny::icon("check") + ) + } else if (isFALSE(private$get_keep_inf()) && private$inf_count > 0) { + tags$span( + class = "filter-card-summary-inf", + "Inf", + shiny::icon("xmark") + ) + } else { + NULL + } + ) + ) + }, # @description # module displaying input to keep or remove Inf in the FilterState call @@ -460,11 +687,25 @@ RangeFilterState <- R6::R6Class( # nolint # been created has some Inf values. keep_inf_ui = function(id) { ns <- NS(id) + if (private$inf_count > 0) { - checkboxInput( - ns("value"), - sprintf("Keep Inf (%s)", private$inf_count), - value = self$get_keep_inf() + countmax <- private$na_count + countnow <- isolate(private$filtered_na_count()) + ui_input <- checkboxInput( + inputId = ns("value"), + label = tags$span( + id = ns("count_label"), + make_count_text( + label = "Keep Inf", + countmax = countmax, + countnow = countnow + ) + ), + value = isolate(private$get_keep_inf()) + ) + div( + uiOutput(ns("trigger_visible"), inline = TRUE), + ui_input ) } else { NULL @@ -474,45 +715,53 @@ RangeFilterState <- R6::R6Class( # nolint # @description # module to handle Inf values in the FilterState # @param shiny `id` parametr passed to moduleServer - # module sets `private$keep_inf` according to the selection. - # Module also updates a UI element if the `private$keep_inf` has been + # module sets `private$teal_slice$keep_inf` according to the selection. + # Module also updates a UI element if the `private$teal_slice$keep_inf` has been # changed through the api keep_inf_srv = function(id) { moduleServer(id, function(input, output, session) { - # this observer is needed in the situation when private$keep_na has been + # 1. renderUI is used here as an observer which triggers only if output is visible + # and if the reactive changes - reactive triggers only if the output is visible. + # 2. We want to trigger change of the labels only if reactive count changes (not underlying data) + output$trigger_visible <- renderUI({ + updateCountText( + inputId = "count_label", + label = "Keep Inf", + countmax = private$inf_count, + countnow = private$inf_filtered_count() + ) + NULL + }) + + # this observer is needed in the situation when private$teal_slice$keep_inf has been # changed directly by the api - then it's needed to rerender UI element # to show relevant values private$observers$keep_inf_api <- observeEvent( ignoreNULL = TRUE, # its not possible for range that NULL is selected ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state - eventExpr = self$get_keep_inf(), + eventExpr = private$get_keep_inf(), handlerExpr = { - if (!setequal(self$get_keep_inf(), input$value)) { + if (!setequal(private$get_keep_inf(), input$value)) { + logger::log_trace("RangeFilterState$keep_inf_srv@1 changed reactive value, id: { private$get_id() }") updateCheckboxInput( inputId = "value", - value = self$get_keep_inf() + value = private$get_keep_inf() ) } } ) + private$observers$keep_inf <- observeEvent( ignoreNULL = TRUE, # it's not possible for range that NULL is selected ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state eventExpr = input$value, handlerExpr = { + logger::log_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }") keep_inf <- input$value - self$set_keep_inf(keep_inf) - logger::log_trace( - sprintf( - "%s$server keep_inf of variable %s set to: %s, dataname: %s", - class(self)[1], - private$varname, - deparse1(input$value), - private$dataname - ) - ) + private$set_keep_inf(keep_inf) } ) + invisible(NULL) }) } diff --git a/R/FilterStates-utils.R b/R/FilterStates-utils.R index 4f95d65ce..28ca6c00d 100644 --- a/R/FilterStates-utils.R +++ b/R/FilterStates-utils.R @@ -1,23 +1,26 @@ -.filterable_class <- c("logical", "integer", "numeric", "factor", "character", "Date", "POSIXct", "POSIXlt") - #' Initialize `FilterStates` object #' #' Initialize `FilterStates` object #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr #' the R object which `subset` function is applied on. -#' +#' @param data_reactive (`function(sid)`)\cr +#' should return an object of the same type as `data` or `NULL`. +#' This object is needed for the `FilterState` shiny module to update +#' counts if filtered data changes. +#' If function returns `NULL` then filtered counts +#' are not shown. Function has to have `sid` argument being a character which +#' is related to `sid` argument in the `get_call` method. #' @param dataname (`character(1)`)\cr #' name of the data used in the expression #' specified to the function argument attached to this `FilterStates`. -#' #' @param datalabel (`character(0)` or `character(1)`)\cr #' text label value. -#' #' @param ... (optional) -#' additional arguments for specific classes: keys +#' additional arguments for specific classes: keys. #' @keywords internal #' @export #' @examples +#' library(shiny) #' df <- data.frame( #' character = letters, #' numeric = seq_along(letters), @@ -26,32 +29,31 @@ #' ) #' rf <- teal.slice:::init_filter_states( #' data = df, -#' dataname = "DF", -#' varlabels = c( -#' "character variable", "numeric variable", "date variable", "datetime variable" -#' ) +#' dataname = "DF" #' ) -#' \dontrun{ -#' shinyApp( +#' app <- shinyApp( #' ui = fluidPage( #' actionButton("clear", span(icon("xmark"), "Remove all filters")), -#' rf$ui_add_filter_state(id = "add", data = df), -#' rf$ui("states"), +#' rf$ui_add(id = "add"), +#' rf$ui_active("states"), #' verbatimTextOutput("expr"), #' ), #' server = function(input, output, session) { -#' rf$srv_add_filter_state(id = "add", data = df) -#' rf$server(id = "states") +#' rf$srv_add(id = "add") +#' rf$srv_active(id = "states") #' output$expr <- renderText({ #' deparse1(rf$get_call(), collapse = "\n") #' }) #' observeEvent(input$clear, rf$state_list_empty()) #' } #' ) +#' if (interactive()) { +#' runApp(app) #' } init_filter_states <- function(data, + data_reactive = reactive(NULL), dataname, - datalabel = character(0), + datalabel = NULL, ...) { UseMethod("init_filter_states") } @@ -59,15 +61,16 @@ init_filter_states <- function(data, #' @keywords internal #' @export init_filter_states.data.frame <- function(data, # nolint + data_reactive = function(sid = "") NULL, dataname, - datalabel = character(0), - varlabels = character(0), + datalabel = NULL, keys = character(0), ...) { DFFilterStates$new( + data = data, + data_reactive = data_reactive, dataname = dataname, datalabel = datalabel, - varlabels = varlabels, keys = keys ) } @@ -75,10 +78,13 @@ init_filter_states.data.frame <- function(data, # nolint #' @keywords internal #' @export init_filter_states.matrix <- function(data, # nolint + data_reactive = function(sid = "") NULL, dataname, - datalabel = character(0), + datalabel = NULL, ...) { MatrixFilterStates$new( + data = data, + data_reactive = data_reactive, dataname = dataname, datalabel = datalabel ) @@ -87,18 +93,19 @@ init_filter_states.matrix <- function(data, # nolint #' @keywords internal #' @export init_filter_states.MultiAssayExperiment <- function(data, # nolint + data_reactive = function(sid = "") NULL, dataname, - datalabel = character(0), - varlabels, + datalabel = "subjects", keys = character(0), ...) { if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { stop("Cannot load MultiAssayExperiment - please install the package or restart your session.") } MAEFilterStates$new( + data = data, + data_reactive = data_reactive, dataname = dataname, datalabel = datalabel, - varlabels = varlabels, keys = keys ) } @@ -106,13 +113,16 @@ init_filter_states.MultiAssayExperiment <- function(data, # nolint #' @keywords internal #' @export init_filter_states.SummarizedExperiment <- function(data, # nolint + data_reactive = function(sid = "") NULL, dataname, - datalabel = character(0), + datalabel = NULL, ...) { if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { stop("Cannot load SummarizedExperiment - please install the package or restart your session.") } SEFilterStates$new( + data = data, + data_reactive = data_reactive, dataname = dataname, datalabel = datalabel ) @@ -156,8 +166,8 @@ get_supported_filter_varnames.default <- function(data) { # nolint get_supported_filter_varnames.matrix <- function(data) { # nolint # all columns are the same type in matrix is_expected_class <- class(data[, 1]) %in% .filterable_class - if (is_expected_class && !is.null(names(data))) { - names(data) + if (is_expected_class && !is.null(colnames(data))) { + colnames(data) } else { character(0) } @@ -165,17 +175,17 @@ get_supported_filter_varnames.matrix <- function(data) { # nolint #' @keywords internal #' @export -get_supported_filter_varnames.FilteredDataset <- function(data) { # nolint - get_supported_filter_varnames(data$get_dataset()) -} - -#' @keywords internal -#' @export -get_supported_filter_varnames.MAEFilteredDataset <- function(data) { # nolint - character(0) +get_supported_filter_varnames.MultiAssayExperiment <- function(data) { # nolint + data <- SummarizedExperiment::colData(data) + # all columns are the same type in matrix + is_expected_class <- class(data[, 1]) %in% .filterable_class + if (is_expected_class && !is.null(names(data))) { + names(data) + } else { + character(0) + } } - #' @title Returns a `choices_labeled` object #' #' @param data (`data.frame`, `DFrame`, `list`)\cr @@ -189,41 +199,38 @@ get_supported_filter_varnames.MAEFilteredDataset <- function(data) { # nolint #' the names of the key columns in data #' @return `character(0)` if choices are empty; a `choices_labeled` object otherwise #' @keywords internal -data_choices_labeled <- function(data, choices, varlabels = character(0), keys = character(0)) { +data_choices_labeled <- function(data, + choices, + varlabels = formatters::var_labels(data, fill = TRUE), + keys = character(0)) { if (length(choices) == 0) { return(character(0)) } + choice_types <- stats::setNames(variable_types(data = data, columns = choices), choices) + choice_types[keys] <- "primary_key" + + choices_labeled( + choices = choices, + labels = unname(varlabels[choices]), + types = choice_types[choices] + ) +} - choice_labels <- if (identical(varlabels, character(0))) { +get_varlabels <- function(data) { + if (!is.array(data)) { vapply( - X = data, - FUN.VALUE = character(1), + colnames(data), FUN = function(x) { - label <- attr(x, "label") - if (length(label) != 1) { - "" + label <- attr(data[[x]], "label") + if (is.null(label)) { + x } else { label } - } - )[choices] - } else { - varlabels - } - - if (!identical(choice_labels, character(0))) { - choice_labels[is.na(choice_labels) | choice_labels == ""] <- names( - choice_labels[is.na(choice_labels) | choice_labels == ""] - ) - choice_types <- setNames(variable_types(data = data, columns = choices), choices) - choice_types[keys] <- "primary_key" - - choices_labeled( - choices = choices, - labels = unname(choice_labels[choices]), - types = choice_types[choices] + }, + FUN.VALUE = character(1) ) } else { - choices + character(0) } } diff --git a/R/FilterStates.R b/R/FilterStates.R index 7ab755efb..8024cfe9d 100644 --- a/R/FilterStates.R +++ b/R/FilterStates.R @@ -11,38 +11,12 @@ #' This expression is hereafter referred to as \emph{subset expression}. #' #' The \emph{subset expression} is constructed differently for different -#' classes of the underlying data object and `FilterStates` subclasses. +#' classes of the underlying data object and `FilterStates` sub-classes. #' Currently implemented for `data.frame`, `matrix`, #' `SummarizedExperiment`, and `MultiAssayExperiment`. #' #' @keywords internal #' -#' @examples -#' library(shiny) -#' filter_states <- teal.slice:::DFFilterStates$new( -#' dataname = "data", -#' varlabels = c(x = "x variable", SEX = "Sex"), -#' datalabel = character(0), -#' keys = character(0) -#' ) -#' filter_state <- teal.slice:::RangeFilterState$new( -#' c(NA, Inf, seq(1:10)), -#' varname = "x", -#' varlabel = "x variable", -#' dataname = "data", -#' extract_type = "list" -#' ) -#' isolate(filter_state$set_selected(c(3L, 8L))) -#' -#' isolate( -#' filter_states$state_list_push( -#' x = filter_state, -#' state_list_index = 1L, -#' state_id = "x" -#' ) -#' ) -#' isolate(filter_states$get_call()) -#' FilterStates <- R6::R6Class( # nolint classname = "FilterStates", @@ -54,81 +28,135 @@ FilterStates <- R6::R6Class( # nolint #' Initializes `FilterStates` object by setting #' `dataname`, and `datalabel`. #' + #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr + #' the R object which `subset` function is applied on. + #' @param data_reactive (`function(sid)`)\cr + #' should return an object of the same type as `data` object or `NULL`. + #' This object is needed for the `FilterState` counts being updated + #' on a change in filters. If function returns `NULL` then filtered counts are not shown. + #' Function has to have `sid` argument being a character. #' @param dataname (`character(1)`)\cr #' name of the data used in the expression #' specified to the function argument attached to this `FilterStates` - #' @param datalabel (`character(0)` or `character(1)`)\cr + #' @param datalabel (`NULL` or `character(1)`)\cr #' text label value #' #' @return #' self invisibly #' - initialize = function(dataname, datalabel) { + initialize = function(data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = NULL) { checkmate::assert_string(dataname) - checkmate::assert_character(datalabel, max.len = 1, any.missing = FALSE) + logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }") + checkmate::assert_function(data_reactive, args = "sid") + checkmate::assert_string(datalabel, null.ok = TRUE) private$dataname <- dataname private$datalabel <- datalabel + private$dataname_prefixed <- dataname + private$data <- data + private$data_reactive <- data_reactive + private$state_list <- reactiveVal() logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }") invisible(self) }, - #' @description - #' Returns the label of the dataset. - #' - #' @return `character(1)` the data label - #' - get_datalabel = function() { - private$datalabel - }, - #' @description #' Returns a formatted string representing this `FilterStates` object. #' - #' @param indent (`numeric(1)`) the number of spaces prepended to each line of the output + #' @param show_all `logical(1)` passed to `format.teal_slices` + #' @param trim_lines `logical(1)` passed to `format.teal_slices` #' #' @return `character(1)` the formatted string #' - format = function(indent) { + format = function(show_all = FALSE, trim_lines = TRUE) { sprintf( - paste( - "%sThis is an instance of an abstract class.", - "Use child class constructors to instantiate objects." - ), - paste(rep(" ", indent), collapse = "") + "%s:\n%s", + class(self)[1], + format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines) ) }, #' @description #' Filter call #' - #' Builds \emph{subset expression} from condition calls stored in `FilterState` - #' objects selection. The `lhs` of the expression is `private$dataname`. - #' The `rhs` is a call to `self$get_fun()` with `private$dataname` - #' as argument and a list of condition calls from `FilterState` objects - #' stored in `private$state_list`. - #' If no filters are applied, - #' `NULL` is returned to avoid no-op calls such as `x <- x`. + #' Builds \emph{subset expression} from condition calls generated by `FilterState`. + #' The `lhs` of the expression is a `dataname_prefixed`, where word prefixed refers to + #' situation when call is evaluated on elements of the original data, for example `dataname[[x]]`. + #' By default `dataname_prefixed = dataname` and it's not alterable through class methods. + #' Customization of `private$dataname_prefixed` is done through inheriting classes. + #' + #' The `rhs` is a call to `private$fun` with following arguments: + #' - `dataname_prefixed` + #' - list of logical expressions generated by `FilterState` objects + #' stored in `private$state_list`. Each logical predicate is combined with `&` operator. + #' Variables in these logical expressions by default are not prefixed but this can be changed + #' by setting `private$extract_type` (change in the similar way as `dataname_prefixed`) + #' Possible call outputs depending on a custom fields/options: + #' ``` + #' # default + #' dataname <- subset(dataname, col == "x") + #' + #' # fun = dplyr::filter + #' dataname <- dplyr::filter(dataname, col == "x") + #' + #' # fun = MultiAssayExperiment::subsetByColData; extract_type = "list" + #' dataname <- MultiAssayExperiment::subsetByColData(dataname, dataname$col == "x") + #' + #' # teal_slice objects having `arg = "subset"` and `arg = "select"` + #' dataname <- subset(dataname, subset = row_col == "x", select = col_col == "x") + #' + #' # dataname = dataname[[element]] + #' dataname[[element]] <- subset(dataname[[element]], subset = col == "x") + #' ``` + #' + #' If no filters are applied, `NULL` is returned to avoid no-op calls such as `dataname <- dataname`. + #' + #' @param sid (`character`)\cr + #' when specified then method returns code containing filter conditions of + #' `FilterState` objects which `"sid"` attribute is different than this `sid` argument. #' #' @return `call` or `NULL` #' - get_call = function() { - # state_list (list) names must be the same as argument of the function - # for ... list should be unnamed - states_list <- private$state_list - filter_items <- sapply( + get_call = function(sid = "") { + logger::log_trace("FilterStates$get_call initializing") + + # `arg` must be the same as argument of the function where + # predicate is passed to. + # For unnamed arguments state_list should have `arg = NULL` + states_list <- private$state_list_get() + if (length(states_list) == 0) { + return(NULL) + } + args <- vapply( + states_list, + function(x) { + arg <- x$get_state()$arg + `if`(is.null(arg), "", arg) # converting NULL -> "" to enable tapply. + }, + character(1) + ) + + filter_items <- tapply( X = states_list, - USE.NAMES = TRUE, + INDEX = args, simplify = FALSE, - function(state_list) { - items <- state_list() - filtered_items <- Filter(f = function(x) x$is_any_filtered(), x = items) - calls <- lapply( - filtered_items, - function(state) { - state$get_call() - } + function(items) { + # removing filters identified by sid + other_filter_idx <- !names(items) %in% sid + filtered_items <- items[other_filter_idx] + + calls <- Filter( + Negate(is.null), + lapply( + filtered_items, + function(state) { + state$get_call(dataname = private$dataname_prefixed) + } + ) ) calls_combine_by(calls, operator = "&") } @@ -138,8 +166,8 @@ FilterStates <- R6::R6Class( # nolint f = Negate(is.null) ) if (length(filter_items) > 0L) { - filter_function <- str2lang(self$get_fun()) - data_name <- str2lang(private$dataname) + filter_function <- private$fun + data_name <- str2lang(private$dataname_prefixed) substitute( env = list( lhs = data_name, @@ -156,158 +184,120 @@ FilterStates <- R6::R6Class( # nolint #' @description #' Prints this `FilterStates` object. #' - #' @param ... additional arguments to this method + #' @param ... additional arguments print = function(...) { - cat(shiny::isolate(self$format()), "\n") + cat(shiny::isolate(self$format(...)), "\n") }, #' @description - #' Gets the name of the function used to filter the data in this `FilterStates`. - #' - #' Get name of function used to create the \emph{subset expression}. - #' Defaults to "subset" but can be overridden by child class method. - #' - #' @return `character(1)` the name of the function - #' - get_fun = function() { - "subset" + #' Remove one or more `FilterState`s from the `state_list` along with their UI elements. + #' + #' @param state (`teal_slices`)\cr + #' specifying `FilterState` objects to remove; + #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored + #' + #' @return `NULL` invisibly + #' + remove_filter_state = function(state) { + shiny::isolate({ + checkmate::assert_class(state, "teal_slices") + state_ids <- vapply(state, `[[`, character(1), "id") + logger::log_trace("{ class(self)[1] }$remove_filter_state removing filters, state_id: { toString(state_ids) }") + private$state_list_remove(state_ids) + invisible(NULL) + }) }, - # state_list methods ---- - #' @description - #' Returns a list of `FilterState` objects stored in this `FilterStates`. + #' Gets reactive values from active `FilterState` objects. #' - #' @param state_list_index (`character(1)`, `integer(1)`)\cr - #' index on the list in `private$state_list` where filter states are kept - #' @param state_id (`character(1)`)\cr - #' name of element in a filter state (which is a `reactiveVal` containing a list) + #' Get active filter state from `FilterState` objects stored in `state_list`(s). + #' The output is a list compatible with input to `self$set_filter_state`. #' - #' @return `list` of `FilterState` objects + #' @return `list` containing `list` per `FilterState` in the `state_list` #' - state_list_get = function(state_list_index, state_id = NULL) { - private$validate_state_list_exists(state_list_index) - checkmate::assert_string(state_id, null.ok = TRUE) - - if (is.null(state_id)) { - private$state_list[[state_list_index]]() - } else { - private$state_list[[state_list_index]]()[[state_id]] + get_filter_state = function() { + slices <- unname(lapply(private$state_list(), function(x) x$get_state())) + fs <- do.call(teal_slices, c(slices, list(count_type = private$count_type))) + + include_varnames <- private$include_varnames + if (length(include_varnames)) { + attr(fs, "include_varnames") <- structure( + list(include_varnames), + names = private$dataname + ) } - }, - - #' @description - #' Adds a new `FilterState` object to this `FilterStates`.\cr - #' Raises error if the length of `x` does not match the length of `state_id`. - #' - #' @param x (`FilterState`)\cr - #' object to be added to filter state list - #' @param state_list_index (`character(1)`, `integer(1)`)\cr - #' index on the list in `private$state_list` where filter states are kept - #' @param state_id (`character(1)`)\cr - #' name of element in a filter state (which is a `reactiveVal` containing a list) - #' - #' @return NULL - #' - state_list_push = function(x, state_list_index, state_id) { - logger::log_trace( - "{ class(self)[1] } pushing into state_list, dataname: { private$dataname }" - ) - private$validate_state_list_exists(state_list_index) - checkmate::assert_string(state_id) - states <- if (is.list(x)) { - x - } else { - list(x) + exclude_varnames <- private$exclude_varnames + if (length(exclude_varnames)) { + attr(fs, "exclude_varnames") <- structure( + list(exclude_varnames), + names = private$dataname + ) } - state <- stats::setNames(states, state_id) - new_state_list <- c(private$state_list[[state_list_index]](), state) - private$state_list[[state_list_index]](new_state_list) - - logger::log_trace( - "{ class(self)[1] } pushed into queue, dataname: { private$dataname }" - ) - invisible(NULL) + return(fs) }, #' @description - #' Removes a single filter state with all associated shiny elements:\cr - #' * specified `FilterState` from `private$state_list` - #' * UI card created for this filter - #' * observers tracking the selection and remove button - #' - #' @param state_list_index (`character(1)`, `integer(1)`)\cr - #' index on the list in `private$state_list` where filter states are kept - #' @param state_id (`character(1)`)\cr - #' name of element in a filter state (which is a `reactiveVal` containing a list) - #' - #' @return NULL + #' Sets active `FilterState` objects. #' - state_list_remove = function(state_list_index, state_id) { - logger::log_trace(paste( - "{ class(self)[1] } removing a filter from state_list { state_list_index },", - "dataname: { private$dataname }" - )) - private$validate_state_list_exists(state_list_index) - checkmate::assert_string(state_id) - checkmate::assert( - checkmate::check_string(state_list_index), - checkmate::check_int(state_list_index) - ) + #' @param data (`data.frame`)\cr + #' data which are supposed to be filtered + #' @param state (`named list`)\cr + #' should contain values which are initial selection in the `FilterState`. + #' Names of the `list` element should correspond to the name of the + #' column in `data`. + #' @return function which throws an error + set_filter_state = function(state) { + shiny::isolate({ + logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }") + checkmate::assert_class(state, "teal_slices") + lapply(state, function(x) { + checkmate::assert_true( + x$dataname == private$dataname, + .var.name = "dataname matches private$dataname" + ) + }) - new_state_list <- private$state_list[[state_list_index]]() - new_state_list[[state_id]] <- NULL - private$state_list[[state_list_index]](new_state_list) + private$set_filterable_varnames( + include_varnames = attr(state, "include_varnames")[[private$dataname]], + exclude_varnames = attr(state, "exclude_varnames")[[private$dataname]] + ) - logger::log_trace(paste( - "{ class(self)[1] } removed from state_list { state_list_index },", - "dataname: { private$dataname }" - )) - invisible(NULL) - }, + count_type <- attr(state, "count_type") + if (length(count_type)) { + private$count_type <- count_type + } - #' @description - #' Remove all `FilterState` objects from this `FilterStates` object. - #' - #' @return NULL - #' - state_list_empty = function() { - logger::log_trace( - "{ class(self)[1] } emptying state_list, dataname: { private$dataname }" - ) + # Drop teal_slices that refer to excluded variables. + varnames <- slices_field(state, "varname") + excluded_varnames <- setdiff(varnames, private$get_filterable_varnames()) + if (length(excluded_varnames)) { + state <- Filter(function(x) !x$varname %in% excluded_varnames, state) + logger::log_warn("filters for columns: { toString(excluded_varnames) } excluded from { private$dataname }") + } - for (i in seq_along(private$state_list)) { - private$state_list[[i]](list()) - } + if (length(state) > 0) { + private$set_filter_state_impl( + state = state, + data = private$data, + data_reactive = private$data_reactive + ) + } + logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }") - logger::log_trace( - "{ class(self)[1] } emptied state_list, dataname: { private$dataname }" - ) - invisible(NULL) + invisible(NULL) + }) }, #' @description - #' Gets the number of active `FilterState` objects in this `FilterStates` object. - #' - #' @return `integer(1)` - #' - get_filter_count = function() { - sum(vapply(private$state_list, function(state_list) { - length(state_list()) - }, FUN.VALUE = integer(1))) - }, - - #' @description Remove a single `FilterState` from `state_list`. - #' - #' @param state_id (`character`)\cr - #' name of variable for which to remove `FilterState` + #' Remove all `FilterState` objects from this `FilterStates` object. #' - #' @return `NULL` + #' @return NULL #' - remove_filter_state = function(state_id) { - stop("This variable can not be removed from the filter.") + clear_filter_states = function() { + private$state_list_empty() }, # shiny modules ---- @@ -323,76 +313,191 @@ FilterStates <- R6::R6Class( # nolint #' #' @return `shiny.tag` #' - ui = function(id) { + ui_active = function(id) { ns <- NS(id) - private$cards_container_id <- ns("cards") tagList( - include_css_files(pattern = "filter-panel"), - tags$div( - id = private$cards_container_id, - class = "list-group hideable-list-group", - `data-label` = ifelse(private$datalabel == "", "", (paste0("> ", private$datalabel))) + teal.slice:::include_css_files(pattern = "filter-panel"), + uiOutput(ns("trigger_visible_state_change"), inline = TRUE), + uiOutput( + ns("cards"), + class = "accordion", + `data-label` = ifelse(length(private$datalabel), paste0("> ", private$datalabel), ""), ) ) }, #' @description - #' Gets reactive values from active `FilterState` objects. + #' Shiny server module. #' - #' Get active filter state from `FilterState` objects stored in `state_list`(s). - #' The output is a list compatible with input to `self$set_filter_state`. + #' @param id (`character(1)`)\cr + #' shiny module instance id #' - #' @return `list` containing `list` per `FilterState` in the `state_list` + #' @return `moduleServer` function which returns `NULL` #' - get_filter_state = function() { - stop("Pure virtual method.") - }, + srv_active = function(id) { + moduleServer( + id = id, + function(input, output, session) { + logger::log_trace("FilterState$srv_active initializing, dataname: { private$dataname }") + current_state <- reactive(private$state_list_get()) + previous_state <- reactiveVal(NULL) # FilterState list + added_states <- reactiveVal(NULL) # FilterState list + + # gives a valid shiny ns based on a default slice id + fs_to_shiny_ns <- function(x) { + checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr")) + gsub("[^[:alnum:]]+", "_", get_default_slice_id(x$get_state())) + } - #' @description - #' Sets active `FilterState` objects. - #' - #' @param data (`data.frame`)\cr - #' data object for which to define a subset - #' @param state (`named list`)\cr - #' should contain values of initial selections in the `FilterState`; - #' `list` names must correspond to column names in `data` - #' @param filtered_dataset - #' data object for which to define a subset(?) - #' - set_filter_state = function(data, state, filtered_dataset) { - stop("Pure virtual method.") + output$trigger_visible_state_change <- renderUI({ + current_state() + isolate({ + logger::log_trace("FilterStates$srv_active@1 determining added and removed filter states") + # Be aware this returns a list because `current_state` is a list and not `teal_slices`. + added_states(setdiff_teal_slices(current_state(), previous_state())) + previous_state(current_state()) + NULL + }) + }) + + output[["cards"]] <- shiny::renderUI({ + lapply( + current_state(), # observes only if added/removed + function(state) { + shiny::isolate( # isolates when existing state changes + state$ui(id = session$ns(fs_to_shiny_ns(state)), parent_id = session$ns("cards")) + ) + } + ) + }) + + observeEvent( + added_states(), # we want to call FilterState module only once when it's added + ignoreNULL = TRUE, + { + added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L)) + logger::log_trace("FilterStates$srv_active@2 triggered by added states: { toString(added_state_names) }") + lapply(added_states(), function(state) { + fs_callback <- state$server(id = fs_to_shiny_ns(state)) + observeEvent( + eventExpr = fs_callback(), # when remove button is clicked in the FilterState ui + once = TRUE, # remove button can be called once, should be destroyed afterwards + handlerExpr = private$state_list_remove(state$get_state()$id) + ) + }) + added_states(NULL) + } + ) + + NULL + } + ) }, #' @description - #' Shiny module UI that adds a filter variable. + #' Shiny UI module to add filter variable. #' #' @param id (`character(1)`)\cr - #' shiny element (module instance) id - #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr - #' data object for which to define a subset + #' shiny element (module instance) id #' #' @return `shiny.tag` #' - ui_add_filter_state = function(id, data) { - div("This object cannot be filtered") + ui_add = function(id) { + checkmate::assert_string(id) + data <- private$data + + ns <- NS(id) + + if (ncol(data) == 0) { + div("no sample variables available") + } else if (nrow(data) == 0) { + div("no samples available") + } else { + uiOutput(ns("add_filter")) + } }, #' @description - #' Shiny module server that adds a filter variable. + #' Shiny server module to add filter variable. + #' + #' This module controls available choices to select as a filter variable. + #' Once selected, a variable is removed from available choices. + #' Removing a filter variable adds it back to available choices. #' #' @param id (`character(1)`)\cr - #' shiny module instance id - #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr - #' data object for which to define a subset - #' @param ... ignored + #' an ID string that corresponds with the ID used to call the module's UI function. #' #' @return `moduleServer` function which returns `NULL` - #' - srv_add_filter_state = function(id, data, ...) { - check_ellipsis(..., stop = FALSE) + srv_add = function(id) { moduleServer( id = id, function(input, output, session) { + logger::log_trace("FilterStates$srv_add initializing, dataname: { private$dataname }") + + # available choices to display + avail_column_choices <- reactive({ + data <- private$data + vars_include <- private$get_filterable_varnames() + active_filter_vars <- slices_field(self$get_filter_state(), "varname") + choices <- setdiff(vars_include, active_filter_vars) + varlabels <- get_varlabels(data) + + data_choices_labeled( + data = data, + choices = choices, + varlabels = varlabels, + keys = private$keys + ) + }) + + + output$add_filter <- renderUI({ + logger::log_trace( + "FilterStates$srv_add@1 updating available column choices, dataname: { private$dataname }" + ) + if (length(avail_column_choices()) == 0) { + span("No available columns to add.") + } else { + div( + teal.widgets::optionalSelectInput( + session$ns("var_to_add"), + choices = avail_column_choices(), + selected = NULL, + options = shinyWidgets::pickerOptions( + liveSearch = TRUE, + noneSelectedText = "Select variable to filter" + ) + ) + ) + } + }) + + observeEvent( + eventExpr = input$var_to_add, + handlerExpr = { + logger::log_trace( + sprintf( + "FilterStates$srv_add@2 adding FilterState of variable %s, dataname: %s", + input$var_to_add, + private$dataname + ) + ) + self$set_filter_state( + teal_slices( + teal_slice(dataname = private$dataname, varname = input$var_to_add) + ) + ) + logger::log_trace( + sprintf( + "FilterStates$srv_add@2 added FilterState of variable %s, dataname: %s", + input$var_to_add, + private$dataname + ) + ) + } + ) + + logger::log_trace("FilterStates$srv_add initialized, dataname: { private$dataname }") NULL } ) @@ -400,175 +505,244 @@ FilterStates <- R6::R6Class( # nolint ), private = list( # private fields ---- - cards_container_id = character(0), - card_ids = character(0), - datalabel = character(0), + count_type = "none", # specifies how observation numbers are displayed in filter cards, + data = NULL, # data.frame, MAE, SE or matrix + data_reactive = NULL, # reactive + datalabel = NULL, # to follow default `experiment = NULL` in `teal_slice` dataname = NULL, # because it holds object of class name + dataname_prefixed = character(0), # name used in call returned from get_call + exclude_varnames = character(0), # holds column names + include_varnames = character(0), # holds column names + extract_type = character(0), # type of the prefix in a subset call (eg. "list": x$var; "matrix": x[["var"]]) + fun = quote(subset), # function used to generate subset call + keys = character(0), ns = NULL, # shiny ns() observers = list(), # observers - state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes + state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes, # private methods ---- - # Module to insert/remove `FilterState` UI + # @description + # Set the allowed filterable variables + # @param include_varnames (`character`) Names of variables included in filtering. + # @param exclude_varnames (`character`) Names of variables excluded from filtering. + # + # @details When retrieving the filtered variables only + # those which have filtering supported (i.e. are of the permitted types). + # Only one from `include_varnames` and `exclude_varnames` can be used in one call. When `exclude_varnames` + # is called `include_varnames` is cleared - same otherwise. + # are included. + # + # @return NULL invisibly + set_filterable_varnames = function(include_varnames = character(0), exclude_varnames = character(0)) { + if ((length(include_varnames) + length(exclude_varnames)) == 0L) { + return(invisible(NULL)) + } + checkmate::assert_character(include_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE) + checkmate::assert_character(exclude_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE) + if (length(include_varnames) && length(exclude_varnames)) { + stop( + "`include_varnames` and `exclude_varnames` has been both specified for", + private$dataname, + ". Only one per dataset is allowed.", + ) + } + supported_vars <- get_supported_filter_varnames(private$data) + if (length(include_varnames)) { + private$include_varnames <- intersect(include_varnames, supported_vars) + private$exclude_varnames <- character(0) + } else { + private$exclude_varnames <- exclude_varnames + private$include_varnames <- character(0) + } + invisible(NULL) + }, + + # @description + # Get vector of filterable varnames # - # This module adds the shiny UI of the `FilterState` object newly added - # to state_list to the Active Filter Variables, - # calls `FilterState` modules and creates an observer to remove state - # parameter filter_state (`FilterState`). + # @details + # These are the only columns which can be used in the filter panel + # + # @return character vector with names of the columns + get_filterable_varnames = function() { + if (length(private$include_varnames)) { + private$include_varnames + } else { + supported_varnames <- get_supported_filter_varnames(private$data) + setdiff(supported_varnames, private$exclude_varnames) + } + }, + + # state_list methods ---- + + # @description + # Returns a list of `FilterState` objects stored in this `FilterStates`. # - # @param id (`character(1)`)\cr - # shiny module instance id - # @param filter_state (`named list`)\cr - # should contain values of initial selections in the `FilterState`; - # `list` names must correspond to column names in `data` - # @param state_list_index (`character(1)`, `integer(1)`)\cr - # index on the list in `private$state_list` where filter states are kept # @param state_id (`character(1)`)\cr # name of element in a filter state (which is a `reactiveVal` containing a list) # - # @return `moduleServer` function which returns `NULL` + # @return `list` of `FilterState` objects # - insert_filter_state_ui = function(id, filter_state, state_list_index, state_id) { - checkmate::assert_class(filter_state, "FilterState") - checkmate::assert( - checkmate::check_int(state_list_index), - checkmate::check_character(state_list_index, len = 1), - combine = "or" - ) - checkmate::assert_character(state_id, len = 1) - moduleServer( - id = id, - function(input, output, session) { - logger::log_trace( - sprintf( - "%s$insert_filter_state_ui, adding FilterState UI of variable %s, dataname: %s", - class(self)[1], - state_id, - private$dataname - ) - ) + state_list_get = function(state_id = NULL) { + checkmate::assert_string(state_id, null.ok = TRUE) - # card_id of inserted card must be saved in private$card_ids as - # it might be removed by the several events: - # - remove button in FilterStates module - # - remove button in FilteredDataset module - # - remove button in FilteredData module - # - API call remove_filter_state - card_id <- session$ns("card") - state_list_id <- sprintf("%s-%s", state_list_index, state_id) - private$card_ids[state_list_id] <- card_id - - insertUI( - selector = sprintf("#%s", private$cards_container_id), - where = "beforeEnd", - # add span with id to be removable - ui = div( - id = card_id, - class = "list-group-item", - filter_state$ui(session$ns("content")) - ) - ) - # signal sent from filter_state when it is marked for removal - remove_fs <- filter_state$server(id = "content") + if (is.null(state_id)) { + private$state_list() + } else { + private$state_list()[[state_id]] + } + }, - private$observers[[state_list_id]] <- observeEvent( - ignoreInit = TRUE, - ignoreNULL = TRUE, - eventExpr = remove_fs(), - handlerExpr = { - logger::log_trace(paste( - "{ class(self)[1] }$insert_filter_state_ui@1", - "removing FilterState from state_list '{ state_list_index }',", - "dataname: { private$dataname }" - )) - self$state_list_remove(state_list_index, state_id) - logger::log_trace(paste( - "{ class(self)[1] }$insert_filter_state_ui@1", - "removed FilterState from state_list '{ state_list_index }',", - "dataname: { private$dataname }" - )) - } - ) + # @description + # Adds a new `FilterState` object to this `FilterStates`.\cr + # Raises error if the length of `x` does not match the length of `state_id`. + # + # @param x (`FilterState`)\cr + # object to be added to filter state list + # @param state_id (`character(1)`)\cr + # name of element in a filter state (which is a `reactiveVal` containing a list) + # + # @return NULL + # + state_list_push = function(x, state_id) { + logger::log_trace("{ class(self)[1] } pushing into state_list, dataname: { private$dataname }") + checkmate::assert_string(state_id) + checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr")) + state <- stats::setNames(list(x), state_id) + new_state_list <- c( + shiny::isolate(private$state_list()), + state + ) + shiny::isolate(private$state_list(new_state_list)) - logger::log_trace( - sprintf( - "%s$insert_filter_state_ui, added FilterState UI of variable %s, dataname: %s", - class(self)[1], - state_id, - private$dataname - ) + logger::log_trace("{ class(self)[1] } pushed into queue, dataname: { private$dataname }") + invisible(NULL) + }, + + # @description + # Removes a single filter state with all associated shiny elements:\cr + # * specified `FilterState` from `private$state_list` + # * UI card created for this filter + # * observers tracking the selection and remove button + # + # @param state_id (`character`)\cr + # names of element in a filter state (which is a `reactiveVal` containing a list) + # + # @return NULL + # + state_list_remove = function(state_id) { + shiny::isolate({ + logger::log_trace("{ class(self)[1] } removing a filter, state_id: { state_id }") + checkmate::assert_character(state_id) + new_state_list <- private$state_list() + current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1)) + to_remove <- state_id %in% current_state_ids + if (any(to_remove)) { + new_state_list <- Filter( + function(state) { + if (state$get_state()$id %in% state_id && !state$get_state()$locked) { + state$destroy_observers() + FALSE + } else { + TRUE + } + }, + private$state_list() ) - NULL + private$state_list(new_state_list) + } else { + warning(sprintf("\"%s\" not found in state list", state_id)) } - ) + invisible(NULL) + }) }, - # Remove shiny element. Method can be called from reactive session where - # `observeEvent` for remove-filter-state is set and also from `FilteredDataset` - # level, where shiny-session-namespace is different. That is why it's important - # to remove shiny elements from anywhere. In `add_filter_state` `session$ns(NULL)` - # is equivalent to `private$ns(state_list_index)`. - # In addition, an unused reactive is being removed from input: - # method searches input for the unique matches with the filter name - # and then removes objects constructed with current card id + filter name. + # @description + # Remove all `FilterState` objects from this `FilterStates` object. # - remove_filter_state_ui = function(state_list_index, state_id, .input) { - state_list_id <- sprintf("%s-%s", state_list_index, state_id) - removeUI(selector = sprintf("#%s", private$card_ids[state_list_id])) - private$card_ids <- private$card_ids[names(private$card_ids) != state_list_id] - if (length(private$observers[[state_list_id]]) > 0) { - private$observers[[state_list_id]]$destroy() - private$observers[[state_list_id]] <- NULL - } - # Remove unused reactive from shiny input (leftover of removeUI). - # This default behavior may change in the future, making this part obsolete. - prefix <- paste0(gsub("cards$", "", private$cards_container_id)) - invisible( - lapply( - unique(grep(state_id, names(.input), value = TRUE)), - function(i) { - .subset2(.input, "impl")$.values$remove(paste0(prefix, i)) - } + # @return invisible NULL + # + state_list_empty = function() { + shiny::isolate({ + logger::log_trace( + "{ class(self)[1] }$state_list_empty removing all non-locked filters for dataname: { private$dataname }" ) - ) + + state_list <- private$state_list() + if (length(state_list)) { + state_list_ids <- vapply(state_list, function(x) x$get_state()$id, character(1)) + private$state_list_remove(state_list_ids) + } + invisible(NULL) + }) }, - # Checks if the state_list of the given index was initialized in this `FilterStates` - # @param state_list_index (character or integer) - validate_state_list_exists = function(state_list_index) { - checkmate::assert( - checkmate::check_string(state_list_index), - checkmate::check_int(state_list_index) - ) - if ( - !( - is.numeric(state_list_index) && - all(state_list_index <= length(private$state_list) && state_list_index > 0) || - is.character(state_list_index) && all(state_list_index %in% names(private$state_list)) - ) - ) { + + # @description + # Set filter state + # + # Utility method for `set_filter_state` to create or modify `FilterState` using a single + # `teal_slice`. + # @param state (`teal_slices`) + # @param data (`data.frame`, `matrix` or `DataFrame`) + # @param data_reactive (`function`) + # function having `sid` as argument + # + # @return invisible NULL + # + set_filter_state_impl = function(state, + data, + data_reactive) { + checkmate::assert_class(state, "teal_slices") + checkmate::assert_multi_class(data, c("data.frame", "matrix", "DataFrame", "HermesData")) + checkmate::assert_function(data_reactive, args = "sid") + if (length(state) == 0L) { + return(invisible(NULL)) + } + + slices_hashed <- vapply(state, `[[`, character(1L), "id") + if (any(duplicated(slices_hashed))) { stop( - paste( - "Filter state list", - state_list_index, - "has not been initialized in FilterStates object belonging to the dataset", - private$datalabel - ) + "Some of the teal_slice objects refer to the same filter. ", + "Please specify different 'id' when calling teal_slice" ) } - }, - # Maps the array of strings to sanitized unique HTML ids. - # @param keys `character` the array of strings - # @param prefix `character(1)` text to prefix id. Needed in case of multiple - # state_list objects where keys (variables) might be duplicated across state_lists - # @return `list` the mapping - map_vars_to_html_ids = function(keys, prefix = "") { - checkmate::assert_character(keys, null.ok = TRUE) - checkmate::assert_character(prefix, len = 1) - sanitized_values <- make.unique(gsub("[^[:alnum:]]", perl = TRUE, replacement = "", x = keys)) - sanitized_values <- paste(prefix, "var", sanitized_values, sep = "_") - stats::setNames(object = sanitized_values, nm = keys) + state_list <- shiny::isolate(private$state_list_get()) + lapply(state, function(slice) { + state_id <- slice$id + if (state_id %in% names(state_list)) { + # Modify existing filter states. + state_list[[state_id]]$set_state(slice) + } else { + if (inherits(slice, "teal_slice_expr")) { + # create a new FilterStateExpr + fstate <- init_filter_state_expr(slice) + private$state_list_push(x = fstate, state_id = state_id) + } else { + # create a new FilterState + fstate <- init_filter_state( + x = data[, slice$varname, drop = TRUE], + # data_reactive is a function which eventually calls get_call(sid). + # This chain of calls returns column from the data filtered by everything + # but filter identified by the sid argument. FilterState then get x_reactive + # and this no longer needs to be a function to pass sid. reactive in the FilterState + # is also beneficial as it can be cached and retriger filter counts only if + # returned vector is different. + x_reactive = if (private$count_type == "none") { + reactive(NULL) + } else { + reactive(data_reactive(state_id)[, slice$varname, drop = TRUE]) + }, + slice = slice, + extract_type = private$extract_type + ) + private$state_list_push(x = fstate, state_id = state_id) + } + } + }) + + invisible(NULL) } ) ) diff --git a/R/FilterStatesDF.R b/R/FilterStatesDF.R index bde15d8bb..674cbabc3 100644 --- a/R/FilterStatesDF.R +++ b/R/FilterStatesDF.R @@ -4,10 +4,10 @@ #' #' #' @examples -#' \dontrun{ #' # working filters in an app #' #' library(shiny) +#' library(shinyjs) #' #' # create data frame to filter #' data_df <- data.frame( @@ -29,22 +29,24 @@ #' data_df <- rbind(data_df, data_na) #' #' -#' # initiate FilterStates object +#' # initiate `FilterStates` object #' filter_states_df <- init_filter_states( #' data = data_df, #' dataname = "dataset", -#' datalabel = ("label"), -#' varlabels = c("long", "short", "long", "short", "long", "long") +#' datalabel = ("label") #' ) #' #' ui <- fluidPage( +#' useShinyjs(), +#' teal.slice:::include_css_files(pattern = "filter-panel"), +#' teal.slice:::include_js_files(pattern = "count-bar-labels"), #' column(4, div( #' h4("Active filters"), -#' filter_states_df$ui("fsdf") +#' filter_states_df$ui_active("fsdf") #' )), #' column(4, div( #' h4("Manual filter control"), -#' filter_states_df$ui_add_filter_state("add_filters", data_df), br(), +#' filter_states_df$ui_add("add_filters"), br(), #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterStates #' textOutput("call_df"), br(), #' h4("Formatted state"), # display human readable filter state @@ -71,49 +73,51 @@ #' ) #' #' server <- function(input, output, session) { -#' filter_states_df$srv_add_filter_state("add_filters", data_df) -#' filter_states_df$server("fsdf") +#' filter_states_df$srv_add("add_filters") +#' filter_states_df$srv_active("fsdf") #' #' output$call_df <- renderPrint(filter_states_df$get_call()) #' output$formatted_df <- renderText(filter_states_df$format()) #' #' observeEvent(input$button1_df, { -#' filter_state <- list(NUM1 = list(selected = c(0, 30))) -#' filter_states_df$set_filter_state(data = data_df, state = filter_state) +#' filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30))) +#' filter_states_df$set_filter_state(state = filter_state) #' }) #' observeEvent(input$button2_df, { -#' filter_state <- list(NUM2 = list(selected = c(20, 21))) -#' filter_states_df$set_filter_state(data = data_df, state = filter_state) +#' filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21))) +#' filter_states_df$set_filter_state(state = filter_state) #' }) #' observeEvent(input$button3_df, { -#' filter_state <- list(CHAR1 = list(selected = c("B", "C", "D"))) -#' filter_states_df$set_filter_state(data = data_df, state = filter_state) +#' filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D"))) +#' filter_states_df$set_filter_state(state = filter_state) #' }) #' observeEvent(input$button4_df, { -#' filter_state <- list(CHAR2 = list(selected = "F")) -#' filter_states_df$set_filter_state(data = data_df, state = filter_state) +#' filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F"))) +#' filter_states_df$set_filter_state(state = filter_state) #' }) #' observeEvent(input$button5_df, { -#' filter_state <- list(DATE = list(selected = c("2020-01-01", "2020-02-02"))) -#' filter_states_df$set_filter_state(data = data_df, state = filter_state) +#' filter_state <- teal_slices( +#' teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02")) +#' ) +#' filter_states_df$set_filter_state(state = filter_state) #' }) #' observeEvent(input$button6_df, { -#' filter_state <- list(DATETIME = list(selected = as.POSIXct(c("2020-01-01", "2020-02-02")))) -#' filter_states_df$set_filter_state(data = data_df, state = filter_state) +#' filter_state <- teal_slices( +#' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02"))) +#' ) +#' filter_states_df$set_filter_state(state = filter_state) #' }) -#' observeEvent(input$button7_df, filter_states_df$state_list_remove(1, state_id = "NUM1")) -#' observeEvent(input$button8_df, filter_states_df$state_list_remove(1, state_id = "NUM2")) -#' observeEvent(input$button9_df, filter_states_df$state_list_remove(1, state_id = "CHAR1")) -#' observeEvent(input$button10_df, filter_states_df$state_list_remove(1, state_id = "CHAR2")) -#' observeEvent(input$button11_df, filter_states_df$state_list_remove(1, state_id = "DATE")) -#' observeEvent(input$button12_df, filter_states_df$state_list_remove(1, state_id = "DATETIME")) -#' observeEvent(input$button0_df, filter_states_df$state_list_empty()) +#' observeEvent(input$button7_df, filter_states_df$remove_filter_state(state_id = "NUM1")) +#' observeEvent(input$button8_df, filter_states_df$remove_filter_state(state_id = "NUM2")) +#' observeEvent(input$button9_df, filter_states_df$remove_filter_state(state_id = "CHAR1")) +#' observeEvent(input$button10_df, filter_states_df$remove_filter_state(state_id = "CHAR2")) +#' observeEvent(input$button11_df, filter_states_df$remove_filter_state(state_id = "DATE")) +#' observeEvent(input$button12_df, filter_states_df$remove_filter_state(state_id = "DATETIME")) +#' observeEvent(input$button0_df, filter_states_df$clear_filter_states()) #' } -#' #' if (interactive()) { #' shinyApp(ui, server) #' } -#' } #' DFFilterStates <- R6::R6Class( # nolint classname = "DFFilterStates", @@ -129,404 +133,36 @@ DFFilterStates <- R6::R6Class( # nolint #' which means that when calling the subset function associated with this class #' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`). #' - #' @param dataname (`character(1)`)\cr + #' @param data (`data.frame`)\cr + #' the R object which `dplyr::filter` function is applied on. + #' @param data_reactive (`function(sid)`)\cr + #' should return a `data.frame` object or `NULL`. + #' This object is needed for the `FilterState` counts being updated + #' on a change in filters. If function returns `NULL` then filtered counts are not shown. + #' Function has to have `sid` argument being a character. + #' @param dataname (`character`)\cr #' name of the data used in the \emph{subset expression} #' specified to the function argument attached to this `FilterStates` - #' @param datalabel (`character(0)` or `character(1)`)\cr + #' @param datalabel (`NULL` or `character(1)`)\cr #' text label value - #' @param varlabels (`character`)\cr - #' labels of the variables used in this object #' @param keys (`character`)\cr #' key columns names #' - initialize = function(dataname, datalabel, varlabels, keys) { - super$initialize(dataname, datalabel) - private$varlabels <- varlabels - private$keys <- keys - private$state_list <- list( - reactiveVal() - ) - }, - - #' @description - #' Returns a formatted string representing this `FilterStates` object. - #' - #' @param indent (`numeric(1)`) the number of spaces prepended to each line of the output - #' - #' @return `character(1)` the formatted string - #' - format = function(indent = 0) { - checkmate::assert_number(indent, finite = TRUE, lower = 0) - - formatted_states <- vapply( - self$state_list_get(1L), function(state) state$format(indent = indent), - USE.NAMES = FALSE, FUN.VALUE = character(1) - ) - paste(formatted_states, collapse = "\n") - }, - - #' @description - #' Gets the name of the function used to filter the data in this `FilterStates`. - #' - #' Get name of function used to create the \emph{subset expression}. - #' For `DFFilterStates` this is `dplyr::filter`. - #' - #' @return `character(1)` - get_fun = function() { - "dplyr::filter" - }, - - #' @description - #' Shiny server module. - #' - #' @param id (`character(1)`)\cr - #' shiny module instance id - #' - #' @return `moduleServer` function which returns `NULL` - #' - server = function(id) { - moduleServer( - id = id, - function(input, output, session) { - previous_state <- reactiveVal(isolate(self$state_list_get(1L))) - added_state_name <- reactiveVal(character(0)) - removed_state_name <- reactiveVal(character(0)) - - observeEvent(self$state_list_get(1L), { - added_state_name(setdiff(names(self$state_list_get(1L)), names(previous_state()))) - removed_state_name(setdiff(names(previous_state()), names(self$state_list_get(1L)))) - previous_state(self$state_list_get(1L)) - }) - - observeEvent(added_state_name(), ignoreNULL = TRUE, { - fstates <- self$state_list_get(1L) - html_ids <- private$map_vars_to_html_ids(names(fstates)) - for (fname in added_state_name()) { - private$insert_filter_state_ui( - id = html_ids[fname], - filter_state = fstates[[fname]], - state_list_index = 1L, - state_id = fname - ) - } - added_state_name(character(0)) - }) - - observeEvent(removed_state_name(), { - req(removed_state_name()) - for (fname in removed_state_name()) { - private$remove_filter_state_ui(1L, fname, .input = input) - } - removed_state_name(character(0)) - }) - NULL - } - ) - }, - - #' @description - #' Gets the reactive values from the active `FilterState` objects. - #' - #' Get active filter state from the `FilterState` objects kept in `state_list`. - #' The output list is a compatible input to `self$set_filter_state`. - #' - #' @return `list` with named elements corresponding to `FilterState` in the `state_list`. - #' - get_filter_state = function() { - lapply(self$state_list_get(1L), function(x) x$get_state()) - }, - - #' @description - #' Set filter state. - #' - #' @param data (`data.frame`)\cr - #' data object for which to define a subset - #' @param state (`named list`)\cr - #' should contain values of initial selections in the `FilterState`; - #' `list` names must correspond to column names in `data` - #' @param vars_include (`character(n)`)\cr - #' optional, vector of column names to be included - #' @param ... ignored - #' - #' @examples - #' dffs <- teal.slice:::DFFilterStates$new( - #' dataname = "iris", - #' datalabel = character(0), - #' varlabels = character(0), - #' keys = character(0) - #' ) - #' fs <- list( - #' Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE), - #' Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) - #' ) - #' shiny::isolate(dffs$set_filter_state(state = fs, data = iris)) - #' shiny::isolate(dffs$get_filter_state()) - #' - #' @return `NULL` - #' - set_filter_state = function(data, state, vars_include = get_supported_filter_varnames(data = data), ...) { + initialize = function(data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = NULL, + keys = character(0)) { + checkmate::assert_function(data_reactive, args = "sid") checkmate::assert_data_frame(data) - checkmate::assert( - checkmate::check_subset(names(state), names(data)), - checkmate::check_class(state, "default_filter"), - combine = "or" - ) - logger::log_trace( - "{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }" - ) - - filter_states <- self$state_list_get(1L) - state_names <- names(state) - excluded_vars <- setdiff(state_names, vars_include) - if (length(excluded_vars) > 0) { - warning( - paste( - "These columns filters were excluded:", - paste(excluded_vars, collapse = ", "), - "from dataset", - private$dataname - ) - ) - logger::log_warn( - paste( - "Columns filters { paste(excluded_vars, collapse = ', ') } were excluded", - "from { private$dataname }" - ) - ) - } - - filters_to_apply <- state_names[state_names %in% vars_include] - - for (varname in filters_to_apply) { - value <- resolve_state(state[[varname]]) - if (varname %in% names(filter_states)) { - fstate <- filter_states[[varname]] - fstate$set_state(value) - } else { - fstate <- init_filter_state( - data[[varname]], - varname = varname, - varlabel = private$get_varlabels(varname), - dataname = private$dataname - ) - fstate$set_state(value) - self$state_list_push(x = fstate, state_list_index = 1L, state_id = varname) - } - } - logger::log_trace( - "{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }" - ) - NULL - }, - - #' @description Remove a `FilterState` from the `state_list`. - #' - #' @param state_id (`character(1)`)\cr name of `state_list` element - #' - #' @return `NULL` - #' - remove_filter_state = function(state_id) { - logger::log_trace( - sprintf( - "%s$remove_filter_state for variable %s called, dataname: %s", - class(self)[1], - state_id, - private$dataname - ) - ) - - if (!state_id %in% names(self$state_list_get(1L))) { - warning(paste( - "Variable:", state_id, - "is not present in the actual active filters of dataset: { private$dataname }", - "therefore no changes are applied." - )) - logger::log_warn( - paste( - "Variable:", state_id, "is not present in the actual active filters of dataset:", - "{ private$dataname } therefore no changes are applied." - ) - ) - } else { - self$state_list_remove(state_list_index = 1L, state_id = state_id) - logger::log_trace( - sprintf( - "%s$remove_filter_state for variable %s done, dataname: %s", - class(self)[1], - state_id, - private$dataname - ) - ) - } - }, - - # shiny modules ---- - - #' @description - #' Shiny UI module to add filter variable. - #' - #' @param id (`character(1)`)\cr - #' shiny element (module instance) id - #' @param data (`data.frame`)\cr - #' data object for which to define a subset - #' - #' @return `shiny.tag` - #' - ui_add_filter_state = function(id, data) { - checkmate::assert_string(id) - checkmate::assert_data_frame(data) - - ns <- NS(id) - - if (ncol(data) == 0) { - div("no sample variables available") - } else if (nrow(data) == 0) { - div("no samples available") - } else { - div( - teal.widgets::optionalSelectInput( - ns("var_to_add"), - choices = NULL, - options = shinyWidgets::pickerOptions( - liveSearch = TRUE, - noneSelectedText = "Select variable to filter" - ) - ) - ) - } - }, - - #' @description - #' Shiny server module to add filter variable. - #' - #' This module controls available choices to select as a filter variable. - #' Once selected, a variable is removed from available choices. - #' Removing a filter variable adds it back to available choices. - #' - #' @param id (`character(1)`)\cr - #' shiny module instance id - #' @param data (`data.frame`)\cr - #' data object for which to define a subset - #' @param vars_include (`character(n)`)\cr - #' optional, vector of column names to be included - #' @param ... ignored - #' - #' @return `moduleServer` function which returns `NULL` - #' - srv_add_filter_state = function(id, data, vars_include = get_supported_filter_varnames(data = data), ...) { - stopifnot(is.data.frame(data)) - check_ellipsis(..., stop = FALSE) - moduleServer( - id = id, - function(input, output, session) { - logger::log_trace( - "DFFilterStates$srv_add_filter_state initializing, dataname: { private$dataname }" - ) - shiny::setBookmarkExclude(c("var_to_add")) - active_filter_vars <- reactive({ - vapply( - X = self$state_list_get(state_list_index = 1L), - FUN.VALUE = character(1), - FUN = function(x) x$get_varname() - ) - }) - - # available choices to display - avail_column_choices <- reactive({ - choices <- setdiff(vars_include, active_filter_vars()) - - data_choices_labeled( - data = data, - choices = choices, - varlabels = private$get_varlabels(choices), - keys = private$keys - ) - }) - observeEvent( - avail_column_choices(), - ignoreNULL = TRUE, - handlerExpr = { - logger::log_trace(paste( - "DFFilterStates$srv_add_filter_state@1 updating available column choices,", - "dataname: { private$dataname }" - )) - if (is.null(avail_column_choices())) { - shinyjs::hide("var_to_add") - } else { - shinyjs::show("var_to_add") - } - teal.widgets::updateOptionalSelectInput( - session, - "var_to_add", - choices = avail_column_choices() - ) - logger::log_trace(paste( - "DFFilterStates$srv_add_filter_state@1 updated available column choices,", - "dataname: { private$dataname }" - )) - } - ) - - observeEvent( - eventExpr = input$var_to_add, - handlerExpr = { - logger::log_trace( - sprintf( - "DFFilterStates$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s", - input$var_to_add, - private$dataname - ) - ) - self$state_list_push( - x = init_filter_state( - data[[input$var_to_add]], - varname = input$var_to_add, - varlabel = private$get_varlabels(input$var_to_add), - dataname = private$dataname - ), - state_list_index = 1L, - state_id = input$var_to_add - ) - logger::log_trace( - sprintf( - "DFFilterStates$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s", - input$var_to_add, - private$dataname - ) - ) - } - ) - - logger::log_trace( - "DFFilterStates$srv_add_filter_state initialized, dataname: { private$dataname }" - ) - NULL - } - ) + super$initialize(data, data_reactive, dataname, datalabel) + private$keys <- keys + private$set_filterable_varnames(include_varnames = colnames(private$data)) } ), # private members ---- private = list( - varlabels = character(0), - keys = character(0), - # @description - # Get label of specific variable. If variable label is missing, variable name is returned. - # - # @para variable (`character`)\cr - # name of variable for which label should be returned - # - # @return `character` - get_varlabels = function(variables = character(0)) { - checkmate::assert_character(variables) - if (identical(variables, character(0))) { - private$varlabels - } else { - varlabels <- private$varlabels[variables] - missing_labels <- is.na(varlabels) | varlabels == "" - varlabels[missing_labels] <- variables[missing_labels] - varlabels - } - } + fun = quote(dplyr::filter) ) ) diff --git a/R/FilterStatesMAE.R b/R/FilterStatesMAE.R index 59a72635e..904058958 100644 --- a/R/FilterStatesMAE.R +++ b/R/FilterStatesMAE.R @@ -1,4 +1,4 @@ -#' @title `FilterStates` subclass for MultiAssayExperiments +#' @title `FilterStates` subclass for `MultiAssayExperiments` #' @description Handles filter states in a `MultiAssayExperiment` #' @keywords internal #' @@ -6,377 +6,53 @@ MAEFilterStates <- R6::R6Class( # nolint classname = "MAEFilterStates", inherit = FilterStates, - - # public methods ---- public = list( + # public methods ---- + #' @description Initializes `MAEFilterStates` object #' #' Initialize `MAEFilterStates` object #' + #' @param data (`MultiAssayExperiment`)\cr + #' the R object which `MultiAssayExperiment::subsetByColData` function is applied on. + #' @param data_reactive (`function(sid)`)\cr + #' should return a `MultiAssayExperiment` object or `NULL`. + #' This object is needed for the `FilterState` counts being updated + #' on a change in filters. If function returns `NULL` then filtered counts are not shown. + #' Function has to have `sid` argument being a character. #' @param dataname (`character(1)`)\cr #' name of the data used in the expression #' specified to the function argument attached to this `FilterStates`. - #' - #' @param datalabel (`character(0)` or `character(1)`)\cr - #' text label value. - #' + #' @param datalabel (`NULL` or `character(1)`)\cr + #' text label value #' @param varlabels (`character`)\cr #' labels of the variables used in this object - #' #' @param keys (`character`)\cr #' key columns names - initialize = function(dataname, datalabel, varlabels, keys) { + #' + initialize = function(data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = "subjects", + keys = character(0)) { if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { stop("Cannot load MultiAssayExperiment - please install the package or restart your session.") } - super$initialize(dataname, datalabel) + checkmate::assert_function(data_reactive, args = "sid") + checkmate::assert_class(data, "MultiAssayExperiment") + data <- SummarizedExperiment::colData(data) + data_reactive <- function(sid = "") SummarizedExperiment::colData(data_reactive(sid = sid)) + super$initialize(data, data_reactive, dataname, datalabel) private$keys <- keys - private$varlabels <- varlabels - private$state_list <- list( - y = reactiveVal() - ) + private$set_filterable_varnames(include_varnames = colnames(data)) return(invisible(self)) - }, - - #' @description - #' Returns the formatted string representing this `MAEFilterStates` object. - #' - #' @param indent (`numeric(1)`) the number of spaces before each line of the representation - #' @return `character(1)` the formatted string - format = function(indent = 0) { - checkmate::assert_number(indent, finite = TRUE, lower = 0) - - if (length(self$state_list_get(1L)) > 0) { - formatted_states <- sprintf("%sSubject filters:", format("", width = indent)) - for (state in self$state_list_get(1L)) { - formatted_states <- c(formatted_states, state$format(indent = indent + 2)) - } - paste(formatted_states, collapse = "\n") - } - }, - - #' @description - #' Returns function name used to create filter call. - #' For `MAEFilterStates` `MultiAssayExperiment::subsetByColData` is used. - #' @return `character(1)` - get_fun = function() { - "MultiAssayExperiment::subsetByColData" - }, - - #' @description - #' Server module - #' @param id (`character(1)`)\cr - #' an ID string that corresponds with the ID used to call the module's UI function. - #' @return `moduleServer` function which returns `NULL` - server = function(id) { - moduleServer( - id = id, - function(input, output, session) { - previous_state <- reactiveVal(isolate(self$state_list_get("y"))) - added_state_name <- reactiveVal(character(0)) - removed_state_name <- reactiveVal(character(0)) - - observeEvent(self$state_list_get("y"), { - added_state_name(setdiff(names(self$state_list_get("y")), names(previous_state()))) - removed_state_name(setdiff(names(previous_state()), names(self$state_list_get("y")))) - - previous_state(self$state_list_get("y")) - }) - - observeEvent(added_state_name(), ignoreNULL = TRUE, { - fstates <- self$state_list_get("y") - html_ids <- private$map_vars_to_html_ids(names(fstates)) - for (fname in added_state_name()) { - private$insert_filter_state_ui( - id = html_ids[fname], - filter_state = fstates[[fname]], - state_list_index = "y", - state_id = fname - ) - } - added_state_name(character(0)) - }) - - observeEvent(removed_state_name(), { - req(removed_state_name()) - for (fname in removed_state_name()) { - private$remove_filter_state_ui("y", fname, .input = input) - } - removed_state_name(character(0)) - }) - NULL - } - ) - }, - - #' @description - #' Returns active `FilterState` objects. - #' - #' Gets all active filters from this dataset in form of the nested list. - #' The output list can be used as input to `self$set_filter_state`. - #' - #' @return `list` with elements number equal number of `FilterStates`. - get_filter_state = function() { - lapply(self$state_list_get(state_list_index = "y"), function(x) x$get_state()) - }, - - #' @description - #' Set filter state - #' - #' @param data (`MultiAssayExperiment`)\cr - #' data which are supposed to be filtered. - #' @param state (`named list`)\cr - #' should contain values which are initial selection in the `FilterState`. - #' Names of the `list` element should correspond to the name of the - #' column in `colData(data)`. - #' @param ... ignored. - #' @return `NULL` - set_filter_state = function(data, state, ...) { - checkmate::assert_class(data, "MultiAssayExperiment") - checkmate::assert( - checkmate::check_subset(names(state), names(SummarizedExperiment::colData(data))), - checkmate::check_class(state, "default_filter"), - combine = "or" - ) - logger::log_trace("MAEFilterState$set_filter_state initializing, dataname: { private$dataname }") - filter_states <- self$state_list_get("y") - for (varname in names(state)) { - value <- resolve_state(state[[varname]]) - if (varname %in% names(filter_states)) { - fstate <- filter_states[[varname]] - fstate$set_state(value) - } else { - fstate <- init_filter_state( - SummarizedExperiment::colData(data)[[varname]], - varname = varname, - varlabel = private$get_varlabels(varname), - dataname = private$dataname, - extract_type = "list" - ) - fstate$set_state(value) - fstate$set_na_rm(TRUE) - self$state_list_push( - x = fstate, - state_list_index = "y", - state_id = varname - ) - } - } - logger::log_trace("MAEFilterState$set_filter_state initialized, dataname: { private$dataname }") - NULL - }, - - #' @description - #' Removes a variable from the `state_list` and its corresponding UI element. - #' - #' @param state_id (`character(1)`)\cr name of `state_list` element. - #' - #' @return `NULL` - #' - remove_filter_state = function(state_id) { - logger::log_trace( - sprintf( - "%s$remove_filter_state for %s called, dataname: %s", - class(self)[1], - state_id, - private$dataname - ) - ) - - if (!state_id %in% names(self$state_list_get("y"))) { - warning(paste( - "Variable:", state_id, - "is not present in the actual active filters of dataset: { private$dataname }", - "therefore no changes are applied." - )) - logger::log_warn( - paste( - "Variable:", state_id, "is not present in the actual active filters of dataset:", - "{ private$dataname } therefore no changes are applied." - ) - ) - } else { - self$state_list_remove(state_list_index = "y", state_id = state_id) - logger::log_trace( - sprintf( - "%s$remove_filter_state for variable %s done, dataname: %s", - class(self)[1], - state_id, - private$dataname - ) - ) - } - }, - - # shiny modules ---- - - #' @description - #' Shiny UI module to add filter variable - #' @param id (`character(1)`)\cr - #' id of shiny module - #' @param data (`MultiAssayExperiment`)\cr - #' object containing `colData` which columns are used to be used - #' to choose filter variables - #' - #' @return `shiny.tag` - #' - ui_add_filter_state = function(id, data) { - checkmate::assert_string(id) - stopifnot(is(data, "MultiAssayExperiment")) - - ns <- NS(id) - - if (ncol(SummarizedExperiment::colData(data)) == 0) { - div("no sample variables available") - } else if (nrow(SummarizedExperiment::colData(data)) == 0) { - div("no samples available") - } else { - teal.widgets::optionalSelectInput( - ns("var_to_add"), - choices = NULL, - options = shinyWidgets::pickerOptions( - liveSearch = TRUE, - noneSelectedText = "Select subject variable" - ) - ) - } - }, - - #' @description - #' Shiny server module to add filter variable. - #' - #' Module controls available choices to select as a filter variable. - #' Selected filter variable is being removed from available choices. - #' Removed filter variable gets back to available choices. - #' - #' @param id (`character(1)`)\cr - #' an ID string that corresponds with the ID used to call the module's UI function. - #' @param data (`MultiAssayExperiment`)\cr - #' object containing `colData` which columns are used to choose filter variables in - #' [teal.widgets::optionalSelectInput()]. - #' @param ... ignored - #' - #' @return `moduleServer` function which returns `NULL` - #' - srv_add_filter_state = function(id, data, ...) { - stopifnot(is(data, "MultiAssayExperiment")) - check_ellipsis(..., stop = FALSE) - moduleServer( - id = id, - function(input, output, session) { - logger::log_trace( - "MAEFilterState$srv_add_filter_state initializing, dataname: { private$dataname }" - ) - shiny::setBookmarkExclude("var_to_add") - active_filter_vars <- reactive({ - vapply( - X = self$state_list_get(state_list_index = "y"), - FUN.VALUE = character(1), - FUN = function(x) x$get_varname() - ) - }) - - # available choices to display - avail_column_choices <- reactive({ - choices <- setdiff( - get_supported_filter_varnames(data = SummarizedExperiment::colData(data)), - active_filter_vars() - ) - data_choices_labeled( - data = SummarizedExperiment::colData(data), - choices = choices, - varlabels = private$get_varlabels(choices), - keys = private$keys - ) - }) - observeEvent( - avail_column_choices(), - ignoreNULL = TRUE, - handlerExpr = { - logger::log_trace(paste( - "MAEFilterStates$srv_add_filter_state@1 updating available column choices,", - "dataname: { private$dataname }" - )) - if (is.null(avail_column_choices())) { - shinyjs::hide("var_to_add") - } else { - shinyjs::show("var_to_add") - } - teal.widgets::updateOptionalSelectInput( - session, - "var_to_add", - choices = avail_column_choices() - ) - logger::log_trace(paste( - "MAEFilterStates$srv_add_filter_state@1 updated available column choices,", - "dataname: { private$dataname }" - )) - } - ) - - observeEvent( - eventExpr = input$var_to_add, - handlerExpr = { - logger::log_trace( - sprintf( - "MAEFilterStates$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s", - deparse1(input$var_to_add), - private$dataname - ) - ) - fstate <- init_filter_state( - SummarizedExperiment::colData(data)[[input$var_to_add]], - varname = input$var_to_add, - varlabel = private$get_varlabels(input$var_to_add), - dataname = private$dataname, - extract_type = "list" - ) - fstate$set_na_rm(TRUE) - - self$state_list_push( - x = fstate, - state_list_index = "y", - state_id = input$var_to_add - ) - logger::log_trace( - sprintf( - "MAEFilterStates$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s", - deparse1(input$var_to_add), - private$dataname - ) - ) - } - ) - - logger::log_trace( - "MAEFilterState$srv_add_filter_state initialized, dataname: { private$dataname }" - ) - NULL - } - ) } ), - # private members ---- + # private fields ---- + private = list( - varlabels = character(0), - keys = character(0), - #' description - #' Get label of specific variable. In case when variable label is missing - #' name of the variable is returned. - #' parameter variable (`character`)\cr - #' name of the variable for which label should be returned - #' return `character` - get_varlabels = function(variables = character(0)) { - checkmate::assert_character(variables) - if (identical(variables, character(0))) { - private$varlabels - } else { - varlabels <- private$varlabels[variables] - missing_labels <- is.na(varlabels) | varlabels == "" - varlabels[missing_labels] <- variables[missing_labels] - varlabels - } - } + extract_type = "list", + fun = quote(MultiAssayExperiment::subsetByColData) ) ) diff --git a/R/FilterStatesMatrix.R b/R/FilterStatesMatrix.R index 200166bbc..da9109558 100644 --- a/R/FilterStatesMatrix.R +++ b/R/FilterStatesMatrix.R @@ -13,331 +13,29 @@ MatrixFilterStates <- R6::R6Class( # nolint #' #' Initialize `MatrixFilterStates` object #' + #' @param data (`matrix`)\cr + #' the R object which `subset` function is applied on. + #' @param data_reactive (`function(sid)`)\cr + #' should return a `matrix` object or `NULL`. + #' This object is needed for the `FilterState` counts being updated + #' on a change in filters. If function returns `NULL` then filtered counts are not shown. + #' Function has to have `sid` argument being a character. #' @param dataname (`character(1)`)\cr #' name of the data used in the expression #' specified to the function argument attached to this `FilterStates`. - #' - #' @param datalabel (`character(0)` or `character(1)`)\cr - #' text label value. - initialize = function(dataname, datalabel) { - super$initialize(dataname, datalabel) - private$state_list <- list( - subset = reactiveVal() - ) - }, - - #' @description - #' Returns the formatted string representing this `MatrixFilterStates` object. - #' - #' @param indent (`numeric(1)`) the number of spaces before each line of the representation - #' @return `character(1)` the formatted string - format = function(indent = 0) { - checkmate::assert_number(indent, finite = TRUE, lower = 0) - - formatted_states <- c() - for (state in self$state_list_get(state_list_index = "subset")) { - formatted_states <- c(formatted_states, state$format(indent = indent + 2)) - } - paste(formatted_states, collapse = "\n") - }, - - #' @description - #' Server module - #' @param id (`character(1)`)\cr - #' an ID string that corresponds with the ID used to call the module's UI function. - #' @return `moduleServer` function which returns `NULL` - server = function(id) { - moduleServer( - id = id, - function(input, output, session) { - previous_state <- reactiveVal(isolate(self$state_list_get("subset"))) - added_state_name <- reactiveVal(character(0)) - removed_state_name <- reactiveVal(character(0)) - - observeEvent(self$state_list_get("subset"), { - added_state_name( - setdiff(names(self$state_list_get("subset")), names(previous_state())) - ) - removed_state_name( - setdiff(names(previous_state()), names(self$state_list_get("subset"))) - ) - previous_state(self$state_list_get("subset")) - }) - - observeEvent(added_state_name(), ignoreNULL = TRUE, { - fstates <- self$state_list_get("subset") - html_ids <- private$map_vars_to_html_ids(keys = names(fstates)) - for (fname in added_state_name()) { - private$insert_filter_state_ui( - id = html_ids[fname], - filter_state = fstates[[fname]], - state_list_index = "subset", - state_id = fname - ) - } - added_state_name(character(0)) - }) - - observeEvent(removed_state_name(), { - req(removed_state_name()) - - for (fname in removed_state_name()) { - private$remove_filter_state_ui("subset", fname, .input = input) - } - removed_state_name(character(0)) - }) - NULL - } - ) - }, - - #' @description - #' Returns active `FilterState` objects. - #' - #' Gets all active filters from this dataset in form of the nested list. - #' The output list can be used as input to `self$set_filter_state`. - #' - #' @return `list` containing `list` with selected values for each `FilterState`. - get_filter_state = function() { - lapply(self$state_list_get(state_list_index = "subset"), function(x) x$get_state()) - }, - - #' @description - #' Sets a filter state - #' - #' @param data (`matrix`)\cr - #' data which are supposed to be filtered. - #' @param state (`named list`)\cr - #' should contain values which are initial selection in the `FilterState`. - #' Names of the `list` element should correspond to the name of the - #' column in `data`. - #' @param ... ignored. - #' @return `NULL` - set_filter_state = function(data, state, ...) { - checkmate::assert_class(data, "matrix") - checkmate::assert( - checkmate::assert( - !checkmate::test_null(names(state)), - checkmate::check_subset(names(state), colnames(data)), - combine = "and" - ), - checkmate::check_class(state, "default_filter"), - combine = "or" - ) - logger::log_trace(paste( - "MatrixFilterState$set_filter_state initializing,", - "dataname: { private$dataname }" - )) - filter_states <- self$state_list_get("subset") - for (varname in names(state)) { - value <- resolve_state(state[[varname]]) - if (varname %in% names(filter_states)) { - fstate <- filter_states[[varname]] - fstate$set_state(value) - } else { - fstate <- init_filter_state( - data[, varname], - varname = varname, - varlabel = varname, - dataname = private$dataname, - extract_type = "matrix" - ) - fstate$set_state(value) - self$state_list_push( - x = fstate, - state_list_index = "subset", - state_id = varname - ) - } - } - logger::log_trace(paste( - "MatrixFilterState$set_filter_state initialized,", - "dataname: { private$dataname }" - )) - NULL - }, - - #' @description Remove a variable from the `state_list` and its corresponding UI element. - #' - #' @param state_id (`character(1)`)\cr name of `state_list` element. - #' - #' @return `NULL` - remove_filter_state = function(state_id) { - logger::log_trace( - sprintf( - "%s$remove_filter_state of variable %s, dataname: %s", - class(self)[1], - state_id, - private$dataname - ) - ) - - if (!state_id %in% names(self$state_list_get("subset"))) { - warning(paste( - "Variable:", state_id, "is not present in the actual active filters of dataset:", - "{ private$dataname } therefore no changes are applied." - )) - logger::log_warn( - paste( - "Variable:", state_id, "is not present in the actual active filters of dataset:", - "{ private$dataname } therefore no changes are applied." - ) - ) - } else { - self$state_list_remove(state_list_index = "subset", state_id = state_id) - logger::log_trace( - sprintf( - "%s$remove_filter_state of variable %s done, dataname: %s", - class(self)[1], - state_id, - private$dataname - ) - ) - } - }, - - # shiny modules ---- - - #' @description - #' Shiny UI module to add filter variable. - #' - #' @param id (`character(1)`)\cr - #' id of shiny module - #' @param data (`matrix`)\cr - #' data object for which to define a subset - #' - #' @return `shiny.tag` - #' - ui_add_filter_state = function(id, data) { - checkmate::assert_string(id) - stopifnot(is.matrix(data)) - - ns <- NS(id) - - if (ncol(data) == 0) { - div("no sample variables available") - } else if (nrow(data) == 0) { - div("no samples available") - } else { - teal.widgets::optionalSelectInput( - ns("var_to_add"), - choices = NULL, - options = shinyWidgets::pickerOptions( - liveSearch = TRUE, - noneSelectedText = "Select variable to filter" - ) - ) - } - }, - - #' @description - #' Shiny server module to add filter variable - #' - #' Module controls available choices to select as a filter variable. - #' Selected filter variable is being removed from available choices. - #' Removed filter variable gets back to available choices. - #' - #' @param id (`character(1)`)\cr - #' shiny module instance id - #' @param data (`matrix`)\cr - #' data object for which to define a subset - #' @param ... ignored - #' - #' @return `moduleServer` function which returns `NULL` - #' - srv_add_filter_state = function(id, data, ...) { - stopifnot(is.matrix(data)) - check_ellipsis(..., stop = FALSE) - moduleServer( - id = id, - function(input, output, session) { - logger::log_trace( - "MatrixFilterStates$srv_add_filter_state initializing, dataname: { private$dataname }" - ) - shiny::setBookmarkExclude("var_to_add") - active_filter_vars <- reactive({ - vapply( - X = self$state_list_get(state_list_index = "subset"), - FUN.VALUE = character(1), - FUN = function(x) x$get_varname() - ) - }) - - # available choices to display - avail_column_choices <- reactive({ - choices <- setdiff( - get_supported_filter_varnames(data = data), - active_filter_vars() - ) - data_choices_labeled( - data = data, - choices = choices, - varlabels = character(0), - keys = NULL - ) - }) - observeEvent( - avail_column_choices(), - ignoreNULL = TRUE, - handlerExpr = { - logger::log_trace(paste( - "MatrixFilterStates$srv_add_filter_state@1 updating column choices,", - "dataname: { private$dataname }" - )) - if (length(avail_column_choices()) < 0) { - shinyjs::hide("var_to_add") - } else { - shinyjs::show("var_to_add") - } - teal.widgets::updateOptionalSelectInput( - session, - "var_to_add", - choices = avail_column_choices() - ) - logger::log_trace(paste( - "MatrixFilterStates$srv_add_filter_state@1 updated column choices,", - "dataname: { private$dataname }" - )) - } - ) - - observeEvent( - eventExpr = input$var_to_add, - handlerExpr = { - logger::log_trace( - sprintf( - "MatrixFilterState$srv_add_filter_state@2 adding FilterState of variable %s, dataname: %s", - deparse1(input$var_to_add), - private$dataname - ) - ) - self$state_list_push( - x = init_filter_state( - subset(data, select = input$var_to_add), - varname = input$var_to_add, - varlabel = private$get_varlabel(input$var_to_add), - dataname = private$dataname, - extract_type = "matrix" - ), - state_list_index = "subset", - state_id = input$var_to_add - ) - logger::log_trace( - sprintf( - "MatrixFilterState$srv_add_filter_state@2 added FilterState of variable %s, dataname: %s", - deparse1(input$var_to_add), - private$dataname - ) - ) - } - ) - - logger::log_trace( - "MatrixFilterStates$srv_add_filter_state initialized, dataname: { private$dataname }" - ) - NULL - } - ) + #' @param datalabel (`NULL` or `character(1)`)\cr + #' text label value. Should be a name of experiment. + #' + initialize = function(data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = NULL) { + checkmate::assert_matrix(data) + super$initialize(data, data_reactive, dataname, datalabel) + private$set_filterable_varnames(include_varnames = colnames(private$data)) } + ), + private = list( + extract_type = "matrix" ) ) diff --git a/R/FilterStatesSE.R b/R/FilterStatesSE.R index a2978a855..1572cbd9a 100644 --- a/R/FilterStatesSE.R +++ b/R/FilterStatesSE.R @@ -1,4 +1,4 @@ -#' @title `FilterStates` subclass for SummarizedExperiments +#' @title `FilterStates` subclass for `SummarizedExperiments` #' @description Handles filter states in a `SummaryExperiment` #' @keywords internal #' @@ -13,333 +13,92 @@ SEFilterStates <- R6::R6Class( # nolint #' #' Initialize `SEFilterStates` object #' + #' @param data (`SummarizedExperiment`)\cr + #' the R object which `subset` function is applied on. + #' @param data_reactive (`function(sid)`)\cr + #' should return a `SummarizedExperiment` object or `NULL`. + #' This object is needed for the `FilterState` counts being updated + #' on a change in filters. If function returns `NULL` then filtered counts are not shown. + #' Function has to have `sid` argument being a character. #' @param dataname (`character(1)`)\cr #' name of the data used in the expression #' specified to the function argument attached to this `FilterStates`. - #' #' @param datalabel (`character(0)` or `character(1)`)\cr - #' text label value. - initialize = function(dataname, datalabel) { + #' text label value. Should be a name of experiment + #' + initialize = function(data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = NULL) { if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) { stop("Cannot load SummarizedExperiment - please install the package or restart your session.") } - super$initialize(dataname, datalabel) - private$state_list <- list( - subset = reactiveVal(), - select = reactiveVal() - ) - }, - - #' @description - #' Returns the formatted string representing this `MAEFilterStates` object. - #' - #' @param indent (`numeric(1)`) the number of spaces before each line of the representation - #' @return `character(1)` the formatted string - format = function(indent = 0) { - checkmate::assert_number(indent, finite = TRUE, lower = 0) - - whitespace_indent <- format("", width = indent) - formatted_states <- c() - if (!is.null(self$state_list_get(state_list_index = "subset"))) { - formatted_states <- c(formatted_states, paste0(whitespace_indent, " Subsetting:")) - for (state in self$state_list_get(state_list_index = "subset")) { - formatted_states <- c(formatted_states, state$format(indent = indent + 4)) - } - } - - if (!is.null(self$state_list_get(state_list_index = "select"))) { - formatted_states <- c(formatted_states, paste0(whitespace_indent, " Selecting:")) - for (state in self$state_list_get(state_list_index = "select")) { - formatted_states <- c(formatted_states, state$format(indent = indent + 4)) - } - } - - if (length(formatted_states) > 0) { - formatted_states <- c(paste0(whitespace_indent, "Assay ", self$get_datalabel(), " filters:"), formatted_states) - paste(formatted_states, collapse = "\n") + checkmate::assert_function(data_reactive, args = "sid") + checkmate::assert_class(data, "SummarizedExperiment") + super$initialize(data, data_reactive, dataname, datalabel) + if (!is.null(datalabel)) { + private$dataname_prefixed <- sprintf("%s[['%s']]", dataname, datalabel) } }, #' @description - #' Server module - #' @param id (`character(1)`)\cr - #' an ID string that corresponds with the ID used to call the module's UI function. - #' @return `moduleServer` function which returns `NULL` - server = function(id) { - moduleServer( - id = id, - function(input, output, session) { - previous_state_subset <- reactiveVal(isolate(self$state_list_get("subset"))) - added_state_name_subset <- reactiveVal(character(0)) - removed_state_name_subset <- reactiveVal(character(0)) - - observeEvent(self$state_list_get("subset"), { - added_state_name_subset( - setdiff(names(self$state_list_get("subset")), names(previous_state_subset())) - ) - removed_state_name_subset( - setdiff(names(previous_state_subset()), names(self$state_list_get("subset"))) - ) - previous_state_subset(self$state_list_get("subset")) - }) - - observeEvent(added_state_name_subset(), ignoreNULL = TRUE, { - fstates <- self$state_list_get("subset") - html_ids <- private$map_vars_to_html_ids(keys = names(fstates), prefix = "rowData") - for (fname in added_state_name_subset()) { - private$insert_filter_state_ui( - id = html_ids[fname], - filter_state = fstates[[fname]], - state_list_index = "subset", - state_id = fname - ) - } - added_state_name_subset(character(0)) - }) - - observeEvent(removed_state_name_subset(), { - req(removed_state_name_subset()) - for (fname in removed_state_name_subset()) { - private$remove_filter_state_ui("subset", fname, .input = input) - } - removed_state_name_subset(character(0)) - }) - - # select - previous_state_select <- reactiveVal(isolate(self$state_list_get("select"))) - added_state_name_select <- reactiveVal(character(0)) - removed_state_name_select <- reactiveVal(character(0)) - - observeEvent(self$state_list_get("select"), { - # find what has been added or removed - added_state_name_select( - setdiff(names(self$state_list_get("select")), names(previous_state_select())) - ) - removed_state_name_select( - setdiff(names(previous_state_select()), names(self$state_list_get("select"))) - ) - previous_state_select(self$state_list_get("select")) - }) - - observeEvent(added_state_name_select(), ignoreNULL = TRUE, { - fstates <- self$state_list_get("select") - html_ids <- private$map_vars_to_html_ids(keys = names(fstates), prefix = "colData") - for (fname in added_state_name_select()) { - private$insert_filter_state_ui( - id = html_ids[fname], - filter_state = fstates[[fname]], - state_list_index = "select", - state_id = fname - ) - } - added_state_name_select(character(0)) - }) - - observeEvent(removed_state_name_select(), { - req(removed_state_name_select()) - for (fname in removed_state_name_select()) { - private$remove_filter_state_ui("select", fname, .input = input) - } - removed_state_name_select(character(0)) - }) - NULL - } - ) - }, - - #' @description - #' Gets the reactive values from the active `FilterState` objects. + #' Set filter state #' - #' Gets all active filters from this dataset in form of the nested list. - #' The output list is a compatible input to `self$set_filter_state`. + #' @param state (`teal_slices`)\cr + #' `teal_slice` objects should contain the field `arg %in% c("subset", "select")` #' - #' @return `list` containing one or two lists depending on the number of - #' `state_list` object (I.e. if `rowData` and `colData` exist). Each - #' `list` contains elements number equal to number of active filter variables. - get_filter_state = function() { - states <- sapply( - X = names(private$state_list), - simplify = FALSE, - function(x) { - lapply(self$state_list_get(state_list_index = x), function(xx) xx$get_state()) - } - ) - Filter(function(x) length(x) > 0, states) - }, - - #' @description - #' Set filter state + #' @return `NULL` invisibly #' - #' @param data (`SummarizedExperiment`)\cr - #' data which are supposed to be filtered. - #' @param state (`named list`)\cr - #' this list should contain `subset` and `select` element where - #' each should be a named list containing values as a selection in the `FilterState`. - #' Names of each the `list` element in `subset` and `select` should correspond to - #' the name of the column in `rowData(data)` and `colData(data)`. - #' @param ... ignored. - #' @return `NULL` - set_filter_state = function(data, state, ...) { - checkmate::assert_class(data, "SummarizedExperiment") - checkmate::assert_class(state, "list") - - checkmate::assert( - checkmate::check_subset(names(state), c("subset", "select")), - checkmate::check_class(state, "default_filter"), - combine = "or" - ) - checkmate::assert( - checkmate::test_null(state$subset), - checkmate::assert( - checkmate::check_class(state$subset, "list"), - checkmate::check_subset(names(state$subset), names(SummarizedExperiment::rowData(data))), - combine = "and" - ), - combine = "or" - ) - checkmate::assert( - checkmate::test_null(state$select), - checkmate::assert( - checkmate::check_class(state$select, "list"), - checkmate::check_subset(names(state$select), names(SummarizedExperiment::colData(data))), - combine = "and" - ), - combine = "or" - ) - - filter_states <- self$state_list_get("subset") - for (varname in names(state$subset)) { - value <- resolve_state(state$subset[[varname]]) - if (varname %in% names(filter_states)) { - fstate <- filter_states[[varname]] - fstate$set_state(value) - } else { - fstate <- init_filter_state( - SummarizedExperiment::rowData(data)[[varname]], - varname = varname, - dataname = private$dataname - ) - fstate$set_state(value) - self$state_list_push( - x = fstate, - state_list_index = "subset", - state_id = varname - ) + set_filter_state = function(state) { + shiny::isolate({ + logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }") + checkmate::assert_class(state, "teal_slices") + lapply(state, function(x) { + checkmate::assert_choice(x$arg, choices = c("subset", "select"), null.ok = TRUE, .var.name = "teal_slice$arg") + }) + count_type <- attr(state, "count_type") + if (length(count_type)) { + private$count_type <- count_type } - } - filter_states <- self$state_list_get("select") - for (varname in names(state$select)) { - value <- resolve_state(state$select[[varname]]) - if (varname %in% names(filter_states)) { - fstate <- filter_states[[varname]] - fstate$set_state(value) - } else { - fstate <- init_filter_state( - SummarizedExperiment::colData(data)[[varname]], - varname = varname, - dataname = private$dataname - ) - fstate$set_state(value) - self$state_list_push( - x = fstate, - state_list_index = "select", - state_id = varname - ) - } - } - logger::log_trace(paste( - "SEFilterState$set_filter_state initialized,", - "dataname: { private$dataname }" - )) - NULL - }, - - #' @description Remove a variable from the `state_list` and its corresponding UI element. - #' - #' @param state_id (`character(1)`)\cr name of `state_list` element. - #' - #' @return `NULL` - remove_filter_state = function(state_id) { - logger::log_trace( - sprintf( - "%s$remove_filter_state called, dataname: %s", - class(self)[1], - private$dataname + subset_states <- Filter(function(x) x$arg == "subset", state) + private$set_filter_state_impl( + state = subset_states, + data = SummarizedExperiment::rowData(private$data), + data_reactive = function(sid = "") { + data <- private$data_reactive() + if (!is.null(data)) { + SummarizedExperiment::rowData(data) + } + } ) - ) - checkmate::assert( - !checkmate::test_null(names(state_id)), - checkmate::check_subset(names(state_id), c("subset", "select")), - combine = "and" - ) - for (varname in state_id$subset) { - if (!all(unlist(state_id$subset) %in% names(self$state_list_get("subset")))) { - warning(paste( - "Variable:", state_id, "is not present in the actual active subset filters of dataset:", - "{ private$dataname } therefore no changes are applied." - )) - logger::log_warn( - paste( - "Variable:", state_id, "is not present in the actual active subset filters of dataset:", - "{ private$dataname } therefore no changes are applied." - ) - ) - } else { - self$state_list_remove(state_list_index = "subset", state_id = varname) - logger::log_trace( - sprintf( - "%s$remove_filter_state for subset variable %s done, dataname: %s", - class(self)[1], - varname, - private$dataname - ) - ) - } - } + select_states <- Filter(function(x) x$arg == "select", state) + private$set_filter_state_impl( + state = select_states, + data = SummarizedExperiment::colData(private$data), + data_reactive = function(sid = "") { + data <- private$data_reactive() + if (!is.null(data)) { + SummarizedExperiment::colData(data) + } + } + ) - for (varname in state_id$select) { - if (!all(unlist(state_id$select) %in% names(self$state_list_get("select")))) { - warning(paste( - "Variable:", state_id, "is not present in the actual active select filters of dataset:", - "{ private$dataname } therefore no changes are applied." - )) - logger::log_warn( - paste( - "Variable:", state_id, "is not present in the actual active select filters of dataset:", - "{ private$dataname } therefore no changes are applied." - ) - ) - } else { - self$state_list_remove(state_list_index = "select", state_id = varname) - sprintf( - "%s$remove_filter_state for select variable %s done, dataname: %s", - class(self)[1], - varname, - private$dataname - ) - } - } + logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }") + invisible(NULL) + }) }, - # shiny modules ---- - #' @description #' Shiny UI module to add filter variable #' @param id (`character(1)`)\cr #' id of shiny module - #' @param data (`SummarizedExperiment`)\cr - #' object containing `colData` and `rowData` which columns - #' are used to choose filter variables. Column selection from `colData` - #' and `rowData` are separate shiny entities. #' @return shiny.tag - ui_add_filter_state = function(id, data) { + ui_add = function(id) { + data <- private$data checkmate::assert_string(id) - stopifnot(is(data, "SummarizedExperiment")) - ns <- NS(id) - row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) { div("no sample variables available") } else if (nrow(SummarizedExperiment::rowData(data)) == 0) { @@ -388,45 +147,25 @@ SEFilterStates <- R6::R6Class( # nolint #' #' @param id (`character(1)`)\cr #' an ID string that corresponds with the ID used to call the module's UI function. - #' @param data (`SummarizedExperiment`)\cr - #' object containing `colData` and `rowData` which columns - #' are used to choose filter variables. Column selection from `colData` - #' and `rowData` are separate shiny entities. - #' @param ... ignored #' @return `moduleServer` function which returns `NULL` - srv_add_filter_state = function(id, data, ...) { - stopifnot(is(data, "SummarizedExperiment")) - check_ellipsis(..., stop = FALSE) + srv_add = function(id) { + data <- private$data + data_reactive <- private$data_reactive moduleServer( id = id, function(input, output, session) { - logger::log_trace( - "SEFilterState$srv_add_filter_state initializing, dataname: { private$dataname }" - ) - shiny::setBookmarkExclude(c("row_to_add", "col_to_add")) - active_filter_col_vars <- reactive({ - vapply( - X = self$state_list_get(state_list_index = "select"), - FUN.VALUE = character(1), - FUN = function(x) x$get_varname() - ) - }) - active_filter_row_vars <- reactive({ - vapply( - X = self$state_list_get(state_list_index = "subset"), - FUN.VALUE = character(1), - FUN = function(x) x$get_varname() - ) - }) + logger::log_trace("SEFilterState$srv_add initializing, dataname: { private$dataname }") row_data <- SummarizedExperiment::rowData(data) col_data <- SummarizedExperiment::colData(data) - # available choices to display avail_row_data_choices <- reactive({ + slices_for_subset <- Filter(function(x) x$arg == "subset", self$get_filter_state()) + active_filter_row_vars <- slices_field(slices_for_subset, "varname") + choices <- setdiff( get_supported_filter_varnames(data = row_data), - active_filter_row_vars() + active_filter_row_vars ) data_choices_labeled( @@ -436,10 +175,14 @@ SEFilterStates <- R6::R6Class( # nolint keys = NULL ) }) + avail_col_data_choices <- reactive({ + slices_for_select <- Filter(function(x) x$arg == "select", self$get_filter_state()) + active_filter_col_vars <- slices_field(slices_for_select, "varname") + choices <- setdiff( get_supported_filter_varnames(data = col_data), - active_filter_col_vars() + active_filter_col_vars ) data_choices_labeled( @@ -450,13 +193,12 @@ SEFilterStates <- R6::R6Class( # nolint ) }) - observeEvent( avail_row_data_choices(), ignoreNULL = TRUE, handlerExpr = { logger::log_trace(paste( - "SEFilterStates$srv_add_filter_state@1 updating available row data choices,", + "SEFilterStates$srv_add@1 updating available row data choices,", "dataname: { private$dataname }" )) if (is.null(avail_row_data_choices())) { @@ -470,7 +212,7 @@ SEFilterStates <- R6::R6Class( # nolint choices = avail_row_data_choices() ) logger::log_trace(paste( - "SEFilterStates$srv_add_filter_state@1 updated available row data choices,", + "SEFilterStates$srv_add@1 updated available row data choices,", "dataname: { private$dataname }" )) } @@ -481,7 +223,7 @@ SEFilterStates <- R6::R6Class( # nolint ignoreNULL = TRUE, handlerExpr = { logger::log_trace(paste( - "SEFilterStates$srv_add_filter_state@2 updating available col data choices,", + "SEFilterStates$srv_add@2 updating available col data choices,", "dataname: { private$dataname }" )) if (is.null(avail_col_data_choices())) { @@ -495,7 +237,7 @@ SEFilterStates <- R6::R6Class( # nolint choices = avail_col_data_choices() ) logger::log_trace(paste( - "SEFilterStates$srv_add_filter_state@2 updated available col data choices,", + "SEFilterStates$srv_add@2 updated available col data choices,", "dataname: { private$dataname }" )) } @@ -506,62 +248,53 @@ SEFilterStates <- R6::R6Class( # nolint handlerExpr = { logger::log_trace( sprintf( - "SEFilterStates$srv_add_filter_state@3 adding FilterState of column %s to col data, dataname: %s", + "SEFilterStates$srv_add@3 adding FilterState of column %s to col data, dataname: %s", deparse1(input$col_to_add), private$dataname ) ) - self$state_list_push( - x = init_filter_state( - SummarizedExperiment::colData(data)[[input$col_to_add]], - varname = input$col_to_add, - dataname = private$dataname - ), - state_list_index = "select", - state_id = input$col_to_add - ) + varname <- input$col_to_add + self$set_filter_state(teal_slices( + teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select") + )) + logger::log_trace( sprintf( - "SEFilterStates$srv_add_filter_state@3 added FilterState of column %s to col data, dataname: %s", - deparse1(input$col_to_add), + "SEFilterStates$srv_add@3 added FilterState of column %s to col data, dataname: %s", + deparse1(varname), private$dataname ) ) } ) + observeEvent( eventExpr = input$row_to_add, handlerExpr = { logger::log_trace( sprintf( - "SEFilterStates$srv_add_filter_state@4 adding FilterState of variable %s to row data, dataname: %s", + "SEFilterStates$srv_add@4 adding FilterState of variable %s to row data, dataname: %s", deparse1(input$row_to_add), private$dataname ) ) - self$state_list_push( - x = init_filter_state( - SummarizedExperiment::rowData(data)[[input$row_to_add]], - varname = input$row_to_add, - dataname = private$dataname - ), - state_list_index = "subset", - state_id = input$row_to_add - ) + varname <- input$row_to_add + self$set_filter_state(teal_slices( + teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset") + )) + logger::log_trace( sprintf( - "SEFilterStates$srv_add_filter_state@4 added FilterState of variable %s to row data, dataname: %s", - deparse1(input$row_to_add), + "SEFilterStates$srv_add@4 added FilterState of variable %s to row data, dataname: %s", + deparse1(varname), private$dataname ) ) } ) - logger::log_trace( - "SEFilterState$srv_add_filter_state initialized, dataname: { private$dataname }" - ) + logger::log_trace("SEFilterState$srv_add initialized, dataname: { private$dataname }") NULL } ) diff --git a/R/FilteredData-utils.R b/R/FilteredData-utils.R index 42f5fc798..73dd94fd4 100644 --- a/R/FilteredData-utils.R +++ b/R/FilteredData-utils.R @@ -10,7 +10,6 @@ #' - `parent` (optional) which `dataset` is a parent of this one. #' @param join_keys (`JoinKeys`) see [teal.data::join_keys()]. #' @param code (`CodeClass`) see [`teal.data::CodeClass`]. -#' @param cdisc (`logical(1)`) whether data is of `cdisc` type (relational). #' @param check (`logical(1)`) whether data has been check against reproducibility. #' @examples #' library(shiny) @@ -21,7 +20,7 @@ #' ) #' ) #' @export -init_filtered_data <- function(x, join_keys, code, cdisc, check) { +init_filtered_data <- function(x, join_keys, code, check) { UseMethod("init_filtered_data") } @@ -30,50 +29,37 @@ init_filtered_data <- function(x, join_keys, code, cdisc, check) { init_filtered_data.TealData <- function(x, # nolint join_keys = x$get_join_keys(), code = x$get_code_class(), - cdisc = FALSE, check = x$get_check()) { - cdisc <- length(join_keys$get_parents()) > 0 - data_objects <- lapply(x$get_datanames(), function(dataname) { - dataset <- x$get_dataset(dataname) - - parent <- if (cdisc) join_keys$get_parent(dataname) else NULL - - return_list <- list( - dataset = dataset$get_raw_data(), - keys = dataset$get_keys(), - metadata = dataset$get_metadata(), - label = dataset$get_dataset_label() - ) - - if (cdisc) return_list[["parent"]] <- parent - return_list - }) - + data_objects <- lapply( + x$get_datanames(), + function(dataname) { + dataset <- x$get_dataset(dataname) + list( + dataset = dataset$get_raw_data(), + metadata = dataset$get_metadata(), + label = dataset$get_dataset_label() + ) + } + ) names(data_objects) <- x$get_datanames() init_filtered_data( x = data_objects, join_keys = join_keys, code = code, - check = check, - cdisc = cdisc + check = check ) } #' @keywords internal #' @export -init_filtered_data.default <- function(x, join_keys = NULL, code = NULL, cdisc = FALSE, check = FALSE) { # nolint +init_filtered_data.default <- function(x, join_keys = teal.data::join_keys(), code = NULL, check = FALSE) { # nolint checkmate::assert_list(x, any.missing = FALSE, names = "unique") - mapply(validate_dataset_args, x, names(x), MoreArgs = list(allowed_parent = cdisc)) + mapply(validate_dataset_args, x, names(x)) checkmate::assert_class(code, "CodeClass", null.ok = TRUE) - checkmate::assert_class(join_keys, "JoinKeys", null.ok = TRUE) + checkmate::assert_class(join_keys, "JoinKeys") checkmate::assert_flag(check) - - datasets <- if (cdisc) { - CDISCFilteredData$new(x, join_keys = join_keys, code = code, check = check) - } else { - FilteredData$new(x, join_keys = join_keys, code = code, check = check) - } + FilteredData$new(x, join_keys = join_keys, code = code, check = check) } #' Validate dataset arguments @@ -84,27 +70,18 @@ init_filtered_data.default <- function(x, join_keys = NULL, code = NULL, cdisc = #' needed by `init_filtered_dataset` #' @param dataname (`character(1)`)\cr #' the name of the `dataset` to be added to this object -#' @param allowed_parent (`logical(1)`)\cr -#' whether `FilteredDataset` can have a parent - i.e. if it's a part of `CDISCFilteredData` #' @keywords internal -#' @return (`NULL` or throws an error) -validate_dataset_args <- function(dataset_args, dataname, allowed_parent = FALSE) { +#' @return (`NULL` or raises an error) +validate_dataset_args <- function(dataset_args, dataname) { check_simple_name(dataname) - checkmate::assert_flag(allowed_parent) checkmate::assert_list(dataset_args, names = "unique") - allowed_names <- c("dataset", "keys", "label", "metadata") - if (allowed_parent) { - allowed_names <- c(allowed_names, "parent") - } + allowed_names <- c("dataset", "label", "metadata") checkmate::assert_subset(names(dataset_args), choices = allowed_names) - checkmate::assert_multi_class(dataset_args[["dataset"]], classes = c("data.frame", "MultiAssayExperiment")) - checkmate::assert_character(dataset_args[["keys"]], null.ok = TRUE) teal.data::validate_metadata(dataset_args[["metadata"]]) checkmate::assert_character(dataset_args[["label"]], null.ok = TRUE, min.len = 0, max.len = 1) - checkmate::assert_character(dataset_args[["parent"]], null.ok = TRUE, min.len = 0, max.len = 1) } #' Evaluate expression with meaningful message @@ -149,7 +126,7 @@ eval_expr_with_msg <- function(expr, env) { #' `removeClass` and `addClass` methods (when `one_way = TRUE`) to change icons. #' `toggle_title` calls the `attr` method to modify the `Title` attribute of the button. #' -#' @param input_id `character(1)` (namespaced) id of the button +#' @param input_id `character(1)` (name-spaced) id of the button #' @param icons,titles `character(2)` vector specifying values between which to toggle #' @param one_way `logical(1)` flag specifying whether to keep toggling; #' if TRUE, the target will be changed @@ -160,15 +137,6 @@ eval_expr_with_msg <- function(expr, env) { #' @name toggle_button #' #' @examples -#' \dontrun{ -#' -#' # continuously switch between right- and down-pointing chevrons -#' toggle_icon("toggle_element", c("fa-angle-right", "fa-angle-down")) -#' -#' # switch right- to down-pointing chevron -#' toggle_icon("toggle_element", c("fa-angle-right", "fa-angle-down"), one_way = TRUE) -#' } -#' #' library(shiny) #' #' ui <- fluidPage( @@ -184,28 +152,34 @@ eval_expr_with_msg <- function(expr, env) { #' ) #' #' server <- function(input, output, session) { +#' observeEvent(input$hide_content, +#' { +#' shinyjs::hide("content") +#' toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE) +#' }, +#' ignoreInit = TRUE +#' ) #' -#' observeEvent(input$hide_content, { -#' shinyjs::hide("content") -#' toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE) -#' }, ignoreInit = TRUE) -#' -#' observeEvent(input$show_content, { -#' shinyjs::show("content") -#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE) -#' }, ignoreInit = TRUE) +#' observeEvent(input$show_content, +#' { +#' shinyjs::show("content") +#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE) +#' }, +#' ignoreInit = TRUE +#' ) #' -#' observeEvent(input$toggle_content, { -#' shinyjs::toggle("content") -#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down")) -#' }, ignoreInit = TRUE) +#' observeEvent(input$toggle_content, +#' { +#' shinyjs::toggle("content") +#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down")) +#' }, +#' ignoreInit = TRUE +#' ) #' #' output$printout <- renderPrint({ #' head(faithful, 10) #' }) -#' #' } -#' #' if (interactive()) { #' shinyApp(ui, server) #' } @@ -262,3 +236,64 @@ toggle_title <- function(input_id, titles, one_way = FALSE) { invisible(NULL) } + +#' Topological graph sort +#' +#' Graph is a list which for each node contains a vector of child nodes +#' in the returned list, parents appear before their children. +#' +#' Implementation of `Kahn` algorithm with a modification to maintain the order of input elements. +#' +#' @param graph (named `list`) list with node vector elements +#' @keywords internal +#' +#' @examples +#' teal.slice:::topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A"))) +#' teal.slice:::topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B"))) +#' teal.slice:::topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c())) +topological_sort <- function(graph) { + # compute in-degrees + in_degrees <- list() + for (node in names(graph)) { + in_degrees[[node]] <- 0 + for (to_edge in graph[[node]]) { + in_degrees[[to_edge]] <- 0 + } + } + + for (node in graph) { + for (to_edge in node) { + in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1 + } + } + + # sort + visited <- 0 + sorted <- list() + zero_in <- list() + for (node in names(in_degrees)) { + if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node) + } + zero_in <- rev(zero_in) + + while (length(zero_in) != 0) { + visited <- visited + 1 + sorted <- c(zero_in[[1]], sorted) + for (edge_to in graph[[zero_in[[1]]]]) { + in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1 + if (in_degrees[[edge_to]] == 0) { + zero_in <- append(zero_in, edge_to, 1) + } + } + zero_in[[1]] <- NULL + } + + if (visited != length(in_degrees)) { + stop( + "Graph is not a directed acyclic graph. Cycles involving nodes: ", + paste0(setdiff(names(in_degrees), sorted), collapse = " ") + ) + } else { + return(sorted) + } +} diff --git a/R/FilteredData.R b/R/FilteredData.R index aea49d58e..b5b20a1fb 100644 --- a/R/FilteredData.R +++ b/R/FilteredData.R @@ -12,7 +12,7 @@ #' #' The datasets are filtered lazily, i.e. only when requested / needed in a Shiny app. #' -#' By design, any dataname set through `set_dataset` cannot be removed because +#' By design, any `dataname` set through `set_dataset` cannot be removed because #' other code may already depend on it. As a workaround, the underlying #' data can be set to `NULL`. #' @@ -38,34 +38,23 @@ #' datasets <- teal.slice:::FilteredData$new( #' list( #' iris = list(dataset = iris), -#' mtcars = list(dataset = mtcars, metadata = list(type = "training")) +#' mtcars = list(dataset = mtcars) #' ) #' ) #' #' # get datanames #' datasets$datanames() #' -#' df <- datasets$get_data("iris", filtered = FALSE) -#' print(df) -#' -#' datasets$get_metadata("mtcars") -#' -#' isolate( -#' datasets$set_filter_state( -#' list(iris = list(Species = list(selected = "virginica"))) -#' ) +#' datasets$set_filter_state( +#' teal_slices(teal_slice(dataname = "iris", varname = "Species", selected = "virginica")) #' ) #' isolate(datasets$get_call("iris")) #' -#' isolate( -#' datasets$set_filter_state( -#' list(mtcars = list(mpg = list(selected = c(15, 20)))) -#' ) +#' datasets$set_filter_state( +#' teal_slices(teal_slice(dataname = "mtcars", varname = "mpg", selected = c(15, 20))) #' ) #' #' isolate(datasets$get_filter_state()) -#' isolate(datasets$get_filter_overview("iris")) -#' isolate(datasets$get_filter_overview("mtcars")) #' isolate(datasets$get_call("iris")) #' isolate(datasets$get_call("mtcars")) #' @@ -75,20 +64,17 @@ FilteredData <- R6::R6Class( # nolint public = list( #' @description #' Initialize a `FilteredData` object - #' @param data_objects (`list`) should contain. - #' - `dataset` data object object supported by [`FilteredDataset`]. - #' - `metatada` (optional) additional metadata attached to the `dataset`. - #' - `keys` (optional) primary keys. - #' - `datalabel` (optional) label describing the `dataset`. - #' - `parent` (optional) which `NULL` is a parent of this one. + #' @param data_objects (`list`) + #' should named elements containing `data.frame` or `MultiAssayExperiment`. + #' Names of the list will serve as `dataname`. #' @param join_keys (`JoinKeys` or NULL) see [`teal.data::join_keys()`]. #' @param code (`CodeClass` or `NULL`) see [`teal.data::CodeClass`]. #' @param check (`logical(1)`) whether data has been check against reproducibility. #' - initialize = function(data_objects, join_keys = NULL, code = NULL, check = FALSE) { + initialize = function(data_objects, join_keys = teal.data::join_keys(), code = NULL, check = FALSE) { checkmate::assert_list(data_objects, any.missing = FALSE, min.len = 0, names = "unique") # Note the internals of data_objects are checked in set_dataset - checkmate::assert_class(join_keys, "JoinKeys", null.ok = TRUE) + checkmate::assert_class(join_keys, "JoinKeys") checkmate::assert_class(code, "CodeClass", null.ok = TRUE) checkmate::assert_flag(check) @@ -97,23 +83,47 @@ FilteredData <- R6::R6Class( # nolint self$set_code(code) } - for (dataname in names(data_objects)) { - self$set_dataset(data_objects[[dataname]], dataname) - } + self$set_join_keys(join_keys) - if (!is.null(join_keys)) { - self$set_join_keys(join_keys) + child_parent <- sapply( + names(data_objects), + function(i) join_keys$get_parent(i), + USE.NAMES = TRUE, + simplify = FALSE + ) + ordered_datanames <- topological_sort(child_parent) + + for (dataname in ordered_datanames) { + ds_object <- data_objects[[dataname]] + validate_dataset_args(ds_object, dataname) + if (inherits(ds_object, c("data.frame", "MultiAssayExperiment"))) { + self$set_dataset( + data = ds_object, + dataname = dataname + ) + } else { + # custom support for TealData object which pass metadata and label also + # see init_filtered_data.TealData + self$set_dataset( + data = ds_object$dataset, + dataname = dataname, + metadata = ds_object$metadata, + label = ds_object$label + ) + } } + self$set_available_teal_slices(x = reactive(NULL)) + invisible(self) }, #' @description - #' Gets datanames + #' Gets `datanames` #' - #' The datanames are returned in the order in which they must be + #' The `datanames` are returned in the order in which they must be #' evaluated (in case of dependencies). - #' @return (`character` vector) of datanames + #' @return (`character` vector) of `datanames` datanames = function() { names(private$filtered_datasets) }, @@ -125,45 +135,7 @@ FilteredData <- R6::R6Class( # nolint #' @param dataname (`character(1)`) name of the dataset #' @return (`character`) keys of dataset get_datalabel = function(dataname) { - self$get_filtered_dataset(dataname)$get_dataset_label() - }, - - #' @description - #' Gets dataset names of a given dataname for the filtering. - #' - #' @param dataname (`character` vector) names of the dataset - #' - #' @return (`character` vector) of dataset names - #' - get_filterable_datanames = function(dataname) { - dataname - }, - - #' @description - #' Gets variable names of a given dataname for the filtering. - #' - #' @param dataname (`character(1)`) name of the dataset - #' - #' @return (`character` vector) of variable names - #' - get_filterable_varnames = function(dataname) { - self$get_filtered_dataset(dataname)$get_filterable_varnames() - }, - - #' @description - #' Set the variable names of a given dataset for the filtering. - #' - #' @param dataname (`character(1)`) name of the dataset - #' @param varnames (`character` or `NULL`) - #' variables which users can choose to filter the data; - #' see `self$get_filterable_varnames` for more details - #' - #' @return this `FilteredData` object invisibly - #' - set_filterable_varnames = function(dataname, varnames) { - private$check_data_varname_exists(dataname) - self$get_filtered_dataset(dataname)$set_filterable_varnames(varnames) - invisible(self) + private$get_filtered_dataset(dataname)$get_dataset_label() }, # datasets methods ---- @@ -190,8 +162,8 @@ FilteredData <- R6::R6Class( # nolint #' @return (`call` or `list` of calls) to filter dataset calls #' get_call = function(dataname) { - private$check_data_varname_exists(dataname) - self$get_filtered_dataset(dataname)$get_call() + checkmate::assert_subset(dataname, self$datanames()) + private$get_filtered_dataset(dataname)$get_call() }, #' @description @@ -209,23 +181,6 @@ FilteredData <- R6::R6Class( # nolint } }, - #' @description - #' Gets `FilteredDataset` object which contains all information - #' pertaining to the specified dataset. - #' - #' @param dataname (`character(1)`)\cr - #' name of the dataset - #' - #' @return `FilteredDataset` object or list of `FilteredDataset`s - #' - get_filtered_dataset = function(dataname = character(0)) { - if (length(dataname) == 0) { - private$filtered_datasets - } else { - private$filtered_datasets[[dataname]] - } - }, - #' @description #' Gets filtered or unfiltered dataset. #' @@ -236,26 +191,10 @@ FilteredData <- R6::R6Class( # nolint #' @param filtered (`logical`) whether to return a filtered or unfiltered dataset #' get_data = function(dataname, filtered = TRUE) { - private$check_data_varname_exists(dataname) + checkmate::assert_subset(dataname, self$datanames()) checkmate::assert_flag(filtered) - if (filtered) { - # This try is specific for MAEFilteredDataset due to a bug in - # S4Vectors causing errors when using the subset function on MAE objects. - # The fix was introduced in S4Vectors 0.30.1, but is unavailable for R versions < 4.1 - # Link to the issue: https://github.com/insightsengineering/teal/issues/210 - tryCatch( - private$reactive_data[[dataname]](), - error = function(error) { - shiny::validate(paste( - "Filtering expression returned error(s). Please change filters.\nThe error message was:", - error$message, - sep = "\n" - )) - } - ) - } else { - self$get_filtered_dataset(dataname)$get_dataset() - } + data <- private$get_filtered_dataset(dataname)$get_dataset(filtered) + if (filtered) data() else data }, #' @description @@ -275,8 +214,8 @@ FilteredData <- R6::R6Class( # nolint #' @return value of metadata for given data (or `NULL` if it does not exist) #' get_metadata = function(dataname) { - private$check_data_varname_exists(dataname) - self$get_filtered_dataset(dataname)$get_metadata() + checkmate::assert_subset(dataname, self$datanames()) + private$get_filtered_dataset(dataname)$get_metadata() }, #' @description @@ -285,7 +224,7 @@ FilteredData <- R6::R6Class( # nolint #' @return (`JoinKeys`) #' get_join_keys = function() { - return(private$keys) + return(private$join_keys) }, #' @description @@ -299,21 +238,13 @@ FilteredData <- R6::R6Class( # nolint #' @return (`matrix`) matrix of observations and subjects of all datasets #' get_filter_overview = function(datanames) { - if (identical(datanames, "all")) { - datanames <- self$datanames() - } - check_in_subset(datanames, self$datanames(), "Some datasets are not available: ") - rows <- lapply( datanames, function(dataname) { - self$get_filtered_dataset(dataname)$get_filter_overview_info( - filtered_dataset = self$get_data(dataname = dataname, filtered = TRUE) - ) + private$get_filtered_dataset(dataname)$get_filter_overview() } ) - - do.call(rbind, rows) + dplyr::bind_rows(rows) }, #' @description @@ -324,101 +255,61 @@ FilteredData <- R6::R6Class( # nolint #' @return (`character`) keys of dataset #' get_keys = function(dataname) { - self$get_filtered_dataset(dataname)$get_keys() - }, - - #' @description - #' Gets labels of variables in the data. - #' - #' Variables are the column names of the data. - #' Either, all labels must have been provided for all variables - #' in `set_data` or `NULL`. - #' - #' @param dataname (`character(1)`) name of the dataset - #' @param variables (`character`) variables to get labels for; - #' if `NULL`, for all variables in data - #' - #' @return (`character` or `NULL`) variable labels, `NULL` if `column_labels` - #' attribute does not exist for the data - #' - get_varlabels = function(dataname, variables = NULL) { - self$get_filtered_dataset(dataname)$get_varlabels(variables = variables) - }, - - #' @description - #' Gets variable names. - #' - #' @param dataname (`character`) the name of the dataset - #' - #' @return (`character` vector) of variable names - #' - get_varnames = function(dataname) { - self$get_filtered_dataset(dataname)$get_varnames() - }, - - #' @description - #' When active_datanames is "all", sets them to all `datanames`, - #' otherwise, it makes sure that it is a subset of the available `datanames`. - #' - #' @param datanames `character vector` datanames to pick - #' - #' @return the intersection of `self$datanames()` and `datanames` - #' - handle_active_datanames = function(datanames) { - logger::log_trace("FilteredData$handle_active_datanames handling { paste(datanames, collapse = \" \") }") - if (identical(datanames, "all")) { - datanames <- self$datanames() - } else { - for (dataname in datanames) { - tryCatch( - check_in_subset(datanames, self$datanames(), "Some datasets are not available: "), - error = function(e) { - message(e$message) - } - ) - } - } - datanames <- self$get_filterable_datanames(datanames) - intersect(self$datanames(), datanames) + private$get_filtered_dataset(dataname)$get_keys() }, #' @description #' Adds a dataset to this `FilteredData`. #' #' @details - #' `set_dataset` creates a `FilteredDataset` object which keeps - #' `dataset` for the filtering purpose. + #' `set_dataset` creates a `FilteredDataset` object which keeps `dataset` for the filtering purpose. + #' If this data has a parent specified in the `JoinKeys` object stored in `private$join_keys` + #' then created `FilteredDataset` (child) gets linked with other `FilteredDataset` (parent). + #' "Child" dataset return filtered data then dependent on the reactive filtered data of the + #' "parent". See more in documentation of `parent` argument in `FilteredDatasetDefault` constructor. + #' + #' @param data (`data.frame`, `MultiAssayExperiment`)\cr + #' data to be filtered. #' - #' @param dataset_args (`list`)\cr - #' containing the arguments except (`dataname`) - #' needed by `init_filtered_dataset` #' @param dataname (`string`)\cr #' the name of the `dataset` to be added to this object #' + #' @param metadata (named `list` or `NULL`) \cr + #' Field containing metadata about the dataset. Each element of the list + #' should be atomic and length one. + #' + #' @param label (`character(1)`)\cr + #' Label to describe the dataset #' @return (`self`) invisibly this `FilteredData` #' - set_dataset = function(dataset_args, dataname) { + set_dataset = function(data, dataname, metadata, label) { logger::log_trace("FilteredData$set_dataset setting dataset, name: { dataname }") - validate_dataset_args(dataset_args, dataname) - - dataset <- dataset_args$dataset - dataset_args$dataset <- NULL - # to include it nicely in the Show R Code; - # the UI also uses datanames in ids, so no whitespaces allowed + # the UI also uses `datanames` in ids, so no whitespaces allowed check_simple_name(dataname) - private$filtered_datasets[[dataname]] <- do.call( - what = init_filtered_dataset, - args = c(list(dataset), dataset_args, list(dataname = dataname)) - ) - private$reactive_data[[dataname]] <- reactive({ - env <- new.env(parent = parent.env(globalenv())) - env[[dataname]] <- self$get_filtered_dataset(dataname)$get_dataset() - filter_call <- self$get_call(dataname) - eval_expr_with_msg(filter_call, env) - get(x = dataname, envir = env) - }) + join_keys <- self$get_join_keys() + parent_dataname <- join_keys$get_parent(dataname) + if (length(parent_dataname) == 0) { + private$filtered_datasets[[dataname]] <- init_filtered_dataset( + dataset = data, + dataname = dataname, + metadata = metadata, + label = label, + keys = self$get_join_keys()$get(dataname, dataname) + ) + } else { + private$filtered_datasets[[dataname]] <- init_filtered_dataset( + dataset = data, + dataname = dataname, + keys = join_keys$get(dataname, dataname), + parent_name = parent_dataname, + parent = reactive(self$get_data(parent_dataname, filtered = TRUE)), + join_keys = self$get_join_keys()$get(dataname, parent_dataname), + label = label, + metadata = metadata + ) + } invisible(self) }, @@ -432,7 +323,7 @@ FilteredData <- R6::R6Class( # nolint #' set_join_keys = function(join_keys) { checkmate::assert_class(join_keys, "JoinKeys") - private$keys <- join_keys + private$join_keys <- join_keys invisible(self) }, @@ -465,74 +356,55 @@ FilteredData <- R6::R6Class( # nolint }, # Functions useful for restoring from another dataset ---- + #' @description - #' Gets the reactive values from the active `FilterState` objects. - #' - #' Gets all active filters in the form of a nested list. - #' The output list is a compatible input to `self$set_filter_state`. - #' The attribute `formatted` renders the output of `self$get_formatted_filter_state`, - #' which is a character formatting of the filter state. + #' Gets states of all active `FilterState` objects. #' - #' @return `named list` with elements corresponding to `FilteredDataset` objects - #' with active filters. In addition, the `formatted` attribute holds - #' the character format of the active filter states. + #' @return A `teal_slices` object. #' get_filter_state = function() { - states <- lapply(self$get_filtered_dataset(), function(x) x$get_filter_state()) - filtered_states <- Filter(function(x) length(x) > 0, states) - structure(filtered_states, formatted = self$get_formatted_filter_state()) + states <- unname(lapply(private$filtered_datasets, function(x) x$get_filter_state())) + slices <- Filter(Negate(is.null), states) + slices <- do.call(c, slices) + if (!is.null(slices)) { + attr(slices, "module_add") <- private$module_add + } + slices }, #' @description - #' Returns the filter state formatted for printing to an `IO` device. + #' Returns a formatted string representing this `FilteredData` object. #' - #' @return `character` the pre-formatted filter state + #' @param show_all `logical(1)` passed to `format.teal_slice` + #' @param trim_lines `logical(1)` passed to `format.teal_slice` #' - #' @examples - #' utils::data(miniACC, package = "MultiAssayExperiment") - #' datasets <- teal.slice:::FilteredData$new( - #' list(iris = list(dataset = iris), - #' mae = list(dataset = miniACC) - #' ), - #' join_keys = NULL - #' ) - #' fs <- list( - #' iris = list( - #' Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE), - #' Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) - #' ), - #' mae = list( - #' subjects = list( - #' years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - #' vital_status = list(selected = "1", keep_na = FALSE), - #' gender = list(selected = "female", keep_na = TRUE) - #' ), - #' RPPAArray = list( - #' subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) - #' ) - #' ) - #' ) - #' isolate(datasets$set_filter_state(state = fs)) - #' cat(shiny::isolate(datasets$get_formatted_filter_state())) + #' @return `character(1)` the formatted string #' - get_formatted_filter_state = function() { - out <- - unlist(sapply( - self$get_filtered_dataset(), - function(filtered_dataset) { - filtered_dataset$get_formatted_filter_state() - } - )) - paste(out, collapse = "\n") + format = function(show_all = FALSE, trim_lines = TRUE) { + sprintf( + "%s:\n%s", + class(self)[1], + format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines) + ) + }, + + #' @description + #' Prints this `FilteredData` object. + #' + #' @param ... additional arguments + #' + print = function(...) { + cat(shiny::isolate(self$format(...)), "\n") }, #' @description #' Sets active filter states. #' - #' @param state (`named list`)\cr - #' nested list of filter selections applied to datasets + #' @param state either a `named list` list of filter selections + #' or a `teal_slices` object\cr + #' specification by list will be deprecated soon #' - #' @return `NULL` + #' @return `NULL` invisibly #' #' @examples #' utils::data(miniACC, package = "MultiAssayExperiment") @@ -540,74 +412,98 @@ FilteredData <- R6::R6Class( # nolint #' datasets <- teal.slice:::FilteredData$new( #' list(iris = list(dataset = iris), #' mae = list(dataset = miniACC) - #' ), - #' join_keys = NULL - #' ) - #' fs <- list( - #' iris = list( - #' Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE), - #' Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) - #' ), - #' mae = list( - #' subjects = list( - #' years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - #' vital_status = list(selected = "1", keep_na = FALSE), - #' gender = list(selected = "female", keep_na = TRUE) - #' ), - #' RPPAArray = list( - #' subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) - #' ) #' ) #' ) - #' shiny::isolate(datasets$set_filter_state(state = fs)) + #' fs <- + #' teal_slices( + #' teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4), + #' keep_na = TRUE, keep_inf = FALSE), + #' teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor"), + #' keep_na = FALSE), + #' teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(30, 50), + #' keep_na = TRUE, keep_inf = FALSE), + #' teal_slice(dataname = "mae", varname = "vital_status", selected = "1", keep_na = FALSE), + #' teal_slice(dataname = "mae", varname = "gender", selected = "female", keep_na = TRUE), + #' teal_slice(dataname = "mae", varname = "ARRAY_TYPE", + #' selected = "", keep_na = TRUE, datalabel = "RPPAArray", arg = "subset") + #' ) + #' datasets$set_filter_state(state = fs) #' shiny::isolate(datasets$get_filter_state()) #' set_filter_state = function(state) { - checkmate::assert_subset(names(state), self$datanames()) - logger::log_trace( - "FilteredData$set_filter_state initializing, dataname: { paste(names(state), collapse = ' ') }" - ) - for (dataname in names(state)) { - fdataset <- self$get_filtered_dataset(dataname = dataname) - dataset_state <- state[[dataname]] + shiny::isolate({ + logger::log_trace("{ class(self)[1] }$set_filter_state initializing") + if (!is.teal_slices(state)) { + warning( + paste( + "From FilteredData$set_filter_state:", + "Specifying filters as lists is obsolete and will be deprecated in the next release.", + "Please see ?set_filter_state and ?teal_slices for details." + ), + call. = FALSE + ) + state <- as.teal_slices(state) + } - fdataset$set_filter_state( - state = dataset_state, - vars_include = self$get_filterable_varnames(dataname) - ) - } - logger::log_trace( - "FilteredData$set_filter_state initialized, dataname: { paste(names(state), collapse = ' ') }" - ) + checkmate::assert_class(state, "teal_slices") + module_add <- attr(state, "module_add") + if (!is.null(module_add)) { + private$module_add <- module_add + } - invisible(NULL) + lapply(self$datanames(), function(dataname) { + states <- Filter(function(x) identical(x$dataname, dataname), state) + private$get_filtered_dataset(dataname)$set_filter_state(states) + }) + + logger::log_trace("{ class(self)[1] }$set_filter_state initialized") + + invisible(NULL) + }) }, #' @description - #' Removes one or more `FilterState` of a `FilteredDataset` in a `FilteredData` object. + #' Removes one or more `FilterState` from a `FilteredData` object. #' - #' @param state (`named list`)\cr - #' nested list of filter selections applied to datasets + #' @param state (`teal_slices`)\cr + #' specifying `FilterState` objects to remove; + #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored #' #' @return `NULL` invisibly #' remove_filter_state = function(state) { - checkmate::assert_subset(names(state), self$datanames()) + shiny::isolate({ + if (!is.teal_slices(state)) { + warning( + paste( + "From FilteredData$remove_filter_state:", + "Specifying filters as lists is obsolete and will be deprecated in the next release.", + "Please see ?set_filter_state and ?teal_slices for details." + ), + call. = FALSE + ) + state <- as.teal_slices(state) + } - logger::log_trace( - "FilteredData$remove_filter_state called, dataname: { paste(names(state), collapse = ' ') }" - ) + checkmate::assert_class(state, "teal_slices") + datanames <- slices_field(state, "dataname") + checkmate::assert_subset(datanames, self$datanames()) - for (dataname in names(state)) { - fdataset <- self$get_filtered_dataset(dataname = dataname) - fdataset$remove_filter_state(state_id = state[[dataname]]) - } + logger::log_trace( + "{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }" + ) - logger::log_trace( - "FilteredData$remove_filter_state done, dataname: { paste(names(state), collapse = ' ') }" - ) + lapply(datanames, function(dataname) { + slices <- Filter(function(x) identical(x$dataname, dataname), state) + private$get_filtered_dataset(dataname)$remove_filter_state(slices) + }) - invisible(NULL) + logger::log_trace( + "{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }" + ) + + invisible(NULL) + }) }, #' @description @@ -615,96 +511,50 @@ FilteredData <- R6::R6Class( # nolint #' of a `FilteredData` object. #' #' @param datanames (`character`)\cr - #' datanames to remove their `FilterStates` or empty which removes + #' `datanames` to remove their `FilterStates` or empty which removes #' all `FilterStates` in the `FilteredData` object #' #' @return `NULL` invisibly #' - remove_all_filter_states = function(datanames = self$datanames()) { + clear_filter_states = function(datanames = self$datanames()) { logger::log_trace( - "FilteredData$remove_all_filter_states called, datanames: { paste(datanames, collapse = ', ') }" + "FilteredData$clear_filter_states called, datanames: { toString(datanames) }" ) for (dataname in datanames) { - fdataset <- self$get_filtered_dataset(dataname = dataname) - fdataset$state_lists_empty() + fdataset <- private$get_filtered_dataset(dataname = dataname) + fdataset$clear_filter_states() } logger::log_trace( paste( - "FilteredData$remove_all_filter_states removed all FilterStates,", - "datanames: { paste(datanames, collapse = ', ') }" + "FilteredData$clear_filter_states removed all non-locked FilterStates,", + "datanames: { toString(datanames) }" ) ) invisible(NULL) }, - #' @description - #' Sets this object from a bookmarked state. - #' - #' Only sets the filter state, does not set the data - #' and the preprocessing code. The data should already have been set. - #' Also checks the preprocessing code is identical if provided in the `state`. - #' - #' Since this function is used from the end-user part, its error messages - #' are more verbose. We don't call the Shiny modals from here because this - #' class may be used outside of a Shiny app. - #' - #' @param state (`named list`)\cr - #' containing fields `data_hash`, `filter_states` and `preproc_code` - #' @param check_data_hash (`logical`) whether to check that `md5sums` agree - #' for the data; may not make sense with randomly generated data per session - #' - restore_state_from_bookmark = function(state, check_data_hash = TRUE) { - stop("Pure virtual method") - }, - - #' @description - #' Disable the filter panel by adding `disable` class to `filter_add_vars` - #' and `filter_panel_active_vars` tags in the User Interface. - #' In addition, it will store the existing filter states in a private field called `cached_states` - #' before removing all filter states from the object. - #' - filter_panel_disable = function() { - private$filter_panel_active <- FALSE - shinyjs::disable("filter_add_vars") - shinyjs::disable("filter_active_vars") - private$cached_states <- self$get_filter_state() - self$remove_all_filter_states() - invisible(NULL) - }, + # shiny modules ----- - #' @description enable the filter panel - #' Enable the filter panel by adding `enable` class to `filter_add_vars` - #' and `filter_active_vars` tags in the User Interface. - #' In addition, it will restore the filter states from a private field called `cached_states`. - #' - filter_panel_enable = function() { - private$filter_panel_active <- TRUE - shinyjs::enable("filter_add_vars") - shinyjs::enable("filter_active_vars") - if (length(private$cached_states) && (length(self$get_filter_state()) == 0)) { - self$set_filter_state(private$cached_states) - } + #' Set external `teal_slice` + #' + #' Unlike adding new filter from the column, these filters can be added with some prespecified + #' settings. List of `teal_slices` should be a reactive so one can make this list to be dynamic. + #' List is accessible in `ui/srv_active` through `ui/srv_available_filters`. + #' @param x (`reactive`)\cr + #' should return `teal_slices` + #' @return invisible `NULL` + set_available_teal_slices = function(x) { + checkmate::assert_class(x, "reactive") + private$available_teal_slices <- reactive({ + # we want to limit the available filters to the ones that are relevant for this FilteredData + Filter(function(x) x$dataname %in% self$datanames(), x()) + }) invisible(NULL) }, - #' @description - #' Gets the state of filter panel, if activated. - #' - get_filter_panel_active = function() { - private$filter_panel_active - }, - - #' @description - #' Gets the id of the filter panel UI. - get_filter_panel_ui_id = function() { - private$filter_panel_ui_id - }, - - # shiny modules ----- - #' Module for the right filter panel in the teal app #' with a filter overview panel and a filter variable panel. #' @@ -713,139 +563,17 @@ FilteredData <- R6::R6Class( # nolint #' #' @param id (`character(1)`)\cr #' module id + #' @return `shiny.tag` ui_filter_panel = function(id) { ns <- NS(id) div( id = ns(NULL), # used for hiding / showing include_css_files(pattern = "filter-panel"), - div( - id = ns("switch-button"), - class = "flex justify-content-right", - div( - title = "Enable/Disable filtering", - shinyWidgets::prettySwitch( - ns("filter_panel_active"), - label = "", - status = "success", - fill = TRUE, - value = TRUE, - inline = FALSE, - width = 30 - ) - ) - ), - div( - id = ns("filters_overview"), # not used, can be used to customize CSS behavior - class = "well", - tags$div( - class = "row", - tags$div( - class = "col-sm-9", - tags$label("Active Filter Summary", class = "text-primary mb-4") - ), - tags$div( - class = "col-sm-3", - actionLink( - ns("minimise_filter_overview"), - label = NULL, - icon = icon("angle-down", lib = "font-awesome"), - title = "Minimise panel", - class = "remove pull-right" - ) - ) - ), - tags$br(), - div( - id = ns("filters_overview_contents"), - self$ui_filter_overview(ns("teal_filters_info")) - ) - ), - div( - id = ns("filter_active_vars"), # not used, can be used to customize CSS behavior - class = "well", - tags$div( - class = "row", - tags$div( - class = "col-sm-6", - tags$label("Active Filter Variables", class = "text-primary mb-4") - ), - tags$div( - class = "col-sm-6", - actionLink( - ns("remove_all_filters"), - label = "", - icon("circle-xmark", lib = "font-awesome"), - title = "Remove active filters", - class = "remove_all pull-right" - ), - actionLink( - ns("minimise_filter_active"), - label = NULL, - icon = icon("angle-down", lib = "font-awesome"), - title = "Minimise panel", - class = "remove pull-right" - ) - ) - ), - div( - id = ns("filter_active_vars_contents"), - tagList( - lapply( - self$datanames(), - function(dataname) { - fdataset <- self$get_filtered_dataset(dataname) - fdataset$ui(id = ns(private$get_ui_id(dataname))) - } - ) - ) - ), - shinyjs::hidden( - div( - id = ns("filters_active_count"), - textOutput(ns("teal_filters_count")) - ) - ) - ), - div( - id = ns("filter_add_vars"), # not used, can be used to customize CSS behavior - class = "well", - tags$div( - class = "row", - tags$div( - class = "col-sm-9", - tags$label("Add Filter Variables", class = "text-primary mb-4") - ), - tags$div( - class = "col-sm-3", - actionLink( - ns("minimise_filter_add_vars"), - label = NULL, - icon = icon("angle-down", lib = "font-awesome"), - title = "Minimise panel", - class = "remove pull-right" - ) - ) - ), - div( - id = ns("filter_add_vars_contents"), - tagList( - lapply( - self$datanames(), - function(dataname) { - fdataset <- self$get_filtered_dataset(dataname) - id <- ns(private$get_ui_add_filter_id(dataname)) - # add span with same id to show / hide - return( - span( - id = id, - fdataset$ui_add_filter_state(id) - ) - ) - } - ) - ) - ) - ) + self$ui_overview(ns("overview")), + self$ui_active(ns("active")), + if (private$module_add) { + self$ui_add(ns("add")) + } ) }, @@ -853,123 +581,236 @@ FilteredData <- R6::R6Class( # nolint #' #' @param id (`character(1)`)\cr #' an ID string that corresponds with the ID used to call the module's UI function. - #' @param active_datanames `function / reactive` returning datanames that + #' @param active_datanames `function / reactive` returning `datanames` that #' should be shown on the filter panel, #' must be a subset of the `datanames` argument provided to `ui_filter_panel`; #' if the function returns `NULL` (as opposed to `character(0)`), the filter #' panel will be hidden #' @return `moduleServer` function which returns `NULL` - srv_filter_panel = function(id, active_datanames = function() "all") { - stopifnot( - is.function(active_datanames) || is.reactive(active_datanames) - ) + srv_filter_panel = function(id, active_datanames = self$datanames) { + checkmate::assert_function(active_datanames) moduleServer( id = id, function(input, output, session) { logger::log_trace("FilteredData$srv_filter_panel initializing") - shiny::setBookmarkExclude("remove_all_filters") - self$srv_filter_overview( - id = "teal_filters_info", - active_datanames = active_datanames - ) - shiny::observeEvent(input$minimise_filter_overview, { - shinyjs::toggle("filters_overview_contents") - toggle_icon(session$ns("minimise_filter_overview"), c("fa-angle-right", "fa-angle-down")) - toggle_title(session$ns("minimise_filter_overview"), c("Restore panel", "Minimise Panel")) + active_datanames_resolved <- reactive({ + checkmate::assert_subset(active_datanames(), self$datanames()) + active_datanames() }) - shiny::observeEvent(input$minimise_filter_active, { - shinyjs::toggle("filter_active_vars_contents") - shinyjs::toggle("filters_active_count") - toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down")) - toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel")) - }) - - shiny::observeEvent(private$get_filter_count(), { - shinyjs::toggle("remove_all_filters", condition = private$get_filter_count() != 0) - shinyjs::show("filter_active_vars_contents") - shinyjs::hide("filters_active_count") - toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"), TRUE) - toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"), TRUE) - }) + self$srv_overview("overview", active_datanames_resolved) + self$srv_active("active", active_datanames_resolved) + if (private$module_add) { + self$srv_add("add", active_datanames_resolved) + } - shiny::observeEvent(input$minimise_filter_add_vars, { - shinyjs::toggle("filter_add_vars_contents") - toggle_icon(session$ns("minimise_filter_add_vars"), c("fa-angle-right", "fa-angle-down")) - toggle_title(session$ns("minimise_filter_add_vars"), c("Restore panel", "Minimise Panel")) - }) + logger::log_trace("FilteredData$srv_filter_panel initialized") + NULL + } + ) + }, - # use isolate because we assume that the number of datasets does not change - # over the course of the teal app - # alternatively, one can proceed as in modules_filter_items to dynamically insert, remove UIs - isol_datanames <- isolate(self$datanames()) # they are already ordered - # should not use for-loop as variables are otherwise only bound by reference - # and last dataname would be used - lapply( - isol_datanames, - function(dataname) { - fdataset <- self$get_filtered_dataset(dataname) - fdataset$server(id = private$get_ui_id(dataname)) - } + #' @description + #' Server module responsible for displaying active filters. + #' @param id (`character(1)`)\cr + #' an ID string that corresponds with the ID used to call the module's UI function. + #' @return `shiny.tag` + ui_active = function(id) { + ns <- NS(id) + div( + id = id, # not used, can be used to customize CSS behavior + class = "well", + tags$div( + class = "filter-panel-active-header", + tags$span("Active Filter Variables", class = "text-primary mb-4"), + private$ui_available_filters(ns("available_filters")), + actionLink( + ns("minimise_filter_active"), + label = NULL, + icon = icon("angle-down", lib = "font-awesome"), + title = "Minimise panel", + class = "remove pull-right" + ), + actionLink( + ns("remove_all_filters"), + label = "", + icon("circle-xmark", lib = "font-awesome"), + title = "Remove active filters", + class = "remove_all pull-right" ) - - lapply( - isol_datanames, - function(dataname) { - fdataset <- self$get_filtered_dataset(dataname) - fdataset$srv_add_filter_state( - id = private$get_ui_add_filter_id(dataname), - vars_include = self$get_filterable_varnames(dataname) - ) - } + ), + div( + id = ns("filter_active_vars_contents"), + tagList( + lapply( + self$datanames(), + function(dataname) { + fdataset <- private$get_filtered_dataset(dataname) + fdataset$ui_active(id = ns(dataname)) + } + ) ) + ), + shinyjs::hidden( + div( + id = ns("filters_active_count"), + textOutput(ns("teal_filters_count")) + ) + ) + ) + }, - output$teal_filters_count <- shiny::renderText({ - n_filters_active <- private$get_filter_count() - shiny::req(n_filters_active > 0L) - sprintf( - "%s filter%s applied across datasets", - n_filters_active, - ifelse(n_filters_active == 1, "", "s") - ) + #' @description + #' Server module responsible for displaying active filters. + #' @param id (`character(1)`)\cr + #' an ID string that corresponds with the ID used to call the module's UI function. + #' @param active_datanames (`reactive`)\cr + #' defining subset of `self$datanames()` to be displayed. + #' @return `moduleServer` returning `NULL` + srv_active = function(id, active_datanames = self$datanames) { + checkmate::assert_function(active_datanames) + shiny::moduleServer(id, function(input, output, session) { + logger::log_trace("FilteredData$srv_active initializing") + + private$srv_available_filters("available_filters") + + shiny::observeEvent(input$minimise_filter_active, { + shinyjs::toggle("filter_active_vars_contents") + shinyjs::toggle("filters_active_count") + toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down")) + toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel")) + }) + + shiny::observeEvent(private$get_filter_count(), { + shinyjs::toggle("remove_all_filters", condition = private$get_filter_count() != 0) + shinyjs::show("filter_active_vars_contents") + shinyjs::hide("filters_active_count") + toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"), TRUE) + toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"), TRUE) + }) + + observeEvent(active_datanames(), { + lapply(self$datanames(), function(dataname) { + if (dataname %in% active_datanames()) { + shinyjs::show(dataname) + } else { + shinyjs::hide(dataname) + } }) + }) + + # should not use for-loop as variables are otherwise only bound by reference + # and last dataname would be used + lapply( + self$datanames(), + function(dataname) { + fdataset <- private$get_filtered_dataset(dataname) + fdataset$srv_active(id = dataname) + } + ) - private$filter_panel_ui_id <- session$ns(NULL) - observeEvent( - eventExpr = input$filter_panel_active, - handlerExpr = { - if (isTRUE(input$filter_panel_active)) { - self$filter_panel_enable() - logger::log_trace("Enable the Filtered Panel with the filter_panel_enable method") - } else { - self$filter_panel_disable() - logger::log_trace("Disable the Filtered Panel with the filter_panel_enable method") - } - }, ignoreNULL = TRUE + output$teal_filters_count <- shiny::renderText({ + n_filters_active <- private$get_filter_count() + shiny::req(n_filters_active > 0L) + sprintf( + "%s filter%s applied across datasets", + n_filters_active, + ifelse(n_filters_active == 1, "", "s") ) + }) + + observeEvent(input$remove_all_filters, { + logger::log_trace("FilteredData$srv_filter_panel@1 removing all non-locked filters") + self$clear_filter_states() + logger::log_trace("FilteredData$srv_filter_panel@1 removed all non-locked filters") + }) + logger::log_trace("FilteredData$srv_active initialized") + NULL + }) + }, - observeEvent( - eventExpr = active_datanames(), - handlerExpr = { - private$hide_inactive_datasets(active_datanames) - }, - priority = 1 + #' @description + #' Server module responsible for displaying drop-downs with variables to add a filter. + #' @param id (`character(1)`)\cr + #' an ID string that corresponds with the ID used to call the module's UI function. + #' @return `shiny.tag` + ui_add = function(id) { + ns <- NS(id) + div( + id = id, # not used, can be used to customize CSS behavior + class = "well", + tags$div( + class = "row", + tags$div( + class = "col-sm-9", + tags$label("Add Filter Variables", class = "text-primary mb-4") + ), + tags$div( + class = "col-sm-3", + actionLink( + ns("minimise_filter_add_vars"), + label = NULL, + icon = icon("angle-down", lib = "font-awesome"), + title = "Minimise panel", + class = "remove pull-right" + ) ) + ), + div( + id = ns("filter_add_vars_contents"), + tagList( + lapply( + self$datanames(), + function(dataname) { + fdataset <- private$get_filtered_dataset(dataname) + span(id = ns(dataname), fdataset$ui_add(ns(dataname))) + } + ) + ) + ) + ) + }, - observeEvent(input$remove_all_filters, { - logger::log_trace("FilteredData$srv_filter_panel@1 removing all filters") - lapply(self$datanames(), function(dataname) { - fdataset <- self$get_filtered_dataset(dataname = dataname) - fdataset$state_lists_empty() - }) - logger::log_trace("FilteredData$srv_filter_panel@1 removed all filters") + #' @description + #' Server module responsible for displaying drop-downs with variables to add a filter. + #' @param id (`character(1)`)\cr + #' an ID string that corresponds with the ID used to call the module's UI function. + #' @param active_datanames (`reactive`)\cr + #' defining subset of `self$datanames()` to be displayed. + #' @return `moduleServer` returning `NULL` + srv_add = function(id, active_datanames = reactive(self$datanames())) { + checkmate::assert_class(active_datanames, "reactive") + moduleServer(id, function(input, output, session) { + logger::log_trace("FilteredData$srv_add initializing") + shiny::observeEvent(input$minimise_filter_add_vars, { + shinyjs::toggle("filter_add_vars_contents") + toggle_icon(session$ns("minimise_filter_add_vars"), c("fa-angle-right", "fa-angle-down")) + toggle_title(session$ns("minimise_filter_add_vars"), c("Restore panel", "Minimise Panel")) + }) + + observeEvent(active_datanames(), { + lapply(self$datanames(), function(dataname) { + if (dataname %in% active_datanames()) { + shinyjs::show(dataname) + } else { + shinyjs::hide(dataname) + } }) - - logger::log_trace("FilteredData$srv_filter_panel initialized") - NULL - } - ) + }) + + # should not use for-loop as variables are otherwise only bound by reference + # and last dataname would be used + lapply( + self$datanames(), + function(dataname) { + fdataset <- private$get_filtered_dataset(dataname) + fdataset$srv_add(id = dataname) + } + ) + logger::log_trace("FilteredData$srv_filter_panel initialized") + NULL + }) }, #' Creates the UI for the module showing counts for each dataset @@ -980,12 +821,36 @@ FilteredData <- R6::R6Class( # nolint #' the number of unique subjects. #' #' @param id module id - ui_filter_overview = function(id) { + ui_overview = function(id) { ns <- NS(id) - div( - class = "teal_active_summary_filter_panel", - tableOutput(ns("table")) + id = id, # not used, can be used to customize CSS behavior + class = "well", + tags$div( + class = "row", + tags$div( + class = "col-sm-9", + tags$label("Active Filter Summary", class = "text-primary mb-4") + ), + tags$div( + class = "col-sm-3", + actionLink( + ns("minimise_filter_overview"), + label = NULL, + icon = icon("angle-down", lib = "font-awesome"), + title = "Minimise panel", + class = "remove pull-right" + ) + ) + ), + tags$br(), + div( + id = ns("filters_overview_contents"), + div( + class = "teal_active_summary_filter_panel", + tableOutput(ns("table")) + ) + ) ) }, @@ -994,49 +859,75 @@ FilteredData <- R6::R6Class( # nolint #' #' @param id (`character(1)`)\cr #' an ID string that corresponds with the ID used to call the module's UI function. - #' @param active_datanames (`function`, `reactive`)\cr - #' returning datanames that should be shown on the filter panel, + #' @param active_datanames (`reactive`)\cr + #' returning `datanames` that should be shown on the filter panel, #' must be a subset of the `datanames` argument provided to `ui_filter_panel`; #' if the function returns `NULL` (as opposed to `character(0)`), the filter #' panel will be hidden. #' @return `moduleServer` function which returns `NULL` - srv_filter_overview = function(id, active_datanames = function() "all") { - stopifnot( - is.function(active_datanames) || is.reactive(active_datanames) - ) + srv_overview = function(id, active_datanames = self$datanames) { + checkmate::assert_class(active_datanames, "reactive") moduleServer( id = id, function(input, output, session) { logger::log_trace("FilteredData$srv_filter_overview initializing") + + shiny::observeEvent(input$minimise_filter_overview, { + shinyjs::toggle("filters_overview_contents") + toggle_icon(session$ns("minimise_filter_overview"), c("fa-angle-right", "fa-angle-down")) + toggle_title(session$ns("minimise_filter_overview"), c("Restore panel", "Minimise Panel")) + }) + output$table <- renderUI({ logger::log_trace("FilteredData$srv_filter_overview@1 updating counts") - datanames <- if (identical(active_datanames(), "all")) { - self$datanames() - } else { - active_datanames() + if (length(active_datanames()) == 0) { + return(NULL) } - if (length(datanames) == 0) { - return(NULL) + datasets_df <- self$get_filter_overview(datanames = active_datanames()) + + if (!is.null(datasets_df$obs)) { + # some datasets (MAE colData) doesn't return obs column + datasets_df <- transform( + datasets_df, + Obs = ifelse( + !is.na(obs), + sprintf("%s/%s", obs_filtered, obs), + "" + ) + ) } - datasets_df <- self$get_filter_overview(datanames = datanames) - body_html <- lapply( - seq_len(nrow(datasets_df)), + if (!is.null(datasets_df$subjects)) { + # some datasets (without keys) doesn't return subjects + datasets_df <- transform( + datasets_df, + Subjects = ifelse( + !is.na(subjects), + sprintf("%s/%s", subjects_filtered, subjects), + "" + ) + ) + } + datasets_df <- datasets_df[, colnames(datasets_df) %in% c("dataname", "Obs", "Subjects")] + + body_html <- apply( + datasets_df, + 1, function(x) { tags$tr( - tags$td(rownames(datasets_df)[x]), - tags$td(datasets_df[x, 1]), - tags$td(datasets_df[x, 2]) + tagList( + lapply(x, tags$td) + ) ) } ) header_html <- tags$tr( - tags$td(""), - tags$td(colnames(datasets_df)[1]), - tags$td(colnames(datasets_df)[2]) + tagList( + lapply(colnames(datasets_df), tags$td) + ) ) table_html <- tags$table( @@ -1047,36 +938,99 @@ FilteredData <- R6::R6Class( # nolint logger::log_trace("FilteredData$srv_filter_overview@1 updated counts") table_html }) - - shiny::outputOptions(output, "table", suspendWhenHidden = FALSE) logger::log_trace("FilteredData$srv_filter_overview initialized") NULL } ) + }, + + # deprecated - to remove after release -------------------------------------- + + #' @description + #' Method is deprecated. Provide resolved `active_datanames` to `srv_filter_panel` + #' + #' @param datanames `character vector` `datanames` to pick + #' + #' @return the intersection of `self$datanames()` and `datanames` + #' + handle_active_datanames = function(datanames) { + stop("Deprecated with teal.slice 0.4.0") + }, + + #' @description + #' Method is deprecated. Please extract column labels directly from the data. + #' + #' @param dataname (`character(1)`) name of the dataset + #' @param variables (`character`) variables to get labels for; + #' if `NULL`, for all variables in data + #' + get_varlabels = function(dataname, variables = NULL) { + stop("Deprecated with 0.4.0 - please extract column labels directly from the data.") + }, + + #' @description + #' Method is deprecated, Please extract variable names directly from the data instead + #' + #' @param dataname (`character`) the name of the dataset + #' + get_varnames = function(dataname) { + stop("Deprecated with 0.4.0 - please extract varniable names directly from the data") + }, + + #' @description + #' Method is deprecated, please use `self$datanames()` instead + #' + #' @param dataname (`character` vector) names of the dataset + #' + get_filterable_datanames = function() { + stop("Deprecated with 0.4.0 - please use self$datanames() instead") + }, + + #' @description + #' Method is deprecated, please use `self$get_filter_state()` and retain `attr(, "filterable_varnames")` instead. + #' + #' @param dataname (`character(1)`) name of the dataset + #' + get_filterable_varnames = function(dataname) { + stop("Deprecated with teal.slice 0.4.0 - see help(teal_slices) and description of include_varnames argument.") + }, + + #' @description + #' Method is deprecated, please use `self$set_filter_state` and [teal_slices()] with `include_varnames` instead. + #' + #' @param dataname (`character(1)`) name of the dataset + #' @param varnames (`character` or `NULL`) + #' variables which users can choose to filter the data; + #' see `self$get_filterable_varnames` for more details + #' + #' + set_filterable_varnames = function(dataname, varnames) { + stop("Deprecated with teal.slice 0.4.0 - see help(teal_slices) and description of include_varnames argument.") + }, + + #' @description + #' Method is deprecated, please use `format.teal_slices` on object returned from `self$get_filter_state()` + #' + get_formatted_filter_state = function() { + stop("Deprecated with teal.slice 0.4.0 - get_filter_state returns teal_slice which has dedicated format method") + }, + + #' @description + #' Deprecated - please use `clear_filter_states` method. + #' + #' @param datanames (`character`) + #' + #' @return `NULL` invisibly + #' + remove_all_filter_states = function(datanames) { + warning("FilteredData$remove_all_filter_states is deprecated, please use FilteredData$clear_filter_states.") + self$clear_filter_states(dataname) } ), ## __Private Methods ==== private = list( # selectively hide / show to only show `active_datanames` out of all datanames - hide_inactive_datasets = function(active_datanames) { - lapply( - self$datanames(), - function(dataname) { - id_add_filter <- private$get_ui_add_filter_id(dataname) - id_filter_dataname <- private$get_ui_id(dataname) - - if (dataname %in% active_datanames()) { - # shinyjs takes care of the namespace around the id - shinyjs::show(id_add_filter) - shinyjs::show(id_filter_dataname) - } else { - shinyjs::hide(id_add_filter) - shinyjs::hide(id_filter_dataname) - } - } - ) - }, # private attributes ---- filtered_datasets = list(), @@ -1084,141 +1038,191 @@ FilteredData <- R6::R6Class( # nolint # activate/deactivate filter panel filter_panel_active = TRUE, - # filter panel ui id - filter_panel_ui_id = character(0), - # whether the datasets had a reproducibility check .check = FALSE, # preprocessing code used to generate the unfiltered datasets as a string code = NULL, + available_teal_slices = NULL, # keys used for joining/filtering data a JoinKeys object (see teal.data) - keys = NULL, + join_keys = NULL, # reactive i.e. filtered data reactive_data = list(), cached_states = NULL, + module_add = TRUE, + + # private methods ---- + + # @description + # Gets `FilteredDataset` object which contains all information + # pertaining to the specified dataset. + # + # @param dataname (`character(1)`)\cr + # name of the dataset + # + # @return `FilteredDataset` object or list of `FilteredDataset`s + # + get_filtered_dataset = function(dataname = character(0)) { + if (length(dataname) == 0) { + private$filtered_datasets + } else { + private$filtered_datasets[[dataname]] + } + }, # we implement these functions as checks rather than returning logicals so they can # give informative error messages immediately - # @details - # Composes id for the FilteredDataset shiny element (active filter vars) - # @param dataname (`character(1)`) name of the dataset which ui is composed for. - # @return `character(1)` - `_filter` - get_ui_id = function(dataname) { - sprintf("%s_filter", dataname) + # @description + # Gets the number of active `FilterState` objects in all `FilterStates` + # in all `FilteredDataset`s in this `FilteredData` object. + # @return `integer(1)` + get_filter_count = function() { + length(self$get_filter_state()) }, - # @details - # Composes id for the FilteredDataset shiny element (add filter state) - # @param dataname (`character(1)`) name of the dataset which ui is composed for. - # @return `character(1)` - `_filter` - get_ui_add_filter_id = function(dataname) { - sprintf("add_%s_filter", dataname) - }, + # @description + # Activate available filters. + # Module is composed from plus button and dropdown menu. Menu is shown when + # the button is clicked. Menu contains available/active filters list + # passed via `set_available_teal_slice`. + ui_available_filters = function(id) { + ns <- NS(id) - # @details - # Validates the state of this FilteredData. - # The call to this function should be isolated to avoid a reactive dependency. - # Getting the names of a reactivevalues also needs a reactive context. - validate = function() { - # Note: Here, we directly refer to the private attributes because the goal of this - # function is to check the underlying attributes and the get / set functions might be corrupted - - has_same_names <- function(x, y) setequal(names(x), names(y)) - # check `filter_states` are all valid - lapply( - names(private$filter_states), - function(dataname) { - stopifnot(is.list(private$filter_states)) # non-NULL, possibly empty list - lapply( - names(private$filter_states[[dataname]]), - function(varname) { - var_state <- private$filter_states[[dataname]][[varname]] - stopifnot(!is.null(var_state)) # should not be NULL, see doc of this attribute - check_valid_filter_state( - filter_state = var_state, - dataname = dataname, - varname = varname - ) - } + active_slices_id <- shiny::isolate(vapply(self$get_filter_state(), `[[`, character(1), "id")) + div( + id = ns("available_menu"), + shinyWidgets::dropMenu( + actionLink( + ns("show"), + label = NULL, + icon = icon("plus", lib = "font-awesome"), + title = "Available filters", + class = "remove pull-right" + ), + div( + class = "menu-content", + uiOutput(ns("checkbox")) ) - } + ) ) - - return(invisible(NULL)) }, # @description - # Checks if the dataname exists and - # (if provided) that varname is a valid column in the dataset - # - # Stops when this is not the case. - # - # @param dataname (`character`) name of the dataset - # @param varname (`character`) column within the dataset; - # if `NULL`, this check is not performed - check_data_varname_exists = function(dataname, varname = NULL) { - checkmate::assert_string(dataname) - checkmate::assert_string(varname, null.ok = TRUE) - - isolate({ - # we isolate everything because we don't want to trigger again when datanames - # change (which also triggers when any of the data changes) - if (!dataname %in% names(self$get_filtered_dataset())) { - # data must be set already - stop(paste("data", dataname, "is not available")) - } - if (!is.null(varname) && !(varname %in% self$get_varnames(dataname = dataname))) { - stop(paste("variable", varname, "is not in data", dataname)) + # Activate available filters. When the filter is selected or removed + # then `set_filter_state` or `remove_filter_state` is executed for + # appropriate filter (identified by it's id) + srv_available_filters = function(id) { + moduleServer(id, function(input, output, session) { + slices_interactive <- reactive( + Filter( + function(slice) !isTRUE(slice$fixed) && !inherits(slice, "teal_slice_expr"), + private$available_teal_slices() + ) + ) + slices_fixed <- reactive( + Filter( + function(slice) isTRUE(slice$fixed) || inherits(slice, "teal_slice_expr"), + private$available_teal_slices() + ) + ) + available_slices_id <- reactive(vapply(private$available_teal_slices(), `[[`, character(1), "id")) + active_slices_id <- reactive(vapply(self$get_filter_state(), `[[`, character(1), "id")) + duplicated_slice_references <- reactive({ + # slice refers to a particular column + slice_reference <- vapply(private$available_teal_slices(), get_default_slice_id, character(1)) + is_duplicated_reference <- duplicated(slice_reference) | duplicated(slice_reference, fromLast = TRUE) + is_active <- available_slices_id() %in% active_slices_id() + is_not_expr <- !vapply(private$available_teal_slices(), inherits, logical(1), "teal_slice_expr") + slice_reference[is_duplicated_reference & is_active & is_not_expr] + }) + + checkbox_group_element <- function(name, value, label, checked, disabled = FALSE) { + tags$div( + class = "checkbox available-filters", + tags$label( + tags$input( + type = "checkbox", + name = name, + value = value, + checked = checked, + disabled = if (disabled) "disabled" + ), + tags$span(label, disabled = if (disabled) disabled) + ) + ) } - }) - - return(invisible(NULL)) - }, - # @description - # Gets the number of active `FilterState` objects in all `FilterStates` - # in all `FilteredDataset`s in this `FilteredData` object. - # @return `integer(1)` - get_filter_count = function() { - sum(vapply(self$datanames(), function(dataname) { - self$get_filtered_dataset(dataname)$get_filter_count() - }, numeric(1L))) - } - ) -) - -# Wrapper functions for `FilteredData` class ---- + output$checkbox <- renderUI({ + checkbox <- checkboxGroupInput( + session$ns("available_slices_id"), + label = NULL, + choices = NULL, + selected = NULL + ) + active_slices_ids <- active_slices_id() + duplicated_slice_refs <- duplicated_slice_references() + + checkbox_group_slice <- function(slice) { + # we need to isolate changes in the fields of the slice (teal_slice) + shiny::isolate({ + checkbox_group_element( + name = session$ns("available_slices_id"), + value = slice$id, + label = slice$id, + checked = if (slice$id %in% active_slices_ids) "checked", + disabled = slice$locked || + get_default_slice_id(slice) %in% duplicated_slice_refs && + !slice$id %in% active_slices_ids + ) + }) + } + interactive_choice_mock <- lapply(slices_interactive(), checkbox_group_slice) + non_interactive_choice_mock <- lapply(slices_fixed(), checkbox_group_slice) + + htmltools::tagInsertChildren( + checkbox, + br(), + tags$strong("Fixed filters"), + non_interactive_choice_mock, + tags$strong("Interactive filters"), + interactive_choice_mock, + .cssSelector = "div.shiny-options-group", + after = 0 + ) + }) + + observeEvent(input$available_slices_id, ignoreNULL = FALSE, ignoreInit = TRUE, { + new_slices_id <- setdiff(input$available_slices_id, active_slices_id()) + removed_slices_id <- setdiff(active_slices_id(), input$available_slices_id) + if (length(new_slices_id)) { + new_teal_slices <- Filter( + function(slice) slice$id %in% new_slices_id, + private$available_teal_slices() + ) + self$set_filter_state(new_teal_slices) + } -#' Gets filter expression for multiple datanames taking into account its order. -#' -#' @description `r lifecycle::badge("stable")` -#' To be used in show R code button. -#' -#' @param datasets (`FilteredData`) -#' @param datanames (`character`) vector of dataset names -#' -#' @export -#' -#' @return (`expression`) -get_filter_expr <- function(datasets, datanames = datasets$datanames()) { - checkmate::assert_character(datanames, min.len = 1, any.missing = FALSE) - stopifnot( - is(datasets, "FilteredData"), - all(datanames %in% datasets$datanames()) - ) + if (length(removed_slices_id)) { + removed_teal_slices <- Filter( + function(slice) slice$id %in% removed_slices_id, + self$get_filter_state() + ) + self$remove_filter_state(removed_teal_slices) + } + }) - paste( - unlist(lapply( - datanames, - function(dataname) { - datasets$get_call(dataname) - } - )), - collapse = "\n" + observeEvent(private$available_teal_slices(), ignoreNULL = FALSE, { + if (length(private$available_teal_slices())) { + shinyjs::show("available_menu") + } else { + shinyjs::hide("available_menu") + } + }) + }) + } ) -} +) diff --git a/R/FilteredDataCDISC.R b/R/FilteredDataCDISC.R deleted file mode 100644 index f33013771..000000000 --- a/R/FilteredDataCDISC.R +++ /dev/null @@ -1,372 +0,0 @@ -#' @name CDISCFilteredData -#' @docType class -#' -#' @title Class to encapsulate relational filtered datasets with its parents. -#' @description `r lifecycle::badge("stable")` -#' @details -#' The `CDISCFilteredData` class implements logic to filter a relational -#' dataset by inheriting from `FilteredData`. -#' A dataset can have up to one parent dataset. Rows are identified by the foreign -#' key and only those rows that appear in the parent dataset are kept in the filtered -#' dataset. -#' -#' The teal UI works with objects of class `FilteredData` which may mix CDISC and other -#' data (e.g. `iris`). -#' -#' @seealso `FilteredData` class -#' -#' @examples -#' library(teal.data) -#' ADSL <- data.frame( -#' STUDYID = 1, -#' USUBJID = letters[1:10], -#' SEX = sample(c("F", "M"), 10, replace = TRUE) -#' ) -#' ADTTE <- data.frame( -#' STUDYID = 1, -#' USUBJID = rep(letters[1:10], each = 3), -#' PARAMCD = rep(c("P1", "P2", "P3"), each = 10), -#' AVAL = runif(30) -#' ) -#' datasets <- teal.slice:::CDISCFilteredData$new( -#' list( -#' ADSL = list(dataset = ADSL, keys = c("STUDYID", "USUBJID")), -#' ADTTE = list(dataset = ADTTE, keys = c("STUDYID", "USUBJID", "PARAMCD"), parent = "ADSL") -#' ), -#' check = FALSE, -#' join_keys = join_keys(join_key("ADSL", "ADTTE", c("STUDYID", "USUBJID"))) -#' ) -#' -#' # to avoid using isolate(), you can provide a default isolate context by calling -#' # options(shiny.suppressMissingContextError = TRUE) #nolint -#' # don't forget to deactivate this option at the end -#' # options(shiny.suppressMissingContextError = FALSE) #nolint -#' -#' isolate({ -#' datasets$datanames() -#' -#' # number observations and subjects of filtered/non-filtered dataset -#' datasets$get_filter_overview("ADSL") -#' -#' print(datasets$get_call("ADSL")) -#' print(datasets$get_call("ADTTE")) -#' -#' df <- datasets$get_data("ADSL", filtered = FALSE) -#' print(df) -#' }) -#' -#' -#' isolate(datasets$set_filter_state(list(ADTTE = list(PARAMCD = "OS")))) -#' isolate(datasets$get_filter_state()) -CDISCFilteredData <- R6::R6Class( # nolint - "CDISCFilteredData", - inherit = FilteredData, - ## CDISCFilteredData ==== - ## __Public Methods ==== - public = list( - #' @description - #' Get datanames - #' - #' The datanames are returned in the order in which they must be - #' evaluated (in case of dependencies). - #' @return (`character` vector) of datanames - datanames = function() { - datanames <- super$datanames() - child_parent <- sapply(datanames, function(i) self$get_parentname(i), USE.NAMES = TRUE, simplify = FALSE) - ordered_datanames <- topological_sort(child_parent) - return(as.character(intersect(as.character(ordered_datanames), datanames))) - }, - - #' @description - #' - #' Produces language required to filter a single dataset and merge it with its parent. - #' The datasets in question are assumed to be available. - #' - #' @param dataname (`character(1)`) name of the dataset - #' @return (`call` or `list` of calls ) to filter dataset - #' - get_call = function(dataname) { - parent_dataname <- self$get_parentname(dataname) - - if (length(parent_dataname) == 0) { - super$get_call(dataname) - } else { - dataset <- self$get_filtered_dataset(dataname) - premerge_call <- Filter( - f = Negate(is.null), - x = lapply( - dataset$get_filter_states(), - function(x) x$get_call() - ) - ) - - join_keys <- self$get_join_keys() - keys <- - if (!is.null(join_keys)) { - join_keys$get(parent_dataname, dataname) - } else { - character(0) - } - parent_keys <- names(keys) - dataset_keys <- unname(keys) - - y_arg <- - if (length(parent_keys) == 0L) { - parent_dataname - } else { - sprintf("%s[, c(%s), drop = FALSE]", parent_dataname, toString(dQuote(parent_keys, q = FALSE))) - } - more_args <- - if (length(parent_keys) == 0 || length(dataset_keys) == 0) { - list() - } else if (identical(parent_keys, dataset_keys)) { - list(by = parent_keys) - } else { - list(by = stats::setNames(parent_keys, dataset_keys)) - } - - merge_call <- call( - "<-", - as.name(dataname), - as.call( - c( - str2lang("dplyr::inner_join"), - x = as.name(dataname), - y = str2lang(y_arg), - more_args - ) - ) - ) - - c(premerge_call, merge_call) - } - }, - - #' @description - #' Get names of datasets available for filtering - #' - #' @param dataname (`character` vector) names of the dataset - #' @return (`character` vector) of dataset names - get_filterable_datanames = function(dataname) { - parents <- character(0) - for (i in dataname) { - while (length(i) > 0) { - parent_i <- self$get_parentname(i) - parents <- c(parents, parent_i) - i <- parent_i - } - } - - return(unique(c(parents, dataname))) - }, - - #' @description - #' Gets variable names of a given dataname for the filtering. This excludes parent dataset variable names. - #' - #' @param dataname (`character(1)`) name of the dataset - #' @return (`character` vector) of variable names - get_filterable_varnames = function(dataname) { - varnames <- self$get_filtered_dataset(dataname)$get_filterable_varnames() - parent_dataname <- self$get_parentname(dataname) - parent_varnames <- if (length(parent_dataname) > 0) { - # cannot call get_filterable_varnames on the parent filtered_dataset in case - # some of its variables are set to be non-filterable - get_supported_filter_varnames(self$get_filtered_dataset(parent_dataname)) - } - setdiff(varnames, parent_varnames) - }, - - #' @description - #' Get filter overview table in form of X (filtered) / Y (non-filtered) - #' - #' This is intended to be presented in the application. - #' - #' @param datanames (`character` vector) names of the dataset (or "all") - #' - #' @return (`matrix`) matrix of observations and subjects of all datasets - get_filter_overview = function(datanames) { - if (identical(datanames, "all")) { - datanames <- self$datanames() - } - check_in_subset(datanames, self$datanames(), "Some datasets are not available: ") - - rows <- lapply( - datanames, - function(dataname) { - obs <- self$get_filtered_dataset(dataname)$get_filter_overview_info( - filtered_dataset = self$get_data(dataname = dataname, filtered = TRUE) - )[, 1] - - subs <- private$get_filter_overview_nsubjs(dataname) - - df <- cbind( - obs, subs - ) - - rownames(df) <- if (!is.null(names(obs))) { - names(obs) - } else { - dataname - } - colnames(df) <- c("Obs", "Subjects") - df - } - ) - - do.call(rbind, rows) - }, - - #' @description - #' Get parent dataset name - #' - #' @param dataname (`character(1)`) name of the dataset - #' @return (`character`) name of parent dataset - get_parentname = function(dataname) { - private$parents[[dataname]] - }, - - #' @description - #' Add dataset - #' - #' Add dataset and preserve all attributes attached to this object. - #' Technically `set_dataset` created `FilteredDataset` which keeps - #' `dataset` for filtering purpose. - #' - #' @param dataset_args (`list`)\cr - #' containing the arguments except (`dataname`) - #' needed by `init_filtered_dataset` (can also - #' include `parent` which will be ignored) - #' @param dataname (`character(1)`)\cr - #' the name of the `dataset` to be added to this object - #' @return (`self`) object of this class - set_dataset = function(dataset_args, dataname) { - logger::log_trace("CDISCFilteredData$set_dataset setting dataset, name: { dataname }") - validate_dataset_args(dataset_args, dataname, allowed_parent = TRUE) - - parent_dataname <- dataset_args[["parent"]] - dataset_args[["parent"]] <- NULL - private$parents[[dataname]] <- parent_dataname - - if (length(parent_dataname) == 0) { - super$set_dataset(dataset_args, dataname) - } else { - dataset <- dataset_args[["dataset"]] - dataset_args[["dataset"]] <- NULL - - # to include it nicely in the Show R Code; the UI also uses datanames in ids, so no whitespaces allowed - check_simple_name(dataname) - private$filtered_datasets[[dataname]] <- do.call( - what = init_filtered_dataset, - args = c(list(dataset), dataset_args, list(dataname = dataname)) - ) - - private$reactive_data[[dataname]] <- reactive({ - env <- new.env(parent = parent.env(globalenv())) - env[[dataname]] <- self$get_filtered_dataset(dataname)$get_dataset() - env[[private$parents[[dataname]]]] <- - private$reactive_data[[private$parents[[dataname]]]]() - - filter_call <- self$get_call(dataname) - eval_expr_with_msg(filter_call, env) - get(x = dataname, envir = env) - }) - } - - invisible(self) - } - ), - - ## __Private Methods--------------------- - private = list( - - # named list of dataset parents parents[[child_dataset]] = its parent - parents = NULL, - - # datanames in the order in which they must be evaluated (in case of dependencies) - # this is a reactive and kept as a field for caching - ordered_datanames = NULL, - validate = function() { - stopifnot( - setequal(private$ordered_datanames, names(private$dataset_filters)), - ) - super$validate() - }, - get_filter_overview_nsubjs = function(dataname) { - # Gets filter overview subjects number and returns a list - # of the number of subjects of filtered/non-filtered datasets - subject_keys <- if (length(self$get_parentname(dataname)) > 0) { - self$get_keys(self$get_parentname(dataname)) - } else { - self$get_filtered_dataset(dataname)$get_keys() - } - - self$get_filtered_dataset(dataname)$get_filter_overview_nsubjs( - self$get_data(dataname = dataname, filtered = TRUE), - subject_keys - ) - } - ) -) - -#' Topological graph sort -#' -#' Graph is a list which for each node contains a vector of child nodes -#' in the returned list, parents appear before their children. -#' -#' Implementation of Kahn algorithm with a modification to maintain the order of input elements. -#' -#' @param graph (named `list`) list with node vector elements -#' @keywords internal -#' -#' @examples -#' \dontrun{ -#' topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A"))) -#' topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B"))) -#' topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c())) -#' } -topological_sort <- function(graph) { - # compute in-degrees - in_degrees <- list() - for (node in names(graph)) { - in_degrees[[node]] <- 0 - for (to_edge in graph[[node]]) { - in_degrees[[to_edge]] <- 0 - } - } - - for (node in graph) { - for (to_edge in node) { - in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1 - } - } - - # sort - visited <- 0 - sorted <- list() - zero_in <- list() - for (node in names(in_degrees)) { - if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node) - } - zero_in <- rev(zero_in) - - while (length(zero_in) != 0) { - visited <- visited + 1 - sorted <- c(zero_in[[1]], sorted) - for (edge_to in graph[[zero_in[[1]]]]) { - in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1 - if (in_degrees[[edge_to]] == 0) { - zero_in <- append(zero_in, edge_to, 1) - } - } - zero_in[[1]] <- NULL - } - - if (visited != length(in_degrees)) { - stop( - "Graph is not a directed acyclic graph. Cycles involving nodes: ", - paste0(setdiff(names(in_degrees), sorted), collapse = " ") - ) - } else { - return(sorted) - } -} diff --git a/R/FilteredDataset-utils.R b/R/FilteredDataset-utils.R new file mode 100644 index 000000000..af31ab037 --- /dev/null +++ b/R/FilteredDataset-utils.R @@ -0,0 +1,142 @@ +#' Initializes `FilteredDataset` +#' +#' @keywords internal +#' @examples +#' # DefaultFilteredDataset example +#' iris_fd <- teal.slice:::init_filtered_dataset( +#' iris, +#' dataname = "iris", +#' metadata = list(type = "teal") +#' ) +#' app <- shinyApp( +#' ui = fluidPage( +#' iris_fd$ui_add(id = "add"), +#' iris_fd$ui_active("dataset"), +#' verbatimTextOutput("call"), +#' verbatimTextOutput("metadata") +#' ), +#' server = function(input, output, session) { +#' iris_fd$srv_add(id = "add") +#' iris_fd$srv_active(id = "dataset") +#' +#' output$metadata <- renderText({ +#' paste("Type =", iris_fd$get_metadata()$type) +#' }) +#' +#' output$call <- renderText({ +#' paste( +#' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"), +#' collapse = "\n" +#' ) +#' }) +#' } +#' ) +#' if (interactive()) { +#' runApp(app) +#' } +#' +#' # MAEFilteredDataset example +#' library(MultiAssayExperiment) +#' data(miniACC) +#' MAE_fd <- teal.slice:::init_filtered_dataset(miniACC, "MAE", metadata = list(type = "MAE")) +#' app <- shinyApp( +#' ui = fluidPage( +#' MAE_fd$ui_add(id = "add"), +#' MAE_fd$ui_active("dataset"), +#' verbatimTextOutput("call"), +#' verbatimTextOutput("metadata") +#' ), +#' server = function(input, output, session) { +#' MAE_fd$srv_add(id = "add") +#' MAE_fd$srv_active(id = "dataset") +#' output$metadata <- renderText({ +#' paste("Type =", MAE_fd$get_metadata()$type) +#' }) +#' output$call <- renderText({ +#' paste( +#' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"), +#' collapse = "\n" +#' ) +#' }) +#' } +#' ) +#' if (interactive()) { +#' runApp(app) +#' } +#' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr +#' @param dataname (`character`)\cr +#' A given name for the dataset it may not contain spaces +#' @param keys optional, (`character`)\cr +#' Vector with primary keys +#' @param parent_name (`character(1)`)\cr +#' Name of the parent dataset +#' @param parent (`reactive`)\cr +#' object returned by this reactive is a filtered `data.frame` from other `FilteredDataset` +#' named `parent_name`. Consequence of passing `parent` is a `reactive` link which causes +#' causing re-filtering of this `dataset` based on the changes in `parent`. +#' @param join_keys (`character`)\cr +#' Name of the columns in this dataset to join with `parent` +#' dataset. If the column names are different if both datasets +#' then the names of the vector define the `parent` columns. +#' @param label (`character`)\cr +#' Label to describe the dataset +#' @param metadata (named `list` or `NULL`) \cr +#' Field containing metadata about the dataset. Each element of the list +#' should be atomic and length one. +#' @export +#' @note Although this function is exported for use in other packages, it may be changed or removed in a future release +#' at which point any code which relies on this exported function will need to be changed. +init_filtered_dataset <- function(dataset, # nolint + dataname, + keys = character(0), + parent_name = character(0), + parent = reactive(dataset), + join_keys = character(0), + label = attr(dataset, "label"), + metadata = NULL) { + UseMethod("init_filtered_dataset") +} + +#' @keywords internal +#' @export +init_filtered_dataset.data.frame <- function(dataset, # nolint + dataname, + keys = character(0), + parent_name = character(0), + parent = NULL, + join_keys = character(0), + label = attr(dataset, "label"), + metadata = NULL) { + DefaultFilteredDataset$new( + dataset = dataset, + dataname = dataname, + keys = keys, + parent_name = parent_name, + parent = parent, + join_keys = join_keys, + label = label, + metadata = metadata + ) +} + +#' @keywords internal +#' @export +init_filtered_dataset.MultiAssayExperiment <- function(dataset, # nolint + dataname, + keys = character(0), + parent_name, # ignored + parent, # ignored + join_keys, # ignored + label = attr(dataset, "label"), + metadata = NULL) { + if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { + stop("Cannot load MultiAssayExperiment - please install the package or restart your session.") + } + MAEFilteredDataset$new( + dataset = dataset, + dataname = dataname, + keys = keys, + label = label, + metadata = metadata + ) +} diff --git a/R/FilteredDataset.R b/R/FilteredDataset.R index da9531527..247eec437 100644 --- a/R/FilteredDataset.R +++ b/R/FilteredDataset.R @@ -1,110 +1,3 @@ -#' Initializes `FilteredDataset` -#' -#' @keywords internal -#' @examples -#' # DefaultFilteredDataset example -#' iris_fd <- teal.slice:::init_filtered_dataset( -#' iris, -#' dataname = "iris", -#' metadata = list(type = "teal") -#' ) -#' \dontrun{ -#' shinyApp( -#' ui = fluidPage( -#' iris_fd$ui_add_filter_state(id = "add"), -#' iris_fd$ui("dataset"), -#' verbatimTextOutput("call"), -#' verbatimTextOutput("metadata") -#' ), -#' server = function(input, output, session) { -#' iris_fd$srv_add_filter_state(id = "add") -#' iris_fd$server(id = "dataset") -#' -#' output$metadata <- renderText({ -#' paste("Type =", iris_fd$get_metadata()$type) -#' }) -#' -#' output$call <- renderText({ -#' paste( -#' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"), -#' collapse = "\n" -#' ) -#' }) -#' } -#' ) -#' } -#' -#' # MAEFilteredDataset example -#' library(MultiAssayExperiment) -#' data(miniACC) -#' MAE_fd <- teal.slice:::init_filtered_dataset(miniACC, "MAE", metadata = list(type = "MAE")) -#' \dontrun{ -#' shinyApp( -#' ui = fluidPage( -#' MAE_fd$ui_add_filter_state(id = "add"), -#' MAE_fd$ui("dataset"), -#' verbatimTextOutput("call"), -#' verbatimTextOutput("metadata") -#' ), -#' server = function(input, output, session) { -#' MAE_fd$srv_add_filter_state(id = "add") -#' MAE_fd$server(id = "dataset") -#' output$metadata <- renderText({ -#' paste("Type =", MAE_fd$get_metadata()$type) -#' }) -#' output$call <- renderText({ -#' paste( -#' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"), -#' collapse = "\n" -#' ) -#' }) -#' } -#' ) -#' } -#' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr -#' @param dataname (`character`)\cr -#' A given name for the dataset it may not contain spaces -#' @param keys optional, (`character`)\cr -#' Vector with primary keys -#' @param label (`character`)\cr -#' Label to describe the dataset -#' @param metadata (named `list` or `NULL`) \cr -#' Field containing metadata about the dataset. Each element of the list -#' should be atomic and length one. -#' @export -#' @note Although this function is exported for use in other packages, it may be changed or removed in a future release -#' at which point any code which relies on this exported function will need to be changed. -init_filtered_dataset <- function(dataset, # nolint - dataname, - keys = character(0), - label = attr(dataset, "label"), - metadata = NULL) { - UseMethod("init_filtered_dataset") -} - -#' @keywords internal -#' @export -init_filtered_dataset.data.frame <- function(dataset, # nolint - dataname, - keys = character(0), - label = attr(dataset, "label"), - metadata = NULL) { - DefaultFilteredDataset$new(dataset, dataname, keys, label, metadata) -} - -#' @keywords internal -#' @export -init_filtered_dataset.MultiAssayExperiment <- function(dataset, # nolint - dataname, - keys = character(0), - label = attr(dataset, "label"), - metadata = NULL) { - if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) { - stop("Cannot load MultiAssayExperiment - please install the package or restart your session.") - } - MAEFilteredDataset$new(dataset, dataname, keys, label, metadata) -} - # FilteredDataset abstract -------- #' @title `FilterStates` R6 class #' @description @@ -133,8 +26,9 @@ FilteredDataset <- R6::R6Class( # nolint #' Field containing metadata about the dataset. Each element of the list #' should be atomic and length one. initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label"), metadata = NULL) { - # dataset assertion in child classes + logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }") + # dataset assertion in child classes check_simple_name(dataname) checkmate::assert_character(keys, any.missing = FALSE) checkmate::assert_character(label, null.ok = TRUE) @@ -146,46 +40,66 @@ FilteredDataset <- R6::R6Class( # nolint private$keys <- keys private$label <- if (is.null(label)) character(0) else label private$metadata <- metadata + + # function executing reactive call and returning data + private$data_filtered_fun <- function(sid = "") { + checkmate::assert_character(sid) + if (length(sid)) { + logger::log_trace("filtering data dataname: { dataname }, sid: { sid }") + } else { + logger::log_trace("filtering data dataname: { private$dataname }") + } + env <- new.env(parent = parent.env(globalenv())) + env[[dataname]] <- private$dataset + filter_call <- self$get_call(sid) + eval_expr_with_msg(filter_call, env) + get(x = dataname, envir = env) + } + + private$data_filtered <- reactive(private$data_filtered_fun()) + logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }") invisible(self) }, - #' @description - #' Returns a string representation of the filter state in this `FilteredDataset`. + #' Returns a formatted string representing this `FilteredDataset` object. #' - #' @return `character(1)` the formatted string representing the filter state or - #' `NULL` if no filter state is present. + #' @param show_all `logical(1)` passed to `format.teal_slice` + #' @param trim_lines `logical(1)` passed to `format.teal_slice` #' - get_formatted_filter_state = function() { - out <- Filter( - function(x) x != "", - sapply( - self$get_filter_states(), - function(states) { - states$format(indent = 2) - } - ) + #' @return `character(1)` the formatted string + #' + format = function(show_all = FALSE, trim_lines = TRUE) { + sprintf( + "%s:\n%s", + class(self)[1], + format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines) ) - if (length(out) > 0) { - header <- paste0("Filters for dataset: ", self$get_dataname()) - paste(c(header, out), collapse = "\n") - } + }, + + #' @description + #' Prints this `FilteredDataset` object. + #' + #' @param ... additional arguments + #' + print = function(...) { + cat(shiny::isolate(self$format(...)), "\n") }, #' @description #' Removes all active filter items applied to this dataset #' @return NULL - state_lists_empty = function() { - logger::log_trace("Removing all filters from FilteredDataset: { deparse1(self$get_dataname()) }") + clear_filter_states = function() { + logger::log_trace("Removing all non-locked filters from FilteredDataset: { deparse1(self$get_dataname()) }") lapply( - self$get_filter_states(), - function(state_list) state_list$state_list_empty() + private$get_filter_states(), + function(filter_states) filter_states$clear_filter_states() ) - logger::log_trace("Removed all filters from FilteredDataset: { deparse1(self$get_dataname()) }") + logger::log_trace("Removed all non-locked filters from FilteredDataset: { deparse1(self$get_dataname()) }") NULL }, - # managing filter states ----- + # managing filter states ----- # getters ---- #' @description @@ -194,49 +108,54 @@ FilteredDataset <- R6::R6Class( # nolint #' This functions returns filter calls equivalent to selected items #' within each of `filter_states`. Configuration of the calls is constant and #' depends on `filter_states` type and order which are set during initialization. + #' + #' @param sid (`character`)\cr + #' when specified then method returns code containing filter conditions of + #' `FilterState` objects which `"sid"` attribute is different than this `sid` argument. + #' #' @return filter `call` or `list` of filter calls - get_call = function() { - stop("Pure virtual method.") + get_call = function(sid = "") { + filter_call <- Filter( + f = Negate(is.null), + x = lapply(private$get_filter_states(), function(x) x$get_call(sid)) + ) + if (length(filter_call) == 0) { + return(NULL) + } + filter_call }, - #' Gets the reactive values from the active `FilterState` objects. + #' @description + #' Gets states of all active `FilterState` objects + #' + #' @return A `teal_slices` object. #' - #' Get all active filters from this dataset in form of the nested list. - #' The output list is a compatible input to `self$set_filter_state`. - #' @return `list` with named elements corresponding to `FilterStates` objects - #' with active filters. get_filter_state = function() { - states <- lapply(self$get_filter_states(), function(x) x$get_filter_state()) - Filter(function(x) length(x) > 0, states) + states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state())) + do.call(c, states) }, #' @description - #' Gets the active `FilterStates` objects. - #' @param id (`character(1)`, `character(0)`)\cr - #' the id of the `private$filter_states` list element where `FilterStates` is kept. - #' @return `FilterStates` or `list` of `FilterStates` objects. - get_filter_states = function(id = character(0)) { - if (length(id) == 0) { - private$filter_states - } else { - private$filter_states[[id]] - } + #' Set filter state + #' + #' @param state (`teal_slice`) object + #' + #' @return `NULL` invisibly + #' + set_filter_state = function(state) { + stop("set_filter_state is an abstract class method.") }, #' @description #' Gets the number of active `FilterState` objects in all `FilterStates` in this `FilteredDataset`. #' @return `integer(1)` get_filter_count = function() { - sum(vapply(private$filter_states, - function(state) state$get_filter_count(), - FUN.VALUE = integer(1) - )) + length(self$get_filter_state()) }, #' @description - #' Get name of the dataset + #' Gets the name of the dataset #' - #' Get name of the dataset #' @return `character(1)` as a name of this dataset get_dataname = function() { private$dataname @@ -244,9 +163,17 @@ FilteredDataset <- R6::R6Class( # nolint #' @description #' Gets the dataset object in this `FilteredDataset` - #' @return `data.frame` or `MultiAssayExperiment` - get_dataset = function() { - private$dataset + #' @param filtered (`logical(1)`)\cr + #' + #' @return `data.frame` or `MultiAssayExperiment`, either raw + #' or as a reactive with current filters applied + #' + get_dataset = function(filtered = FALSE) { + if (filtered) { + private$data_filtered + } else { + private$dataset + } }, #' @description @@ -263,13 +190,15 @@ FilteredDataset <- R6::R6Class( # nolint #' @param filtered_dataset comparison object, of the same class #' as `self$get_dataset()`, if `NULL` then `self$get_dataset()` #' is used. - #' @return (`matrix`) matrix of observations and subjects - get_filter_overview_info = function(filtered_dataset = self$get_dataset()) { - checkmate::assert_class(filtered_dataset, classes = class(self$get_dataset())) - df <- cbind(private$get_filter_overview_nobs(filtered_dataset), "") - rownames(df) <- self$get_dataname() - colnames(df) <- c("Obs", "Subjects") - df + #' @return (`data.frame`) matrix of observations and subjects + get_filter_overview = function() { + dataset <- self$get_dataset() + data_filtered <- self$get_dataset(TRUE) + data.frame( + dataname = private$dataname, + obs = nrow(dataset), + obs_filtered = nrow(data_filtered) + ) }, #' @description @@ -279,28 +208,6 @@ FilteredDataset <- R6::R6Class( # nolint private$keys }, - #' @description - #' Gets labels of variables in the data - #' - #' Variables are the column names of the data. - #' Either, all labels must have been provided for all variables - #' in `set_data` or `NULL`. - #' - #' @param variables (`character` vector) variables to get labels for; - #' if `NULL`, for all variables in data - #' @return (`character` or `NULL`) variable labels, `NULL` if `column_labels` - #' attribute does not exist for the data - get_varlabels = function(variables = NULL) { - checkmate::assert_character(variables, null.ok = TRUE, any.missing = FALSE) - - labels <- formatters::var_labels(private$dataset, fill = FALSE) - if (is.null(labels)) { - return(NULL) - } - if (!is.null(variables)) labels <- labels[intersect(self$get_varnames(), variables)] - labels - }, - #' @description #' Gets the dataset label #' @return (`character`) the dataset label @@ -308,46 +215,6 @@ FilteredDataset <- R6::R6Class( # nolint private$label }, - #' @description - #' Gets variable names from dataset - #' @return `character` the variable names - get_varnames = function() { - colnames(self$get_dataset()) - }, - - #' @description - #' Gets variable names for the filtering. - #' - #' It takes the intersection of the column names - #' of the data and `private$filterable_varnames` if - #' `private$filterable_varnames` has positive length - #' - #' @return (`character` vector) of variable names - get_filterable_varnames = function() { - varnames <- get_supported_filter_varnames(self) - if (length(private$filterable_varnames) > 0) { - return(intersect(private$filterable_varnames, varnames)) - } - return(varnames) - }, - - # setters ------ - #' @description - #' Set the allowed filterable variables - #' @param varnames (`character` or `NULL`) The variables which can be filtered - #' See `self$get_filterable_varnames` for more details - #' - #' @details When retrieving the filtered variables only - #' those which have filtering supported (i.e. are of the permitted types) - #' are included. - #' - #' @return invisibly this `FilteredDataset` - set_filterable_varnames = function(varnames) { - checkmate::assert_character(varnames, any.missing = FALSE, null.ok = TRUE) - private$filterable_varnames <- varnames - return(invisible(self)) - }, - # modules ------ #' @description #' UI module for dataset active filters @@ -358,12 +225,12 @@ FilteredDataset <- R6::R6Class( # nolint #' identifier of the element - preferably containing dataset name #' #' @return function - shiny UI module - ui = function(id) { + ui_active = function(id) { dataname <- self$get_dataname() checkmate::assert_string(dataname) ns <- NS(id) - if_multiple_filter_states <- length(self$get_filter_states()) > 1 + if_multiple_filter_states <- length(private$get_filter_states()) > 1 span( id = id, include_css_files("filter-panel"), @@ -408,9 +275,9 @@ FilteredDataset <- R6::R6Class( # nolint class = "parent-hideable-list-group", tagList( lapply( - names(self$get_filter_states()), + names(private$get_filter_states()), function(x) { - tagList(self$get_filter_states(id = x)$ui(id = ns(x))) + tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x))) } ) ) @@ -426,15 +293,13 @@ FilteredDataset <- R6::R6Class( # nolint #' @param id (`character(1)`)\cr #' an ID string that corresponds with the ID used to call the module's UI function. #' @return `moduleServer` function which returns `NULL` - server = function(id) { + srv_active = function(id) { moduleServer( id = id, function(input, output, session) { dataname <- self$get_dataname() - logger::log_trace("FilteredDataset$server initializing, dataname: { dataname }") + logger::log_trace("FilteredDataset$srv_active initializing, dataname: { dataname }") checkmate::assert_string(dataname) - shiny::setBookmarkExclude("remove_filters") - output$filter_count <- renderText( sprintf( "%d filter%s applied", @@ -444,9 +309,9 @@ FilteredDataset <- R6::R6Class( # nolint ) lapply( - names(self$get_filter_states()), + names(private$get_filter_states()), function(x) { - self$get_filter_states(id = x)$server(id = x) + private$get_filter_states()[[x]]$srv_active(id = x) } ) @@ -464,15 +329,13 @@ FilteredDataset <- R6::R6Class( # nolint }) observeEvent(input$remove_filters, { - logger::log_trace("FilteredDataset$server@1 removing filters, dataname: { dataname }") - lapply( - self$get_filter_states(), - function(x) x$state_list_empty() - ) - logger::log_trace("FilteredDataset$server@1 removed filters, dataname: { dataname }") + logger::log_trace("FilteredDataset$srv_active@1 removing all non-locked filters, dataname: { dataname }") + self$clear_filter_states() + logger::log_trace("FilteredDataset$srv_active@1 removed all non-locked filters, dataname: { dataname }") }) logger::log_trace("FilteredDataset$initialized, dataname: { dataname }") + NULL } ) @@ -486,73 +349,70 @@ FilteredDataset <- R6::R6Class( # nolint #' identifier of the element - preferably containing dataset name #' #' @return function - shiny UI module - ui_add_filter_state = function(id) { + ui_add = function(id) { stop("Pure virtual method") }, #' @description #' Server module to add filter variable for this dataset #' - #' Server module to add filter variable for this dataset + #' Server module to add filter variable for this dataset. + #' For this class `srv_add` calls multiple modules + #' of the same name from `FilterStates` as `MAEFilteredDataset` + #' contains one `FilterStates` object for `colData` and one for each + #' experiment. + #' #' @param id (`character(1)`)\cr #' an ID string that corresponds with the ID used to call the module's UI function. - #' @param ... ignored - #' @return `moduleServer` function. - srv_add_filter_state = function(id, ...) { - check_ellipsis(..., stop = FALSE) + #' + #' @return `moduleServer` function which returns `NULL` + #' + srv_add = function(id) { moduleServer( id = id, function(input, output, session) { - stop("Pure virtual method") + logger::log_trace("MAEFilteredDataset$srv_add initializing, dataname: { deparse1(self$get_dataname()) }") + elems <- private$get_filter_states() + elem_names <- names(private$get_filter_states()) + lapply( + elem_names, + function(elem_name) elems[[elem_name]]$srv_add(elem_name) + ) + logger::log_trace("MAEFilteredDataset$srv_add initialized, dataname: { deparse1(self$get_dataname()) }") + NULL } ) } ), ## __Private Fields ==== private = list( - dataset = NULL, + dataset = NULL, # data.frame or MultiAssayExperiment + data_filtered = NULL, + data_filtered_fun = NULL, # function filter_states = list(), dataname = character(0), keys = character(0), label = character(0), metadata = NULL, - # if this has length > 0 then only varnames in this vector - # can be filtered - filterable_varnames = NULL, - # Adds `FilterStates` to the `private$filter_states`. # `FilterStates` is added once for each element of the dataset. # @param filter_states (`FilterStates`) # @param id (`character(1)`) add_filter_states = function(filter_states, id) { - stopifnot(is(filter_states, "FilterStates")) + checkmate::assert_class(filter_states, "FilterStates") checkmate::assert_string(id) - - x <- setNames(list(filter_states), id) - private$filter_states <- c(self$get_filter_states(), x) + x <- stats::setNames(list(filter_states), id) + private$filter_states <- c(private$get_filter_states(), x) }, # @description - # Checks if the dataname exists and - # (if provided) that varname is a valid column in the dataset - # - # Stops when this is not the case. - # - # @param varname (`character`) column within the dataset; - # if `NULL`, this check is not performed - check_data_varname_exists = function(varname = NULL) { - checkmate::assert_string(varname, null.ok = TRUE) - - isolate({ - if (!is.null(varname) && !(varname %in% self$get_varnames())) { - stop( - sprintf("variable '%s' does not exist in data '%s'", varname, dataname) - ) - } - }) - - return(invisible(NULL)) + # Gets the active `FilterStates` objects. + # @param id (`character(1)`, `character(0)`)\cr + # the id of the `private$filter_states` list element where `FilterStates` is kept. + # @return `FilterStates` or `list` of `FilterStates` objects. + get_filter_states = function() { + private$filter_states } ) ) diff --git a/R/FilteredDatasetDefault.R b/R/FilteredDatasetDefault.R index c34217389..73b8fd43c 100644 --- a/R/FilteredDatasetDefault.R +++ b/R/FilteredDatasetDefault.R @@ -4,12 +4,10 @@ #' @examples #' library(shiny) #' ds <- teal.slice:::DefaultFilteredDataset$new(iris, "iris") -#' isolate( -#' ds$set_filter_state( -#' state = list( -#' Species = list(selected = "virginica"), -#' Petal.Length = list(selected = c(2.0, 5)) -#' ) +#' ds$set_filter_state( +#' teal_slices( +#' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"), +#' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5)) #' ) #' ) #' isolate(ds$get_filter_state()) @@ -28,25 +26,78 @@ DefaultFilteredDataset <- R6::R6Class( # nolint #' A given name for the dataset it may not contain spaces #' @param keys optional, (`character`)\cr #' Vector with primary keys + #' @param parent_name (`character(1)`)\cr + #' Name of the parent dataset + #' @param parent (`reactive`)\cr + #' object returned by this reactive is a filtered `data.frame` from other `FilteredDataset` + #' named `parent_name`. Consequence of passing `parent` is a `reactive` link which causes + #' causing re-filtering of this `dataset` based on the changes in `parent`. + #' @param join_keys (`character`)\cr + #' Name of the columns in this dataset to join with `parent` + #' dataset. If the column names are different if both datasets + #' then the names of the vector define the `parent` columns. + #' #' @param label (`character`)\cr #' Label to describe the dataset #' @param metadata (named `list` or `NULL`) \cr #' Field containing metadata about the dataset. Each element of the list #' should be atomic and length one. - initialize = function(dataset, dataname, keys = character(0), label = character(0), metadata = NULL) { - checkmate::assert_class(dataset, "data.frame") + initialize = function(dataset, + dataname, + keys = character(0), + parent_name = character(0), + parent = NULL, + join_keys = character(0), + label = character(0), + metadata = NULL) { + checkmate::assert_data_frame(dataset) super$initialize(dataset, dataname, keys, label, metadata) - dataname <- self$get_dataname() + + # overwrite filtered_data if there is relationship with parent dataset + if (!is.null(parent)) { + checkmate::assert_character(parent_name, len = 1) + checkmate::assert_character(join_keys, min.len = 1) + + private$parent_name <- parent_name + private$join_keys <- join_keys + + private$data_filtered_fun <- function(sid = "") { + checkmate::assert_character(sid) + if (length(sid)) { + logger::log_trace("filtering data dataname: { dataname }, sid: { sid }") + } else { + logger::log_trace("filtering data dataname: { private$dataname }") + } + env <- new.env(parent = parent.env(globalenv())) + env[[dataname]] <- private$dataset + env[[parent_name]] <- parent() + filter_call <- self$get_call(sid) + eval_expr_with_msg(filter_call, env) + get(x = dataname, envir = env) + } + } private$add_filter_states( filter_states = init_filter_states( - data = self$get_dataset(), + data = dataset, + data_reactive = private$data_filtered_fun, dataname = dataname, - varlabels = self$get_varlabels(), keys = self$get_keys() ), id = "filter" ) + + # todo: Should we make these defaults? It could be handled by the app developer + if (!is.null(parent)) { + fs <- teal_slices( + exclude_varnames = structure( + list(intersect(colnames(dataset), colnames(isolate(parent())))), + names = private$dataname + ) + ) + self$set_filter_state(fs) + } + invisible(self) }, @@ -59,99 +110,109 @@ DefaultFilteredDataset <- R6::R6Class( # nolint #' This class contains single `FilterStates` #' which contains single `state_list` and all `FilterState` objects #' applies to one argument (`...`) in `dplyr::filter` call. + #' + #' @param sid (`character`)\cr + #' when specified then method returns code containing filter conditions of + #' `FilterState` objects which `"sid"` attribute is different than this `sid` argument. + #' #' @return filter `call` or `list` of filter calls - get_call = function() { - filter_call <- Filter( - f = Negate(is.null), - x = lapply( - self$get_filter_states(), - function(x) x$get_call() + get_call = function(sid = "") { + logger::log_trace("FilteredDatasetDefault$get_call initializing for dataname: { private$dataname }") + filter_call <- super$get_call(sid) + dataname <- private$dataname + parent_dataname <- private$parent_name + + if (!identical(parent_dataname, character(0))) { + join_keys <- private$join_keys + parent_keys <- names(join_keys) + dataset_keys <- unname(join_keys) + + y_arg <- if (length(parent_keys) == 0L) { + parent_dataname + } else { + sprintf( + "%s[, c(%s), drop = FALSE]", + parent_dataname, + toString(dQuote(parent_keys, q = FALSE)) + ) + } + + more_args <- if (length(parent_keys) == 0 || length(dataset_keys) == 0) { + list() + } else if (identical(parent_keys, dataset_keys)) { + list(by = parent_keys) + } else { + list(by = stats::setNames(parent_keys, dataset_keys)) + } + + merge_call <- call( + "<-", + as.name(dataname), + as.call( + c( + str2lang("dplyr::inner_join"), + x = as.name(dataname), + y = str2lang(y_arg), + more_args + ) + ) ) - ) - if (length(filter_call) == 0) { - return(NULL) + + filter_call <- c(filter_call, merge_call) } + logger::log_trace("FilteredDatasetDefault$get_call initializing for dataname: { private$dataname }") filter_call }, - #' @description - #' Gets the reactive values from the active `FilterState` objects. - #' - #' Get all active filters from this dataset in form of the nested list. - #' The output list is a compatible input to `self$set_filter_state`. - #' @return `list` with named elements corresponding to `FilterState` objects - #' (active filters). - get_filter_state = function() { - self$get_filter_states("filter")$get_filter_state() - }, - #' @description #' Set filter state #' - #' @param state (`named list`)\cr - #' containing values of the initial filter. Values should be relevant - #' to the referred column. - #' @param ... Additional arguments. Note that this is currently not used + #' @param state (`teal_slice`) object + #' #' @examples #' dataset <- teal.slice:::DefaultFilteredDataset$new(iris, "iris") - #' fs <- list( - #' Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE), - #' Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) + #' fs <- teal_slices( + #' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"), + #' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5)) #' ) - #' shiny::isolate(dataset$set_filter_state(state = fs)) + #' dataset$set_filter_state(state = fs) #' shiny::isolate(dataset$get_filter_state()) #' - #' @return `NULL` - set_filter_state = function(state, ...) { - checkmate::assert_list(state) - logger::log_trace( - sprintf( - "DefaultFilteredDataset$set_filter_state setting up filters of variables %s, dataname: %s", - paste(names(state), collapse = ", "), - self$get_dataname() - ) - ) - - data <- self$get_dataset() - fs <- self$get_filter_states()[[1]] - fs$set_filter_state(state = state, data = data, ...) - logger::log_trace( - sprintf( - "DefaultFilteredDataset$set_filter_state done setting up filters of variables %s, dataname: %s", - paste(names(state), collapse = ", "), - self$get_dataname() - ) - ) - NULL + #' @return `NULL` invisibly + #' + set_filter_state = function(state) { + shiny::isolate({ + logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }") + checkmate::assert_class(state, "teal_slices") + lapply(state, function(slice) { + checkmate::assert_true(slice$dataname == private$dataname) + }) + private$get_filter_states()[[1L]]$set_filter_state(state = state) + invisible(NULL) + }) }, - #' @description Remove one or more `FilterState` of a `FilteredDataset` + #' @description + #' Remove one or more `FilterState` form a `FilteredDataset` #' - #' @param state_id (`character`)\cr - #' Vector of character names of variables to remove their `FilterState`. + #' @param state (`teal_slices`)\cr + #' specifying `FilterState` objects to remove; + #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored #' - #' @return `NULL` - remove_filter_state = function(state_id) { - logger::log_trace( - sprintf( - "DefaultFilteredDataset$remove_filter_state removing filters of variable %s, dataname: %s", - state_id, - self$get_dataname() - ) - ) + #' @return `NULL` invisibly + #' + remove_filter_state = function(state) { + shiny::isolate({ + logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }") + checkmate::assert_class(state, "teal_slices") - fdata_filter_state <- self$get_filter_states()[[1]] - for (element in state_id) { - fdata_filter_state$remove_filter_state(element) - } - logger::log_trace( - sprintf( - "DefaultFilteredDataset$remove_filter_state done removing filters of variable %s, dataname: %s", - state_id, - self$get_dataname() - ) - ) - invisible(NULL) + varnames <- slices_field(state, "varname") + private$get_filter_states()[[1]]$remove_filter_state(state) + + logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }") + + invisible(NULL) + }) }, #' @description @@ -162,49 +223,11 @@ DefaultFilteredDataset <- R6::R6Class( # nolint #' identifier of the element - preferably containing dataset name #' #' @return function - shiny UI module - ui_add_filter_state = function(id) { + ui_add = function(id) { ns <- NS(id) tagList( tags$label("Add", tags$code(self$get_dataname()), "filter"), - self$get_filter_states(id = "filter")$ui_add_filter_state( - id = ns("filter"), - data = self$get_dataset() - ) - ) - }, - - #' @description - #' Server module to add filter variable for this dataset - #' - #' Server module to add filter variable for this dataset. - #' For this class `srv_add_filter_state` calls single module - #' `srv_add_filter_state` from `FilterStates` (`DefaultFilteredDataset` - #' contains single `FilterStates`) - #' - #' @param id (`character(1)`)\cr - #' an ID string that corresponds with the ID used to call the module's UI function. - #' @param ... other arguments passed on to child `FilterStates` methods. - #' - #' @return `moduleServer` function which returns `NULL` - srv_add_filter_state = function(id, ...) { - check_ellipsis(..., stop = FALSE, allowed_args = "vars_include") - moduleServer( - id = id, - function(input, output, session) { - logger::log_trace( - "DefaultFilteredDataset$srv_add_filter_state initializing, dataname: { deparse1(self$get_dataname()) }" - ) - data <- self$get_dataset() - self$get_filter_states(id = "filter")$srv_add_filter_state( - id = "filter", - data = data, - ... - ) - logger::log_trace( - "DefaultFilteredDataset$srv_add_filter_state initialized, dataname: { deparse1(self$get_dataname()) }" - ) - NULL - } + private$get_filter_states()[["filter"]]$ui_add(id = ns("filter")) ) }, @@ -212,40 +235,38 @@ DefaultFilteredDataset <- R6::R6Class( # nolint #' Get number of observations based on given keys #' The output shows the comparison between `filtered_dataset` #' function parameter and the dataset inside self - #' @param filtered_dataset comparison object, of the same class - #' as `self$get_dataset()`, if `NULL` then `self$get_dataset()` - #' is used. - #' @param subject_keys (`character` or `NULL`) columns denoting unique subjects when - #' calculating the filtering. #' @return `list` containing character `#filtered/#not_filtered` - get_filter_overview_nsubjs = function(filtered_dataset = self$get_dataset(), subject_keys = NULL) { - checkmate::assert_class(filtered_dataset, classes = class(self$get_dataset())) - checkmate::assert_character(subject_keys, null.ok = TRUE, any.missing = FALSE) - - f_rows <- if (length(subject_keys) == 0) { - dplyr::n_distinct(filtered_dataset) + get_filter_overview = function() { + logger::log_trace("FilteredDataset$srv_filter_overview initialized") + # Gets filter overview subjects number and returns a list + # of the number of subjects of filtered/non-filtered datasets + subject_keys <- if (length(private$parent_name) > 0) { + private$join_keys } else { - dplyr::n_distinct(filtered_dataset[subject_keys]) + self$get_keys() } - nf_rows <- if (length(subject_keys) == 0) { - dplyr::n_distinct(self$get_dataset()) + dataset <- self$get_dataset() + data_filtered <- self$get_dataset(TRUE) + if (length(subject_keys) == 0) { + data.frame( + dataname = private$dataname, + obs = nrow(dataset), + obs_filtered = nrow(data_filtered()) + ) } else { - dplyr::n_distinct(self$get_dataset()[subject_keys]) + data.frame( + dataname = private$dataname, + obs = nrow(dataset), + obs_filtered = nrow(data_filtered()), + subjects = nrow(unique(dataset[subject_keys])), + subjects_filtered = nrow(unique(data_filtered()[subject_keys])) + ) } - - list(paste0(f_rows, "/", nf_rows)) } ), private = list( - # Gets filter overview observations number and returns a - # list of the number of observations of filtered/non-filtered datasets - get_filter_overview_nobs = function(filtered_dataset) { - f_rows <- nrow(filtered_dataset) - nf_rows <- nrow(self$get_dataset()) - list( - paste0(f_rows, "/", nf_rows) - ) - } + parent_name = character(0), + join_keys = character(0) ) ) diff --git a/R/FilteredDatasetMAE.R b/R/FilteredDatasetMAE.R index d56226b75..42512410d 100644 --- a/R/FilteredDatasetMAE.R +++ b/R/FilteredDatasetMAE.R @@ -7,7 +7,6 @@ MAEFilteredDataset <- R6::R6Class( # nolint # public methods ---- public = list( - #' @description #' Initialize `MAEFilteredDataset` object #' @@ -35,8 +34,8 @@ MAEFilteredDataset <- R6::R6Class( # nolint private$add_filter_states( filter_states = init_filter_states( data = dataset, + data_reactive = private$data_filtered_fun, dataname = dataname, - varlabels = self$get_varlabels(), datalabel = "subjects", keys = self$get_keys() ), @@ -48,10 +47,12 @@ MAEFilteredDataset <- R6::R6Class( # nolint lapply( experiment_names, function(experiment_name) { + data_reactive <- function(sid = "") private$data_filtered_fun(sid)[[experiment_name]] private$add_filter_states( filter_states = init_filter_states( data = dataset[[experiment_name]], - dataname = sprintf('%s[["%s"]]', dataname, experiment_name), + data_reactive = data_reactive, + dataname = dataname, datalabel = experiment_name ), id = experiment_name @@ -60,95 +61,6 @@ MAEFilteredDataset <- R6::R6Class( # nolint ) }, - #' @description - #' Get filter expression - #' - #' This functions returns filter calls equivalent to selected items - #' within each of `filter_states`. Configuration of the calls is constant and - #' depends on `filter_states` type and order which are set during initialization. - #' This class contains multiple `FilterStates`: - #' \itemize{ - #' \item{`colData(dataset)`}{for this object single `MAEFilterStates` - #' which returns `subsetByColData` call} - #' \item{experiments}{for each experiment single `SEFilterStates` and - #' `FilterStates_matrix`, both returns `subset` call} - #' } - #' @return filter `call` or `list` of filter calls - get_call = function() { - filter_call <- Filter( - f = Negate(is.null), - x = lapply( - self$get_filter_states(), - function(x) x$get_call() - ) - ) - if (length(filter_call) == 0) { - return(NULL) - } - filter_call - }, - - #' @description - #' Gets labels of variables in the data - #' - #' Variables are the column names of the data. - #' Either, all labels must have been provided for all variables - #' in `set_data` or `NULL`. - #' - #' @param variables (`character` vector) variables to get labels for; - #' if `NULL`, for all variables in data - #' @return (`character` or `NULL`) variable labels, `NULL` if `column_labels` - #' attribute does not exist for the data - get_varlabels = function(variables = NULL) { - checkmate::assert_character(variables, null.ok = TRUE, any.missing = FALSE) - - labels <- vapply( - X = SummarizedExperiment::colData(private$dataset), - FUN.VALUE = character(1), - FUN = function(x) { - label <- attr(x, "label") - if (length(label) != 1) { - NA_character_ - } else { - label - } - } - ) - - if (is.null(labels)) { - return(NULL) - } - if (!is.null(variables)) labels <- labels[names(labels) %in% variables] - labels - }, - - #' @description - #' Get filter overview rows of a dataset - #' @param filtered_dataset (`MultiAssayExperiment`) object to calculate filter overview statistics on. - #' @return (`matrix`) matrix of observations and subjects - get_filter_overview_info = function(filtered_dataset = self$get_dataset()) { - names_exps <- paste0("- ", names(self$get_dataset())) - mae_and_exps <- c(self$get_dataname(), names_exps) - - df <- cbind( - private$get_filter_overview_nobs(filtered_dataset), - self$get_filter_overview_nsubjs(filtered_dataset) - ) - - rownames(df) <- mae_and_exps - colnames(df) <- c("Obs", "Subjects") - - df - }, - - #' @description - #' Gets variable names for the filtering. - #' - #' @return (`character(0)`) - get_filterable_varnames = function() { - character(0) - }, - #' @description #' Set filter state #' @@ -157,86 +69,109 @@ MAEFilteredDataset <- R6::R6Class( # nolint #' kept in `private$filter_states`. For this object they are `"subjects"` and #' names of the experiments. Values of initial state should be relevant #' to the referred column. - #' @param ... ignored. + #' #' @examples #' utils::data(miniACC, package = "MultiAssayExperiment") #' dataset <- teal.slice:::MAEFilteredDataset$new(miniACC, "MAE") - #' fs <- list( - #' subjects = list( - #' years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - #' vital_status = list(selected = "1", keep_na = FALSE), - #' gender = list(selected = "female", keep_na = TRUE) + #' fs <- teal_slices( + #' teal_slice( + #' dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE + #' ), + #' teal_slice( + #' dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE + #' ), + #' teal_slice( + #' dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE #' ), - #' RPPAArray = list( - #' subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) + #' teal_slice( + #' dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE #' ) #' ) - #' shiny::isolate(dataset$set_filter_state(state = fs)) + #' dataset$set_filter_state(state = fs) #' shiny::isolate(dataset$get_filter_state()) - #' @return `NULL` - set_filter_state = function(state, ...) { - checkmate::assert_list(state) - checkmate::assert_subset(names(state), c(names(self$get_filter_states()))) + #' + #' @return `NULL` invisibly + #' + set_filter_state = function(state) { + shiny::isolate({ + logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }") + checkmate::assert_class(state, "teal_slices") + lapply(state, function(x) { + checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname") + }) + + # set state on subjects + subject_state <- Filter(function(x) is.null(x$experiment), state) + private$get_filter_states()[["subjects"]]$set_filter_state(subject_state) + + # set state on experiments + # determine target experiments (defined in teal_slices) + experiments <- slices_field(state, "experiment") + available_experiments <- setdiff(names(private$get_filter_states()), "subjects") + excluded_filters <- setdiff(experiments, available_experiments) + if (length(excluded_filters)) { + stop(sprintf( + "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s", + private$dataname, + toString(excluded_filters), + toString(available_experiments) + )) + } - logger::log_trace( - sprintf( - "MAEFilteredDataset$set_filter_state setting up filters of variable %s, dataname: %s", - paste(names(state), collapse = ", "), - self$get_dataname() - ) - ) - data <- self$get_dataset() - for (fs_name in names(state)) { - fs <- self$get_filter_states()[[fs_name]] - fs$set_filter_state( - state = state[[fs_name]], - data = `if`(fs_name == "subjects", data, data[[fs_name]]) - ) - } + # set states on state_lists with corresponding experiments + lapply(available_experiments, function(experiment) { + slices <- Filter(function(x) identical(x$experiment, experiment), state) + private$get_filter_states()[[experiment]]$set_filter_state(slices) + }) - logger::log_trace( - sprintf( - "MAEFilteredDataset$set_filter_state done setting filters of variable %s, dataname: %s", - paste(names(state), collapse = ", "), - self$get_dataname() - ) - ) - NULL + logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }") + + invisible(NULL) + }) }, - #' @description Remove one or more `FilterState` of a `MAEFilteredDataset` + #' @description + #' Remove one or more `FilterState` of a `MAEFilteredDataset` #' - #' @param state_id (`list`)\cr - #' Named list of variables to remove their `FilterState`. + #' @param state (`teal_slices`)\cr + #' specifying `FilterState` objects to remove; + #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored #' - #' @return `NULL` + #' @return `NULL` invisibly #' - remove_filter_state = function(state_id) { - checkmate::assert_list(state_id, names = "unique") - checkmate::assert_subset(names(state_id), c(names(self$get_filter_states()))) + remove_filter_state = function(state) { + shiny::isolate({ + checkmate::assert_class(state, "teal_slices") + + logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }") + # remove state on subjects + subject_state <- Filter(function(x) is.null(x$experiment), state) + private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state) + + # remove state on experiments + # determine target experiments (defined in teal_slices) + experiments <- slices_field(state, "experiment") + available_experiments <- setdiff(names(private$get_filter_states()), "subjects") + excluded_filters <- setdiff(experiments, available_experiments) + if (length(excluded_filters)) { + stop(sprintf( + "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s", + private$dataname, + toString(excluded_filters), + toString(available_experiments) + )) + } + # remove states on state_lists with corresponding experiments + lapply(experiments, function(experiment) { + slices <- Filter(function(x) identical(x$experiment, experiment), state) + private$get_filter_states()[[experiment]]$remove_filter_state(slices) + }) - logger::log_trace( - sprintf( - "MAEFilteredDataset$remove_filter_state removing filters of variable %s, dataname: %s", - state_id, - self$get_dataname() - ) - ) - for (fs_name in names(state_id)) { - fdata_filter_state <- self$get_filter_states()[[fs_name]] - fdata_filter_state$remove_filter_state( - `if`(fs_name == "subjects", state_id[[fs_name]][[1]], state_id[[fs_name]]) - ) - } - logger::log_trace( - sprintf( - "MAEFilteredDataset$remove_filter_state done removing filters of variable %s, dataname: %s", - state_id, - self$get_dataname() - ) - ) - invisible(NULL) + logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }") + + invisible(NULL) + }) }, #' @description @@ -247,7 +182,8 @@ MAEFilteredDataset <- R6::R6Class( # nolint #' identifier of the element - preferably containing dataset name #' #' @return function - shiny UI module - ui_add_filter_state = function(id) { + #' + ui_add = function(id) { ns <- NS(id) data <- self$get_dataset() experiment_names <- names(data) @@ -257,10 +193,7 @@ MAEFilteredDataset <- R6::R6Class( # nolint br(), HTML("►"), tags$label("Add subjects filter"), - self$get_filter_states("subjects")$ui_add_filter_state( - id = ns("subjects"), - data = data - ), + private$get_filter_states()[["subjects"]]$ui_add(id = ns("subjects")), tagList( lapply( experiment_names, @@ -268,10 +201,7 @@ MAEFilteredDataset <- R6::R6Class( # nolint tagList( HTML("►"), tags$label("Add", tags$code(experiment_name), "filter"), - self$get_filter_states(experiment_name)$ui_add_filter_state( - id = ns(experiment_name), - data = data[[experiment_name]] - ) + private$get_filter_states()[[experiment_name]]$ui_add(id = ns(experiment_name)) ) } ) @@ -280,116 +210,46 @@ MAEFilteredDataset <- R6::R6Class( # nolint }, #' @description - #' Server module to add filter variable for this dataset - #' - #' Server module to add filter variable for this dataset. - #' For this class `srv_add_filter_state` calls multiple modules - #' of the same name from `FilterStates` as `MAEFilteredDataset` - #' contains one `FilterStates` object for `colData` and one for each - #' experiment. - #' - #' @param id (`character(1)`)\cr - #' an ID string that corresponds with the ID used to call the module's UI function. - #' @param ... ignored. - #' @return `moduleServer` function which returns `NULL` - srv_add_filter_state = function(id, ...) { - moduleServer( - id = id, - function(input, output, session) { - logger::log_trace(paste( - "MAEFilteredDataset$srv_add_filter_state initializing,", - "dataname: { deparse1(self$get_dataname()) }" - )) - data <- self$get_dataset() - self$get_filter_states("subjects")$srv_add_filter_state( - id = "subjects", - data = data # MultiAssayExperiment - # ignoring vars_include - ) + #' Get filter overview rows of a dataset + #' @return (`matrix`) matrix of observations and subjects + get_filter_overview = function() { + data <- self$get_dataset() + data_filtered <- self$get_dataset(TRUE) + experiment_names <- names(data) - experiment_names <- names(data) - lapply( - experiment_names, - function(experiment_name) { - self$get_filter_states(experiment_name)$srv_add_filter_state( - id = experiment_name, - data = data[[experiment_name]] # SummarizedExperiment or matrix - # ignoring vars_include - ) - } - ) - logger::log_trace(paste( - "MAEFilteredDataset$srv_add_filter_state initialized,", - "dataname: { deparse1(self$get_dataname()) }" - )) - NULL - } + mae_info <- data.frame( + dataname = private$dataname, + subjects = nrow(SummarizedExperiment::colData(data)), + subjects_filtered = nrow(SummarizedExperiment::colData(data_filtered())) ) - }, - - #' @description - #' Gets filter overview subjects number - #' @param filtered_dataset (`MultiAssayExperiment`) object to calculate filter overview statistics on. - #' @param subject_keys (unused) in `MultiAssayExperiment` unique subjects are the rows of `colData` slot. - #' @return `list` with the number of subjects of filtered/non-filtered datasets. - get_filter_overview_nsubjs = function(filtered_dataset = self$get_dataset(), subject_keys) { - data_f <- filtered_dataset - data_nf <- self$get_dataset() - experiment_names <- names(data_nf) - - data_f_subjects_info <- nrow(SummarizedExperiment::colData(data_f)) - data_nf_subjects_info <- nrow(SummarizedExperiment::colData(data_nf)) - mae_total_subjects_info <- paste0(data_f_subjects_info, "/", data_nf_subjects_info) - - get_experiment_rows <- function(mae, experiment) { - sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment)) - length(unique(sample_subset$primary)) - } - subjects_info <- lapply( + experiment_obs_info <- do.call("rbind", lapply( experiment_names, function(experiment_name) { - subjects_f_rows <- get_experiment_rows(data_f, data_f[[experiment_name]]) - subjects_nf_rows <- get_experiment_rows(data_nf, data_nf[[experiment_name]]) - - subjects_info <- paste0(subjects_f_rows, "/", subjects_nf_rows) - subjects_info + data.frame( + dataname = sprintf("- %s", experiment_name), + obs = nrow(data[[experiment_name]]), + obs_filtered = nrow(data_filtered()[[experiment_name]]) + ) } - ) + )) - append( - list(mae_total_subjects_info), - subjects_info - ) - } - ), - - # private members ---- - private = list( - - # Gets filter overview observations number and returns a - # list of the number of observations of filtered/non-filtered datasets - get_filter_overview_nobs = function(filtered_dataset) { - data_f <- filtered_dataset - data_nf <- self$get_dataset() - experiment_names <- names(data_nf) - mae_total_data_info <- "" + get_experiment_keys <- function(mae, experiment) { + sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment)) + length(unique(sample_subset$primary)) + } - data_info <- lapply( + experiment_subjects_info <- do.call("rbind", lapply( experiment_names, function(experiment_name) { - data_f_rows <- ncol(data_f[[experiment_name]]) - data_nf_rows <- ncol(data_nf[[experiment_name]]) - - data_info <- paste0(data_f_rows, "/", data_nf_rows) - data_info + data.frame( + subjects = get_experiment_keys(data, data[[experiment_name]]), + subjects_filtered = get_experiment_keys(data_filtered(), data_filtered()[[experiment_name]]) + ) } - ) - - append( - list(mae_total_data_info), - data_info - ) + )) + experiment_info <- cbind(experiment_obs_info, experiment_subjects_info) + dplyr::bind_rows(mae_info, experiment_info) } ) ) diff --git a/R/calls_combine_by.R b/R/calls_combine_by.R index 1d5d1ea35..29fe47f6e 100644 --- a/R/calls_combine_by.R +++ b/R/calls_combine_by.R @@ -11,14 +11,13 @@ #' @return call or NULL, if `calls` is an empty list #' #' @examples -#' \dontrun{ #' calls <- list( #' quote(SEX == "F"), # subsetting on factor #' quote(AGE >= 20 & AGE <= 50), # subsetting on range #' quote(!SURV) # subsetting on logical #' ) -#' calls_combine_by(calls, "&") -#' } +#' teal.slice:::calls_combine_by(calls, "&") +#' #' @return a combined `call` #' @keywords internal calls_combine_by <- function(calls, operator) { @@ -26,6 +25,8 @@ calls_combine_by <- function(calls, operator) { if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name")) checkmate::assert_string(operator) + calls <- Filter(x = calls, f = Negate(is.null)) + Reduce( x = calls, f = function(x, y) call(operator, x, y) diff --git a/R/choices_labeled.R b/R/choices_labeled.R index c4b5389ba..4c7da4763 100644 --- a/R/choices_labeled.R +++ b/R/choices_labeled.R @@ -1,7 +1,7 @@ #' Set "`:

Inherited methods - -
-}} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-CDISCFilteredData-datanames}{}}} -\subsection{Method \code{datanames()}}{ -Get datanames - -The datanames are returned in the order in which they must be -evaluated (in case of dependencies). -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{CDISCFilteredData$datanames()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -(\code{character} vector) of datanames -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-CDISCFilteredData-get_call}{}}} -\subsection{Method \code{get_call()}}{ -Produces language required to filter a single dataset and merge it with its parent. -The datasets in question are assumed to be available. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{CDISCFilteredData$get_call(dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)}) name of the dataset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{call} or \code{list} of calls ) to filter dataset -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-CDISCFilteredData-get_filterable_datanames}{}}} -\subsection{Method \code{get_filterable_datanames()}}{ -Get names of datasets available for filtering -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{CDISCFilteredData$get_filterable_datanames(dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character} vector) names of the dataset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character} vector) of dataset names -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-CDISCFilteredData-get_filterable_varnames}{}}} -\subsection{Method \code{get_filterable_varnames()}}{ -Gets variable names of a given dataname for the filtering. This excludes parent dataset variable names. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{CDISCFilteredData$get_filterable_varnames(dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)}) name of the dataset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character} vector) of variable names -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-CDISCFilteredData-get_filter_overview}{}}} -\subsection{Method \code{get_filter_overview()}}{ -Get filter overview table in form of X (filtered) / Y (non-filtered) - -This is intended to be presented in the application. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{CDISCFilteredData$get_filter_overview(datanames)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{datanames}}{(\code{character} vector) names of the dataset (or "all")} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{matrix}) matrix of observations and subjects of all datasets -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-CDISCFilteredData-get_parentname}{}}} -\subsection{Method \code{get_parentname()}}{ -Get parent dataset name -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{CDISCFilteredData$get_parentname(dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)}) name of the dataset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character}) name of parent dataset -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-CDISCFilteredData-set_dataset}{}}} -\subsection{Method \code{set_dataset()}}{ -Add dataset - -Add dataset and preserve all attributes attached to this object. -Technically \code{set_dataset} created \code{FilteredDataset} which keeps -\code{dataset} for filtering purpose. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{CDISCFilteredData$set_dataset(dataset_args, dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataset_args}}{(\code{list})\cr -containing the arguments except (\code{dataname}) -needed by \code{init_filtered_dataset} (can also -include \code{parent} which will be ignored)} - -\item{\code{dataname}}{(\code{character(1)})\cr -the name of the \code{dataset} to be added to this object} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{self}) object of this class -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-CDISCFilteredData-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{CDISCFilteredData$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/ChoicesFilterState.Rd b/man/ChoicesFilterState.Rd index e9b18b2a7..19c1db3c2 100644 --- a/man/ChoicesFilterState.Rd +++ b/man/ChoicesFilterState.Rd @@ -7,38 +7,42 @@ \description{ Manages choosing elements from a set } -\note{ -Casts the passed object to \code{character} before validating the input -making it possible to pass any object coercible to \code{character} to this method. -} \examples{ filter_state <- teal.slice:::ChoicesFilterState$new( - c(LETTERS, NA), - varname = "x", - dataname = "data", - extract_type = character(0) + x = c(LETTERS, NA), + slice = teal_slice(varname = "x", dataname = "data") +) +shiny::isolate(filter_state$get_call()) +filter_state$set_state( + teal_slice( + dataname = "data", + varname = "x", + selected = "A", + keep_na = TRUE + ) ) -isolate(filter_state$get_call()) -isolate(filter_state$set_selected("B")) -isolate(filter_state$set_keep_na(TRUE)) -isolate(filter_state$get_call()) +shiny::isolate(filter_state$get_call()) -\dontrun{ # working filter in an app library(shiny) +library(shinyjs) data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA) -filter_state_choices <- ChoicesFilterState$new( +attr(data_choices, "label") <- "lowercase letters" +fs <- teal.slice:::ChoicesFilterState$new( x = data_choices, - varname = "variable", - varlabel = "label" + slice = teal_slice( + dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE + ) ) -filter_state_choices$set_state(list(selected = c("a", "c"), keep_na = TRUE)) ui <- fluidPage( + useShinyjs(), + teal.slice:::include_css_files(pattern = "filter-panel"), + teal.slice:::include_js_files(pattern = "count-bar-labels"), column(4, div( h4("ChoicesFilterState"), - isolate(filter_state_choices$ui("fs")) + fs$ui("fs") )), column(4, div( h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState @@ -52,43 +56,54 @@ ui <- fluidPage( h4("Programmatic filter control"), actionButton("button1_choices", "set drop NA", width = "100\%"), br(), actionButton("button2_choices", "set keep NA", width = "100\%"), br(), - actionButton("button3_choices", "set a selection", width = "100\%"), br(), + actionButton("button3_choices", "set selection: a, b", width = "100\%"), br(), actionButton("button4_choices", "deselect all", width = "100\%"), br(), actionButton("button0_choices", "set initial state", width = "100\%"), br() )) ) server <- function(input, output, session) { - filter_state_choices$server("fs") - output$condition_choices <- renderPrint(filter_state_choices$get_call()) - output$formatted_choices <- renderText(filter_state_choices$format()) - output$unformatted_choices <- renderPrint(filter_state_choices$get_state()) + fs$server("fs") + output$condition_choices <- renderPrint(fs$get_call()) + output$formatted_choices <- renderText(fs$format()) + output$unformatted_choices <- renderPrint(fs$get_state()) # modify filter state programmatically - observeEvent(input$button1_choices, filter_state_choices$set_keep_na(FALSE)) - observeEvent(input$button2_choices, filter_state_choices$set_keep_na(TRUE)) + observeEvent( + input$button1_choices, + fs$set_state( + teal_slice(dataname = "data", varname = "variable", keep_na = FALSE) + ) + ) + observeEvent( + input$button2_choices, + fs$set_state( + teal_slice(dataname = "data", varname = "variable", keep_na = TRUE) + ) + ) observeEvent( input$button3_choices, - filter_state_choices$set_selected(c("b", "c")) + fs$set_state( + teal_slice(dataname = "data", varname = "variable", selected = c("a", "b")) + ) + ) + observeEvent( + input$button4_choices, + fs$set_state( + teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE) + ) ) - observeEvent(input$button4_choices, filter_state_choices$set_selected(c())) observeEvent( input$button0_choices, - filter_state_choices$set_state(list(selected = c("a", "c"), keep_na = TRUE)) + fs$set_state( + teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE) + ) ) } if (interactive()) { shinyApp(ui, server) } -} - -## ------------------------------------------------ -## Method `ChoicesFilterState$set_selected` -## ------------------------------------------------ - -filter <- teal.slice:::ChoicesFilterState$new(c("a", "b", "c"), varname = "name") -filter$set_selected(c("c", "a")) } \keyword{internal} \section{Super class}{ @@ -98,10 +113,7 @@ filter$set_selected(c("c", "a")) \subsection{Public methods}{ \itemize{ \item \href{#method-ChoicesFilterState-new}{\code{ChoicesFilterState$new()}} -\item \href{#method-ChoicesFilterState-is_any_filtered}{\code{ChoicesFilterState$is_any_filtered()}} \item \href{#method-ChoicesFilterState-get_call}{\code{ChoicesFilterState$get_call()}} -\item \href{#method-ChoicesFilterState-set_state}{\code{ChoicesFilterState$set_state()}} -\item \href{#method-ChoicesFilterState-set_selected}{\code{ChoicesFilterState$set_selected()}} \item \href{#method-ChoicesFilterState-clone}{\code{ChoicesFilterState$clone()}} } } @@ -110,16 +122,10 @@ filter$set_selected(c("c", "a")) @@ -128,13 +134,12 @@ filter$set_selected(c("c", "a")) \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-ChoicesFilterState-new}{}}} \subsection{Method \code{new()}}{ -Initialize a \code{FilterState} object +Initialize a \code{InteractiveFilterState} object \subsection{Usage}{ \if{html}{\out{
}}\preformatted{ChoicesFilterState$new( x, - varname, - varlabel = character(0), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0) )}\if{html}{\out{
}} } @@ -142,43 +147,36 @@ Initialize a \code{FilterState} object \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{x}}{(\code{character} or \code{factor})\cr +\item{\code{x}}{(\code{vector})\cr values of the variable used in filter} -\item{\code{varname}}{(\code{character})\cr -name of the variable} - -\item{\code{varlabel}}{(\code{character(1)})\cr -label of the variable (optional).} +\item{\code{x_reactive}}{(\code{reactive})\cr +returning vector of the same type as \code{x}. Is used to update +counts following the change in values of the filtered dataset. +If it is set to \code{reactive(NULL)} then counts based on filtered +dataset are not shown.} -\item{\code{dataname}}{(\code{character(1)})\cr -optional name of dataset where \code{x} is taken from} +\item{\code{slice}}{(\code{teal_slice})\cr +object created using \code{\link[=teal_slice]{teal_slice()}}. \code{teal_slice} is stored +in the class and \code{set_state} directly manipulates values within \code{teal_slice}. \code{get_state} +returns \code{teal_slice} object which can be reused in other places. Beware, that \code{teal_slice} +is a \code{reactiveValues} which means that changes in particular object are automatically +reflected in all places which refer to the same \code{teal_slice}.} \item{\code{extract_type}}{(\code{character(0)}, \code{character(1)})\cr -whether condition calls should be prefixed by dataname. Possible values: +whether condition calls should be prefixed by \code{dataname}. Possible values: \itemize{ \item{\code{character(0)} (default)}{ \code{varname} in the condition call will not be prefixed} \item{\code{"list"}}{ \code{varname} in the condition call will be returned as \verb{$}} \item{\code{"matrix"}}{ \code{varname} in the condition call will be returned as \verb{[, ]}} }} + +\item{\code{...}}{additional arguments to be saved as a list in \code{private$extras} field} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-ChoicesFilterState-is_any_filtered}{}}} -\subsection{Method \code{is_any_filtered()}}{ -Answers the question of whether the current settings and values selected actually filters out any values. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ChoicesFilterState$is_any_filtered()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -logical scalar -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-ChoicesFilterState-get_call}{}}} \subsection{Method \code{get_call()}}{ @@ -187,64 +185,19 @@ For this class returned call looks like \verb{ \%in\% c()} with optional \verb{is.na()}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ChoicesFilterState$get_call()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -(\code{call}) -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-ChoicesFilterState-set_state}{}}} -\subsection{Method \code{set_state()}}{ -Set state -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ChoicesFilterState$set_state(state)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{state}}{(\code{list})\cr -contains fields relevant for a specific class -\itemize{ -\item{\code{selected}}{ defines initial selection} -\item{\code{keep_na} (\code{logical})}{ defines whether to keep or remove \code{NA} values} -}} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-ChoicesFilterState-set_selected}{}}} -\subsection{Method \code{set_selected()}}{ -Sets the selected values of this \code{ChoicesFilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{ChoicesFilterState$set_selected(value)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{ChoicesFilterState$get_call(dataname)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{value}}{(\code{character}) the array of the selected choices. -Must not contain NA values.} +\item{\code{dataname}}{name of data set; defaults to \code{private$get_dataname()}} } \if{html}{\out{
}} } \subsection{Returns}{ -invisibly \code{NULL} -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{filter <- teal.slice:::ChoicesFilterState$new(c("a", "b", "c"), varname = "name") -filter$set_selected(c("c", "a")) -} -\if{html}{\out{
}} - +(\code{call}) or \code{NULL} } - } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/DFFilterStates.Rd b/man/DFFilterStates.Rd index ba3a3e655..9ae804d5c 100644 --- a/man/DFFilterStates.Rd +++ b/man/DFFilterStates.Rd @@ -7,10 +7,10 @@ Handles filter states in a \code{data.frame} } \examples{ -\dontrun{ # working filters in an app library(shiny) +library(shinyjs) # create data frame to filter data_df <- data.frame( @@ -32,22 +32,24 @@ data_na <- data.frame( data_df <- rbind(data_df, data_na) -# initiate FilterStates object +# initiate `FilterStates` object filter_states_df <- init_filter_states( data = data_df, dataname = "dataset", - datalabel = ("label"), - varlabels = c("long", "short", "long", "short", "long", "long") + datalabel = ("label") ) ui <- fluidPage( + useShinyjs(), + teal.slice:::include_css_files(pattern = "filter-panel"), + teal.slice:::include_js_files(pattern = "count-bar-labels"), column(4, div( h4("Active filters"), - filter_states_df$ui("fsdf") + filter_states_df$ui_active("fsdf") )), column(4, div( h4("Manual filter control"), - filter_states_df$ui_add_filter_state("add_filters", data_df), br(), + filter_states_df$ui_add("add_filters"), br(), h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterStates textOutput("call_df"), br(), h4("Formatted state"), # display human readable filter state @@ -74,67 +76,51 @@ ui <- fluidPage( ) server <- function(input, output, session) { - filter_states_df$srv_add_filter_state("add_filters", data_df) - filter_states_df$server("fsdf") + filter_states_df$srv_add("add_filters") + filter_states_df$srv_active("fsdf") output$call_df <- renderPrint(filter_states_df$get_call()) output$formatted_df <- renderText(filter_states_df$format()) observeEvent(input$button1_df, { - filter_state <- list(NUM1 = list(selected = c(0, 30))) - filter_states_df$set_filter_state(data = data_df, state = filter_state) + filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30))) + filter_states_df$set_filter_state(state = filter_state) }) observeEvent(input$button2_df, { - filter_state <- list(NUM2 = list(selected = c(20, 21))) - filter_states_df$set_filter_state(data = data_df, state = filter_state) + filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21))) + filter_states_df$set_filter_state(state = filter_state) }) observeEvent(input$button3_df, { - filter_state <- list(CHAR1 = list(selected = c("B", "C", "D"))) - filter_states_df$set_filter_state(data = data_df, state = filter_state) + filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D"))) + filter_states_df$set_filter_state(state = filter_state) }) observeEvent(input$button4_df, { - filter_state <- list(CHAR2 = list(selected = "F")) - filter_states_df$set_filter_state(data = data_df, state = filter_state) + filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F"))) + filter_states_df$set_filter_state(state = filter_state) }) observeEvent(input$button5_df, { - filter_state <- list(DATE = list(selected = c("2020-01-01", "2020-02-02"))) - filter_states_df$set_filter_state(data = data_df, state = filter_state) + filter_state <- teal_slices( + teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02")) + ) + filter_states_df$set_filter_state(state = filter_state) }) observeEvent(input$button6_df, { - filter_state <- list(DATETIME = list(selected = as.POSIXct(c("2020-01-01", "2020-02-02")))) - filter_states_df$set_filter_state(data = data_df, state = filter_state) + filter_state <- teal_slices( + teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02"))) + ) + filter_states_df$set_filter_state(state = filter_state) }) - observeEvent(input$button7_df, filter_states_df$state_list_remove(1, state_id = "NUM1")) - observeEvent(input$button8_df, filter_states_df$state_list_remove(1, state_id = "NUM2")) - observeEvent(input$button9_df, filter_states_df$state_list_remove(1, state_id = "CHAR1")) - observeEvent(input$button10_df, filter_states_df$state_list_remove(1, state_id = "CHAR2")) - observeEvent(input$button11_df, filter_states_df$state_list_remove(1, state_id = "DATE")) - observeEvent(input$button12_df, filter_states_df$state_list_remove(1, state_id = "DATETIME")) - observeEvent(input$button0_df, filter_states_df$state_list_empty()) + observeEvent(input$button7_df, filter_states_df$remove_filter_state(state_id = "NUM1")) + observeEvent(input$button8_df, filter_states_df$remove_filter_state(state_id = "NUM2")) + observeEvent(input$button9_df, filter_states_df$remove_filter_state(state_id = "CHAR1")) + observeEvent(input$button10_df, filter_states_df$remove_filter_state(state_id = "CHAR2")) + observeEvent(input$button11_df, filter_states_df$remove_filter_state(state_id = "DATE")) + observeEvent(input$button12_df, filter_states_df$remove_filter_state(state_id = "DATETIME")) + observeEvent(input$button0_df, filter_states_df$clear_filter_states()) } - if (interactive()) { shinyApp(ui, server) } -} - - -## ------------------------------------------------ -## Method `DFFilterStates$set_filter_state` -## ------------------------------------------------ - -dffs <- teal.slice:::DFFilterStates$new( - dataname = "iris", - datalabel = character(0), - varlabels = character(0), - keys = character(0) -) -fs <- list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) -) -shiny::isolate(dffs$set_filter_state(state = fs, data = iris)) -shiny::isolate(dffs$get_filter_state()) } \keyword{internal} @@ -145,29 +131,23 @@ shiny::isolate(dffs$get_filter_state()) \subsection{Public methods}{ \itemize{ \item \href{#method-DFFilterStates-new}{\code{DFFilterStates$new()}} -\item \href{#method-DFFilterStates-format}{\code{DFFilterStates$format()}} -\item \href{#method-DFFilterStates-get_fun}{\code{DFFilterStates$get_fun()}} -\item \href{#method-DFFilterStates-server}{\code{DFFilterStates$server()}} -\item \href{#method-DFFilterStates-get_filter_state}{\code{DFFilterStates$get_filter_state()}} -\item \href{#method-DFFilterStates-set_filter_state}{\code{DFFilterStates$set_filter_state()}} -\item \href{#method-DFFilterStates-remove_filter_state}{\code{DFFilterStates$remove_filter_state()}} -\item \href{#method-DFFilterStates-ui_add_filter_state}{\code{DFFilterStates$ui_add_filter_state()}} -\item \href{#method-DFFilterStates-srv_add_filter_state}{\code{DFFilterStates$srv_add_filter_state()}} \item \href{#method-DFFilterStates-clone}{\code{DFFilterStates$clone()}} } } \if{html}{\out{
Inherited methods
}} @@ -183,237 +163,39 @@ This class contains a single \code{state_list} with no specified name, which means that when calling the subset function associated with this class (\code{dplyr::filter}), a list of conditions is passed to unnamed arguments (\code{...}). \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$new(dataname, datalabel, varlabels, keys)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)})\cr -name of the data used in the \emph{subset expression} -specified to the function argument attached to this \code{FilterStates}} - -\item{\code{datalabel}}{(\code{character(0)} or \code{character(1)})\cr -text label value} - -\item{\code{varlabels}}{(\code{character})\cr -labels of the variables used in this object} - -\item{\code{keys}}{(\code{character})\cr -key columns names} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DFFilterStates-format}{}}} -\subsection{Method \code{format()}}{ -Returns a formatted string representing this \code{FilterStates} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$format(indent = 0)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{indent}}{(\code{numeric(1)}) the number of spaces prepended to each line of the output} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{character(1)} the formatted string -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DFFilterStates-get_fun}{}}} -\subsection{Method \code{get_fun()}}{ -Gets the name of the function used to filter the data in this \code{FilterStates}. - -Get name of function used to create the \emph{subset expression}. -For \code{DFFilterStates} this is \code{dplyr::filter}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$get_fun()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character(1)} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DFFilterStates-server}{}}} -\subsection{Method \code{server()}}{ -Shiny server module. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$server(id)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -shiny module instance id} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DFFilterStates-get_filter_state}{}}} -\subsection{Method \code{get_filter_state()}}{ -Gets the reactive values from the active \code{FilterState} objects. - -Get active filter state from the \code{FilterState} objects kept in \code{state_list}. -The output list is a compatible input to \code{self$set_filter_state}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$get_filter_state()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{list} with named elements corresponding to \code{FilterState} in the \code{state_list}. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DFFilterStates-set_filter_state}{}}} -\subsection{Method \code{set_filter_state()}}{ -Set filter state. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$set_filter_state( +\if{html}{\out{
}}\preformatted{DFFilterStates$new( data, - state, - vars_include = get_supported_filter_varnames(data = data), - ... -)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{data}}{(\code{data.frame})\cr -data object for which to define a subset} - -\item{\code{state}}{(\verb{named list})\cr -should contain values of initial selections in the \code{FilterState}; -\code{list} names must correspond to column names in \code{data}} - -\item{\code{vars_include}}{(\code{character(n)})\cr -optional, vector of column names to be included} - -\item{\code{...}}{ignored} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{NULL} -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{dffs <- teal.slice:::DFFilterStates$new( - dataname = "iris", - datalabel = character(0), - varlabels = character(0), + data_reactive = function(sid = "") NULL, + dataname, + datalabel = NULL, keys = character(0) -) -fs <- list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) -) -shiny::isolate(dffs$set_filter_state(state = fs, data = iris)) -shiny::isolate(dffs$get_filter_state()) - -} -\if{html}{\out{
}} - -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DFFilterStates-remove_filter_state}{}}} -\subsection{Method \code{remove_filter_state()}}{ -Remove a \code{FilterState} from the \code{state_list}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$remove_filter_state(state_id)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{state_id}}{(\code{character(1)})\cr name of \code{state_list} element} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DFFilterStates-ui_add_filter_state}{}}} -\subsection{Method \code{ui_add_filter_state()}}{ -Shiny UI module to add filter variable. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$ui_add_filter_state(id, data)}\if{html}{\out{
}} +)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{id}}{(\code{character(1)})\cr -shiny element (module instance) id} - \item{\code{data}}{(\code{data.frame})\cr -data object for which to define a subset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{shiny.tag} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DFFilterStates-srv_add_filter_state}{}}} -\subsection{Method \code{srv_add_filter_state()}}{ -Shiny server module to add filter variable. +the R object which \code{dplyr::filter} function is applied on.} -This module controls available choices to select as a filter variable. -Once selected, a variable is removed from available choices. -Removing a filter variable adds it back to available choices. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DFFilterStates$srv_add_filter_state( - id, - data, - vars_include = get_supported_filter_varnames(data = data), - ... -)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -shiny module instance id} +\item{\code{data_reactive}}{(\verb{function(sid)})\cr +should return a \code{data.frame} object or \code{NULL}. +This object is needed for the \code{FilterState} counts being updated +on a change in filters. If function returns \code{NULL} then filtered counts are not shown. +Function has to have \code{sid} argument being a character.} -\item{\code{data}}{(\code{data.frame})\cr -data object for which to define a subset} +\item{\code{dataname}}{(\code{character})\cr +name of the data used in the \emph{subset expression} +specified to the function argument attached to this \code{FilterStates}} -\item{\code{vars_include}}{(\code{character(n)})\cr -optional, vector of column names to be included} +\item{\code{datalabel}}{(\code{NULL} or \code{character(1)})\cr +text label value} -\item{\code{...}}{ignored} +\item{\code{keys}}{(\code{character})\cr +key columns names} } \if{html}{\out{
}} } -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} -} } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/DateFilterState.Rd b/man/DateFilterState.Rd index 6d14f6bd8..f0f727130 100644 --- a/man/DateFilterState.Rd +++ b/man/DateFilterState.Rd @@ -7,40 +7,43 @@ \description{ Manages choosing a range of Dates } -\note{ -Casts the passed object to \code{Date} before validating the input -making it possible to pass any object coercible to \code{Date} to this method. -} \examples{ filter_state <- teal.slice:::DateFilterState$new( - c(Sys.Date() + seq(1:10), NA), - varname = "x", - dataname = "data", + x = c(Sys.Date() + seq(1:10), NA), + slice = teal_slice(varname = "x", dataname = "data"), extract_type = character(0) ) -isolate(filter_state$get_call()) - -isolate(filter_state$set_selected(c(Sys.Date() + 3L, Sys.Date() + 8L))) -isolate(filter_state$set_keep_na(TRUE)) -isolate(filter_state$get_call()) +shiny::isolate(filter_state$get_call()) +filter_state$set_state( + teal_slice( + dataname = "data", + varname = "x", + selected = c(Sys.Date() + 3L, Sys.Date() + 8L), + keep_na = TRUE + ) +) +shiny::isolate(filter_state$get_call()) -\dontrun{ # working filter in an app library(shiny) +library(shinyjs) dates <- c(Sys.Date() - 100, Sys.Date()) data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA) -filter_state_date <- DateFilterState$new( +fs <- teal.slice:::DateFilterState$new( x = data_date, - varname = "variable", - varlabel = "label" + slice = teal_slice( + dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE + ) ) -filter_state_date$set_state(list(selected = data_date[c(47, 98)], keep_na = TRUE)) ui <- fluidPage( + useShinyjs(), + teal.slice:::include_css_files(pattern = "filter-panel"), + teal.slice:::include_js_files(pattern = "count-bar-labels"), column(4, div( h4("DateFilterState"), - isolate(filter_state_date$ui("fs")) + fs$ui("fs") )), column(4, div( id = "outputs", # div id is needed for toggling the element @@ -62,40 +65,39 @@ ui <- fluidPage( ) server <- function(input, output, session) { - filter_state_date$server("fs") - output$condition_date <- renderPrint(filter_state_date$get_call()) - output$formatted_date <- renderText(filter_state_date$format()) - output$unformatted_date <- renderPrint(filter_state_date$get_state()) + fs$server("fs") + output$condition_date <- renderPrint(fs$get_call()) + output$formatted_date <- renderText(fs$format()) + output$unformatted_date <- renderPrint(fs$get_state()) # modify filter state programmatically - observeEvent(input$button1_date, filter_state_date$set_keep_na(FALSE)) - observeEvent(input$button2_date, filter_state_date$set_keep_na(TRUE)) + observeEvent( + input$button1_date, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) + ) + observeEvent( + input$button2_date, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) + ) observeEvent( input$button3_date, - filter_state_date$set_selected(data_date[c(34, 56)]) + fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)])) + ) + observeEvent( + input$button4_date, + fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates)) ) - observeEvent(input$button4_date, filter_state_date$set_selected(dates)) observeEvent( input$button0_date, - filter_state_date$set_state(list(selected = data_date[c(47, 98)], keep_na = TRUE)) + fs$set_state( + teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE) + ) ) } if (interactive()) { shinyApp(ui, server) } -} - -## ------------------------------------------------ -## Method `DateFilterState$set_selected` -## ------------------------------------------------ - -date <- as.Date("13/09/2021") -filter <- teal.slice:::DateFilterState$new( - c(date, date + 1, date + 2, date + 3), - varname = "name" -) -filter$set_selected(c(date + 1, date + 2)) } \keyword{internal} \section{Super class}{ @@ -105,10 +107,7 @@ filter$set_selected(c(date + 1, date + 2)) \subsection{Public methods}{ \itemize{ \item \href{#method-DateFilterState-new}{\code{DateFilterState$new()}} -\item \href{#method-DateFilterState-format}{\code{DateFilterState$format()}} -\item \href{#method-DateFilterState-is_any_filtered}{\code{DateFilterState$is_any_filtered()}} \item \href{#method-DateFilterState-get_call}{\code{DateFilterState$get_call()}} -\item \href{#method-DateFilterState-set_selected}{\code{DateFilterState$set_selected()}} \item \href{#method-DateFilterState-clone}{\code{DateFilterState$clone()}} } } @@ -116,16 +115,10 @@ filter$set_selected(c(date + 1, date + 2))
Inherited methods @@ -139,9 +132,8 @@ Initialize a \code{FilterState} object \subsection{Usage}{ \if{html}{\out{
}}\preformatted{DateFilterState$new( x, - varname, - varlabel = character(0), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0) )}\if{html}{\out{
}} } @@ -152,59 +144,31 @@ Initialize a \code{FilterState} object \item{\code{x}}{(\code{Date})\cr values of the variable used in filter} -\item{\code{varname}}{(\code{character}, \code{name})\cr -name of the variable} - -\item{\code{varlabel}}{(\code{character(1)})\cr -label of the variable (optional).} +\item{\code{x_reactive}}{(\code{reactive})\cr +returning vector of the same type as \code{x}. Is used to update +counts following the change in values of the filtered dataset. +If it is set to \code{reactive(NULL)} then counts based on filtered +dataset are not shown.} -\item{\code{dataname}}{(\code{character(1)})\cr -optional name of dataset where \code{x} is taken from} +\item{\code{slice}}{(\code{teal_slice})\cr +object created using \code{\link[=teal_slice]{teal_slice()}}. \code{teal_slice} is stored +in the class and \code{set_state} directly manipulates values within \code{teal_slice}. \code{get_state} +returns \code{teal_slice} object which can be reused in other places. Beware, that \code{teal_slice} +is a \code{reactiveValues} which means that changes in particular object are automatically +reflected in all places which refer to the same \code{teal_slice}.} \item{\code{extract_type}}{(\code{character(0)}, \code{character(1)})\cr -whether condition calls should be prefixed by dataname. Possible values: +whether condition calls should be prefixed by \code{dataname}. Possible values: \itemize{ \item{\code{character(0)} (default)}{ \code{varname} in the condition call will not be prefixed} \item{\code{"list"}}{ \code{varname} in the condition call will be returned as \verb{$}} \item{\code{"matrix"}}{ \code{varname} in the condition call will be returned as \verb{[, ]}} }} -} -\if{html}{\out{}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DateFilterState-format}{}}} -\subsection{Method \code{format()}}{ -Returns a formatted string representing this \code{DateFilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DateFilterState$format(indent = 0)}\if{html}{\out{
}} -} -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{indent}}{(\code{numeric(1)}) the number of spaces before after each new line character of the formatted string. -Default: 0} +\item{\code{...}}{additional arguments to be saved as a list in \code{private$extras} field} } \if{html}{\out{
}} } -\subsection{Returns}{ -\code{character(1)} the formatted string -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DateFilterState-is_any_filtered}{}}} -\subsection{Method \code{is_any_filtered()}}{ -Answers the question of whether the current settings and values selected actually filters out any values. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DateFilterState$is_any_filtered()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -logical scalar -} } \if{html}{\out{
}} \if{html}{\out{}} @@ -215,46 +179,19 @@ For this class returned call looks like \verb{ >= & <= } with optional \verb{is.na()}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DateFilterState$get_call()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -(\code{call}) -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DateFilterState-set_selected}{}}} -\subsection{Method \code{set_selected()}}{ -Sets the selected time frame of this \code{DateFilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DateFilterState$set_selected(value)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{DateFilterState$get_call(dataname)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{value}}{(\code{Date(2)}) the lower and the upper bound of the selected -time frame. Must not contain NA values.} +\item{\code{dataname}}{\code{character(1)} containing possibly prefixed name of data set} } \if{html}{\out{
}} } \subsection{Returns}{ -invisibly \code{NULL}. -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{date <- as.Date("13/09/2021") -filter <- teal.slice:::DateFilterState$new( - c(date, date + 1, date + 2, date + 3), - varname = "name" -) -filter$set_selected(c(date + 1, date + 2)) -} -\if{html}{\out{
}} - +(\code{call}) } - } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/DatetimeFilterState.Rd b/man/DatetimeFilterState.Rd index a1ac95213..a178dc048 100644 --- a/man/DatetimeFilterState.Rd +++ b/man/DatetimeFilterState.Rd @@ -7,40 +7,43 @@ \description{ Manages choosing a range of date-times } -\note{ -Casts the passed object to \code{POSIXct} before validating the input -making it possible to pass any object coercible to \code{POSIXct} to this method. -} \examples{ filter_state <- teal.slice:::DatetimeFilterState$new( - c(Sys.time() + seq(0, by = 3600, length.out = 10), NA), - varname = "x", - dataname = "data", + x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA), + slice = teal_slice(varname = "x", dataname = "data"), extract_type = character(0) ) +shiny::isolate(filter_state$get_call()) +filter_state$set_state( + teal_slice( + dataname = "data", + varname = "x", + selected = c(Sys.time() + 3L, Sys.time() + 8L), + keep_na = TRUE + ) +) +shiny::isolate(filter_state$get_call()) -isolate(filter_state$get_call()) -isolate(filter_state$set_selected(c(Sys.time() + 3L, Sys.time() + 8L))) -isolate(filter_state$set_keep_na(TRUE)) -isolate(filter_state$get_call()) - -\dontrun{ # working filter in an app library(shiny) +library(shinyjs) datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00")) data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA) -filter_state_datetime <- DatetimeFilterState$new( +fs <- teal.slice:::DatetimeFilterState$new( x = data_datetime, - varname = "variable", - varlabel = "label" + slice = teal_slice( + varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE + ) ) -filter_state_datetime$set_state(list(selected = data_datetime[c(47, 98)], keep_na = TRUE)) ui <- fluidPage( + useShinyjs(), + teal.slice:::include_css_files(pattern = "filter-panel"), + teal.slice:::include_js_files(pattern = "count-bar-labels"), column(4, div( h4("DatetimeFilterState"), - isolate(filter_state_datetime$ui("fs")) + fs$ui("fs") )), column(4, div( id = "outputs", # div id is needed for toggling the element @@ -62,40 +65,45 @@ ui <- fluidPage( ) server <- function(input, output, session) { - filter_state_datetime$server("fs") - output$condition_datetime <- renderPrint(filter_state_datetime$get_call()) - output$formatted_datetime <- renderText(filter_state_datetime$format()) - output$unformatted_datetime <- renderPrint(filter_state_datetime$get_state()) + fs$server("fs") + output$condition_datetime <- renderPrint(fs$get_call()) + output$formatted_datetime <- renderText(fs$format()) + output$unformatted_datetime <- renderPrint(fs$get_state()) # modify filter state programmatically - observeEvent(input$button1_datetime, filter_state_datetime$set_keep_na(FALSE)) - observeEvent(input$button2_datetime, filter_state_datetime$set_keep_na(TRUE)) + observeEvent( + input$button1_datetime, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) + ) + observeEvent( + input$button2_datetime, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) + ) observeEvent( input$button3_datetime, - filter_state_datetime$set_selected(data_datetime[c(34, 56)]) + fs$set_state( + teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)]) + ) + ) + observeEvent( + input$button4_datetime, + fs$set_state( + teal_slice(dataname = "data", varname = "x", selected = datetimes) + ) ) - observeEvent(input$button4_datetime, filter_state_datetime$set_selected(datetimes)) observeEvent( input$button0_datetime, - filter_state_datetime$set_state(list(selected = data_datetime[c(47, 98)], keep_na = TRUE)) + fs$set_state( + teal_slice( + dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE + ) + ) ) } if (interactive()) { shinyApp(ui, server) } -} - -## ------------------------------------------------ -## Method `DatetimeFilterState$set_selected` -## ------------------------------------------------ - -date <- as.POSIXct(1, origin = "01/01/1970") -filter <- teal.slice:::DatetimeFilterState$new( - c(date, date + 1, date + 2, date + 3), - varname = "name" -) -filter$set_selected(c(date + 1, date + 2)) } \keyword{internal} \section{Super class}{ @@ -105,10 +113,7 @@ filter$set_selected(c(date + 1, date + 2)) \subsection{Public methods}{ \itemize{ \item \href{#method-DatetimeFilterState-new}{\code{DatetimeFilterState$new()}} -\item \href{#method-DatetimeFilterState-format}{\code{DatetimeFilterState$format()}} -\item \href{#method-DatetimeFilterState-is_any_filtered}{\code{DatetimeFilterState$is_any_filtered()}} \item \href{#method-DatetimeFilterState-get_call}{\code{DatetimeFilterState$get_call()}} -\item \href{#method-DatetimeFilterState-set_selected}{\code{DatetimeFilterState$set_selected()}} \item \href{#method-DatetimeFilterState-clone}{\code{DatetimeFilterState$clone()}} } } @@ -116,16 +121,10 @@ filter$set_selected(c(date + 1, date + 2))
Inherited methods @@ -143,10 +142,9 @@ and is set only if object is initialized in \code{shiny}. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{DatetimeFilterState$new( x, - varname, - varlabel = character(0), - dataname = NULL, - extract_type = character(0) + x_reactive = reactive(NULL), + extract_type = character(0), + slice )}\if{html}{\out{
}} } @@ -156,59 +154,31 @@ and is set only if object is initialized in \code{shiny}. \item{\code{x}}{(\code{POSIXct} or \code{POSIXlt})\cr values of the variable used in filter} -\item{\code{varname}}{(\code{character}, \code{name})\cr -name of the variable} - -\item{\code{varlabel}}{(\code{character(1)})\cr -label of the variable (optional).} - -\item{\code{dataname}}{(\code{character(1)})\cr -optional name of dataset where \code{x} is taken from} +\item{\code{x_reactive}}{(\code{reactive})\cr +returning vector of the same type as \code{x}. Is used to update +counts following the change in values of the filtered dataset. +If it is set to \code{reactive(NULL)} then counts based on filtered +dataset are not shown.} \item{\code{extract_type}}{(\code{character(0)}, \code{character(1)})\cr -whether condition calls should be prefixed by dataname. Possible values: +whether condition calls should be prefixed by \code{dataname}. Possible values: \itemize{ \item{\code{character(0)} (default)}{ \code{varname} in the condition call will not be prefixed} \item{\code{"list"}}{ \code{varname} in the condition call will be returned as \verb{$}} \item{\code{"matrix"}}{ \code{varname} in the condition call will be returned as \verb{[, ]}} }} -} -\if{html}{\out{}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DatetimeFilterState-format}{}}} -\subsection{Method \code{format()}}{ -Returns a formatted string representing this \code{DatetimeFilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DatetimeFilterState$format(indent = 0)}\if{html}{\out{
}} -} -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{indent}}{(\code{numeric(1)}) the number of spaces before after each new line character of the formatted string. -Default: 0} +\item{\code{slice}}{(\code{teal_slice})\cr +object created using \code{\link[=teal_slice]{teal_slice()}}. \code{teal_slice} is stored +in the class and \code{set_state} directly manipulates values within \code{teal_slice}. \code{get_state} +returns \code{teal_slice} object which can be reused in other places. Beware, that \code{teal_slice} +is a \code{reactiveValues} which means that changes in particular object are automatically +reflected in all places which refer to the same \code{teal_slice}.} + +\item{\code{...}}{additional arguments to be saved as a list in \code{private$extras} field} } \if{html}{\out{
}} } -\subsection{Returns}{ -\code{character(1)} the formatted string -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DatetimeFilterState-is_any_filtered}{}}} -\subsection{Method \code{is_any_filtered()}}{ -Answers the question of whether the current settings and values selected actually filters out any values. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DatetimeFilterState$is_any_filtered()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -logical scalar -} } \if{html}{\out{
}} \if{html}{\out{}} @@ -219,43 +189,19 @@ For this class returned call looks like \verb{ >= as.POSIXct() & <= )} with optional \verb{is.na()}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DatetimeFilterState$get_call()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DatetimeFilterState-set_selected}{}}} -\subsection{Method \code{set_selected()}}{ -Sets the selected time frame of this \code{DatetimeFilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DatetimeFilterState$set_selected(value)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{DatetimeFilterState$get_call(dataname)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{value}}{(\code{POSIX(2)}) the lower and the upper bound of the selected -time frame. Must not contain NA values.} +\item{\code{dataname}}{name of data set; defaults to \code{private$get_dataname()}} } \if{html}{\out{
}} } \subsection{Returns}{ -invisibly \code{NULL}. +(\code{call}) } -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{date <- as.POSIXct(1, origin = "01/01/1970") -filter <- teal.slice:::DatetimeFilterState$new( - c(date, date + 1, date + 2, date + 3), - varname = "name" -) -filter$set_selected(c(date + 1, date + 2)) -} -\if{html}{\out{
}} - -} - } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/DefaultFilteredDataset.Rd b/man/DefaultFilteredDataset.Rd index 85eee1d63..672bfcd85 100644 --- a/man/DefaultFilteredDataset.Rd +++ b/man/DefaultFilteredDataset.Rd @@ -11,12 +11,10 @@ The \code{DefaultFilteredDataset} R6 class \examples{ library(shiny) ds <- teal.slice:::DefaultFilteredDataset$new(iris, "iris") -isolate( - ds$set_filter_state( - state = list( - Species = list(selected = "virginica"), - Petal.Length = list(selected = c(2.0, 5)) - ) +ds$set_filter_state( + teal_slices( + teal_slice(dataname = "iris", varname = "Species", selected = "virginica"), + teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5)) ) ) isolate(ds$get_filter_state()) @@ -27,11 +25,11 @@ isolate(ds$get_call()) ## ------------------------------------------------ dataset <- teal.slice:::DefaultFilteredDataset$new(iris, "iris") -fs <- list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) +fs <- teal_slices( + teal_slice(dataname = "iris", varname = "Species", selected = "virginica"), + teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5)) ) -shiny::isolate(dataset$set_filter_state(state = fs)) +dataset$set_filter_state(state = fs) shiny::isolate(dataset$get_filter_state()) } @@ -44,34 +42,29 @@ shiny::isolate(dataset$get_filter_state()) \itemize{ \item \href{#method-DefaultFilteredDataset-new}{\code{DefaultFilteredDataset$new()}} \item \href{#method-DefaultFilteredDataset-get_call}{\code{DefaultFilteredDataset$get_call()}} -\item \href{#method-DefaultFilteredDataset-get_filter_state}{\code{DefaultFilteredDataset$get_filter_state()}} \item \href{#method-DefaultFilteredDataset-set_filter_state}{\code{DefaultFilteredDataset$set_filter_state()}} \item \href{#method-DefaultFilteredDataset-remove_filter_state}{\code{DefaultFilteredDataset$remove_filter_state()}} -\item \href{#method-DefaultFilteredDataset-ui_add_filter_state}{\code{DefaultFilteredDataset$ui_add_filter_state()}} -\item \href{#method-DefaultFilteredDataset-srv_add_filter_state}{\code{DefaultFilteredDataset$srv_add_filter_state()}} -\item \href{#method-DefaultFilteredDataset-get_filter_overview_nsubjs}{\code{DefaultFilteredDataset$get_filter_overview_nsubjs()}} +\item \href{#method-DefaultFilteredDataset-ui_add}{\code{DefaultFilteredDataset$ui_add()}} +\item \href{#method-DefaultFilteredDataset-get_filter_overview}{\code{DefaultFilteredDataset$get_filter_overview()}} \item \href{#method-DefaultFilteredDataset-clone}{\code{DefaultFilteredDataset$clone()}} } } \if{html}{\out{
Inherited methods
}} @@ -85,6 +78,9 @@ Initializes this \code{DefaultFilteredDataset} object dataset, dataname, keys = character(0), + parent_name = character(0), + parent = NULL, + join_keys = character(0), label = character(0), metadata = NULL )}\if{html}{\out{}} @@ -102,6 +98,19 @@ A given name for the dataset it may not contain spaces} \item{\code{keys}}{optional, (\code{character})\cr Vector with primary keys} +\item{\code{parent_name}}{(\code{character(1)})\cr +Name of the parent dataset} + +\item{\code{parent}}{(\code{reactive})\cr +object returned by this reactive is a filtered \code{data.frame} from other \code{FilteredDataset} +named \code{parent_name}. Consequence of passing \code{parent} is a \code{reactive} link which causes +causing re-filtering of this \code{dataset} based on the changes in \code{parent}.} + +\item{\code{join_keys}}{(\code{character})\cr +Name of the columns in this dataset to join with \code{parent} +dataset. If the column names are different if both datasets +then the names of the vector define the \code{parent} columns.} + \item{\code{label}}{(\code{character})\cr Label to describe the dataset} @@ -125,28 +134,20 @@ This class contains single \code{FilterStates} which contains single \code{state_list} and all \code{FilterState} objects applies to one argument (\code{...}) in \code{dplyr::filter} call. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$get_call()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$get_call(sid = "")}\if{html}{\out{
}} } -\subsection{Returns}{ -filter \code{call} or \code{list} of filter calls -} +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{sid}}{(\code{character})\cr +when specified then method returns code containing filter conditions of +\code{FilterState} objects which \code{"sid"} attribute is different than this \code{sid} argument.} } -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DefaultFilteredDataset-get_filter_state}{}}} -\subsection{Method \code{get_filter_state()}}{ -Gets the reactive values from the active \code{FilterState} objects. - -Get all active filters from this dataset in form of the nested list. -The output list is a compatible input to \code{self$set_filter_state}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$get_filter_state()}\if{html}{\out{
}} +\if{html}{\out{
}} } - \subsection{Returns}{ -\code{list} with named elements corresponding to \code{FilterState} objects -(active filters). +filter \code{call} or \code{list} of filter calls } } \if{html}{\out{
}} @@ -155,31 +156,27 @@ The output list is a compatible input to \code{self$set_filter_state}. \subsection{Method \code{set_filter_state()}}{ Set filter state \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$set_filter_state(state, ...)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$set_filter_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state}}{(\verb{named list})\cr -containing values of the initial filter. Values should be relevant -to the referred column.} - -\item{\code{...}}{Additional arguments. Note that this is currently not used} +\item{\code{state}}{(\code{teal_slice}) object} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } \subsection{Examples}{ \if{html}{\out{
}} \preformatted{dataset <- teal.slice:::DefaultFilteredDataset$new(iris, "iris") -fs <- list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = TRUE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) +fs <- teal_slices( + teal_slice(dataname = "iris", varname = "Species", selected = "virginica"), + teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5)) ) -shiny::isolate(dataset$set_filter_state(state = fs)) +dataset$set_filter_state(state = fs) shiny::isolate(dataset$get_filter_state()) } @@ -192,32 +189,33 @@ shiny::isolate(dataset$get_filter_state()) \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-DefaultFilteredDataset-remove_filter_state}{}}} \subsection{Method \code{remove_filter_state()}}{ -Remove one or more \code{FilterState} of a \code{FilteredDataset} +Remove one or more \code{FilterState} form a \code{FilteredDataset} \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$remove_filter_state(state_id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$remove_filter_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state_id}}{(\code{character})\cr -Vector of character names of variables to remove their \code{FilterState}.} +\item{\code{state}}{(\code{teal_slices})\cr +specifying \code{FilterState} objects to remove; +\code{teal_slice}s may contain only \code{dataname} and \code{varname}, other elements are ignored} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DefaultFilteredDataset-ui_add_filter_state}{}}} -\subsection{Method \code{ui_add_filter_state()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-DefaultFilteredDataset-ui_add}{}}} +\subsection{Method \code{ui_add()}}{ UI module to add filter variable for this dataset UI module to add filter variable for this dataset \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$ui_add_filter_state(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$ui_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -233,59 +231,16 @@ function - shiny UI module } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DefaultFilteredDataset-srv_add_filter_state}{}}} -\subsection{Method \code{srv_add_filter_state()}}{ -Server module to add filter variable for this dataset - -Server module to add filter variable for this dataset. -For this class \code{srv_add_filter_state} calls single module -\code{srv_add_filter_state} from \code{FilterStates} (\code{DefaultFilteredDataset} -contains single \code{FilterStates}) -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$srv_add_filter_state(id, ...)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -an ID string that corresponds with the ID used to call the module's UI function.} - -\item{\code{...}}{other arguments passed on to child \code{FilterStates} methods.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-DefaultFilteredDataset-get_filter_overview_nsubjs}{}}} -\subsection{Method \code{get_filter_overview_nsubjs()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-DefaultFilteredDataset-get_filter_overview}{}}} +\subsection{Method \code{get_filter_overview()}}{ Get number of observations based on given keys The output shows the comparison between \code{filtered_dataset} function parameter and the dataset inside self \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$get_filter_overview_nsubjs( - filtered_dataset = self$get_dataset(), - subject_keys = NULL -)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{DefaultFilteredDataset$get_filter_overview()}\if{html}{\out{
}} } -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{filtered_dataset}}{comparison object, of the same class -as \code{self$get_dataset()}, if \code{NULL} then \code{self$get_dataset()} -is used.} - -\item{\code{subject_keys}}{(\code{character} or \code{NULL}) columns denoting unique subjects when -calculating the filtering.} -} -\if{html}{\out{
}} -} \subsection{Returns}{ \code{list} containing character \verb{#filtered/#not_filtered} } diff --git a/man/EmptyFilterState.Rd b/man/EmptyFilterState.Rd index 928e007ea..c61c8b292 100644 --- a/man/EmptyFilterState.Rd +++ b/man/EmptyFilterState.Rd @@ -9,15 +9,13 @@ } \examples{ filter_state <- teal.slice:::EmptyFilterState$new( - NA, - varname = "x", - dataname = "data", + x = NA, + slice = teal_slice(varname = "x", dataname = "data"), extract_type = character(0) ) -isolate(filter_state$get_call()) -isolate(filter_state$set_selected(TRUE)) -isolate(filter_state$set_keep_na(TRUE)) -isolate(filter_state$get_call()) +shiny::isolate(filter_state$get_call()) +filter_state$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) +shiny::isolate(filter_state$get_call()) } \keyword{internal} @@ -28,10 +26,7 @@ isolate(filter_state$get_call()) \subsection{Public methods}{ \itemize{ \item \href{#method-EmptyFilterState-new}{\code{EmptyFilterState$new()}} -\item \href{#method-EmptyFilterState-is_any_filtered}{\code{EmptyFilterState$is_any_filtered()}} \item \href{#method-EmptyFilterState-get_call}{\code{EmptyFilterState$get_call()}} -\item \href{#method-EmptyFilterState-get_state}{\code{EmptyFilterState$get_state()}} -\item \href{#method-EmptyFilterState-set_state}{\code{EmptyFilterState$set_state()}} \item \href{#method-EmptyFilterState-clone}{\code{EmptyFilterState$clone()}} } } @@ -40,16 +35,10 @@ isolate(filter_state$get_call())
@@ -62,10 +51,9 @@ Initialize \code{EmptyFilterState} object. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{EmptyFilterState$new( x, - varname, - varlabel = character(0), - dataname = NULL, - extract_type = character(0) + x_reactive = reactive(NULL), + extract_type = character(0), + slice )}\if{html}{\out{
}} } @@ -75,40 +63,33 @@ Initialize \code{EmptyFilterState} object. \item{\code{x}}{(\code{vector})\cr values of the variable used in filter} -\item{\code{varname}}{(\code{character}, \code{name})\cr -name of the variable} - -\item{\code{varlabel}}{(\code{character(1)})\cr -label of the variable (optional).} - -\item{\code{dataname}}{(\code{character(1)})\cr -optional name of dataset where \code{x} is taken from} +\item{\code{x_reactive}}{(\code{reactive})\cr +returning vector of the same type as \code{x}. Is used to update +counts following the change in values of the filtered dataset. +If it is set to \code{reactive(NULL)} then counts based on filtered +dataset are not shown.} \item{\code{extract_type}}{(\code{character(0)}, \code{character(1)})\cr -whether condition calls should be prefixed by dataname. Possible values: +whether condition calls should be prefixed by \code{dataname}. Possible values: \itemize{ \item{\code{character(0)} (default)}{ \code{varname} in the condition call will not be prefixed} \item{\code{"list"}}{ \code{varname} in the condition call will be returned as \verb{$}} \item{\code{"matrix"}}{ \code{varname} in the condition call will be returned as \verb{[, ]}} }} + +\item{\code{slice}}{(\code{teal_slice})\cr +object created using \code{\link[=teal_slice]{teal_slice()}}. \code{teal_slice} is stored +in the class and \code{set_state} directly manipulates values within \code{teal_slice}. \code{get_state} +returns \code{teal_slice} object which can be reused in other places. Beware, that \code{teal_slice} +is a \code{reactiveValues} which means that changes in particular object are automatically +reflected in all places which refer to the same \code{teal_slice}.} + +\item{\code{...}}{additional arguments to be saved as a list in \code{private$extras} field} } \if{html}{\out{}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-EmptyFilterState-is_any_filtered}{}}} -\subsection{Method \code{is_any_filtered()}}{ -Reports whether the current state filters out any values.(?) -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{EmptyFilterState$is_any_filtered()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{logical(1)} -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-EmptyFilterState-get_call}{}}} \subsection{Method \code{get_call()}}{ @@ -117,51 +98,18 @@ for selected variable type. Uses internal reactive values, hence must be called in reactive or isolated context. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{EmptyFilterState$get_call()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{logical(1)} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-EmptyFilterState-get_state}{}}} -\subsection{Method \code{get_state()}}{ -Returns the filtering state. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{EmptyFilterState$get_state()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{list} containing values taken from the reactive fields: -\itemize{ -\item \code{keep_na} (\code{logical(1)}) whether \code{NA} should be kept. -} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-EmptyFilterState-set_state}{}}} -\subsection{Method \code{set_state()}}{ -Set state. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{EmptyFilterState$set_state(state)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{EmptyFilterState$get_call(dataname)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state}}{(\code{list})\cr -contains fields relevant for specific class: -\itemize{ -\item{\code{keep_na} (\code{logical})}{ defines whether to keep or remove \code{NA} values} -}} +\item{\code{dataname}}{name of data set; defaults to \code{private$get_dataname()}} } \if{html}{\out{
}} } \subsection{Returns}{ -NULL invisibly +\code{logical(1)} } } \if{html}{\out{
}} diff --git a/man/FilterPanelAPI.Rd b/man/FilterPanelAPI.Rd index e8e2439d7..1e45ae0db 100644 --- a/man/FilterPanelAPI.Rd +++ b/man/FilterPanelAPI.Rd @@ -25,10 +25,10 @@ fpa <- FilterPanelAPI$new(fd) isolate(fpa$get_filter_state()) # set a filter state -isolate( - set_filter_state( - fpa, - list(iris = list(Species = list(selected = "setosa", keep_na = TRUE))) +set_filter_state( + fpa, + teal_slices( + teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE) ) ) @@ -36,7 +36,7 @@ isolate( isolate(fpa$get_filter_state()) # remove all_filter_states -fpa$remove_all_filter_states() +fpa$clear_filter_states() # get the actual filter state --> empty named list isolate(fpa$get_filter_state()) @@ -49,8 +49,7 @@ isolate(fpa$get_filter_state()) \item \href{#method-FilterPanelAPI-get_filter_state}{\code{FilterPanelAPI$get_filter_state()}} \item \href{#method-FilterPanelAPI-set_filter_state}{\code{FilterPanelAPI$set_filter_state()}} \item \href{#method-FilterPanelAPI-remove_filter_state}{\code{FilterPanelAPI$remove_filter_state()}} -\item \href{#method-FilterPanelAPI-remove_all_filter_states}{\code{FilterPanelAPI$remove_all_filter_states()}} -\item \href{#method-FilterPanelAPI-filter_panel_toggle}{\code{FilterPanelAPI$filter_panel_toggle()}} +\item \href{#method-FilterPanelAPI-clear_filter_states}{\code{FilterPanelAPI$clear_filter_states()}} \item \href{#method-FilterPanelAPI-clone}{\code{FilterPanelAPI$clone()}} } } @@ -99,13 +98,12 @@ Sets active filter states. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{filter}}{(\verb{named list})\cr -nested list of filter selections applied to datasets.} +\item{\code{filter}}{(\code{teal_slices})} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } } \if{html}{\out{
}} @@ -120,52 +118,36 @@ Remove one or more \code{FilterState} of a \code{FilteredDataset} in the \code{F \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{filter}}{(\verb{named list})\cr -nested list of filter selections applied to datasets.} +\item{\code{filter}}{(\code{teal_slices})\cr +specifying \code{FilterState} objects to remove; +\code{teal_slice}s may contain only \code{dataname} and \code{varname}, other elements are ignored} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterPanelAPI-remove_all_filter_states}{}}} -\subsection{Method \code{remove_all_filter_states()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterPanelAPI-clear_filter_states}{}}} +\subsection{Method \code{clear_filter_states()}}{ Remove all \code{FilterStates} of the \code{FilteredData} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterPanelAPI$remove_all_filter_states(datanames)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterPanelAPI$clear_filter_states(datanames)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{datanames}}{(\code{character})\cr -datanames to remove their \code{FilterStates}; +\code{datanames} to remove their \code{FilterStates}; omit to remove all \code{FilterStates} in the \code{FilteredData} object} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterPanelAPI-filter_panel_toggle}{}}} -\subsection{Method \code{filter_panel_toggle()}}{ -Toggle the state of the global Filter Panel button by running \code{javascript} code -to click the toggle button with the \code{filter_panel_active} id suffix. -The button id is prefixed with the Filter Panel shiny namespace. -This button is observed in \code{srv_filter_panel} method that executes -\code{filter_panel_enable()} or \code{filter_panel_disable()} method depending on the toggle state. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterPanelAPI$filter_panel_toggle()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } } \if{html}{\out{
}} diff --git a/man/FilterState.Rd b/man/FilterState.Rd index 7fc4b47e2..694d4160e 100644 --- a/man/FilterState.Rd +++ b/man/FilterState.Rd @@ -3,9 +3,9 @@ \docType{class} \name{FilterState} \alias{FilterState} -\title{FilterState Abstract Class} +\title{\code{FilterState} Abstract Class} \description{ -Abstract class to encapsulate filter states +Abstract class to encapsulate single filter state } \details{ This class is responsible for managing single filter item within @@ -28,8 +28,7 @@ Each variable's filter state is an \code{R6} object which contains \code{choices variable type specific fields (\code{keep_inf}, \code{inf_count}, \code{timezone}). Object contains also shiny module (\code{ui} and \code{server}) which manages state of the filter through reactive values \code{selected}, \code{keep_na}, \code{keep_inf} -which trigger \code{get_call()} and every R function call up in reactive -chain. +which trigger \code{get_call()} and every R function call up in reactive chain. \cr \cr } @@ -38,12 +37,12 @@ chain. Modifying a \code{FilterState} object is possible in three scenarios: \itemize{ -\item In the interactive session by directly specifying values of \code{selected}, -\code{keep_na} or \code{keep_inf} using \code{set_state} method (to update all at once), -or using \code{set_selected}, \code{set_keep_na} or \code{set_keep_inf} -\item In a running application by changing appropriate inputs -\item In a running application by using \link{filter_state_api} which directly uses \code{set_state} method -of the \code{FilterState} object. +\item In the interactive session by passing an appropriate \code{teal_slice} +to the \code{set_state} method, or using +\code{set_selected}, \code{set_keep_na} or \code{set_keep_inf} methods. +\item In a running application by changing appropriate inputs. +\item In a running application by using \link{filter_state_api} which directly uses +\code{set_state} method of the \code{InteractiveFilterState} object. } } @@ -52,22 +51,14 @@ of the \code{FilterState} object. \subsection{Public methods}{ \itemize{ \item \href{#method-FilterState-new}{\code{FilterState$new()}} -\item \href{#method-FilterState-destroy_observers}{\code{FilterState$destroy_observers()}} \item \href{#method-FilterState-format}{\code{FilterState$format()}} -\item \href{#method-FilterState-get_call}{\code{FilterState$get_call()}} -\item \href{#method-FilterState-get_dataname}{\code{FilterState$get_dataname()}} -\item \href{#method-FilterState-get_keep_na}{\code{FilterState$get_keep_na()}} -\item \href{#method-FilterState-get_varlabel}{\code{FilterState$get_varlabel()}} -\item \href{#method-FilterState-get_varname}{\code{FilterState$get_varname()}} -\item \href{#method-FilterState-get_selected}{\code{FilterState$get_selected()}} -\item \href{#method-FilterState-get_state}{\code{FilterState$get_state()}} \item \href{#method-FilterState-print}{\code{FilterState$print()}} -\item \href{#method-FilterState-set_keep_na}{\code{FilterState$set_keep_na()}} -\item \href{#method-FilterState-set_na_rm}{\code{FilterState$set_na_rm()}} -\item \href{#method-FilterState-set_selected}{\code{FilterState$set_selected()}} \item \href{#method-FilterState-set_state}{\code{FilterState$set_state()}} +\item \href{#method-FilterState-get_state}{\code{FilterState$get_state()}} +\item \href{#method-FilterState-get_call}{\code{FilterState$get_call()}} \item \href{#method-FilterState-server}{\code{FilterState$server()}} \item \href{#method-FilterState-ui}{\code{FilterState$ui()}} +\item \href{#method-FilterState-destroy_observers}{\code{FilterState$destroy_observers()}} \item \href{#method-FilterState-clone}{\code{FilterState$clone()}} } } @@ -79,9 +70,8 @@ Initialize a \code{FilterState} object \subsection{Usage}{ \if{html}{\out{
}}\preformatted{FilterState$new( x, - varname, - varlabel = character(0), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0) )}\if{html}{\out{
}} } @@ -92,23 +82,24 @@ Initialize a \code{FilterState} object \item{\code{x}}{(\code{vector})\cr values of the variable used in filter} -\item{\code{varname}}{(\code{character})\cr -name of the variable} - -\item{\code{varlabel}}{(\code{character(1)})\cr -label of the variable (optional).} +\item{\code{x_reactive}}{(\code{reactive})\cr +returning vector of the same type as \code{x}. Is used to update +counts following the change in values of the filtered dataset. +If it is set to \code{reactive(NULL)} then counts based on filtered +dataset are not shown.} -\item{\code{dataname}}{(\code{character(1)})\cr -name of dataset where \code{x} is taken from. Must be specified if \code{extract_type} argument -is not empty.} +\item{\code{slice}}{(\code{teal_slice})\cr +object created by \code{\link[=teal_slice]{teal_slice()}}} \item{\code{extract_type}}{(\code{character(0)}, \code{character(1)})\cr -whether condition calls should be prefixed by dataname. Possible values: +specifying whether condition calls should be prefixed by \code{dataname}. Possible values: \itemize{ \item{\code{character(0)} (default)}{ \code{varname} in the condition call will not be prefixed} \item{\code{"list"}}{ \code{varname} in the condition call will be returned as \verb{$}} \item{\code{"matrix"}}{ \code{varname} in the condition call will be returned as \verb{[, ]}} }} + +\item{\code{...}}{additional arguments to be saved as a list in \code{private$extras} field} } \if{html}{\out{}} } @@ -117,37 +108,20 @@ self invisibly } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-destroy_observers}{}}} -\subsection{Method \code{destroy_observers()}}{ -Destroy observers stored in \code{private$observers}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$destroy_observers()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -NULL invisibly -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilterState-format}{}}} \subsection{Method \code{format()}}{ -Returns a formatted string representing this \code{FilterState}. +Returns a formatted string representing this \code{FilterState} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$format(indent = 0L, wrap_width = 76L)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterState$format(show_all = FALSE, trim_lines = TRUE)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{indent}}{(\code{numeric(1)}) -number of spaces before after each new line character of the formatted string; -defaults to 0} +\item{\code{show_all}}{\code{logical(1)} passed to \code{format.teal_slice}} -\item{\code{wrap_width}}{(\code{numeric(1)}) -number of characters to wrap lines at in the printed output; -allowed range is 30 to 120; defaults to 76} +\item{\code{trim_lines}}{\code{logical(1)} passed to \code{format.teal_slice}} } \if{html}{\out{
}} } @@ -156,101 +130,6 @@ allowed range is 30 to 120; defaults to 76} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-get_call}{}}} -\subsection{Method \code{get_call()}}{ -Returns reproducible condition call for current selection relevant -for selected variable type. -Method is using internal reactive values which makes it reactive -and must be executed in reactive or isolated context. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$get_call()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-get_dataname}{}}} -\subsection{Method \code{get_dataname()}}{ -Returns dataname or "NULL" if dataname is NULL. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$get_dataname()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character(1)} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-get_keep_na}{}}} -\subsection{Method \code{get_keep_na()}}{ -Returns current \code{keep_na} selection. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$get_keep_na()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{logical(1)} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-get_varlabel}{}}} -\subsection{Method \code{get_varlabel()}}{ -Returns variable label. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$get_varlabel()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character(1)} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-get_varname}{}}} -\subsection{Method \code{get_varname()}}{ -Get variable name. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$get_varname()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character(1)} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-get_selected}{}}} -\subsection{Method \code{get_selected()}}{ -Get selected values from \code{FilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$get_selected()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -class of the returned object depends of class of the \code{FilterState} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-get_state}{}}} -\subsection{Method \code{get_state()}}{ -Returns the filtering state. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$get_state()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{list} containing values taken from the reactive fields: -\itemize{ -\item \code{selected} (\code{atomic}) length depends on a \code{FilterState} variant. -\item \code{keep_na} (\code{logical(1)}) whether \code{NA} should be kept. -} -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilterState-print}{}}} \subsection{Method \code{print()}}{ @@ -262,106 +141,60 @@ Prints this \code{FilterState} object. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{...}}{additional arguments to this method} +\item{\code{...}}{additional arguments} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-set_keep_na}{}}} -\subsection{Method \code{set_keep_na()}}{ -Set whether to keep NAs. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$set_keep_na(value)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{value}}{\code{logical(1)}\cr -value(s) which come from the filter selection. Value is set in \code{server} -modules after selecting check-box-input in the shiny interface. Values are set to -\code{private$keep_na} which is reactive.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -NULL invisibly -} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterState-set_state}{}}} +\subsection{Method \code{set_state()}}{ +Sets filtering state. +\itemize{ +\item \code{fixed} state is prevented from changing state +\item \code{locked} state is prevented from removing state } -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-set_na_rm}{}}} -\subsection{Method \code{set_na_rm()}}{ -Some methods need an additional \code{!is.na(varame)} condition to drop -missing values. When \code{private$na_rm = TRUE}, \code{self$get_call} returns -condition extended by \code{!is.na}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$set_na_rm(value)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterState$set_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{value}}{\code{logical(1)}\cr -when \code{TRUE}, \code{FilterState$get_call} appends an expression -removing \code{NA} values to the filter expression returned by \code{get_call}} +\item{\code{state}}{a \code{teal_slice} object} } \if{html}{\out{
}} } \subsection{Returns}{ -NULL invisibly +\code{self} invisibly } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-set_selected}{}}} -\subsection{Method \code{set_selected()}}{ -Set selection. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterState-get_state}{}}} +\subsection{Method \code{get_state()}}{ +Returns filtering state. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$set_selected(value)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterState$get_state()}\if{html}{\out{
}} } -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{value}}{(\code{vector})\cr -value(s) that come from filter selection; values are set in the -module server after a selection is made in the app interface; -values are stored in \code{private$selected} which is reactive; -value types have to be the same as \code{private$choices}} -} -\if{html}{\out{
}} -} \subsection{Returns}{ -NULL invisibly +A \code{teal_slice} object. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterState-set_state}{}}} -\subsection{Method \code{set_state()}}{ -Set state. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterState-get_call}{}}} +\subsection{Method \code{get_call()}}{ +Returns reproducible condition call for current selection relevant +for selected variable type. +Method is using internal reactive values which makes it reactive +and must be executed in reactive or isolated context. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$set_state(state)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterState$get_call()}\if{html}{\out{
}} } -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{state}}{(\code{list})\cr -contains fields relevant for a specific class: -\itemize{ -\item{\code{selected}}{ defines initial selection} -\item{\code{keep_na} (\code{logical})}{ defines whether to keep or remove \code{NA} values} -}} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -NULL invisibly -} } \if{html}{\out{
}} \if{html}{\out{}} @@ -391,7 +224,7 @@ signaling that remove button has been clicked \subsection{Method \code{ui()}}{ Shiny module UI. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterState$ui(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterState$ui(id, parent_id = "cards")}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -400,11 +233,26 @@ Shiny module UI. \item{\code{id}}{(\code{character(1)})\cr shiny element (module instance) id; the UI for this class contains simple message stating that it is not supported} + +\item{\code{parent_id}}{(\code{character(1)}) id of the \code{FilterStates} card container} } \if{html}{\out{}} } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterState-destroy_observers}{}}} +\subsection{Method \code{destroy_observers()}}{ +Destroy observers stored in \code{private$observers}. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterState$destroy_observers()}\if{html}{\out{
}} +} + +\subsection{Returns}{ +NULL invisibly +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilterState-clone}{}}} \subsection{Method \code{clone()}}{ diff --git a/man/FilterStateExpr.Rd b/man/FilterStateExpr.Rd new file mode 100644 index 000000000..24c4d5b03 --- /dev/null +++ b/man/FilterStateExpr.Rd @@ -0,0 +1,264 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FilterStateExpr.R +\docType{class} +\name{FilterStateExpr} +\alias{FilterStateExpr} +\title{\code{FilterStateExpr} Class} +\description{ +Class to handle filter expression. +} +\details{ +This class is responsible for displaying filter card and returning filter expression +} +\examples{ +filter_state <- teal.slice:::FilterStateExpr$new( + slice = teal_slice( + dataname = "x", + id = "FA", + title = "Adult females", + expr = "sex == 'F' & age >= 18" + ) +) +filter_state$get_call() + +# working filter in an app +library(shiny) +library(shinyjs) + +ui <- fluidPage( + useShinyjs(), + teal.slice:::include_css_files(pattern = "filter-panel"), + teal.slice:::include_js_files(pattern = "count-bar-labels"), + column(4, div( + h4("ChoicesFilterState"), + filter_state$ui("fs") + )), + column(8, div( + h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState + textOutput("condition_choices"), br(), + h4("Unformatted state"), # display raw filter state + textOutput("unformatted_choices"), br(), + h4("Formatted state"), # display human readable filter state + textOutput("formatted_choices"), br() + )) +) + +server <- function(input, output, session) { + filter_state$server("fs") + output$condition_choices <- renderPrint(filter_state$get_call()) + output$formatted_choices <- renderText(filter_state$format()) + output$unformatted_choices <- renderPrint(filter_state$get_state()) +} + +if (interactive()) { + shinyApp(ui, server) +} +} +\keyword{internal} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-FilterStateExpr-new}{\code{FilterStateExpr$new()}} +\item \href{#method-FilterStateExpr-format}{\code{FilterStateExpr$format()}} +\item \href{#method-FilterStateExpr-print}{\code{FilterStateExpr$print()}} +\item \href{#method-FilterStateExpr-get_state}{\code{FilterStateExpr$get_state()}} +\item \href{#method-FilterStateExpr-set_state}{\code{FilterStateExpr$set_state()}} +\item \href{#method-FilterStateExpr-get_call}{\code{FilterStateExpr$get_call()}} +\item \href{#method-FilterStateExpr-destroy_observers}{\code{FilterStateExpr$destroy_observers()}} +\item \href{#method-FilterStateExpr-server}{\code{FilterStateExpr$server()}} +\item \href{#method-FilterStateExpr-ui}{\code{FilterStateExpr$ui()}} +\item \href{#method-FilterStateExpr-clone}{\code{FilterStateExpr$clone()}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-new}{}}} +\subsection{Method \code{new()}}{ +Initialize a \code{FilterStateExpr} object +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$new(slice)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{slice}}{(\code{teal_slice_expr})\cr +object created by \code{\link[=teal_slice]{teal_slice()}}} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{FilterStateExpr} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-format}{}}} +\subsection{Method \code{format()}}{ +Returns a formatted string representing this \code{FilterStateExpr} object. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$format(show_all = FALSE, trim_lines = TRUE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{show_all}}{\code{logical(1)} passed to \code{format.teal_slice}} + +\item{\code{trim_lines}}{\code{logical(1)} passed to \code{format.teal_slice}} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{character(1)} the formatted string +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-print}{}}} +\subsection{Method \code{print()}}{ +Prints this \code{FilterStateExpr} object. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$print(...)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{...}}{additional arguments} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-get_state}{}}} +\subsection{Method \code{get_state()}}{ +Returns filtering state. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$get_state()}\if{html}{\out{
}} +} + +\subsection{Returns}{ +A \code{teal_slice} object. +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-set_state}{}}} +\subsection{Method \code{set_state()}}{ +Sets filtering state. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$set_state(state)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{state}}{a \code{teal_slice} object} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{self} invisibly +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-get_call}{}}} +\subsection{Method \code{get_call()}}{ +Get reproducible call +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$get_call(dataname)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{dataname}}{(\code{ignored}) for a consistency with \code{FilterState} + +Returns reproducible condition call for current selection relevant +for selected variable type. +Method is using internal reactive values which makes it reactive +and must be executed in reactive or isolated context.} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{language} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-destroy_observers}{}}} +\subsection{Method \code{destroy_observers()}}{ +Destroy observers stored in \code{private$observers}. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$destroy_observers()}\if{html}{\out{
}} +} + +\subsection{Returns}{ +NULL invisibly +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-server}{}}} +\subsection{Method \code{server()}}{ +Shiny module server. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$server(id)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{(\code{character(1)})\cr +shiny module instance id} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{moduleServer} function which returns reactive value +signaling that remove button has been clicked +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-ui}{}}} +\subsection{Method \code{ui()}}{ +Shiny module UI. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$ui(id, parent_id = "cards")}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{(\code{character(1)})\cr +shiny element (module instance) id; +the UI for this class contains simple message stating that it is not supported} + +\item{\code{parent_id}}{(\code{character(1)}) id of the \code{FilterStates} card container} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStateExpr-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilterStateExpr$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/man/FilterStates.Rd b/man/FilterStates.Rd index 4d8d19cea..8d415b308 100644 --- a/man/FilterStates.Rd +++ b/man/FilterStates.Rd @@ -14,58 +14,26 @@ that will assign a subset of the original data to a new variable. This expression is hereafter referred to as \emph{subset expression}. The \emph{subset expression} is constructed differently for different -classes of the underlying data object and \code{FilterStates} subclasses. +classes of the underlying data object and \code{FilterStates} sub-classes. Currently implemented for \code{data.frame}, \code{matrix}, \code{SummarizedExperiment}, and \code{MultiAssayExperiment}. -} -\examples{ -library(shiny) -filter_states <- teal.slice:::DFFilterStates$new( - dataname = "data", - varlabels = c(x = "x variable", SEX = "Sex"), - datalabel = character(0), - keys = character(0) -) -filter_state <- teal.slice:::RangeFilterState$new( - c(NA, Inf, seq(1:10)), - varname = "x", - varlabel = "x variable", - dataname = "data", - extract_type = "list" -) -isolate(filter_state$set_selected(c(3L, 8L))) - -isolate( - filter_states$state_list_push( - x = filter_state, - state_list_index = 1L, - state_id = "x" - ) -) -isolate(filter_states$get_call()) - } \keyword{internal} \section{Methods}{ \subsection{Public methods}{ \itemize{ \item \href{#method-FilterStates-new}{\code{FilterStates$new()}} -\item \href{#method-FilterStates-get_datalabel}{\code{FilterStates$get_datalabel()}} \item \href{#method-FilterStates-format}{\code{FilterStates$format()}} \item \href{#method-FilterStates-get_call}{\code{FilterStates$get_call()}} \item \href{#method-FilterStates-print}{\code{FilterStates$print()}} -\item \href{#method-FilterStates-get_fun}{\code{FilterStates$get_fun()}} -\item \href{#method-FilterStates-state_list_get}{\code{FilterStates$state_list_get()}} -\item \href{#method-FilterStates-state_list_push}{\code{FilterStates$state_list_push()}} -\item \href{#method-FilterStates-state_list_remove}{\code{FilterStates$state_list_remove()}} -\item \href{#method-FilterStates-state_list_empty}{\code{FilterStates$state_list_empty()}} -\item \href{#method-FilterStates-get_filter_count}{\code{FilterStates$get_filter_count()}} \item \href{#method-FilterStates-remove_filter_state}{\code{FilterStates$remove_filter_state()}} -\item \href{#method-FilterStates-ui}{\code{FilterStates$ui()}} \item \href{#method-FilterStates-get_filter_state}{\code{FilterStates$get_filter_state()}} \item \href{#method-FilterStates-set_filter_state}{\code{FilterStates$set_filter_state()}} -\item \href{#method-FilterStates-ui_add_filter_state}{\code{FilterStates$ui_add_filter_state()}} -\item \href{#method-FilterStates-srv_add_filter_state}{\code{FilterStates$srv_add_filter_state()}} +\item \href{#method-FilterStates-clear_filter_states}{\code{FilterStates$clear_filter_states()}} +\item \href{#method-FilterStates-ui_active}{\code{FilterStates$ui_active()}} +\item \href{#method-FilterStates-srv_active}{\code{FilterStates$srv_active()}} +\item \href{#method-FilterStates-ui_add}{\code{FilterStates$ui_add()}} +\item \href{#method-FilterStates-srv_add}{\code{FilterStates$srv_add()}} \item \href{#method-FilterStates-clone}{\code{FilterStates$clone()}} } } @@ -78,17 +46,31 @@ Initializes \code{FilterStates} object. Initializes \code{FilterStates} object by setting \code{dataname}, and \code{datalabel}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$new(dataname, datalabel)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$new( + data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = NULL +)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ +\item{\code{data}}{(\code{data.frame}, \code{MultiAssayExperiment}, \code{SummarizedExperiment}, \code{matrix})\cr +the R object which \code{subset} function is applied on.} + +\item{\code{data_reactive}}{(\verb{function(sid)})\cr +should return an object of the same type as \code{data} object or \code{NULL}. +This object is needed for the \code{FilterState} counts being updated +on a change in filters. If function returns \code{NULL} then filtered counts are not shown. +Function has to have \code{sid} argument being a character.} + \item{\code{dataname}}{(\code{character(1)})\cr name of the data used in the expression specified to the function argument attached to this \code{FilterStates}} -\item{\code{datalabel}}{(\code{character(0)} or \code{character(1)})\cr +\item{\code{datalabel}}{(\code{NULL} or \code{character(1)})\cr text label value} } \if{html}{\out{
}} @@ -98,31 +80,20 @@ self invisibly } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-get_datalabel}{}}} -\subsection{Method \code{get_datalabel()}}{ -Returns the label of the dataset. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$get_datalabel()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character(1)} the data label -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilterStates-format}{}}} \subsection{Method \code{format()}}{ Returns a formatted string representing this \code{FilterStates} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$format(indent)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$format(show_all = FALSE, trim_lines = TRUE)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{indent}}{(\code{numeric(1)}) the number of spaces prepended to each line of the output} +\item{\code{show_all}}{\code{logical(1)} passed to \code{format.teal_slices}} + +\item{\code{trim_lines}}{\code{logical(1)} passed to \code{format.teal_slices}} } \if{html}{\out{
}} } @@ -136,17 +107,52 @@ Returns a formatted string representing this \code{FilterStates} object. \subsection{Method \code{get_call()}}{ Filter call -Builds \emph{subset expression} from condition calls stored in \code{FilterState} -objects selection. The \code{lhs} of the expression is \code{private$dataname}. -The \code{rhs} is a call to \code{self$get_fun()} with \code{private$dataname} -as argument and a list of condition calls from \code{FilterState} objects -stored in \code{private$state_list}. -If no filters are applied, -\code{NULL} is returned to avoid no-op calls such as \code{x <- x}. +Builds \emph{subset expression} from condition calls generated by \code{FilterState}. +The \code{lhs} of the expression is a \code{dataname_prefixed}, where word prefixed refers to +situation when call is evaluated on elements of the original data, for example \code{dataname[[x]]}. +By default \code{dataname_prefixed = dataname} and it's not alterable through class methods. +Customization of \code{private$dataname_prefixed} is done through inheriting classes. + +The \code{rhs} is a call to \code{private$fun} with following arguments: +\itemize{ +\item \code{dataname_prefixed} +\item list of logical expressions generated by \code{FilterState} objects +stored in \code{private$state_list}. Each logical predicate is combined with \code{&} operator. +Variables in these logical expressions by default are not prefixed but this can be changed +by setting \code{private$extract_type} (change in the similar way as \code{dataname_prefixed}) +Possible call outputs depending on a custom fields/options: +} + +\if{html}{\out{
}}\preformatted{# default +dataname <- subset(dataname, col == "x") + +# fun = dplyr::filter +dataname <- dplyr::filter(dataname, col == "x") + +# fun = MultiAssayExperiment::subsetByColData; extract_type = "list" +dataname <- MultiAssayExperiment::subsetByColData(dataname, dataname$col == "x") + +# teal_slice objects having `arg = "subset"` and `arg = "select"` +dataname <- subset(dataname, subset = row_col == "x", select = col_col == "x") + +# dataname = dataname[[element]] +dataname[[element]] <- subset(dataname[[element]], subset = col == "x") +}\if{html}{\out{
}} + +If no filters are applied, \code{NULL} is returned to avoid no-op calls such as \code{dataname <- dataname}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$get_call()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$get_call(sid = "")}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{sid}}{(\code{character})\cr +when specified then method returns code containing filter conditions of +\code{FilterState} objects which \code{"sid"} attribute is different than this \code{sid} argument.} +} +\if{html}{\out{
}} +} \subsection{Returns}{ \code{call} or \code{NULL} } @@ -163,115 +169,82 @@ Prints this \code{FilterStates} object. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{...}}{additional arguments to this method} +\item{\code{...}}{additional arguments} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-get_fun}{}}} -\subsection{Method \code{get_fun()}}{ -Gets the name of the function used to filter the data in this \code{FilterStates}. - -Get name of function used to create the \emph{subset expression}. -Defaults to "subset" but can be overridden by child class method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$get_fun()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character(1)} the name of the function -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-state_list_get}{}}} -\subsection{Method \code{state_list_get()}}{ -Returns a list of \code{FilterState} objects stored in this \code{FilterStates}. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStates-remove_filter_state}{}}} +\subsection{Method \code{remove_filter_state()}}{ +Remove one or more \code{FilterState}s from the \code{state_list} along with their UI elements. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$state_list_get(state_list_index, state_id = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$remove_filter_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state_list_index}}{(\code{character(1)}, \code{integer(1)})\cr -index on the list in \code{private$state_list} where filter states are kept} - -\item{\code{state_id}}{(\code{character(1)})\cr -name of element in a filter state (which is a \code{reactiveVal} containing a list)} +\item{\code{state}}{(\code{teal_slices})\cr +specifying \code{FilterState} objects to remove; +\code{teal_slice}s may contain only \code{dataname} and \code{varname}, other elements are ignored} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{list} of \code{FilterState} objects +\code{NULL} invisibly } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-state_list_push}{}}} -\subsection{Method \code{state_list_push()}}{ -Adds a new \code{FilterState} object to this \code{FilterStates}.\cr -Raises error if the length of \code{x} does not match the length of \code{state_id}. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStates-get_filter_state}{}}} +\subsection{Method \code{get_filter_state()}}{ +Gets reactive values from active \code{FilterState} objects. + +Get active filter state from \code{FilterState} objects stored in \code{state_list}(s). +The output is a list compatible with input to \code{self$set_filter_state}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$state_list_push(x, state_list_index, state_id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$get_filter_state()}\if{html}{\out{
}} } -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{x}}{(\code{FilterState})\cr -object to be added to filter state list} - -\item{\code{state_list_index}}{(\code{character(1)}, \code{integer(1)})\cr -index on the list in \code{private$state_list} where filter states are kept} - -\item{\code{state_id}}{(\code{character(1)})\cr -name of element in a filter state (which is a \code{reactiveVal} containing a list)} -} -\if{html}{\out{
}} -} \subsection{Returns}{ -NULL +\code{list} containing \code{list} per \code{FilterState} in the \code{state_list} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-state_list_remove}{}}} -\subsection{Method \code{state_list_remove()}}{ -Removes a single filter state with all associated shiny elements:\cr -\itemize{ -\item specified \code{FilterState} from \code{private$state_list} -\item UI card created for this filter -\item observers tracking the selection and remove button -} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStates-set_filter_state}{}}} +\subsection{Method \code{set_filter_state()}}{ +Sets active \code{FilterState} objects. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$state_list_remove(state_list_index, state_id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$set_filter_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state_list_index}}{(\code{character(1)}, \code{integer(1)})\cr -index on the list in \code{private$state_list} where filter states are kept} +\item{\code{state}}{(\verb{named list})\cr +should contain values which are initial selection in the \code{FilterState}. +Names of the \code{list} element should correspond to the name of the +column in \code{data}.} -\item{\code{state_id}}{(\code{character(1)})\cr -name of element in a filter state (which is a \code{reactiveVal} containing a list)} +\item{\code{data}}{(\code{data.frame})\cr +data which are supposed to be filtered} } \if{html}{\out{
}} } \subsection{Returns}{ -NULL +function which throws an error } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-state_list_empty}{}}} -\subsection{Method \code{state_list_empty()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStates-clear_filter_states}{}}} +\subsection{Method \code{clear_filter_states()}}{ Remove all \code{FilterState} objects from this \code{FilterStates} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$state_list_empty()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$clear_filter_states()}\if{html}{\out{
}} } \subsection{Returns}{ @@ -279,49 +252,15 @@ NULL } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-get_filter_count}{}}} -\subsection{Method \code{get_filter_count()}}{ -Gets the number of active \code{FilterState} objects in this \code{FilterStates} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$get_filter_count()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{integer(1)} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-remove_filter_state}{}}} -\subsection{Method \code{remove_filter_state()}}{ -Remove a single \code{FilterState} from \code{state_list}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$remove_filter_state(state_id)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{state_id}}{(\code{character})\cr -name of variable for which to remove \code{FilterState}} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-ui}{}}} -\subsection{Method \code{ui()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStates-ui_active}{}}} +\subsection{Method \code{ui_active()}}{ Shiny module UI Shiny UI element that stores \code{FilterState} UI elements. Populated with elements created with \code{renderUI} in the module server. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$ui(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$ui_active(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -337,52 +276,33 @@ shiny element (module instance) id} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-get_filter_state}{}}} -\subsection{Method \code{get_filter_state()}}{ -Gets reactive values from active \code{FilterState} objects. - -Get active filter state from \code{FilterState} objects stored in \code{state_list}(s). -The output is a list compatible with input to \code{self$set_filter_state}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$get_filter_state()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{list} containing \code{list} per \code{FilterState} in the \code{state_list} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-set_filter_state}{}}} -\subsection{Method \code{set_filter_state()}}{ -Sets active \code{FilterState} objects. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStates-srv_active}{}}} +\subsection{Method \code{srv_active()}}{ +Shiny server module. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$set_filter_state(data, state, filtered_dataset)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$srv_active(id)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{data}}{(\code{data.frame})\cr -data object for which to define a subset} - -\item{\code{state}}{(\verb{named list})\cr -should contain values of initial selections in the \code{FilterState}; -\code{list} names must correspond to column names in \code{data}} - -\item{\code{filtered_dataset}}{data object for which to define a subset(?)} +\item{\code{id}}{(\code{character(1)})\cr +shiny module instance id} } \if{html}{\out{
}} } +\subsection{Returns}{ +\code{moduleServer} function which returns \code{NULL} +} } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-ui_add_filter_state}{}}} -\subsection{Method \code{ui_add_filter_state()}}{ -Shiny module UI that adds a filter variable. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStates-ui_add}{}}} +\subsection{Method \code{ui_add()}}{ +Shiny UI module to add filter variable. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$ui_add_filter_state(id, data)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$ui_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -390,9 +310,6 @@ Shiny module UI that adds a filter variable. \describe{ \item{\code{id}}{(\code{character(1)})\cr shiny element (module instance) id} - -\item{\code{data}}{(\code{data.frame}, \code{MultiAssayExperiment}, \code{SummarizedExperiment}, \code{matrix})\cr -data object for which to define a subset} } \if{html}{\out{}} } @@ -401,24 +318,23 @@ data object for which to define a subset} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilterStates-srv_add_filter_state}{}}} -\subsection{Method \code{srv_add_filter_state()}}{ -Shiny module server that adds a filter variable. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilterStates-srv_add}{}}} +\subsection{Method \code{srv_add()}}{ +Shiny server module to add filter variable. + +This module controls available choices to select as a filter variable. +Once selected, a variable is removed from available choices. +Removing a filter variable adds it back to available choices. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilterStates$srv_add_filter_state(id, data, ...)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilterStates$srv_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{(\code{character(1)})\cr -shiny module instance id} - -\item{\code{data}}{(\code{data.frame}, \code{MultiAssayExperiment}, \code{SummarizedExperiment}, \code{matrix})\cr -data object for which to define a subset} - -\item{\code{...}}{ignored} +an ID string that corresponds with the ID used to call the module's UI function.} } \if{html}{\out{
}} } diff --git a/man/FilteredData.Rd b/man/FilteredData.Rd index c9b9c128a..be6de1df2 100644 --- a/man/FilteredData.Rd +++ b/man/FilteredData.Rd @@ -18,7 +18,7 @@ to the filter state. The data itself can be obtained through \code{get_data}. The datasets are filtered lazily, i.e. only when requested / needed in a Shiny app. -By design, any dataname set through \code{set_dataset} cannot be removed because +By design, any \code{dataname} set through \code{set_dataset} cannot be removed because other code may already depend on it. As a workaround, the underlying data can be set to \code{NULL}. @@ -46,69 +46,27 @@ library(shiny) datasets <- teal.slice:::FilteredData$new( list( iris = list(dataset = iris), - mtcars = list(dataset = mtcars, metadata = list(type = "training")) + mtcars = list(dataset = mtcars) ) ) # get datanames datasets$datanames() -df <- datasets$get_data("iris", filtered = FALSE) -print(df) - -datasets$get_metadata("mtcars") - -isolate( - datasets$set_filter_state( - list(iris = list(Species = list(selected = "virginica"))) - ) +datasets$set_filter_state( + teal_slices(teal_slice(dataname = "iris", varname = "Species", selected = "virginica")) ) isolate(datasets$get_call("iris")) -isolate( - datasets$set_filter_state( - list(mtcars = list(mpg = list(selected = c(15, 20)))) - ) +datasets$set_filter_state( + teal_slices(teal_slice(dataname = "mtcars", varname = "mpg", selected = c(15, 20))) ) isolate(datasets$get_filter_state()) -isolate(datasets$get_filter_overview("iris")) -isolate(datasets$get_filter_overview("mtcars")) isolate(datasets$get_call("iris")) isolate(datasets$get_call("mtcars")) -## ------------------------------------------------ -## Method `FilteredData$get_formatted_filter_state` -## ------------------------------------------------ - -utils::data(miniACC, package = "MultiAssayExperiment") -datasets <- teal.slice:::FilteredData$new( - list(iris = list(dataset = iris), - mae = list(dataset = miniACC) - ), - join_keys = NULL -) -fs <- list( - iris = list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) - ), - mae = list( - subjects = list( - years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - vital_status = list(selected = "1", keep_na = FALSE), - gender = list(selected = "female", keep_na = TRUE) - ), - RPPAArray = list( - subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) - ) - ) -) -isolate(datasets$set_filter_state(state = fs)) -cat(shiny::isolate(datasets$get_formatted_filter_state())) - - ## ------------------------------------------------ ## Method `FilteredData$set_filter_state` ## ------------------------------------------------ @@ -118,26 +76,22 @@ utils::data(miniACC, package = "MultiAssayExperiment") datasets <- teal.slice:::FilteredData$new( list(iris = list(dataset = iris), mae = list(dataset = miniACC) - ), - join_keys = NULL -) -fs <- list( - iris = list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) - ), - mae = list( - subjects = list( - years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - vital_status = list(selected = "1", keep_na = FALSE), - gender = list(selected = "female", keep_na = TRUE) - ), - RPPAArray = list( - subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) - ) ) ) -shiny::isolate(datasets$set_filter_state(state = fs)) +fs <- + teal_slices( + teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4), + keep_na = TRUE, keep_inf = FALSE), + teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor"), + keep_na = FALSE), + teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(30, 50), + keep_na = TRUE, keep_inf = FALSE), + teal_slice(dataname = "mae", varname = "vital_status", selected = "1", keep_na = FALSE), + teal_slice(dataname = "mae", varname = "gender", selected = "female", keep_na = TRUE), + teal_slice(dataname = "mae", varname = "ARRAY_TYPE", + selected = "", keep_na = TRUE, datalabel = "RPPAArray", arg = "subset") + ) +datasets$set_filter_state(state = fs) shiny::isolate(datasets$get_filter_state()) } @@ -148,39 +102,41 @@ shiny::isolate(datasets$get_filter_state()) \item \href{#method-FilteredData-new}{\code{FilteredData$new()}} \item \href{#method-FilteredData-datanames}{\code{FilteredData$datanames()}} \item \href{#method-FilteredData-get_datalabel}{\code{FilteredData$get_datalabel()}} -\item \href{#method-FilteredData-get_filterable_datanames}{\code{FilteredData$get_filterable_datanames()}} -\item \href{#method-FilteredData-get_filterable_varnames}{\code{FilteredData$get_filterable_varnames()}} -\item \href{#method-FilteredData-set_filterable_varnames}{\code{FilteredData$set_filterable_varnames()}} \item \href{#method-FilteredData-get_call}{\code{FilteredData$get_call()}} \item \href{#method-FilteredData-get_code}{\code{FilteredData$get_code()}} -\item \href{#method-FilteredData-get_filtered_dataset}{\code{FilteredData$get_filtered_dataset()}} \item \href{#method-FilteredData-get_data}{\code{FilteredData$get_data()}} \item \href{#method-FilteredData-get_check}{\code{FilteredData$get_check()}} \item \href{#method-FilteredData-get_metadata}{\code{FilteredData$get_metadata()}} \item \href{#method-FilteredData-get_join_keys}{\code{FilteredData$get_join_keys()}} \item \href{#method-FilteredData-get_filter_overview}{\code{FilteredData$get_filter_overview()}} \item \href{#method-FilteredData-get_keys}{\code{FilteredData$get_keys()}} -\item \href{#method-FilteredData-get_varlabels}{\code{FilteredData$get_varlabels()}} -\item \href{#method-FilteredData-get_varnames}{\code{FilteredData$get_varnames()}} -\item \href{#method-FilteredData-handle_active_datanames}{\code{FilteredData$handle_active_datanames()}} \item \href{#method-FilteredData-set_dataset}{\code{FilteredData$set_dataset()}} \item \href{#method-FilteredData-set_join_keys}{\code{FilteredData$set_join_keys()}} \item \href{#method-FilteredData-set_check}{\code{FilteredData$set_check()}} \item \href{#method-FilteredData-set_code}{\code{FilteredData$set_code()}} \item \href{#method-FilteredData-get_filter_state}{\code{FilteredData$get_filter_state()}} -\item \href{#method-FilteredData-get_formatted_filter_state}{\code{FilteredData$get_formatted_filter_state()}} +\item \href{#method-FilteredData-format}{\code{FilteredData$format()}} +\item \href{#method-FilteredData-print}{\code{FilteredData$print()}} \item \href{#method-FilteredData-set_filter_state}{\code{FilteredData$set_filter_state()}} \item \href{#method-FilteredData-remove_filter_state}{\code{FilteredData$remove_filter_state()}} -\item \href{#method-FilteredData-remove_all_filter_states}{\code{FilteredData$remove_all_filter_states()}} -\item \href{#method-FilteredData-restore_state_from_bookmark}{\code{FilteredData$restore_state_from_bookmark()}} -\item \href{#method-FilteredData-filter_panel_disable}{\code{FilteredData$filter_panel_disable()}} -\item \href{#method-FilteredData-filter_panel_enable}{\code{FilteredData$filter_panel_enable()}} -\item \href{#method-FilteredData-get_filter_panel_active}{\code{FilteredData$get_filter_panel_active()}} -\item \href{#method-FilteredData-get_filter_panel_ui_id}{\code{FilteredData$get_filter_panel_ui_id()}} +\item \href{#method-FilteredData-clear_filter_states}{\code{FilteredData$clear_filter_states()}} +\item \href{#method-FilteredData-set_available_teal_slices}{\code{FilteredData$set_available_teal_slices()}} \item \href{#method-FilteredData-ui_filter_panel}{\code{FilteredData$ui_filter_panel()}} \item \href{#method-FilteredData-srv_filter_panel}{\code{FilteredData$srv_filter_panel()}} -\item \href{#method-FilteredData-ui_filter_overview}{\code{FilteredData$ui_filter_overview()}} -\item \href{#method-FilteredData-srv_filter_overview}{\code{FilteredData$srv_filter_overview()}} +\item \href{#method-FilteredData-ui_active}{\code{FilteredData$ui_active()}} +\item \href{#method-FilteredData-srv_active}{\code{FilteredData$srv_active()}} +\item \href{#method-FilteredData-ui_add}{\code{FilteredData$ui_add()}} +\item \href{#method-FilteredData-srv_add}{\code{FilteredData$srv_add()}} +\item \href{#method-FilteredData-ui_overview}{\code{FilteredData$ui_overview()}} +\item \href{#method-FilteredData-srv_overview}{\code{FilteredData$srv_overview()}} +\item \href{#method-FilteredData-handle_active_datanames}{\code{FilteredData$handle_active_datanames()}} +\item \href{#method-FilteredData-get_varlabels}{\code{FilteredData$get_varlabels()}} +\item \href{#method-FilteredData-get_varnames}{\code{FilteredData$get_varnames()}} +\item \href{#method-FilteredData-get_filterable_datanames}{\code{FilteredData$get_filterable_datanames()}} +\item \href{#method-FilteredData-get_filterable_varnames}{\code{FilteredData$get_filterable_varnames()}} +\item \href{#method-FilteredData-set_filterable_varnames}{\code{FilteredData$set_filterable_varnames()}} +\item \href{#method-FilteredData-get_formatted_filter_state}{\code{FilteredData$get_formatted_filter_state()}} +\item \href{#method-FilteredData-remove_all_filter_states}{\code{FilteredData$remove_all_filter_states()}} \item \href{#method-FilteredData-clone}{\code{FilteredData$clone()}} } } @@ -190,20 +146,20 @@ shiny::isolate(datasets$get_filter_state()) \subsection{Method \code{new()}}{ Initialize a \code{FilteredData} object \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$new(data_objects, join_keys = NULL, code = NULL, check = FALSE)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$new( + data_objects, + join_keys = teal.data::join_keys(), + code = NULL, + check = FALSE +)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{data_objects}}{(\code{list}) should contain. -\itemize{ -\item \code{dataset} data object object supported by \code{\link{FilteredDataset}}. -\item \code{metatada} (optional) additional metadata attached to the \code{dataset}. -\item \code{keys} (optional) primary keys. -\item \code{datalabel} (optional) label describing the \code{dataset}. -\item \code{parent} (optional) which \code{NULL} is a parent of this one. -}} +\item{\code{data_objects}}{(\code{list}) +should named elements containing \code{data.frame} or \code{MultiAssayExperiment}. +Names of the list will serve as \code{dataname}.} \item{\code{join_keys}}{(\code{JoinKeys} or NULL) see \code{\link[teal.data:join_keys]{teal.data::join_keys()}}.} @@ -218,16 +174,16 @@ Initialize a \code{FilteredData} object \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredData-datanames}{}}} \subsection{Method \code{datanames()}}{ -Gets datanames +Gets \code{datanames} -The datanames are returned in the order in which they must be +The \code{datanames} are returned in the order in which they must be evaluated (in case of dependencies). \subsection{Usage}{ \if{html}{\out{
}}\preformatted{FilteredData$datanames()}\if{html}{\out{
}} } \subsection{Returns}{ -(\code{character} vector) of datanames +(\code{character} vector) of \code{datanames} Gets data label for the dataset Useful to display in \verb{Show R Code}. @@ -253,70 +209,6 @@ Useful to display in \verb{Show R Code}. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-get_filterable_datanames}{}}} -\subsection{Method \code{get_filterable_datanames()}}{ -Gets dataset names of a given dataname for the filtering. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$get_filterable_datanames(dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character} vector) names of the dataset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character} vector) of dataset names -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-get_filterable_varnames}{}}} -\subsection{Method \code{get_filterable_varnames()}}{ -Gets variable names of a given dataname for the filtering. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$get_filterable_varnames(dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)}) name of the dataset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character} vector) of variable names -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-set_filterable_varnames}{}}} -\subsection{Method \code{set_filterable_varnames()}}{ -Set the variable names of a given dataset for the filtering. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$set_filterable_varnames(dataname, varnames)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)}) name of the dataset} - -\item{\code{varnames}}{(\code{character} or \code{NULL}) -variables which users can choose to filter the data; -see \code{self$get_filterable_varnames} for more details} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -this \code{FilteredData} object invisibly -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredData-get_call}{}}} \subsection{Method \code{get_call()}}{ @@ -372,28 +264,6 @@ Gets the R preprocessing code string that generates the unfiltered datasets. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-get_filtered_dataset}{}}} -\subsection{Method \code{get_filtered_dataset()}}{ -Gets \code{FilteredDataset} object which contains all information -pertaining to the specified dataset. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$get_filtered_dataset(dataname = character(0))}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)})\cr -name of the dataset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{FilteredDataset} object or list of \code{FilteredDataset}s -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredData-get_data}{}}} \subsection{Method \code{get_data()}}{ @@ -505,98 +375,38 @@ Get keys for the dataset. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-get_varlabels}{}}} -\subsection{Method \code{get_varlabels()}}{ -Gets labels of variables in the data. - -Variables are the column names of the data. -Either, all labels must have been provided for all variables -in \code{set_data} or \code{NULL}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$get_varlabels(dataname, variables = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)}) name of the dataset} - -\item{\code{variables}}{(\code{character}) variables to get labels for; -if \code{NULL}, for all variables in data} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character} or \code{NULL}) variable labels, \code{NULL} if \code{column_labels} -attribute does not exist for the data -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-get_varnames}{}}} -\subsection{Method \code{get_varnames()}}{ -Gets variable names. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$get_varnames(dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character}) the name of the dataset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character} vector) of variable names -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-handle_active_datanames}{}}} -\subsection{Method \code{handle_active_datanames()}}{ -When active_datanames is "all", sets them to all \code{datanames}, -otherwise, it makes sure that it is a subset of the available \code{datanames}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$handle_active_datanames(datanames)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{datanames}}{\verb{character vector} datanames to pick} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -the intersection of \code{self$datanames()} and \code{datanames} -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredData-set_dataset}{}}} \subsection{Method \code{set_dataset()}}{ Adds a dataset to this \code{FilteredData}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$set_dataset(dataset_args, dataname)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$set_dataset(data, dataname, metadata, label)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{dataset_args}}{(\code{list})\cr -containing the arguments except (\code{dataname}) -needed by \code{init_filtered_dataset}} +\item{\code{data}}{(\code{data.frame}, \code{MultiAssayExperiment})\cr +data to be filtered.} \item{\code{dataname}}{(\code{string})\cr the name of the \code{dataset} to be added to this object} + +\item{\code{metadata}}{(named \code{list} or \code{NULL}) \cr +Field containing metadata about the dataset. Each element of the list +should be atomic and length one.} + +\item{\code{label}}{(\code{character(1)})\cr +Label to describe the dataset} } \if{html}{\out{
}} } \subsection{Details}{ -\code{set_dataset} creates a \code{FilteredDataset} object which keeps -\code{dataset} for the filtering purpose. +\code{set_dataset} creates a \code{FilteredDataset} object which keeps \code{dataset} for the filtering purpose. +If this data has a parent specified in the \code{JoinKeys} object stored in \code{private$join_keys} +then created \code{FilteredDataset} (child) gets linked with other \code{FilteredDataset} (parent). +"Child" dataset return filtered data then dependent on the reactive filtered data of the +"parent". See more in documentation of \code{parent} argument in \code{FilteredDatasetDefault} constructor. } \subsection{Returns}{ @@ -668,67 +478,53 @@ preprocessing code that can be parsed to generate the unfiltered datasets} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredData-get_filter_state}{}}} \subsection{Method \code{get_filter_state()}}{ -Gets the reactive values from the active \code{FilterState} objects. - -Gets all active filters in the form of a nested list. -The output list is a compatible input to \code{self$set_filter_state}. -The attribute \code{formatted} renders the output of \code{self$get_formatted_filter_state}, -which is a character formatting of the filter state. +Gets states of all active \code{FilterState} objects. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{FilteredData$get_filter_state()}\if{html}{\out{
}} } \subsection{Returns}{ -\verb{named list} with elements corresponding to \code{FilteredDataset} objects -with active filters. In addition, the \code{formatted} attribute holds -the character format of the active filter states. +A \code{teal_slices} object. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-get_formatted_filter_state}{}}} -\subsection{Method \code{get_formatted_filter_state()}}{ -Returns the filter state formatted for printing to an \code{IO} device. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-format}{}}} +\subsection{Method \code{format()}}{ +Returns a formatted string representing this \code{FilteredData} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$get_formatted_filter_state()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$format(show_all = FALSE, trim_lines = TRUE)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{show_all}}{\code{logical(1)} passed to \code{format.teal_slice}} + +\item{\code{trim_lines}}{\code{logical(1)} passed to \code{format.teal_slice}} +} +\if{html}{\out{
}} +} \subsection{Returns}{ -\code{character} the pre-formatted filter state +\code{character(1)} the formatted string +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-print}{}}} +\subsection{Method \code{print()}}{ +Prints this \code{FilteredData} object. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$print(...)}\if{html}{\out{
}} } -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{utils::data(miniACC, package = "MultiAssayExperiment") -datasets <- teal.slice:::FilteredData$new( - list(iris = list(dataset = iris), - mae = list(dataset = miniACC) - ), - join_keys = NULL -) -fs <- list( - iris = list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) - ), - mae = list( - subjects = list( - years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - vital_status = list(selected = "1", keep_na = FALSE), - gender = list(selected = "female", keep_na = TRUE) - ), - RPPAArray = list( - subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) - ) - ) -) -isolate(datasets$set_filter_state(state = fs)) -cat(shiny::isolate(datasets$get_formatted_filter_state())) +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{...}}{additional arguments} } \if{html}{\out{
}} - } - } \if{html}{\out{
}} \if{html}{\out{}} @@ -742,13 +538,14 @@ Sets active filter states. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state}}{(\verb{named list})\cr -nested list of filter selections applied to datasets} +\item{\code{state}}{either a \verb{named list} list of filter selections +or a \code{teal_slices} object\cr +specification by list will be deprecated soon} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } \subsection{Examples}{ \if{html}{\out{
}} @@ -757,26 +554,22 @@ nested list of filter selections applied to datasets} datasets <- teal.slice:::FilteredData$new( list(iris = list(dataset = iris), mae = list(dataset = miniACC) - ), - join_keys = NULL -) -fs <- list( - iris = list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) - ), - mae = list( - subjects = list( - years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - vital_status = list(selected = "1", keep_na = FALSE), - gender = list(selected = "female", keep_na = TRUE) - ), - RPPAArray = list( - subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) - ) ) ) -shiny::isolate(datasets$set_filter_state(state = fs)) +fs <- + teal_slices( + teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4), + keep_na = TRUE, keep_inf = FALSE), + teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor"), + keep_na = FALSE), + teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(30, 50), + keep_na = TRUE, keep_inf = FALSE), + teal_slice(dataname = "mae", varname = "vital_status", selected = "1", keep_na = FALSE), + teal_slice(dataname = "mae", varname = "gender", selected = "female", keep_na = TRUE), + teal_slice(dataname = "mae", varname = "ARRAY_TYPE", + selected = "", keep_na = TRUE, datalabel = "RPPAArray", arg = "subset") + ) +datasets$set_filter_state(state = fs) shiny::isolate(datasets$get_filter_state()) } @@ -789,7 +582,7 @@ shiny::isolate(datasets$get_filter_state()) \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredData-remove_filter_state}{}}} \subsection{Method \code{remove_filter_state()}}{ -Removes one or more \code{FilterState} of a \code{FilteredDataset} in a \code{FilteredData} object. +Removes one or more \code{FilterState} from a \code{FilteredData} object. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{FilteredData$remove_filter_state(state)}\if{html}{\out{
}} } @@ -797,8 +590,9 @@ Removes one or more \code{FilterState} of a \code{FilteredDataset} in a \code{Fi \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state}}{(\verb{named list})\cr -nested list of filter selections applied to datasets} +\item{\code{state}}{(\code{teal_slices})\cr +specifying \code{FilterState} objects to remove; +\code{teal_slice}s may contain only \code{dataname} and \code{varname}, other elements are ignored} } \if{html}{\out{
}} } @@ -807,132 +601,179 @@ nested list of filter selections applied to datasets} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-remove_all_filter_states}{}}} -\subsection{Method \code{remove_all_filter_states()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-clear_filter_states}{}}} +\subsection{Method \code{clear_filter_states()}}{ Remove all \code{FilterStates} of a \code{FilteredDataset} or all \code{FilterStates} of a \code{FilteredData} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$remove_all_filter_states(datanames = self$datanames())}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$clear_filter_states(datanames = self$datanames())}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{datanames}}{(\code{character})\cr -datanames to remove their \code{FilterStates} or empty which removes +\code{datanames} to remove their \code{FilterStates} or empty which removes all \code{FilterStates} in the \code{FilteredData} object} } \if{html}{\out{
}} } \subsection{Returns}{ \code{NULL} invisibly + +Set external \code{teal_slice} + +Unlike adding new filter from the column, these filters can be added with some prespecified +settings. List of \code{teal_slices} should be a reactive so one can make this list to be dynamic. +List is accessible in \code{ui/srv_active} through \code{ui/srv_available_filters}. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-restore_state_from_bookmark}{}}} -\subsection{Method \code{restore_state_from_bookmark()}}{ -Sets this object from a bookmarked state. - -Only sets the filter state, does not set the data -and the preprocessing code. The data should already have been set. -Also checks the preprocessing code is identical if provided in the \code{state}. - -Since this function is used from the end-user part, its error messages -are more verbose. We don't call the Shiny modals from here because this -class may be used outside of a Shiny app. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-set_available_teal_slices}{}}} +\subsection{Method \code{set_available_teal_slices()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$restore_state_from_bookmark(state, check_data_hash = TRUE)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$set_available_teal_slices(x)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state}}{(\verb{named list})\cr -containing fields \code{data_hash}, \code{filter_states} and \code{preproc_code}} - -\item{\code{check_data_hash}}{(\code{logical}) whether to check that \code{md5sums} agree -for the data; may not make sense with randomly generated data per session} +\item{\code{x}}{(\code{reactive})\cr +should return \code{teal_slices}} } \if{html}{\out{
}} } +\subsection{Returns}{ +invisible \code{NULL} +Module for the right filter panel in the teal app +with a filter overview panel and a filter variable panel. + +This panel contains info about the number of observations left in +the (active) datasets and allows to filter the datasets. +} } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-filter_panel_disable}{}}} -\subsection{Method \code{filter_panel_disable()}}{ -Disable the filter panel by adding \code{disable} class to \code{filter_add_vars} -and \code{filter_panel_active_vars} tags in the User Interface. -In addition, it will store the existing filter states in a private field called \code{cached_states} -before removing all filter states from the object. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-ui_filter_panel}{}}} +\subsection{Method \code{ui_filter_panel()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$filter_panel_disable()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$ui_filter_panel(id)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{(\code{character(1)})\cr +module id} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{shiny.tag} +Server function for filter panel +} } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-filter_panel_enable}{}}} -\subsection{Method \code{filter_panel_enable()}}{ -enable the filter panel -Enable the filter panel by adding \code{enable} class to \code{filter_add_vars} -and \code{filter_active_vars} tags in the User Interface. -In addition, it will restore the filter states from a private field called \code{cached_states}. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-srv_filter_panel}{}}} +\subsection{Method \code{srv_filter_panel()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$filter_panel_enable()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$srv_filter_panel(id, active_datanames = self$datanames)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{(\code{character(1)})\cr +an ID string that corresponds with the ID used to call the module's UI function.} + +\item{\code{active_datanames}}{\verb{function / reactive} returning \code{datanames} that +should be shown on the filter panel, +must be a subset of the \code{datanames} argument provided to \code{ui_filter_panel}; +if the function returns \code{NULL} (as opposed to \code{character(0)}), the filter +panel will be hidden} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{moduleServer} function which returns \code{NULL} +} } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-get_filter_panel_active}{}}} -\subsection{Method \code{get_filter_panel_active()}}{ -Gets the state of filter panel, if activated. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-ui_active}{}}} +\subsection{Method \code{ui_active()}}{ +Server module responsible for displaying active filters. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$get_filter_panel_active()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$ui_active(id)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{(\code{character(1)})\cr +an ID string that corresponds with the ID used to call the module's UI function.} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{shiny.tag} +} } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-get_filter_panel_ui_id}{}}} -\subsection{Method \code{get_filter_panel_ui_id()}}{ -Gets the id of the filter panel UI. -Module for the right filter panel in the teal app -with a filter overview panel and a filter variable panel. - -This panel contains info about the number of observations left in -the (active) datasets and allows to filter the datasets. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-srv_active}{}}} +\subsection{Method \code{srv_active()}}{ +Server module responsible for displaying active filters. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$get_filter_panel_ui_id()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$srv_active(id, active_datanames = self$datanames)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{(\code{character(1)})\cr +an ID string that corresponds with the ID used to call the module's UI function.} + +\item{\code{active_datanames}}{(\code{reactive})\cr +defining subset of \code{self$datanames()} to be displayed.} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{moduleServer} returning \code{NULL} +} } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-ui_filter_panel}{}}} -\subsection{Method \code{ui_filter_panel()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-ui_add}{}}} +\subsection{Method \code{ui_add()}}{ +Server module responsible for displaying drop-downs with variables to add a filter. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$ui_filter_panel(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$ui_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{(\code{character(1)})\cr -module id -Server function for filter panel} +an ID string that corresponds with the ID used to call the module's UI function.} } \if{html}{\out{
}} } +\subsection{Returns}{ +\code{shiny.tag} +} } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-srv_filter_panel}{}}} -\subsection{Method \code{srv_filter_panel()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-srv_add}{}}} +\subsection{Method \code{srv_add()}}{ +Server module responsible for displaying drop-downs with variables to add a filter. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$srv_filter_panel(id, active_datanames = function() "all")}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$srv_add(id, active_datanames = reactive(self$datanames()))}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -941,16 +782,13 @@ Server function for filter panel} \item{\code{id}}{(\code{character(1)})\cr an ID string that corresponds with the ID used to call the module's UI function.} -\item{\code{active_datanames}}{\verb{function / reactive} returning datanames that -should be shown on the filter panel, -must be a subset of the \code{datanames} argument provided to \code{ui_filter_panel}; -if the function returns \code{NULL} (as opposed to \code{character(0)}), the filter -panel will be hidden} +\item{\code{active_datanames}}{(\code{reactive})\cr +defining subset of \code{self$datanames()} to be displayed.} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} +\code{moduleServer} returning \code{NULL} Creates the UI for the module showing counts for each dataset contrasting the filtered to the full unfiltered dataset @@ -960,11 +798,11 @@ the number of unique subjects. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-ui_filter_overview}{}}} -\subsection{Method \code{ui_filter_overview()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-ui_overview}{}}} +\subsection{Method \code{ui_overview()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$ui_filter_overview(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$ui_overview(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -978,11 +816,11 @@ data} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredData-srv_filter_overview}{}}} -\subsection{Method \code{srv_filter_overview()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-srv_overview}{}}} +\subsection{Method \code{srv_overview()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredData$srv_filter_overview(id, active_datanames = function() "all")}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredData$srv_overview(id, active_datanames = self$datanames)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -991,8 +829,8 @@ data} \item{\code{id}}{(\code{character(1)})\cr an ID string that corresponds with the ID used to call the module's UI function.} -\item{\code{active_datanames}}{(\code{function}, \code{reactive})\cr -returning datanames that should be shown on the filter panel, +\item{\code{active_datanames}}{(\code{reactive})\cr +returning \code{datanames} that should be shown on the filter panel, must be a subset of the \code{datanames} argument provided to \code{ui_filter_panel}; if the function returns \code{NULL} (as opposed to \code{character(0)}), the filter panel will be hidden.} @@ -1004,6 +842,148 @@ panel will be hidden.} } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-handle_active_datanames}{}}} +\subsection{Method \code{handle_active_datanames()}}{ +Method is deprecated. Provide resolved \code{active_datanames} to \code{srv_filter_panel} +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$handle_active_datanames(datanames)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{datanames}}{\verb{character vector} \code{datanames} to pick} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +the intersection of \code{self$datanames()} and \code{datanames} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-get_varlabels}{}}} +\subsection{Method \code{get_varlabels()}}{ +Method is deprecated. Please extract column labels directly from the data. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$get_varlabels(dataname, variables = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{dataname}}{(\code{character(1)}) name of the dataset} + +\item{\code{variables}}{(\code{character}) variables to get labels for; +if \code{NULL}, for all variables in data} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-get_varnames}{}}} +\subsection{Method \code{get_varnames()}}{ +Method is deprecated, Please extract variable names directly from the data instead +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$get_varnames(dataname)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{dataname}}{(\code{character}) the name of the dataset} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-get_filterable_datanames}{}}} +\subsection{Method \code{get_filterable_datanames()}}{ +Method is deprecated, please use \code{self$datanames()} instead +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$get_filterable_datanames()}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{dataname}}{(\code{character} vector) names of the dataset} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-get_filterable_varnames}{}}} +\subsection{Method \code{get_filterable_varnames()}}{ +Method is deprecated, please use \code{self$get_filter_state()} and retain \code{attr(, "filterable_varnames")} instead. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$get_filterable_varnames(dataname)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{dataname}}{(\code{character(1)}) name of the dataset} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-set_filterable_varnames}{}}} +\subsection{Method \code{set_filterable_varnames()}}{ +Method is deprecated, please use \code{self$set_filter_state} and \code{\link[=teal_slices]{teal_slices()}} with \code{include_varnames} instead. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$set_filterable_varnames(dataname, varnames)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{dataname}}{(\code{character(1)}) name of the dataset} + +\item{\code{varnames}}{(\code{character} or \code{NULL}) +variables which users can choose to filter the data; +see \code{self$get_filterable_varnames} for more details} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-get_formatted_filter_state}{}}} +\subsection{Method \code{get_formatted_filter_state()}}{ +Method is deprecated, please use \code{format.teal_slices} on object returned from \code{self$get_filter_state()} +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$get_formatted_filter_state()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredData-remove_all_filter_states}{}}} +\subsection{Method \code{remove_all_filter_states()}}{ +Deprecated - please use \code{clear_filter_states} method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredData$remove_all_filter_states(datanames)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{datanames}}{(\code{character})} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +\code{NULL} invisibly +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredData-clone}{}}} \subsection{Method \code{clone()}}{ diff --git a/man/FilteredDataset.Rd b/man/FilteredDataset.Rd index 77db2a561..b45da07af 100644 --- a/man/FilteredDataset.Rd +++ b/man/FilteredDataset.Rd @@ -15,26 +15,23 @@ components of the dataset. \subsection{Public methods}{ \itemize{ \item \href{#method-FilteredDataset-new}{\code{FilteredDataset$new()}} -\item \href{#method-FilteredDataset-get_formatted_filter_state}{\code{FilteredDataset$get_formatted_filter_state()}} -\item \href{#method-FilteredDataset-state_lists_empty}{\code{FilteredDataset$state_lists_empty()}} +\item \href{#method-FilteredDataset-format}{\code{FilteredDataset$format()}} +\item \href{#method-FilteredDataset-print}{\code{FilteredDataset$print()}} +\item \href{#method-FilteredDataset-clear_filter_states}{\code{FilteredDataset$clear_filter_states()}} \item \href{#method-FilteredDataset-get_call}{\code{FilteredDataset$get_call()}} \item \href{#method-FilteredDataset-get_filter_state}{\code{FilteredDataset$get_filter_state()}} -\item \href{#method-FilteredDataset-get_filter_states}{\code{FilteredDataset$get_filter_states()}} +\item \href{#method-FilteredDataset-set_filter_state}{\code{FilteredDataset$set_filter_state()}} \item \href{#method-FilteredDataset-get_filter_count}{\code{FilteredDataset$get_filter_count()}} \item \href{#method-FilteredDataset-get_dataname}{\code{FilteredDataset$get_dataname()}} \item \href{#method-FilteredDataset-get_dataset}{\code{FilteredDataset$get_dataset()}} \item \href{#method-FilteredDataset-get_metadata}{\code{FilteredDataset$get_metadata()}} -\item \href{#method-FilteredDataset-get_filter_overview_info}{\code{FilteredDataset$get_filter_overview_info()}} +\item \href{#method-FilteredDataset-get_filter_overview}{\code{FilteredDataset$get_filter_overview()}} \item \href{#method-FilteredDataset-get_keys}{\code{FilteredDataset$get_keys()}} -\item \href{#method-FilteredDataset-get_varlabels}{\code{FilteredDataset$get_varlabels()}} \item \href{#method-FilteredDataset-get_dataset_label}{\code{FilteredDataset$get_dataset_label()}} -\item \href{#method-FilteredDataset-get_varnames}{\code{FilteredDataset$get_varnames()}} -\item \href{#method-FilteredDataset-get_filterable_varnames}{\code{FilteredDataset$get_filterable_varnames()}} -\item \href{#method-FilteredDataset-set_filterable_varnames}{\code{FilteredDataset$set_filterable_varnames()}} -\item \href{#method-FilteredDataset-ui}{\code{FilteredDataset$ui()}} -\item \href{#method-FilteredDataset-server}{\code{FilteredDataset$server()}} -\item \href{#method-FilteredDataset-ui_add_filter_state}{\code{FilteredDataset$ui_add_filter_state()}} -\item \href{#method-FilteredDataset-srv_add_filter_state}{\code{FilteredDataset$srv_add_filter_state()}} +\item \href{#method-FilteredDataset-ui_active}{\code{FilteredDataset$ui_active()}} +\item \href{#method-FilteredDataset-srv_active}{\code{FilteredDataset$srv_active()}} +\item \href{#method-FilteredDataset-ui_add}{\code{FilteredDataset$ui_add()}} +\item \href{#method-FilteredDataset-srv_add}{\code{FilteredDataset$srv_add()}} \item \href{#method-FilteredDataset-clone}{\code{FilteredDataset$clone()}} } } @@ -76,26 +73,51 @@ should be atomic and length one.} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-get_formatted_filter_state}{}}} -\subsection{Method \code{get_formatted_filter_state()}}{ -Returns a string representation of the filter state in this \code{FilteredDataset}. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-format}{}}} +\subsection{Method \code{format()}}{ +Returns a formatted string representing this \code{FilteredDataset} object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$get_formatted_filter_state()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$format(show_all = FALSE, trim_lines = TRUE)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{show_all}}{\code{logical(1)} passed to \code{format.teal_slice}} + +\item{\code{trim_lines}}{\code{logical(1)} passed to \code{format.teal_slice}} +} +\if{html}{\out{
}} +} \subsection{Returns}{ -\code{character(1)} the formatted string representing the filter state or -\code{NULL} if no filter state is present. +\code{character(1)} the formatted string +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-print}{}}} +\subsection{Method \code{print()}}{ +Prints this \code{FilteredDataset} object. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{FilteredDataset$print(...)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{...}}{additional arguments} +} +\if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-state_lists_empty}{}}} -\subsection{Method \code{state_lists_empty()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-clear_filter_states}{}}} +\subsection{Method \code{clear_filter_states()}}{ Removes all active filter items applied to this dataset \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$state_lists_empty()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$clear_filter_states()}\if{html}{\out{
}} } \subsection{Returns}{ @@ -112,49 +134,53 @@ This functions returns filter calls equivalent to selected items within each of \code{filter_states}. Configuration of the calls is constant and depends on \code{filter_states} type and order which are set during initialization. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$get_call()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$get_call(sid = "")}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{sid}}{(\code{character})\cr +when specified then method returns code containing filter conditions of +\code{FilterState} objects which \code{"sid"} attribute is different than this \code{sid} argument.} +} +\if{html}{\out{
}} +} \subsection{Returns}{ filter \code{call} or \code{list} of filter calls -Gets the reactive values from the active \code{FilterState} objects. - -Get all active filters from this dataset in form of the nested list. -The output list is a compatible input to \code{self$set_filter_state}. } } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredDataset-get_filter_state}{}}} \subsection{Method \code{get_filter_state()}}{ +Gets states of all active \code{FilterState} objects \subsection{Usage}{ \if{html}{\out{
}}\preformatted{FilteredDataset$get_filter_state()}\if{html}{\out{
}} } \subsection{Returns}{ -\code{list} with named elements corresponding to \code{FilterStates} objects -with active filters. +A \code{teal_slices} object. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-get_filter_states}{}}} -\subsection{Method \code{get_filter_states()}}{ -Gets the active \code{FilterStates} objects. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-set_filter_state}{}}} +\subsection{Method \code{set_filter_state()}}{ +Set filter state \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$get_filter_states(id = character(0))}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$set_filter_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{id}}{(\code{character(1)}, \code{character(0)})\cr -the id of the \code{private$filter_states} list element where \code{FilterStates} is kept.} +\item{\code{state}}{(\code{teal_slice}) object} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{FilterStates} or \code{list} of \code{FilterStates} objects. +\code{NULL} invisibly } } \if{html}{\out{
}} @@ -174,9 +200,7 @@ Gets the number of active \code{FilterState} objects in all \code{FilterStates} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredDataset-get_dataname}{}}} \subsection{Method \code{get_dataname()}}{ -Get name of the dataset - -Get name of the dataset +Gets the name of the dataset \subsection{Usage}{ \if{html}{\out{
}}\preformatted{FilteredDataset$get_dataname()}\if{html}{\out{
}} } @@ -191,11 +215,19 @@ Get name of the dataset \subsection{Method \code{get_dataset()}}{ Gets the dataset object in this \code{FilteredDataset} \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$get_dataset()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$get_dataset(filtered = FALSE)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{filtered}}{(\code{logical(1)})\cr} +} +\if{html}{\out{
}} +} \subsection{Returns}{ -\code{data.frame} or \code{MultiAssayExperiment} +\code{data.frame} or \code{MultiAssayExperiment}, either raw +or as a reactive with current filters applied } } \if{html}{\out{
}} @@ -212,14 +244,14 @@ named \code{list} or \code{NULL} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-get_filter_overview_info}{}}} -\subsection{Method \code{get_filter_overview_info()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-get_filter_overview}{}}} +\subsection{Method \code{get_filter_overview()}}{ Get filter overview rows of a dataset The output shows the comparison between \code{filtered_dataset} function parameter and the dataset inside self \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$get_filter_overview_info(filtered_dataset = self$get_dataset())}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$get_filter_overview()}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -232,7 +264,7 @@ is used.} \if{html}{\out{
}} } \subsection{Returns}{ -(\code{matrix}) matrix of observations and subjects +(\code{data.frame}) matrix of observations and subjects } } \if{html}{\out{
}} @@ -249,32 +281,6 @@ Gets the keys for the dataset of this \code{FilteredDataset} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-get_varlabels}{}}} -\subsection{Method \code{get_varlabels()}}{ -Gets labels of variables in the data - -Variables are the column names of the data. -Either, all labels must have been provided for all variables -in \code{set_data} or \code{NULL}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$get_varlabels(variables = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{variables}}{(\code{character} vector) variables to get labels for; -if \code{NULL}, for all variables in data} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character} or \code{NULL}) variable labels, \code{NULL} if \code{column_labels} -attribute does not exist for the data -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-FilteredDataset-get_dataset_label}{}}} \subsection{Method \code{get_dataset_label()}}{ @@ -288,72 +294,15 @@ Gets the dataset label } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-get_varnames}{}}} -\subsection{Method \code{get_varnames()}}{ -Gets variable names from dataset -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$get_varnames()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character} the variable names -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-get_filterable_varnames}{}}} -\subsection{Method \code{get_filterable_varnames()}}{ -Gets variable names for the filtering. - -It takes the intersection of the column names -of the data and \code{private$filterable_varnames} if -\code{private$filterable_varnames} has positive length -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$get_filterable_varnames()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -(\code{character} vector) of variable names -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-set_filterable_varnames}{}}} -\subsection{Method \code{set_filterable_varnames()}}{ -Set the allowed filterable variables -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$set_filterable_varnames(varnames)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{varnames}}{(\code{character} or \code{NULL}) The variables which can be filtered -See \code{self$get_filterable_varnames} for more details} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -When retrieving the filtered variables only -those which have filtering supported (i.e. are of the permitted types) -are included. -} - -\subsection{Returns}{ -invisibly this \code{FilteredDataset} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-ui}{}}} -\subsection{Method \code{ui()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-ui_active}{}}} +\subsection{Method \code{ui_active()}}{ UI module for dataset active filters UI module containing dataset active filters along with title and remove button. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$ui(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$ui_active(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -369,14 +318,14 @@ function - shiny UI module } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-server}{}}} -\subsection{Method \code{server()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-srv_active}{}}} +\subsection{Method \code{srv_active()}}{ Server module for a dataset active filters Server module managing a active filters. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$server(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$srv_active(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -392,14 +341,14 @@ an ID string that corresponds with the ID used to call the module's UI function. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-ui_add_filter_state}{}}} -\subsection{Method \code{ui_add_filter_state()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-ui_add}{}}} +\subsection{Method \code{ui_add()}}{ UI module to add filter variable for this dataset UI module to add filter variable for this dataset \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$ui_add_filter_state(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$ui_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -415,14 +364,18 @@ function - shiny UI module } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-FilteredDataset-srv_add_filter_state}{}}} -\subsection{Method \code{srv_add_filter_state()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-FilteredDataset-srv_add}{}}} +\subsection{Method \code{srv_add()}}{ Server module to add filter variable for this dataset -Server module to add filter variable for this dataset +Server module to add filter variable for this dataset. +For this class \code{srv_add} calls multiple modules +of the same name from \code{FilterStates} as \code{MAEFilteredDataset} +contains one \code{FilterStates} object for \code{colData} and one for each +experiment. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{FilteredDataset$srv_add_filter_state(id, ...)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{FilteredDataset$srv_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -430,13 +383,11 @@ Server module to add filter variable for this dataset \describe{ \item{\code{id}}{(\code{character(1)})\cr an ID string that corresponds with the ID used to call the module's UI function.} - -\item{\code{...}}{ignored} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{moduleServer} function. +\code{moduleServer} function which returns \code{NULL} } } \if{html}{\out{
}} diff --git a/man/LogicalFilterState.Rd b/man/LogicalFilterState.Rd index 7777ad137..c06fe5c8d 100644 --- a/man/LogicalFilterState.Rd +++ b/man/LogicalFilterState.Rd @@ -4,45 +4,37 @@ \name{LogicalFilterState} \alias{LogicalFilterState} \title{\code{FilterState} object for logical variable} -\value{ -invisibly \code{NULL}. -} \description{ Manages choosing a logical state } -\note{ -Casts the passed object to \code{logical} before validating the input -making it possible to pass any object coercible to \code{logical} to this method. -} \examples{ filter_state <- teal.slice:::LogicalFilterState$new( - sample(c(TRUE, FALSE, NA), 10, replace = TRUE), - varname = "x", - dataname = "data", - extract_type = character(0) + x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE), + slice = teal_slice(varname = "x", dataname = "data") ) -isolate(filter_state$get_call()) - -isolate(filter_state$set_selected(TRUE)) -isolate(filter_state$set_keep_na(TRUE)) -isolate(filter_state$get_call()) +shiny::isolate(filter_state$get_call()) +filter_state$set_state( + teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE) +) +shiny::isolate(filter_state$get_call()) -\dontrun{ # working filter in an app library(shiny) +library(shinyjs) data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA) -filter_state_logical <- LogicalFilterState$new( +fs <- teal.slice:::LogicalFilterState$new( x = data_logical, - varname = "variable", - varlabel = "label" + slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE) ) -filter_state_logical$set_state(list(selected = FALSE, keep_na = TRUE)) ui <- fluidPage( + useShinyjs(), + teal.slice:::include_css_files(pattern = "filter-panel"), + teal.slice:::include_js_files(pattern = "count-bar-labels"), column(4, div( h4("LogicalFilterState"), - isolate(filter_state_logical$ui("fs")) + fs$ui("fs") )), column(4, div( id = "outputs", # div id is needed for toggling the element @@ -63,32 +55,35 @@ ui <- fluidPage( ) server <- function(input, output, session) { - filter_state_logical$server("fs") - output$condition_logical <- renderPrint(filter_state_logical$get_call()) - output$formatted_logical <- renderText(filter_state_logical$format()) - output$unformatted_logical <- renderPrint(filter_state_logical$get_state()) + fs$server("fs") + output$condition_logical <- renderPrint(fs$get_call()) + output$formatted_logical <- renderText(fs$format()) + output$unformatted_logical <- renderPrint(fs$get_state()) # modify filter state programmatically - observeEvent(input$button1_logical, filter_state_logical$set_keep_na(FALSE)) - observeEvent(input$button2_logical, filter_state_logical$set_keep_na(TRUE)) - observeEvent(input$button3_logical, filter_state_logical$set_selected(TRUE)) + observeEvent( + input$button1_logical, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) + ) + observeEvent( + input$button2_logical, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) + ) + observeEvent( + input$button3_logical, + fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE)) + ) observeEvent( input$button0_logical, - filter_state_logical$set_state(list(selected = FALSE, keep_na = TRUE)) + fs$set_state( + teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE) + ) ) } if (interactive()) { shinyApp(ui, server) } -} - - -## ------------------------------------------------ -## Method `LogicalFilterState$set_selected` -## ------------------------------------------------ -filter <- teal.slice:::LogicalFilterState$new(c(TRUE), varname = "name") -filter$set_selected(TRUE) } \keyword{internal} \section{Super class}{ @@ -98,9 +93,7 @@ filter$set_selected(TRUE) \subsection{Public methods}{ \itemize{ \item \href{#method-LogicalFilterState-new}{\code{LogicalFilterState$new()}} -\item \href{#method-LogicalFilterState-is_any_filtered}{\code{LogicalFilterState$is_any_filtered()}} \item \href{#method-LogicalFilterState-get_call}{\code{LogicalFilterState$get_call()}} -\item \href{#method-LogicalFilterState-set_selected}{\code{LogicalFilterState$set_selected()}} \item \href{#method-LogicalFilterState-clone}{\code{LogicalFilterState$clone()}} } } @@ -109,16 +102,9 @@ filter$set_selected(TRUE) @@ -132,10 +118,9 @@ Initialize a \code{FilterState} object \subsection{Usage}{ \if{html}{\out{
}}\preformatted{LogicalFilterState$new( x, - varname, - varlabel = character(0), - dataname = NULL, - extract_type = character(0) + x_reactive = reactive(NULL), + extract_type = character(0), + slice )}\if{html}{\out{
}} } @@ -145,40 +130,33 @@ Initialize a \code{FilterState} object \item{\code{x}}{(\code{logical})\cr values of the variable used in filter} -\item{\code{varname}}{(\code{character}, \code{name})\cr -label of the variable (optional).} - -\item{\code{varlabel}}{(\code{character(1)})\cr -label of the variable (optional).} - -\item{\code{dataname}}{(\code{character(1)})\cr -optional name of dataset where \code{x} is taken from} +\item{\code{x_reactive}}{(\code{reactive})\cr +returning vector of the same type as \code{x}. Is used to update +counts following the change in values of the filtered dataset. +If it is set to \code{reactive(NULL)} then counts based on filtered +dataset are not shown.} \item{\code{extract_type}}{(\code{character(0)}, \code{character(1)})\cr -whether condition calls should be prefixed by dataname. Possible values: +whether condition calls should be prefixed by \code{dataname}. Possible values: \itemize{ \item{\code{character(0)} (default)}{ \code{varname} in the condition call will not be prefixed} \item{\code{"list"}}{ \code{varname} in the condition call will be returned as \verb{$}} \item{\code{"matrix"}}{ \code{varname} in the condition call will be returned as \verb{[, ]}} }} + +\item{\code{slice}}{(\code{teal_slice})\cr +object created using \code{\link[=teal_slice]{teal_slice()}}. \code{teal_slice} is stored +in the class and \code{set_state} directly manipulates values within \code{teal_slice}. \code{get_state} +returns \code{teal_slice} object which can be reused in other places. Beware, that \code{teal_slice} +is a \code{reactiveValues} which means that changes in particular object are automatically +reflected in all places which refer to the same \code{teal_slice}.} + +\item{\code{...}}{additional arguments to be saved as a list in \code{private$extras} field} } \if{html}{\out{}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-LogicalFilterState-is_any_filtered}{}}} -\subsection{Method \code{is_any_filtered()}}{ -Answers the question of whether the current settings and values selected actually filters out any values. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{LogicalFilterState$is_any_filtered()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -logical scalar -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-LogicalFilterState-get_call}{}}} \subsection{Method \code{get_call()}}{ @@ -186,36 +164,19 @@ Returns reproducible condition call for current selection. For \code{LogicalFilterState} it's a \verb{!} or \verb{} and optionally \verb{is.na()} \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{LogicalFilterState$get_call()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-LogicalFilterState-set_selected}{}}} -\subsection{Method \code{set_selected()}}{ -Sets the selected values of this \code{LogicalFilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{LogicalFilterState$set_selected(value)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{LogicalFilterState$get_call(dataname)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{value}}{(\code{logical(1)})\cr -the value to set. Must not contain the NA value.} +\item{\code{dataname}}{name of data set; defaults to \code{private$get_dataname()}} } \if{html}{\out{
}} } -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{filter <- teal.slice:::LogicalFilterState$new(c(TRUE), varname = "name") -filter$set_selected(TRUE) -} -\if{html}{\out{
}} - +\subsection{Returns}{ +(\code{call}) } - } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/MAEFilterStates.Rd b/man/MAEFilterStates.Rd index 88e934669..f9408afe0 100644 --- a/man/MAEFilterStates.Rd +++ b/man/MAEFilterStates.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/FilterStatesMAE.R \name{MAEFilterStates} \alias{MAEFilterStates} -\title{\code{FilterStates} subclass for MultiAssayExperiments} +\title{\code{FilterStates} subclass for \code{MultiAssayExperiments}} \description{ Handles filter states in a \code{MultiAssayExperiment} } @@ -14,29 +14,23 @@ Handles filter states in a \code{MultiAssayExperiment} \subsection{Public methods}{ \itemize{ \item \href{#method-MAEFilterStates-new}{\code{MAEFilterStates$new()}} -\item \href{#method-MAEFilterStates-format}{\code{MAEFilterStates$format()}} -\item \href{#method-MAEFilterStates-get_fun}{\code{MAEFilterStates$get_fun()}} -\item \href{#method-MAEFilterStates-server}{\code{MAEFilterStates$server()}} -\item \href{#method-MAEFilterStates-get_filter_state}{\code{MAEFilterStates$get_filter_state()}} -\item \href{#method-MAEFilterStates-set_filter_state}{\code{MAEFilterStates$set_filter_state()}} -\item \href{#method-MAEFilterStates-remove_filter_state}{\code{MAEFilterStates$remove_filter_state()}} -\item \href{#method-MAEFilterStates-ui_add_filter_state}{\code{MAEFilterStates$ui_add_filter_state()}} -\item \href{#method-MAEFilterStates-srv_add_filter_state}{\code{MAEFilterStates$srv_add_filter_state()}} \item \href{#method-MAEFilterStates-clone}{\code{MAEFilterStates$clone()}} } } \if{html}{\out{
Inherited methods
}} @@ -48,209 +42,42 @@ Initializes \code{MAEFilterStates} object Initialize \code{MAEFilterStates} object \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$new(dataname, datalabel, varlabels, keys)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{MAEFilterStates$new( + data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = "subjects", + keys = character(0) +)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ +\item{\code{data}}{(\code{MultiAssayExperiment})\cr +the R object which \code{MultiAssayExperiment::subsetByColData} function is applied on.} + +\item{\code{data_reactive}}{(\verb{function(sid)})\cr +should return a \code{MultiAssayExperiment} object or \code{NULL}. +This object is needed for the \code{FilterState} counts being updated +on a change in filters. If function returns \code{NULL} then filtered counts are not shown. +Function has to have \code{sid} argument being a character.} + \item{\code{dataname}}{(\code{character(1)})\cr name of the data used in the expression specified to the function argument attached to this \code{FilterStates}.} -\item{\code{datalabel}}{(\code{character(0)} or \code{character(1)})\cr -text label value.} - -\item{\code{varlabels}}{(\code{character})\cr -labels of the variables used in this object} +\item{\code{datalabel}}{(\code{NULL} or \code{character(1)})\cr +text label value} \item{\code{keys}}{(\code{character})\cr key columns names} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilterStates-format}{}}} -\subsection{Method \code{format()}}{ -Returns the formatted string representing this \code{MAEFilterStates} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$format(indent = 0)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{indent}}{(\code{numeric(1)}) the number of spaces before each line of the representation} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{character(1)} the formatted string -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilterStates-get_fun}{}}} -\subsection{Method \code{get_fun()}}{ -Returns function name used to create filter call. -For \code{MAEFilterStates} \code{MultiAssayExperiment::subsetByColData} is used. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$get_fun()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{character(1)} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilterStates-server}{}}} -\subsection{Method \code{server()}}{ -Server module -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$server(id)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -an ID string that corresponds with the ID used to call the module's UI function.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilterStates-get_filter_state}{}}} -\subsection{Method \code{get_filter_state()}}{ -Returns active \code{FilterState} objects. - -Gets all active filters from this dataset in form of the nested list. -The output list can be used as input to \code{self$set_filter_state}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$get_filter_state()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{list} with elements number equal number of \code{FilterStates}. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilterStates-set_filter_state}{}}} -\subsection{Method \code{set_filter_state()}}{ -Set filter state -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$set_filter_state(data, state, ...)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{data}}{(\code{MultiAssayExperiment})\cr -data which are supposed to be filtered.} - -\item{\code{state}}{(\verb{named list})\cr -should contain values which are initial selection in the \code{FilterState}. -Names of the \code{list} element should correspond to the name of the -column in \code{colData(data)}.} - -\item{\code{...}}{ignored.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilterStates-remove_filter_state}{}}} -\subsection{Method \code{remove_filter_state()}}{ -Removes a variable from the \code{state_list} and its corresponding UI element. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$remove_filter_state(state_id)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{state_id}}{(\code{character(1)})\cr name of \code{state_list} element.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilterStates-ui_add_filter_state}{}}} -\subsection{Method \code{ui_add_filter_state()}}{ -Shiny UI module to add filter variable -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$ui_add_filter_state(id, data)}\if{html}{\out{
}} -} -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -id of shiny module} - -\item{\code{data}}{(\code{MultiAssayExperiment})\cr -object containing \code{colData} which columns are used to be used -to choose filter variables} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{shiny.tag} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilterStates-srv_add_filter_state}{}}} -\subsection{Method \code{srv_add_filter_state()}}{ -Shiny server module to add filter variable. - -Module controls available choices to select as a filter variable. -Selected filter variable is being removed from available choices. -Removed filter variable gets back to available choices. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilterStates$srv_add_filter_state(id, data, ...)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -an ID string that corresponds with the ID used to call the module's UI function.} - -\item{\code{data}}{(\code{MultiAssayExperiment})\cr -object containing \code{colData} which columns are used to choose filter variables in -\code{\link[teal.widgets:optionalSelectInput]{teal.widgets::optionalSelectInput()}}.} - -\item{\code{...}}{ignored} +\item{\code{varlabels}}{(\code{character})\cr +labels of the variables used in this object} } \if{html}{\out{
}} } -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} - -description -Get label of specific variable. In case when variable label is missing -name of the variable is returned. -parameter variable (\code{character})\cr -name of the variable for which label should be returned -return \code{character} -} } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/MAEFilteredDataset.Rd b/man/MAEFilteredDataset.Rd index 70c98ba60..4036447a7 100644 --- a/man/MAEFilteredDataset.Rd +++ b/man/MAEFilteredDataset.Rd @@ -16,18 +16,23 @@ utils::data(miniACC, package = "MultiAssayExperiment") dataset <- teal.slice:::MAEFilteredDataset$new(miniACC, "MAE") -fs <- list( - subjects = list( - years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - vital_status = list(selected = "1", keep_na = FALSE), - gender = list(selected = "female", keep_na = TRUE) +fs <- teal_slices( + teal_slice( + dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE ), - RPPAArray = list( - subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) + teal_slice( + dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE + ), + teal_slice( + dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE + ), + teal_slice( + dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE ) ) -shiny::isolate(dataset$set_filter_state(state = fs)) +dataset$set_filter_state(state = fs) shiny::isolate(dataset$get_filter_state()) + } \keyword{internal} \section{Super class}{ @@ -37,35 +42,30 @@ shiny::isolate(dataset$get_filter_state()) \subsection{Public methods}{ \itemize{ \item \href{#method-MAEFilteredDataset-new}{\code{MAEFilteredDataset$new()}} -\item \href{#method-MAEFilteredDataset-get_call}{\code{MAEFilteredDataset$get_call()}} -\item \href{#method-MAEFilteredDataset-get_varlabels}{\code{MAEFilteredDataset$get_varlabels()}} -\item \href{#method-MAEFilteredDataset-get_filter_overview_info}{\code{MAEFilteredDataset$get_filter_overview_info()}} -\item \href{#method-MAEFilteredDataset-get_filterable_varnames}{\code{MAEFilteredDataset$get_filterable_varnames()}} \item \href{#method-MAEFilteredDataset-set_filter_state}{\code{MAEFilteredDataset$set_filter_state()}} \item \href{#method-MAEFilteredDataset-remove_filter_state}{\code{MAEFilteredDataset$remove_filter_state()}} -\item \href{#method-MAEFilteredDataset-ui_add_filter_state}{\code{MAEFilteredDataset$ui_add_filter_state()}} -\item \href{#method-MAEFilteredDataset-srv_add_filter_state}{\code{MAEFilteredDataset$srv_add_filter_state()}} -\item \href{#method-MAEFilteredDataset-get_filter_overview_nsubjs}{\code{MAEFilteredDataset$get_filter_overview_nsubjs()}} +\item \href{#method-MAEFilteredDataset-ui_add}{\code{MAEFilteredDataset$ui_add()}} +\item \href{#method-MAEFilteredDataset-get_filter_overview}{\code{MAEFilteredDataset$get_filter_overview()}} \item \href{#method-MAEFilteredDataset-clone}{\code{MAEFilteredDataset$clone()}} } } \if{html}{\out{
Inherited methods
}} @@ -107,97 +107,12 @@ each element of the list must be atomic and length one} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-get_call}{}}} -\subsection{Method \code{get_call()}}{ -Get filter expression - -This functions returns filter calls equivalent to selected items -within each of \code{filter_states}. Configuration of the calls is constant and -depends on \code{filter_states} type and order which are set during initialization. -This class contains multiple \code{FilterStates}: -\itemize{ -\item{\code{colData(dataset)}}{for this object single \code{MAEFilterStates} -which returns \code{subsetByColData} call} -\item{experiments}{for each experiment single \code{SEFilterStates} and -\code{FilterStates_matrix}, both returns \code{subset} call} -} -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$get_call()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -filter \code{call} or \code{list} of filter calls -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-get_varlabels}{}}} -\subsection{Method \code{get_varlabels()}}{ -Gets labels of variables in the data - -Variables are the column names of the data. -Either, all labels must have been provided for all variables -in \code{set_data} or \code{NULL}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$get_varlabels(variables = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{variables}}{(\code{character} vector) variables to get labels for; -if \code{NULL}, for all variables in data} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character} or \code{NULL}) variable labels, \code{NULL} if \code{column_labels} -attribute does not exist for the data -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-get_filter_overview_info}{}}} -\subsection{Method \code{get_filter_overview_info()}}{ -Get filter overview rows of a dataset -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$get_filter_overview_info( - filtered_dataset = self$get_dataset() -)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{filtered_dataset}}{(\code{MultiAssayExperiment}) object to calculate filter overview statistics on.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{matrix}) matrix of observations and subjects -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-get_filterable_varnames}{}}} -\subsection{Method \code{get_filterable_varnames()}}{ -Gets variable names for the filtering. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$get_filterable_varnames()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -(\code{character(0)}) -} -} -\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-MAEFilteredDataset-set_filter_state}{}}} \subsection{Method \code{set_filter_state()}}{ Set filter state \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$set_filter_state(state, ...)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{MAEFilteredDataset$set_filter_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -208,30 +123,33 @@ names of the list should correspond to the names of the initialized \code{Filter kept in \code{private$filter_states}. For this object they are \code{"subjects"} and names of the experiments. Values of initial state should be relevant to the referred column.} - -\item{\code{...}}{ignored.} } \if{html}{\out{}} } \subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } \subsection{Examples}{ \if{html}{\out{
}} \preformatted{utils::data(miniACC, package = "MultiAssayExperiment") dataset <- teal.slice:::MAEFilteredDataset$new(miniACC, "MAE") -fs <- list( - subjects = list( - years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - vital_status = list(selected = "1", keep_na = FALSE), - gender = list(selected = "female", keep_na = TRUE) +fs <- teal_slices( + teal_slice( + dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE + ), + teal_slice( + dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE + ), + teal_slice( + dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE ), - RPPAArray = list( - subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) + teal_slice( + dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE ) ) -shiny::isolate(dataset$set_filter_state(state = fs)) +dataset$set_filter_state(state = fs) shiny::isolate(dataset$get_filter_state()) + } \if{html}{\out{
}} @@ -244,30 +162,31 @@ shiny::isolate(dataset$get_filter_state()) \subsection{Method \code{remove_filter_state()}}{ Remove one or more \code{FilterState} of a \code{MAEFilteredDataset} \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$remove_filter_state(state_id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{MAEFilteredDataset$remove_filter_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state_id}}{(\code{list})\cr -Named list of variables to remove their \code{FilterState}.} +\item{\code{state}}{(\code{teal_slices})\cr +specifying \code{FilterState} objects to remove; +\code{teal_slice}s may contain only \code{dataname} and \code{varname}, other elements are ignored} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-ui_add_filter_state}{}}} -\subsection{Method \code{ui_add_filter_state()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-ui_add}{}}} +\subsection{Method \code{ui_add()}}{ UI module to add filter variable for this dataset UI module to add filter variable for this dataset \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$ui_add_filter_state(id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{MAEFilteredDataset$ui_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -283,57 +202,16 @@ function - shiny UI module } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-srv_add_filter_state}{}}} -\subsection{Method \code{srv_add_filter_state()}}{ -Server module to add filter variable for this dataset - -Server module to add filter variable for this dataset. -For this class \code{srv_add_filter_state} calls multiple modules -of the same name from \code{FilterStates} as \code{MAEFilteredDataset} -contains one \code{FilterStates} object for \code{colData} and one for each -experiment. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$srv_add_filter_state(id, ...)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -an ID string that corresponds with the ID used to call the module's UI function.} - -\item{\code{...}}{ignored.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-get_filter_overview_nsubjs}{}}} -\subsection{Method \code{get_filter_overview_nsubjs()}}{ -Gets filter overview subjects number +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-MAEFilteredDataset-get_filter_overview}{}}} +\subsection{Method \code{get_filter_overview()}}{ +Get filter overview rows of a dataset \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MAEFilteredDataset$get_filter_overview_nsubjs( - filtered_dataset = self$get_dataset(), - subject_keys -)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{MAEFilteredDataset$get_filter_overview()}\if{html}{\out{
}} } -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{filtered_dataset}}{(\code{MultiAssayExperiment}) object to calculate filter overview statistics on.} - -\item{\code{subject_keys}}{(unused) in \code{MultiAssayExperiment} unique subjects are the rows of \code{colData} slot.} -} -\if{html}{\out{
}} -} \subsection{Returns}{ -\code{list} with the number of subjects of filtered/non-filtered datasets. +(\code{matrix}) matrix of observations and subjects } } \if{html}{\out{
}} diff --git a/man/MatrixFilterStates.Rd b/man/MatrixFilterStates.Rd index 976010078..e4e5bc921 100644 --- a/man/MatrixFilterStates.Rd +++ b/man/MatrixFilterStates.Rd @@ -14,29 +14,23 @@ Handles filter states in a \code{matrix} \subsection{Public methods}{ \itemize{ \item \href{#method-MatrixFilterStates-new}{\code{MatrixFilterStates$new()}} -\item \href{#method-MatrixFilterStates-format}{\code{MatrixFilterStates$format()}} -\item \href{#method-MatrixFilterStates-server}{\code{MatrixFilterStates$server()}} -\item \href{#method-MatrixFilterStates-get_filter_state}{\code{MatrixFilterStates$get_filter_state()}} -\item \href{#method-MatrixFilterStates-set_filter_state}{\code{MatrixFilterStates$set_filter_state()}} -\item \href{#method-MatrixFilterStates-remove_filter_state}{\code{MatrixFilterStates$remove_filter_state()}} -\item \href{#method-MatrixFilterStates-ui_add_filter_state}{\code{MatrixFilterStates$ui_add_filter_state()}} -\item \href{#method-MatrixFilterStates-srv_add_filter_state}{\code{MatrixFilterStates$srv_add_filter_state()}} \item \href{#method-MatrixFilterStates-clone}{\code{MatrixFilterStates$clone()}} } } \if{html}{\out{
Inherited methods
}} @@ -48,180 +42,35 @@ Initialize \code{MatrixFilterStates} object Initialize \code{MatrixFilterStates} object \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MatrixFilterStates$new(dataname, datalabel)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character(1)})\cr -name of the data used in the expression -specified to the function argument attached to this \code{FilterStates}.} - -\item{\code{datalabel}}{(\code{character(0)} or \code{character(1)})\cr -text label value.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MatrixFilterStates-format}{}}} -\subsection{Method \code{format()}}{ -Returns the formatted string representing this \code{MatrixFilterStates} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MatrixFilterStates$format(indent = 0)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{indent}}{(\code{numeric(1)}) the number of spaces before each line of the representation} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{character(1)} the formatted string -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MatrixFilterStates-server}{}}} -\subsection{Method \code{server()}}{ -Server module -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MatrixFilterStates$server(id)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -an ID string that corresponds with the ID used to call the module's UI function.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MatrixFilterStates-get_filter_state}{}}} -\subsection{Method \code{get_filter_state()}}{ -Returns active \code{FilterState} objects. - -Gets all active filters from this dataset in form of the nested list. -The output list can be used as input to \code{self$set_filter_state}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MatrixFilterStates$get_filter_state()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{list} containing \code{list} with selected values for each \code{FilterState}. -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MatrixFilterStates-set_filter_state}{}}} -\subsection{Method \code{set_filter_state()}}{ -Sets a filter state -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MatrixFilterStates$set_filter_state(data, state, ...)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{MatrixFilterStates$new( + data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = NULL +)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{data}}{(\code{matrix})\cr -data which are supposed to be filtered.} +the R object which \code{subset} function is applied on.} -\item{\code{state}}{(\verb{named list})\cr -should contain values which are initial selection in the \code{FilterState}. -Names of the \code{list} element should correspond to the name of the -column in \code{data}.} +\item{\code{data_reactive}}{(\verb{function(sid)})\cr +should return a \code{matrix} object or \code{NULL}. +This object is needed for the \code{FilterState} counts being updated +on a change in filters. If function returns \code{NULL} then filtered counts are not shown. +Function has to have \code{sid} argument being a character.} -\item{\code{...}}{ignored.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MatrixFilterStates-remove_filter_state}{}}} -\subsection{Method \code{remove_filter_state()}}{ -Remove a variable from the \code{state_list} and its corresponding UI element. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MatrixFilterStates$remove_filter_state(state_id)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{state_id}}{(\code{character(1)})\cr name of \code{state_list} element.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MatrixFilterStates-ui_add_filter_state}{}}} -\subsection{Method \code{ui_add_filter_state()}}{ -Shiny UI module to add filter variable. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MatrixFilterStates$ui_add_filter_state(id, data)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -id of shiny module} - -\item{\code{data}}{(\code{matrix})\cr -data object for which to define a subset} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{shiny.tag} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-MatrixFilterStates-srv_add_filter_state}{}}} -\subsection{Method \code{srv_add_filter_state()}}{ -Shiny server module to add filter variable - -Module controls available choices to select as a filter variable. -Selected filter variable is being removed from available choices. -Removed filter variable gets back to available choices. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{MatrixFilterStates$srv_add_filter_state(id, data, ...)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -shiny module instance id} - -\item{\code{data}}{(\code{matrix})\cr -data object for which to define a subset} +\item{\code{dataname}}{(\code{character(1)})\cr +name of the data used in the expression +specified to the function argument attached to this \code{FilterStates}.} -\item{\code{...}}{ignored} +\item{\code{datalabel}}{(\code{NULL} or \code{character(1)})\cr +text label value. Should be a name of experiment.} } \if{html}{\out{
}} } -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} -} } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/RangeFilterState.Rd b/man/RangeFilterState.Rd index 7e6435cac..3c92f4d28 100644 --- a/man/RangeFilterState.Rd +++ b/man/RangeFilterState.Rd @@ -4,45 +4,49 @@ \name{RangeFilterState} \alias{RangeFilterState} \title{\code{FilterState} object for numeric variable} -\value{ -invisibly \code{NULL} -} \description{ Manages choosing a numeric range } -\note{ -Casts the passed object to \code{numeric} before validating the input -making it possible to pass any object coercible to \code{numeric} to this method. -} \examples{ filter_state <- teal.slice:::RangeFilterState$new( - c(NA, Inf, seq(1:10)), - varname = "x", - dataname = "data", - extract_type = character(0) + x = c(NA, Inf, seq(1:10)), + slice = teal_slice(varname = "x", dataname = "data") +) +shiny::isolate(filter_state$get_call()) +filter_state$set_state( + teal_slice( + dataname = "data", + varname = "x", + selected = c(3L, 8L), + keep_na = TRUE, + keep_inf = TRUE + ) ) -isolate(filter_state$get_call()) -isolate(filter_state$set_selected(c(3L, 8L))) -isolate(filter_state$set_keep_na(TRUE)) -isolate(filter_state$set_keep_inf(TRUE)) -isolate(filter_state$get_call()) +shiny::isolate(filter_state$get_call()) -\dontrun{ # working filter in an app library(shiny) +library(shinyjs) data_range <- c(runif(100, 0, 1), NA, Inf) -filter_state_range <- RangeFilterState$new( +fs <- teal.slice:::RangeFilterState$new( x = data_range, - varname = "variable", - varlabel = "label" + slice = teal_slice( + dataname = "data", + varname = "x", + selected = c(0.15, 0.93), + keep_na = TRUE, + keep_inf = TRUE + ) ) -filter_state_range$set_state(list(selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)) ui <- fluidPage( + useShinyjs(), + teal.slice:::include_css_files(pattern = "filter-panel"), + teal.slice:::include_js_files(pattern = "count-bar-labels"), column(4, div( h4("RangeFilterState"), - isolate(filter_state_range$ui("fs")) + fs$ui("fs") )), column(4, div( id = "outputs", # div id is needed for toggling the element @@ -66,35 +70,48 @@ ui <- fluidPage( ) server <- function(input, output, session) { - filter_state_range$server("fs") - output$condition_range <- renderPrint(filter_state_range$get_call()) - output$formatted_range <- renderText(filter_state_range$format()) - output$unformatted_range <- renderPrint(filter_state_range$get_state()) + fs$server("fs") + output$condition_range <- renderPrint(fs$get_call()) + output$formatted_range <- renderText(fs$format()) + output$unformatted_range <- renderPrint(fs$get_state()) # modify filter state programmatically - observeEvent(input$button1_range, filter_state_range$set_keep_na(FALSE)) - observeEvent(input$button2_range, filter_state_range$set_keep_na(TRUE)) - observeEvent(input$button3_range, filter_state_range$set_keep_inf(FALSE)) - observeEvent(input$button4_range, filter_state_range$set_keep_inf(TRUE)) - observeEvent(input$button5_range, filter_state_range$set_selected(c(0.2, 0.74))) - observeEvent(input$button6_range, filter_state_range$set_selected(c(0, 1))) + observeEvent( + input$button1_range, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) + ) + observeEvent( + input$button2_range, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) + ) + observeEvent( + input$button3_range, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = FALSE)) + ) + observeEvent( + input$button4_range, + fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = TRUE)) + ) + observeEvent( + input$button5_range, + fs$set_state( + teal_slice(dataname = "data", varname = "x", selected = c(0.2, 0.74)) + ) + ) + observeEvent( + input$button6_range, + fs$set_state(teal_slice(dataname = "data", varname = "x", selected = c(0, 1))) + ) observeEvent( input$button0_range, - filter_state_range$set_state(list(selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)) + fs$set_state( + teal_slice("data", "variable", selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE) + ) ) } if (interactive()) { shinyApp(ui, server) } -} - - -## ------------------------------------------------ -## Method `RangeFilterState$set_selected` -## ------------------------------------------------ - -filter <- teal.slice:::RangeFilterState$new(c(1, 2, 3, 4), varname = "name") -filter$set_selected(c(2, 3)) } \keyword{internal} @@ -105,14 +122,8 @@ filter$set_selected(c(2, 3)) \subsection{Public methods}{ \itemize{ \item \href{#method-RangeFilterState-new}{\code{RangeFilterState$new()}} -\item \href{#method-RangeFilterState-format}{\code{RangeFilterState$format()}} -\item \href{#method-RangeFilterState-is_any_filtered}{\code{RangeFilterState$is_any_filtered()}} \item \href{#method-RangeFilterState-get_call}{\code{RangeFilterState$get_call()}} \item \href{#method-RangeFilterState-get_keep_inf}{\code{RangeFilterState$get_keep_inf()}} -\item \href{#method-RangeFilterState-get_state}{\code{RangeFilterState$get_state()}} -\item \href{#method-RangeFilterState-set_keep_inf}{\code{RangeFilterState$set_keep_inf()}} -\item \href{#method-RangeFilterState-set_state}{\code{RangeFilterState$set_state()}} -\item \href{#method-RangeFilterState-set_selected}{\code{RangeFilterState$set_selected()}} \item \href{#method-RangeFilterState-clone}{\code{RangeFilterState$clone()}} } } @@ -120,15 +131,11 @@ filter$set_selected(c(2, 3))
Inherited methods
@@ -137,14 +144,13 @@ filter$set_selected(c(2, 3)) \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-RangeFilterState-new}{}}} \subsection{Method \code{new()}}{ -Initialize a \code{FilterState} object +Initialize a \code{FilterState} object for range selection \subsection{Usage}{ \if{html}{\out{
}}\preformatted{RangeFilterState$new( x, - varname, - varlabel = character(0), - dataname = NULL, - extract_type = character(0) + x_reactive = reactive(NULL), + extract_type = character(0), + slice )}\if{html}{\out{
}} } @@ -154,60 +160,31 @@ Initialize a \code{FilterState} object \item{\code{x}}{(\code{numeric})\cr values of the variable used in filter} -\item{\code{varname}}{(\code{character}, \code{name})\cr -name of the variable} - -\item{\code{varlabel}}{(\code{character(1)})\cr -label of the variable (optional).} - -\item{\code{dataname}}{(\code{character(1)})\cr -optional name of dataset where \code{x} is taken from} +\item{\code{x_reactive}}{(\code{reactive})\cr +returning vector of the same type as \code{x}. Is used to update +counts following the change in values of the filtered dataset. +If it is set to \code{reactive(NULL)} then counts based on filtered +dataset are not shown.} \item{\code{extract_type}}{(\code{character(0)}, \code{character(1)})\cr -whether condition calls should be prefixed by dataname. Possible values: +whether condition calls should be prefixed by \code{dataname}. Possible values: \itemize{ \item{\code{character(0)} (default)}{ \code{varname} in the condition call will not be prefixed} \item{\code{"list"}}{ \code{varname} in the condition call will be returned as \verb{$}} \item{\code{"matrix"}}{ \code{varname} in the condition call will be returned as \verb{[, ]}} }} -} -\if{html}{\out{}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RangeFilterState-format}{}}} -\subsection{Method \code{format()}}{ -Returns a formatted string representing this \code{RangeFilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RangeFilterState$format(indent = 0)}\if{html}{\out{
}} -} -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{indent}}{(\code{numeric(1)}) -the number of spaces before after each new line character of the formatted string. -Default: 0} +\item{\code{slice}}{(\code{teal_slice})\cr +object created using \code{\link[=teal_slice]{teal_slice()}}. \code{teal_slice} is stored +in the class and \code{set_state} directly manipulates values within \code{teal_slice}. \code{get_state} +returns \code{teal_slice} object which can be reused in other places. Beware, that \code{teal_slice} +is a \code{reactiveValues} which means that changes in particular object are automatically +reflected in all places which refer to the same \code{teal_slice}.} + +\item{\code{...}}{additional arguments to be saved as a list in \code{private$extras} field} } \if{html}{\out{
}} } -\subsection{Returns}{ -\code{character(1)} the formatted string -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RangeFilterState-is_any_filtered}{}}} -\subsection{Method \code{is_any_filtered()}}{ -Answers the question of whether the current settings and values selected actually filters out any values. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RangeFilterState$is_any_filtered()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -logical scalar -} } \if{html}{\out{
}} \if{html}{\out{}} @@ -218,9 +195,16 @@ For this class returned call looks like \verb{ >= & <= } with optional \verb{is.na()} and \verb{is.finite()}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RangeFilterState$get_call()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{RangeFilterState$get_call(dataname)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{dataname}}{name of data set; defaults to \code{private$get_dataname()}} +} +\if{html}{\out{
}} +} \subsection{Returns}{ (\code{call}) } @@ -237,95 +221,6 @@ Returns current \code{keep_inf} selection \subsection{Returns}{ (\code{logical(1)}) } -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RangeFilterState-get_state}{}}} -\subsection{Method \code{get_state()}}{ -Returns the filtering state. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RangeFilterState$get_state()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{list} containing values taken from the reactive fields: -\itemize{ -\item \code{selected} (\code{numeric(2)}) range of the filter. -\item \code{keep_na} (\code{logical(1)}) whether \code{NA} should be kept. -\item \code{keep_inf} (\code{logical(1)}) whether \code{Inf} should be kept. -} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RangeFilterState-set_keep_inf}{}}} -\subsection{Method \code{set_keep_inf()}}{ -Set if \code{Inf} should be kept -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RangeFilterState$set_keep_inf(value)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{value}}{(\code{logical(1)})\cr -Value(s) which come from the filter selection. Value is set in \code{server} -modules after selecting check-box-input in the shiny interface. Values are set to -\code{private$keep_inf} which is reactive.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RangeFilterState-set_state}{}}} -\subsection{Method \code{set_state()}}{ -Set state -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RangeFilterState$set_state(state)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{state}}{(\code{list})\cr -contains fields relevant for a specific class -\itemize{ -\item{\code{selected}}{ defines initial selection} -\item{\code{keep_na} (\code{logical})}{ defines whether to keep or remove \code{NA} values} -\item{\code{keep_inf} (\code{logical})}{ defines whether to keep or remove \code{Inf} values} -}} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-RangeFilterState-set_selected}{}}} -\subsection{Method \code{set_selected()}}{ -Sets the selected values of this \code{RangeFilterState}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{RangeFilterState$set_selected(value)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{value}}{(\code{numeric(2)}) the two-elements array of the lower and upper bound -of the selected range. Must not contain NA values.} -} -\if{html}{\out{
}} -} -\subsection{Examples}{ -\if{html}{\out{
}} -\preformatted{filter <- teal.slice:::RangeFilterState$new(c(1, 2, 3, 4), varname = "name") -filter$set_selected(c(2, 3)) - -} -\if{html}{\out{
}} - -} - } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/SEFilterStates.Rd b/man/SEFilterStates.Rd index 1aa4e1687..62bd111c3 100644 --- a/man/SEFilterStates.Rd +++ b/man/SEFilterStates.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/FilterStatesSE.R \name{SEFilterStates} \alias{SEFilterStates} -\title{\code{FilterStates} subclass for SummarizedExperiments} +\title{\code{FilterStates} subclass for \code{SummarizedExperiments}} \description{ Handles filter states in a \code{SummaryExperiment} } @@ -14,29 +14,23 @@ Handles filter states in a \code{SummaryExperiment} \subsection{Public methods}{ \itemize{ \item \href{#method-SEFilterStates-new}{\code{SEFilterStates$new()}} -\item \href{#method-SEFilterStates-format}{\code{SEFilterStates$format()}} -\item \href{#method-SEFilterStates-server}{\code{SEFilterStates$server()}} -\item \href{#method-SEFilterStates-get_filter_state}{\code{SEFilterStates$get_filter_state()}} \item \href{#method-SEFilterStates-set_filter_state}{\code{SEFilterStates$set_filter_state()}} -\item \href{#method-SEFilterStates-remove_filter_state}{\code{SEFilterStates$remove_filter_state()}} -\item \href{#method-SEFilterStates-ui_add_filter_state}{\code{SEFilterStates$ui_add_filter_state()}} -\item \href{#method-SEFilterStates-srv_add_filter_state}{\code{SEFilterStates$srv_add_filter_state()}} +\item \href{#method-SEFilterStates-ui_add}{\code{SEFilterStates$ui_add()}} +\item \href{#method-SEFilterStates-srv_add}{\code{SEFilterStates$srv_add()}} \item \href{#method-SEFilterStates-clone}{\code{SEFilterStates$clone()}} } } \if{html}{\out{
Inherited methods
}} @@ -48,80 +42,35 @@ Initialize \code{SEFilterStates} object Initialize \code{SEFilterStates} object \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SEFilterStates$new(dataname, datalabel)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{SEFilterStates$new( + data, + data_reactive = function(sid = "") NULL, + dataname, + datalabel = NULL +)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ +\item{\code{data}}{(\code{SummarizedExperiment})\cr +the R object which \code{subset} function is applied on.} + +\item{\code{data_reactive}}{(\verb{function(sid)})\cr +should return a \code{SummarizedExperiment} object or \code{NULL}. +This object is needed for the \code{FilterState} counts being updated +on a change in filters. If function returns \code{NULL} then filtered counts are not shown. +Function has to have \code{sid} argument being a character.} + \item{\code{dataname}}{(\code{character(1)})\cr name of the data used in the expression specified to the function argument attached to this \code{FilterStates}.} \item{\code{datalabel}}{(\code{character(0)} or \code{character(1)})\cr -text label value.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SEFilterStates-format}{}}} -\subsection{Method \code{format()}}{ -Returns the formatted string representing this \code{MAEFilterStates} object. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SEFilterStates$format(indent = 0)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{indent}}{(\code{numeric(1)}) the number of spaces before each line of the representation} +text label value. Should be a name of experiment} } \if{html}{\out{
}} } -\subsection{Returns}{ -\code{character(1)} the formatted string -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SEFilterStates-server}{}}} -\subsection{Method \code{server()}}{ -Server module -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SEFilterStates$server(id)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{(\code{character(1)})\cr -an ID string that corresponds with the ID used to call the module's UI function.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{moduleServer} function which returns \code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SEFilterStates-get_filter_state}{}}} -\subsection{Method \code{get_filter_state()}}{ -Gets the reactive values from the active \code{FilterState} objects. - -Gets all active filters from this dataset in form of the nested list. -The output list is a compatible input to \code{self$set_filter_state}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SEFilterStates$get_filter_state()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -\code{list} containing one or two lists depending on the number of -\code{state_list} object (I.e. if \code{rowData} and \code{colData} exist). Each -\code{list} contains elements number equal to number of active filter variables. -} } \if{html}{\out{
}} \if{html}{\out{}} @@ -129,56 +78,28 @@ The output list is a compatible input to \code{self$set_filter_state}. \subsection{Method \code{set_filter_state()}}{ Set filter state \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SEFilterStates$set_filter_state(data, state, ...)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{data}}{(\code{SummarizedExperiment})\cr -data which are supposed to be filtered.} - -\item{\code{state}}{(\verb{named list})\cr -this list should contain \code{subset} and \code{select} element where -each should be a named list containing values as a selection in the \code{FilterState}. -Names of each the \code{list} element in \code{subset} and \code{select} should correspond to -the name of the column in \code{rowData(data)} and \code{colData(data)}.} - -\item{\code{...}}{ignored.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -\code{NULL} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SEFilterStates-remove_filter_state}{}}} -\subsection{Method \code{remove_filter_state()}}{ -Remove a variable from the \code{state_list} and its corresponding UI element. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SEFilterStates$remove_filter_state(state_id)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{SEFilterStates$set_filter_state(state)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{state_id}}{(\code{character(1)})\cr name of \code{state_list} element.} +\item{\code{state}}{(\code{teal_slices})\cr +\code{teal_slice} objects should contain the field \code{arg \%in\% c("subset", "select")}} } \if{html}{\out{
}} } \subsection{Returns}{ -\code{NULL} +\code{NULL} invisibly } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SEFilterStates-ui_add_filter_state}{}}} -\subsection{Method \code{ui_add_filter_state()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SEFilterStates-ui_add}{}}} +\subsection{Method \code{ui_add()}}{ Shiny UI module to add filter variable \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SEFilterStates$ui_add_filter_state(id, data)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{SEFilterStates$ui_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -186,11 +107,6 @@ Shiny UI module to add filter variable \describe{ \item{\code{id}}{(\code{character(1)})\cr id of shiny module} - -\item{\code{data}}{(\code{SummarizedExperiment})\cr -object containing \code{colData} and \code{rowData} which columns -are used to choose filter variables. Column selection from \code{colData} -and \code{rowData} are separate shiny entities.} } \if{html}{\out{}} } @@ -199,9 +115,9 @@ shiny.tag } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-SEFilterStates-srv_add_filter_state}{}}} -\subsection{Method \code{srv_add_filter_state()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-SEFilterStates-srv_add}{}}} +\subsection{Method \code{srv_add()}}{ Shiny server module to add filter variable Module controls available choices to select as a filter variable. @@ -211,7 +127,7 @@ This module unlike other \code{FilterStates} classes manages two sets of filter variables - one for \code{colData} and another for \code{rowData}. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{SEFilterStates$srv_add_filter_state(id, data, ...)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{SEFilterStates$srv_add(id)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -219,13 +135,6 @@ sets of filter variables - one for \code{colData} and another for \describe{ \item{\code{id}}{(\code{character(1)})\cr an ID string that corresponds with the ID used to call the module's UI function.} - -\item{\code{data}}{(\code{SummarizedExperiment})\cr -object containing \code{colData} and \code{rowData} which columns -are used to choose filter variables. Column selection from \code{colData} -and \code{rowData} are separate shiny entities.} - -\item{\code{...}}{ignored} } \if{html}{\out{}} } diff --git a/man/calls_combine_by.Rd b/man/calls_combine_by.Rd index 0934f3179..8ff9821b4 100644 --- a/man/calls_combine_by.Rd +++ b/man/calls_combine_by.Rd @@ -23,13 +23,12 @@ a combined \code{call} Combine list of calls by specific operator } \examples{ -\dontrun{ calls <- list( quote(SEX == "F"), # subsetting on factor quote(AGE >= 20 & AGE <= 50), # subsetting on range quote(!SURV) # subsetting on logical ) -calls_combine_by(calls, "&") -} +teal.slice:::calls_combine_by(calls, "&") + } \keyword{internal} diff --git a/man/check_in_range.Rd b/man/check_in_range.Rd index aa7c8b9eb..d41d6aea1 100644 --- a/man/check_in_range.Rd +++ b/man/check_in_range.Rd @@ -20,13 +20,13 @@ check_in_range(subinterval, range, pre_msg = "") Check that a given range is valid } \examples{ -\dontrun{ -check_in_range(c(3, 1), c(1, 3)) -check_in_range(c(0, 3), c(1, 3)) -check_in_range( - c(as.Date("2020-01-01"), as.Date("2020-01-20")), - c(as.Date("2020-01-01"), as.Date("2020-01-02")) -) +if (interactive()) { + teal.slice:::check_in_range(c(3, 1), c(1, 3)) + teal.slice:::check_in_range(c(0, 3), c(1, 3)) + teal.slice:::check_in_range( + c(as.Date("2020-01-01"), as.Date("2020-01-20")), + c(as.Date("2020-01-01"), as.Date("2020-01-02")) + ) } } \keyword{internal} diff --git a/man/check_in_subset.Rd b/man/check_in_subset.Rd index 6ec77dc1d..a90e91784 100644 --- a/man/check_in_subset.Rd +++ b/man/check_in_subset.Rd @@ -7,9 +7,7 @@ check_in_subset(subset, choices, pre_msg = "") } \arguments{ -\item{subset}{\code{collection-like} should be a subset of the second argument \code{choices}} - -\item{choices}{\code{collection-like} superset} +\item{subset, choices}{atomic vectors} \item{pre_msg}{\code{character} message to print before error should there be any errors} } @@ -17,13 +15,12 @@ check_in_subset(subset, choices, pre_msg = "") Raises an error message if not and says which elements are not in the allowed \code{choices}. } \examples{ -\dontrun{ -check_in_subset <- check_in_subset -check_in_subset(c("a", "b"), c("a", "b", "c")) -\dontrun{ -check_in_subset(c("a", "b"), c("b", "c"), pre_msg = "Error: ") -# truncated because too long -check_in_subset("a", LETTERS, pre_msg = "Error: ") +\donttest{ +teal.slice:::check_in_subset(c("a", "b"), c("a", "b", "c")) +if (interactive()) { + teal.slice:::check_in_subset(c("a", "b"), c("b", "c"), pre_msg = "Error: ") + # truncated because too long + teal.slice:::check_in_subset("a", LETTERS, pre_msg = "Error: ") } } } diff --git a/man/check_simple_name.Rd b/man/check_simple_name.Rd index 8b2986262..7b249be35 100644 --- a/man/check_simple_name.Rd +++ b/man/check_simple_name.Rd @@ -23,10 +23,10 @@ teal.slice:::check_simple_name("ADSL_modified") teal.slice:::check_simple_name("ADSL_2") teal.slice:::check_simple_name("a1") # the following fail -\dontrun{ -teal.slice:::check_simple_name("1a") -teal.slice:::check_simple_name("ADSL.modified") -teal.slice:::check_simple_name("a1...") +if (interactive()) { + teal.slice:::check_simple_name("1a") + teal.slice:::check_simple_name("ADSL.modified") + teal.slice:::check_simple_name("a1...") } } \keyword{internal} diff --git a/man/choices_labeled.Rd b/man/choices_labeled.Rd index 8c209784b..6eb0ecde0 100644 --- a/man/choices_labeled.Rd +++ b/man/choices_labeled.Rd @@ -23,9 +23,10 @@ a named character vector } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} -This is often useful for as it marks up the dropdown boxes for \code{\link[shiny:selectInput]{shiny::selectInput()}}. +This is often useful for as it marks up the drop-down boxes for \code{\link[shiny:selectInput]{shiny::selectInput()}}. } \details{ If either \code{choices} or \code{labels} are factors, they are coerced to character. Duplicated elements from \code{choices} get removed. } +\keyword{internal} diff --git a/man/contain_interval.Rd b/man/contain_interval.Rd deleted file mode 100644 index d6768ddb1..000000000 --- a/man/contain_interval.Rd +++ /dev/null @@ -1,45 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/FilterState-utils.R -\name{contain_interval} -\alias{contain_interval} -\title{Find containing limits for interval.} -\usage{ -contain_interval(x, range) -} -\arguments{ -\item{x}{\code{numeric(2)} interval to contain} - -\item{range}{\verb{numeric(>=2)} vector of values to contain \code{x} in} -} -\value{ -Numeric vector of length 2 that lies within \code{range}. -} -\description{ -Given an interval and a numeric vector, -find the smallest interval within the numeric vector that contains the interval. -} -\details{ -This is a helper function for \code{RangeFilterState} that modifies slider selection -so that the \emph{subsetting call} includes the value specified by the filter API call. - -Regardless of the underlying numeric data, the slider always presents 100 steps. -The ticks on the slider do not represent actual observations but rather borders between virtual bins. -Since the value selected on the slider is passed to \code{private$selected} and that in turn -updates the slider selection, programmatic selection of arbitrary values may inadvertently shift -the selection to the closest tick, thereby dropping the actual value set (if it exists in the data). - -This function purposely shifts the selection to the closest ticks whose values form an interval -that will contain the interval defined by the filter API call. -} -\examples{ -\dontrun{ -ticks <- 1:10 -values1 <- c(3, 5) -contain_interval(values1, ticks) -values2 <- c(3.1, 5.7) -contain_interval(values2, ticks) -values3 <- c(0, 20) -contain_interval(values3, ticks) -} -} -\keyword{internal} diff --git a/man/countBar.Rd b/man/countBar.Rd new file mode 100644 index 000000000..6d8a5d6e9 --- /dev/null +++ b/man/countBar.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/count_labels.R +\name{countBar} +\alias{countBar} +\alias{updateCountBar} +\alias{updateCountText} +\title{Progress bar with label} +\usage{ +countBar(inputId, label, countmax, countnow = NULL, counttotal = countmax) + +updateCountBar( + session = getDefaultReactiveDomain(), + inputId, + label, + countmax, + countnow = NULL, + counttotal +) + +updateCountText( + session = getDefaultReactiveDomain(), + inputId, + label, + countmax, + countnow +) +} +\arguments{ +\item{inputId}{(\code{character(1)}) \code{shiny} id} + +\item{label}{(\code{character(1)}) Text to display followed by counts} + +\item{countmax}{(\code{numeric(1)}) maximal possible count for a single item.} + +\item{countnow}{(\code{numeric(1)}) current count of a single item.} + +\item{counttotal}{(\code{numeric(1)}) total count to make whole progress bar +taking part of the container. Ratio between \code{countmax / counttotal} +determines \verb{\%""}.} + +\item{session}{(\code{session}) object passed to function given to \code{shinyServer}.} +} +\value{ +\code{shiny.tag} object with a progress bar and a label. +} +\description{ +Progress bar with label +} +\keyword{internal} diff --git a/man/countBars.Rd b/man/countBars.Rd new file mode 100644 index 000000000..46330582f --- /dev/null +++ b/man/countBars.Rd @@ -0,0 +1,83 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/count_labels.R +\name{countBars} +\alias{countBars} +\alias{updateCountBars} +\title{Progress bars with labels} +\usage{ +countBars(inputId, choices, countsmax, countsnow = NULL) + +updateCountBars( + session = getDefaultReactiveDomain(), + inputId, + choices, + countsmax, + countsnow = NULL +) +} +\arguments{ +\item{inputId}{(\code{character(1)}) \code{shiny} id} + +\item{choices}{(\code{vector}) determines label text.} + +\item{countsmax}{(\code{numeric}) determining maximal count of each element. +Length should be the same as \code{choices}.} + +\item{countsnow}{(\code{numeric}) actual counts of each element. +Length should be the same as \code{choices}.} + +\item{session}{(\code{session}) object passed to function given to \code{shinyServer}.} +} +\value{ +list of \code{shiny.tag} +} +\description{ +\code{shiny} element showing progress bar counts. Each element can have an +unique \code{id} attribute so each can be used independently. +Progress bar size is dependent on the ratio \code{choicesnow[i] / countsmax[i]}. +Label is \code{choices[i] (countsnow[i]/countsmax)} +} +\examples{ + +choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE) +counts <- table(choices) +labels <- teal.slice:::countBars( + inputId = "counts", + choices = c("a", "b", "c"), + countsmax = counts, + countsnow = unname(counts) +) + +app <- shinyApp( + ui = fluidPage( + div( + class = "choices_state", + teal.slice:::include_js_files("count-bar-labels.js"), + teal.slice:::include_css_files(pattern = "filter-panel"), + checkboxGroupInput( + inputId = "choices", + selected = levels(choices), + choiceNames = labels, + choiceValues = levels(choices), + label = NULL + ) + ) + ), + server = function(input, output, session) { + observeEvent(input$choices, { + new_counts <- counts + new_counts[!names(new_counts) \%in\% input$choices] <- 0 + teal.slice:::updateCountBars( + inputId = "counts", + choices = levels(choices), + countsmax = counts, + countsnow = unname(new_counts) + ) + }) + } +) +if (interactive()) { + runApp(app) +} +} +\keyword{internal} diff --git a/man/data_choices_labeled.Rd b/man/data_choices_labeled.Rd index 083af8c9e..1f73091b6 100644 --- a/man/data_choices_labeled.Rd +++ b/man/data_choices_labeled.Rd @@ -7,7 +7,7 @@ data_choices_labeled( data, choices, - varlabels = character(0), + varlabels = formatters::var_labels(data, fill = TRUE), keys = character(0) ) } diff --git a/man/fetch_bs_color.Rd b/man/fetch_bs_color.Rd new file mode 100644 index 000000000..0b6974072 --- /dev/null +++ b/man/fetch_bs_color.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FilterState-utils.R +\name{fetch_bs_color} +\alias{fetch_bs_color} +\title{Get hex code of the current Bootstrap theme color.} +\usage{ +fetch_bs_color(color, alpha = NULL) +} +\arguments{ +\item{color}{\code{character(1)} naming one of the available theme colors} + +\item{alpha}{either a \code{numeric(1)} or \code{character(1)} specifying transparency +in the range of \code{0-1} or a hexadecimal value \code{00-ff}, respectively; +set to NULL to omit adding the alpha channel} +} +\value{ +Named \code{character(1)} containing a hexadecimal color representation. +} +\description{ +Determines the color specification for the currently active Bootstrap color theme and returns one queried color. +} +\examples{ +teal.slice:::fetch_bs_color("primary") +teal.slice:::fetch_bs_color("danger", 0.35) +teal.slice:::fetch_bs_color("danger", "80") + +} +\keyword{internal} diff --git a/man/filter_state_api.Rd b/man/filter_state_api.Rd index 37c3ff564..1edceb0b6 100644 --- a/man/filter_state_api.Rd +++ b/man/filter_state_api.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/filter_state_api.R +% Please edit documentation in R/filter_panel_api.R \name{filter_state_api} \alias{filter_state_api} \alias{set_filter_state} @@ -18,79 +18,17 @@ clear_filter_states(datasets) } \arguments{ \item{datasets}{(\code{FilteredData})\cr -object to store filter state and filtered datasets, shared across modules. For more -details see \code{\link{FilteredData}}} +object to store filter state and filtered datasets, shared across modules\cr +see \code{\link{FilteredData}} for details} -\item{filter}{(\code{list})\cr -You can define filters that show when the app starts. List names should be -named according to 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{MultiAssayExperiment} \code{filter} should be specified in slightly different -way. Since \code{\link[MultiAssayExperiment:MultiAssayExperiment]{MultiAssayExperiment::MultiAssayExperiment()}} contains -patient data (\code{\link[SummarizedExperiment:SummarizedExperiment-class]{SummarizedExperiment::colData()}}) with list of experiments -(\code{\link[MultiAssayExperiment:ExperimentList]{MultiAssayExperiment::ExperimentList()}}), \code{filter} list should be named -in the following name. -\cr -} - -\if{html}{\out{
}}\preformatted{list( - = list( - subjects = list( = ..., = ...), - = list( - subset = list( = ..., - = ...), - select = list( = ..., - = ...) - ) - ) -) -}\if{html}{\out{
}} - -\code{filter} is ignored if the app is restored from a bookmarked state.} +\item{filter}{(\code{teal_slices})\cr +specify filters in place on app start-up} } \value{ \itemize{ -\item set, remove and clear returns \code{NULL} -\item get returns named \code{list} of the same structure as described in \code{filter} argument. +\item \verb{set_*}, \verb{remove_*} and \code{clear_filter_state} return \code{NULL} invisibly +\item \code{get_filter_state} returns a named \code{teal_slices} object +containing a \code{teal_slice} for every existing \code{FilterState} } } \description{ @@ -106,48 +44,54 @@ datasets <- init_filtered_data( mae = list(dataset = miniACC) ) ) -fs <- list( - iris = list( - Sepal.Length = list(selected = c(5.1, 6.4), keep_na = TRUE, keep_inf = FALSE), - Species = list(selected = c("setosa", "versicolor"), keep_na = FALSE) +fs <- teal_slices( + teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor")), + teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)), + teal_slice( + dataname = "mae", varname = "years_to_birth", selected = c(30, 50), + keep_na = TRUE, keep_inf = FALSE ), - mae = list( - subjects = list( - years_to_birth = list(selected = c(30, 50), keep_na = TRUE, keep_inf = FALSE), - vital_status = list(selected = "1", keep_na = FALSE), - gender = list(selected = "female", keep_na = TRUE) - ), - RPPAArray = list( - subset = list(ARRAY_TYPE = list(selected = "", keep_na = TRUE)) - ) + teal_slice( + dataname = "mae", varname = "vital_status", selected = "1", + keep_na = FALSE + ), + teal_slice( + dataname = "mae", varname = "gender", selected = "female", + keep_na = TRUE + ), + teal_slice( + dataname = "mae", varname = "ARRAY_TYPE", selected = "", + keep_na = TRUE, experiment = "RPPAArray", arg = "subset" ) ) # set initial filter state -isolate(set_filter_state(datasets, filter = fs)) +set_filter_state(datasets, filter = fs) # get filter state get_filter_state(datasets) # modify filter state -isolate( - set_filter_state( - datasets, - filter = list(iris = list(Species = list(selected = "setosa", keep_na = TRUE))) +set_filter_state( + datasets, + teal_slices( + teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE) ) ) # remove specific filters -isolate( - remove_filter_state(datasets, - filter = list( - iris = "Species", - mae = list( - subjects = c("years_to_birth", "vital_status") - ) - ) +remove_filter_state( + datasets, + teal_slices( + teal_slice(dataname = "iris", varname = "Species"), + teal_slice(dataname = "mae", varname = "years_to_birth"), + teal_slice(dataname = "mae", varname = "vital_status") ) ) + # remove all states clear_filter_states(datasets) } +\seealso{ +\code{\link{teal_slice}} +} diff --git a/man/get_default_slice_id.Rd b/man/get_default_slice_id.Rd new file mode 100644 index 000000000..825da19c4 --- /dev/null +++ b/man/get_default_slice_id.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_slice.R +\name{get_default_slice_id} +\alias{get_default_slice_id} +\title{Default \code{teal_slice} id} +\usage{ +get_default_slice_id(x) +} +\arguments{ +\item{x}{(\code{teal_slice} or \code{list})} +} +\value{ +(\code{character(1)}) \code{id} for a \code{teal_slice} object. +} +\description{ +Function returns a default \code{id} for a \code{teal_slice} object which needs +to be distinct from other \code{teal_slice} objects created for any +\code{FilterStates} object. Returned \code{id} can be treated as a location of +a vector on which \code{FilterState} is built: +\itemize{ +\item for a \code{data.frame} \code{id} concatenates \code{dataname} and \code{varname}. +\item for a \code{MultiAssayExperiment} \code{id} concatenates \code{dataname}, \code{varname}, +\code{experiment} and \code{arg}, so that one can add \code{teal_slice} for a \code{varname} +which exists in multiple \code{SummarizedExperiment}s or exists in both \code{colData} +and \code{rowData} of given experiment. +} +} +\keyword{internal} diff --git a/man/get_filter_expr.Rd b/man/get_filter_expr.Rd index e2c6e3201..cda94e305 100644 --- a/man/get_filter_expr.Rd +++ b/man/get_filter_expr.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/FilteredData.R +% Please edit documentation in R/filter_panel_api.R \name{get_filter_expr} \alias{get_filter_expr} -\title{Gets filter expression for multiple datanames taking into account its order.} +\title{Gets filter expression for multiple \code{datanames} taking into account its order.} \usage{ get_filter_expr(datasets, datanames = datasets$datanames()) } diff --git a/man/include_js_files.Rd b/man/include_js_files.Rd new file mode 100644 index 000000000..d09f5d4ce --- /dev/null +++ b/man/include_js_files.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{include_js_files} +\alias{include_js_files} +\title{Include \code{JS} files from \verb{/inst/js/} package directory to application header} +\usage{ +include_js_files(pattern) +} +\arguments{ +\item{pattern}{(\code{character}) pattern of files to be included, passed to \code{system.file}} + +\item{except}{(\code{character}) vector of basename filenames to be excluded} +} +\value{ +HTML code that includes \code{JS} files +} +\description{ +\code{system.file} should not be used to access files in other packages, it does +not work with \code{devtools}. Therefore, we redefine this method in each package +as needed. Thus, we do not export this method +} +\keyword{internal} diff --git a/man/init_filter_state.Rd b/man/init_filter_state.Rd index 2939189c7..8ff1e3619 100644 --- a/man/init_filter_state.Rd +++ b/man/init_filter_state.Rd @@ -6,9 +6,8 @@ \usage{ init_filter_state( x, - varname, - varlabel = attr(x, "label"), - dataname = NULL, + x_reactive = reactive(NULL), + slice, extract_type = character(0) ) } @@ -16,23 +15,24 @@ init_filter_state( \item{x}{(\code{vector})\cr values of the variable used in filter} -\item{varname}{(\code{character(1)})\cr -name of the variable.} +\item{x_reactive}{(\code{reactive})\cr +returning vector of the same type as \code{x}. Is used to update +counts following the change in values of the filtered dataset. +If it is set to \code{reactive(NULL)} then counts based on filtered +dataset are not shown.} -\item{varlabel}{(\code{character(0)}, \code{character(1)} or \code{NULL})\cr -label of the variable (optional).} - -\item{dataname}{(\code{character(1)})\cr -optional name of dataset where \code{x} is taken from. Must be specified -if \code{extract_type} argument is not empty.} +\item{slice}{(\code{teal_slice})\cr +object created using \code{\link[=teal_slice]{teal_slice()}}.} \item{extract_type}{(\code{character(0)}, \code{character(1)})\cr -whether condition calls should be prefixed by dataname. Possible values: +specifying whether condition calls should be prefixed by \code{dataname}. Possible values: \itemize{ \item{\code{character(0)} (default)}{ \code{varname} in the condition call will not be prefixed} \item{\code{"list"}}{ \code{varname} in the condition call will be returned as \verb{$}} \item{\code{"matrix"}}{ \code{varname} in the condition call will be returned as \verb{[, ]}} }} + +\item{...}{additional arguments to be saved as a list in \code{private$extras} field} } \value{ \code{FilterState} object @@ -41,21 +41,20 @@ whether condition calls should be prefixed by dataname. Possible values: Initializes \code{FilterState} depending on a variable class.\cr } \examples{ -filter_state <- teal.slice:::RangeFilterState$new( - c(1:10, NA, Inf), - varname = "x", - varlabel = "Pretty name", - dataname = "dataname", +filter_state <- teal.slice:::init_filter_state( + x = c(1:10, NA, Inf), + x_reactive = reactive(c(1:10, NA, Inf)), + slice = teal_slice( + varname = "x", + dataname = "dataname" + ), extract_type = "matrix" ) -filter_state$get_varname() -filter_state$get_varlabel() -isolate(filter_state$get_call()) -\dontrun{ -shinyApp( +shiny::isolate(filter_state$get_call()) +app <- shinyApp( ui = fluidPage( - isolate(filter_state$ui(id = "app")), + filter_state$ui(id = "app"), verbatimTextOutput("call") ), server = function(input, output, session) { @@ -66,6 +65,8 @@ shinyApp( ) } ) +if (interactive()) { + runApp(app) } } \keyword{internal} diff --git a/man/init_filter_state_expr.Rd b/man/init_filter_state_expr.Rd new file mode 100644 index 000000000..19c2b9ae0 --- /dev/null +++ b/man/init_filter_state_expr.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FilterState-utils.R +\name{init_filter_state_expr} +\alias{init_filter_state_expr} +\title{Initialize a \code{FilterStateExpr} object} +\usage{ +init_filter_state_expr(slice) +} +\arguments{ +\item{slice}{(\code{teal_slice_expr})\cr +object created using \code{\link[=teal_slice]{teal_slice()}}. \code{teal_slice} is stored +in the class and \code{set_state} directly manipulates values within \code{teal_slice}. \code{get_state} +returns \code{teal_slice} object which can be reused in other places. Beware, that \code{teal_slice} +is a \code{reactiveValues} which means that changes in particular object are automatically +reflected in all places which refer to the same \code{teal_slice}.} +} +\value{ +\code{FilterStateExpr} object +} +\description{ +Initialize a \code{FilterStateExpr} object +} +\keyword{internal} diff --git a/man/init_filter_states.Rd b/man/init_filter_states.Rd index aff425258..743d66e73 100644 --- a/man/init_filter_states.Rd +++ b/man/init_filter_states.Rd @@ -4,12 +4,26 @@ \alias{init_filter_states} \title{Initialize \code{FilterStates} object} \usage{ -init_filter_states(data, dataname, datalabel = character(0), ...) +init_filter_states( + data, + data_reactive = reactive(NULL), + dataname, + datalabel = NULL, + ... +) } \arguments{ \item{data}{(\code{data.frame}, \code{MultiAssayExperiment}, \code{SummarizedExperiment}, \code{matrix})\cr the R object which \code{subset} function is applied on.} +\item{data_reactive}{(\verb{function(sid)})\cr +should return an object of the same type as \code{data} or \code{NULL}. +This object is needed for the \code{FilterState} shiny module to update +counts if filtered data changes. +If function returns \code{NULL} then filtered counts +are not shown. Function has to have \code{sid} argument being a character which +is related to \code{sid} argument in the \code{get_call} method.} + \item{dataname}{(\code{character(1)})\cr name of the data used in the expression specified to the function argument attached to this \code{FilterStates}.} @@ -18,12 +32,13 @@ specified to the function argument attached to this \code{FilterStates}.} text label value.} \item{...}{(optional) -additional arguments for specific classes: keys} +additional arguments for specific classes: keys.} } \description{ Initialize \code{FilterStates} object } \examples{ +library(shiny) df <- data.frame( character = letters, numeric = seq_along(letters), @@ -32,28 +47,26 @@ df <- data.frame( ) rf <- teal.slice:::init_filter_states( data = df, - dataname = "DF", - varlabels = c( - "character variable", "numeric variable", "date variable", "datetime variable" - ) + dataname = "DF" ) -\dontrun{ -shinyApp( +app <- shinyApp( ui = fluidPage( actionButton("clear", span(icon("xmark"), "Remove all filters")), - rf$ui_add_filter_state(id = "add", data = df), - rf$ui("states"), + rf$ui_add(id = "add"), + rf$ui_active("states"), verbatimTextOutput("expr"), ), server = function(input, output, session) { - rf$srv_add_filter_state(id = "add", data = df) - rf$server(id = "states") + rf$srv_add(id = "add") + rf$srv_active(id = "states") output$expr <- renderText({ deparse1(rf$get_call(), collapse = "\n") }) observeEvent(input$clear, rf$state_list_empty()) } ) +if (interactive()) { + runApp(app) } } \keyword{internal} diff --git a/man/init_filtered_data.Rd b/man/init_filtered_data.Rd index 9389fb243..554b78b44 100644 --- a/man/init_filtered_data.Rd +++ b/man/init_filtered_data.Rd @@ -4,7 +4,7 @@ \alias{init_filtered_data} \title{Initialize \code{FilteredData}} \usage{ -init_filtered_data(x, join_keys, code, cdisc, check) +init_filtered_data(x, join_keys, code, check) } \arguments{ \item{x}{(named \code{list} or \code{TealData}) In case of \code{TealData} see \code{\link[teal.data:teal_data]{teal.data::teal_data()}}. @@ -21,8 +21,6 @@ If the list is provided, it should contain \code{list}(s) containing following f \item{code}{(\code{CodeClass}) see \code{\link[teal.data:CodeClass]{teal.data::CodeClass}}.} -\item{cdisc}{(\code{logical(1)}) whether data is of \code{cdisc} type (relational).} - \item{check}{(\code{logical(1)}) whether data has been check against reproducibility.} } \description{ diff --git a/man/init_filtered_dataset.Rd b/man/init_filtered_dataset.Rd index 49bac2561..1dec902e3 100644 --- a/man/init_filtered_dataset.Rd +++ b/man/init_filtered_dataset.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/FilteredDataset.R +% Please edit documentation in R/FilteredDataset-utils.R \name{init_filtered_dataset} \alias{init_filtered_dataset} \title{Initializes \code{FilteredDataset}} @@ -8,6 +8,9 @@ init_filtered_dataset( dataset, dataname, keys = character(0), + parent_name = character(0), + parent = reactive(dataset), + join_keys = character(0), label = attr(dataset, "label"), metadata = NULL ) @@ -21,6 +24,19 @@ A given name for the dataset it may not contain spaces} \item{keys}{optional, (\code{character})\cr Vector with primary keys} +\item{parent_name}{(\code{character(1)})\cr +Name of the parent dataset} + +\item{parent}{(\code{reactive})\cr +object returned by this reactive is a filtered \code{data.frame} from other \code{FilteredDataset} +named \code{parent_name}. Consequence of passing \code{parent} is a \code{reactive} link which causes +causing re-filtering of this \code{dataset} based on the changes in \code{parent}.} + +\item{join_keys}{(\code{character})\cr +Name of the columns in this dataset to join with \code{parent} +dataset. If the column names are different if both datasets +then the names of the vector define the \code{parent} columns.} + \item{label}{(\code{character})\cr Label to describe the dataset} @@ -42,17 +58,16 @@ iris_fd <- teal.slice:::init_filtered_dataset( dataname = "iris", metadata = list(type = "teal") ) -\dontrun{ -shinyApp( +app <- shinyApp( ui = fluidPage( - iris_fd$ui_add_filter_state(id = "add"), - iris_fd$ui("dataset"), + iris_fd$ui_add(id = "add"), + iris_fd$ui_active("dataset"), verbatimTextOutput("call"), verbatimTextOutput("metadata") ), server = function(input, output, session) { - iris_fd$srv_add_filter_state(id = "add") - iris_fd$server(id = "dataset") + iris_fd$srv_add(id = "add") + iris_fd$srv_active(id = "dataset") output$metadata <- renderText({ paste("Type =", iris_fd$get_metadata()$type) @@ -66,23 +81,24 @@ shinyApp( }) } ) +if (interactive()) { + runApp(app) } # MAEFilteredDataset example library(MultiAssayExperiment) data(miniACC) MAE_fd <- teal.slice:::init_filtered_dataset(miniACC, "MAE", metadata = list(type = "MAE")) -\dontrun{ -shinyApp( +app <- shinyApp( ui = fluidPage( - MAE_fd$ui_add_filter_state(id = "add"), - MAE_fd$ui("dataset"), + MAE_fd$ui_add(id = "add"), + MAE_fd$ui_active("dataset"), verbatimTextOutput("call"), verbatimTextOutput("metadata") ), server = function(input, output, session) { - MAE_fd$srv_add_filter_state(id = "add") - MAE_fd$server(id = "dataset") + MAE_fd$srv_add(id = "add") + MAE_fd$srv_active(id = "dataset") output$metadata <- renderText({ paste("Type =", MAE_fd$get_metadata()$type) }) @@ -94,6 +110,8 @@ shinyApp( }) } ) +if (interactive()) { + runApp(app) } } \keyword{internal} diff --git a/man/jsonify.Rd b/man/jsonify.Rd new file mode 100644 index 000000000..b7bc6646b --- /dev/null +++ b/man/jsonify.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_slice.R +\name{jsonify} +\alias{jsonify} +\title{Convert a list to a justified \code{JSON} string} +\usage{ +jsonify(x, trim_lines) +} +\arguments{ +\item{x}{(\code{list}), possibly recursive, obtained from \code{teal_slice} or \code{teal_slices}.} + +\item{trim_lines}{(\code{logical(1)}) flag specifying whether to trim lines of the \code{JSON} string.} +} +\value{ +A \code{JSON} string representation of the input list. +} +\description{ +This function takes a list and converts it to a \code{JSON} string. +The resulting \code{JSON} string is then optionally justified to improve readability +and trimmed to easier fit in the console when printing. +} +\keyword{internal} diff --git a/man/justify_json.Rd b/man/justify_json.Rd new file mode 100644 index 000000000..01659fa5a --- /dev/null +++ b/man/justify_json.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/teal_slice.R +\name{justify_json} +\alias{justify_json} +\title{Justify Colons in \code{JSON} String} +\usage{ +justify_json(json) +} +\arguments{ +\item{json}{(\code{character(1)}) a \code{JSON} string.} +} +\value{ +A list of character strings, which can be collapsed into a \code{JSON} string. +} +\description{ +This function takes a \code{JSON} string as input, splits it into lines, and pads element names +with spaces so that colons are justified between lines. +} +\keyword{internal} diff --git a/man/make_c_call.Rd b/man/make_c_call.Rd new file mode 100644 index 000000000..b0b18ed52 --- /dev/null +++ b/man/make_c_call.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{make_c_call} +\alias{make_c_call} +\title{This function takes a vector of values and returns a \code{c} call. If the vector +has only one element, the element is returned directly.} +\usage{ +make_c_call(choices) +} +\arguments{ +\item{choices}{A vector of values.} +} +\value{ +A \code{c} call. +} +\description{ +This function takes a vector of values and returns a \code{c} call. If the vector +has only one element, the element is returned directly. +} +\examples{ +teal.slice:::make_c_call(1:3) +# [1] 1 2 3 + +teal.slice:::make_c_call(1) +# [1] 1 +} +\keyword{internal} diff --git a/man/make_count_text.Rd b/man/make_count_text.Rd new file mode 100644 index 000000000..7ff96e9d0 --- /dev/null +++ b/man/make_count_text.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/count_labels.R +\name{make_count_text} +\alias{make_count_text} +\title{Make a count text} +\usage{ +make_count_text(label, countmax, countnow = NULL) +} +\arguments{ +\item{label}{(\code{character(1)}) Text displayed before counts} + +\item{countmax}{(\code{numeric(1)}) unfiltered counts} + +\item{countnow}{(\code{numeric(1)}) filtered counts} +} +\value{ +\code{character(1)} +} +\description{ +Returns a text describing filtered counts. The text is composed in the following way: +\itemize{ +\item when \code{countnow} is not \code{NULL}: \verb{