| 1 |
- # FilteredDataset abstract --------+ # FilteredData ------ |
||
| 3 |
- #' @name FilteredDataset+ #' @name FilteredData |
||
| 6 |
- #' @title `FilteredDataset` `R6` class+ #' @title Class to encapsulate filtered datasets |
||
| 7 |
- #' @description+ #' |
||
| 8 |
- #' `FilteredDataset` is a class which renders/controls `FilterStates`(s)+ #' @description |
||
| 9 |
- #' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one+ #' Manages filtering of all datasets in the application or module. |
||
| 10 |
- #' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects.+ #' |
||
| 11 |
- #' Each `FilterStates` is responsible for one filter/subset expression applied for specific+ #' @details |
||
| 12 |
- #' components of the dataset.+ #' The main purpose of this class is to provide a collection of reactive datasets, |
||
| 13 |
- #'+ #' each dataset having a filter state that determines how it is filtered. |
||
| 14 |
- #' @keywords internal+ #' |
||
| 15 |
- FilteredDataset <- R6::R6Class( # nolint+ #' For each dataset, `get_filter_expr` returns the call to filter the dataset according |
||
| 16 |
- "FilteredDataset",+ #' to the filter state. The data itself can be obtained through `get_data`. |
||
| 17 |
- # public methods ----+ #' |
||
| 18 |
- public = list(+ #' The datasets are filtered lazily, i.e. only when requested / needed in a `shiny` app. |
||
| 19 |
- #' @description+ #' |
||
| 20 |
- #' Initializes this `FilteredDataset` object.+ #' By design, any `dataname` set through `set_dataset` cannot be removed because |
||
| 21 |
- #'+ #' other code may already depend on it. As a workaround, the underlying |
||
| 22 |
- #' @param dataset any object+ #' data can be set to `NULL`. |
||
| 23 |
- #' @param dataname (`character(1)`)+ #' |
||
| 24 |
- #' syntactically valid name given to the dataset.+ #' The class currently supports variables of the following types within datasets: |
||
| 25 |
- #' @param keys (`character`) optional+ #' - `choices`: variable of type `factor`, e.g. `ADSL$COUNTRY`, `iris$Species` |
||
| 26 |
- #' vector of primary key column names.+ #' zero or more options can be selected, when the variable is a factor |
||
| 27 |
- #' @param label (`character(1)`)+ #' - `logical`: variable of type `logical`, e.g. `ADSL$TRT_FLAG` |
||
| 28 |
- #' label to describe the dataset.+ #' exactly one option must be selected, `TRUE` or `FALSE` |
||
| 29 |
- #'+ #' - `ranges`: variable of type `numeric`, e.g. `ADSL$AGE`, `iris$Sepal.Length` |
||
| 30 |
- #' @return Object of class `FilteredDataset`, invisibly.+ #' numerical range, a range within this range can be selected |
||
| 31 |
- #'+ #' - `dates`: variable of type `Date`, `POSIXlt` |
||
| 32 |
- initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label", exact = TRUE)) {
+ #' Other variables cannot be used for filtering the data in this class. |
||
| 33 | -153x | +
- logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
+ #' |
|
| 34 |
-
+ #' Common arguments are: |
||
| 35 |
- # dataset assertion in child classes+ #' 1. `filtered`: whether to return a filtered result or not |
||
| 36 | -153x | +
- check_simple_name(dataname)+ #' 2. `dataname`: the name of one of the datasets in this `FilteredData` object |
|
| 37 | -151x | +
- checkmate::assert_character(keys, any.missing = FALSE)+ #' 3. `varname`: one of the columns in a dataset |
|
| 38 | -151x | +
- checkmate::assert_character(label, null.ok = TRUE)+ #' |
|
| 39 |
-
+ #' @examples |
||
| 40 | -151x | +
- logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
+ #' # use non-exported function from teal.slice |
|
| 41 | -151x | +
- private$dataset <- dataset+ #' FilteredData <- getFromNamespace("FilteredData", "teal.slice")
|
|
| 42 | -151x | +
- private$dataname <- dataname+ #' |
|
| 43 | -151x | +
- private$keys <- keys+ #' library(shiny) |
|
| 44 | -151x | +
- private$label <- if (is.null(label)) character(0) else label+ #' |
|
| 45 |
-
+ #' datasets <- FilteredData$new(list(iris = iris, mtcars = mtcars)) |
||
| 46 |
- # function executing reactive call and returning data+ #' |
||
| 47 | -151x | +
- private$data_filtered_fun <- function(sid = "") {
+ #' # get datanames |
|
| 48 | -24x | +
- checkmate::assert_character(sid)+ #' datasets$datanames() |
|
| 49 | -24x | +
- if (length(sid)) {
+ #' |
|
| 50 | -24x | +
- logger::log_trace("filtering data dataname: { dataname }, sid: { sid }")
+ #' datasets$set_filter_state( |
|
| 51 |
- } else {
+ #' teal_slices(teal_slice(dataname = "iris", varname = "Species", selected = "virginica")) |
||
| 52 | -! | +
- logger::log_trace("filtering data dataname: { private$dataname }")
+ #' ) |
|
| 53 |
- }+ #' isolate(datasets$get_call("iris"))
|
||
| 54 | -24x | +
- env <- new.env(parent = parent.env(globalenv()))+ #' |
|
| 55 | -24x | +
- env[[dataname]] <- private$dataset+ #' datasets$set_filter_state( |
|
| 56 | -24x | +
- filter_call <- self$get_call(sid)+ #' teal_slices(teal_slice(dataname = "mtcars", varname = "mpg", selected = c(15, 20))) |
|
| 57 | -24x | +
- eval_expr_with_msg(filter_call, env)+ #' ) |
|
| 58 | -24x | +
- get(x = dataname, envir = env)+ #' |
|
| 59 |
- }+ #' isolate(datasets$get_filter_state()) |
||
| 60 |
-
+ #' isolate(datasets$get_call("iris"))
|
||
| 61 | -151x | +
- private$data_filtered <- reactive(private$data_filtered_fun())+ #' isolate(datasets$get_call("mtcars"))
|
|
| 62 | -151x | +
- logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
+ #' |
|
| 63 | -151x | +
- invisible(self)+ #' @examplesIf requireNamespace("MultiAssayExperiment")
|
|
| 64 |
- },+ #' ### set_filter_state |
||
| 65 |
-
+ #' library(shiny) |
||
| 66 |
- #' @description+ #' |
||
| 67 |
- #' Returns a formatted string representing this `FilteredDataset` object.+ #' data(miniACC, package = "MultiAssayExperiment") |
||
| 68 |
- #'+ #' datasets <- FilteredData$new(list(iris = iris, mae = miniACC)) |
||
| 69 |
- #' @param show_all (`logical(1)`) passed to `format.teal_slice`.+ #' fs <- teal_slices( |
||
| 70 |
- #' @param trim_lines (`logical(1)`) passed to `format.teal_slice`.+ #' teal_slice( |
||
| 71 |
- #'+ #' dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4), |
||
| 72 |
- #' @return The formatted character string.+ #' keep_na = TRUE, keep_inf = FALSE |
||
| 73 |
- #'+ #' ), |
||
| 74 |
- format = function(show_all = FALSE, trim_lines = TRUE) {
+ #' teal_slice( |
||
| 75 | -24x | +
- sprintf(+ #' dataname = "iris", varname = "Species", selected = c("setosa", "versicolor"),
|
|
| 76 | -24x | +
- "%s:\n%s",+ #' keep_na = FALSE |
|
| 77 | -24x | +
- class(self)[1],+ #' ), |
|
| 78 | -24x | +
- format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)+ #' teal_slice( |
|
| 79 |
- )+ #' dataname = "mae", varname = "years_to_birth", selected = c(30, 50), |
||
| 80 |
- },+ #' keep_na = TRUE, keep_inf = FALSE |
||
| 81 |
-
+ #' ), |
||
| 82 |
- #' @description+ #' teal_slice(dataname = "mae", varname = "vital_status", selected = "1", keep_na = FALSE), |
||
| 83 |
- #' Prints this `FilteredDataset` object.+ #' teal_slice(dataname = "mae", varname = "gender", selected = "female", keep_na = TRUE), |
||
| 84 |
- #'+ #' teal_slice( |
||
| 85 |
- #' @param ... additional arguments passed to `format`.+ #' dataname = "mae", varname = "ARRAY_TYPE", |
||
| 86 |
- #'+ #' selected = "", keep_na = TRUE, experiment = "RPPAArray", arg = "subset" |
||
| 87 |
- print = function(...) {
+ #' ) |
||
| 88 | -10x | +
- cat(isolate(self$format(...)), "\n")+ #' ) |
|
| 89 |
- },+ #' datasets$set_filter_state(state = fs) |
||
| 90 |
-
+ #' isolate(datasets$get_filter_state()) |
||
| 91 |
- #' @description+ #' |
||
| 92 |
- #' Removes all filter items applied to this dataset.+ #' @keywords internal |
||
| 93 |
- #'+ #' |
||
| 94 |
- #' @param force (`logical(1)`)+ FilteredData <- R6::R6Class( # nolint |
||
| 95 |
- #' flag specifying whether to include anchored filter states.+ "FilteredData", |
||
| 96 |
- #'+ # public methods ---- |
||
| 97 |
- #' @return `NULL`.+ public = list( |
||
| 98 |
- clear_filter_states = function(force = FALSE) {
+ #' @description |
||
| 99 | -14x | +
- logger::log_trace("Removing filters from FilteredDataset: { deparse1(self$get_dataname()) }")
+ #' Initialize a `FilteredData` object. |
|
| 100 | -14x | +
- lapply(+ #' @param data_objects (`named list`) |
|
| 101 | -14x | +
- private$get_filter_states(),+ #' List of data objects. |
|
| 102 | -14x | +
- function(filter_states) filter_states$clear_filter_states(force)+ #' Names of the list will be used as `dataname` for respective datasets. |
|
| 103 |
- )+ #' @param join_keys (`join_keys`) optional joining keys, see [`teal.data::join_keys()`]. |
||
| 104 | -14x | +
- logger::log_trace("Removed filters from FilteredDataset: { deparse1(self$get_dataname()) }")
+ #' |
|
| 105 | -14x | +
- NULL+ initialize = function(data_objects, join_keys = teal.data::join_keys()) {
|
|
| 106 | -+ | 67x |
- },+ checkmate::assert_list(data_objects, any.missing = FALSE, min.len = 0, names = "unique") |
| 107 |
-
+ # unpack data.object from the nested list |
||
| 108 | -+ | 67x |
- # managing filter states -----+ data_objects <- lapply(data_objects, function(dataset) {
|
| 109 | -+ | 101x |
-
+ if (is.list(dataset) && "dataset" %in% names(dataset)) {
|
| 110 | -+ | ! |
- # getters ----+ dataset$dataset |
| 111 |
- #' @description+ } else {
|
||
| 112 | -+ | 101x |
- #' Gets a filter expression.+ dataset |
| 113 |
- #'+ } |
||
| 114 |
- #' This function returns filter calls equivalent to selected items+ }) |
||
| 115 |
- #' within each of `filter_states`. Configuration of the calls is constant and+ |
||
| 116 |
- #' depends on `filter_states` type and order which are set during initialization.+ # Note the internals of data_objects are checked in set_dataset |
||
| 117 | -+ | 67x |
- #'+ checkmate::assert_class(join_keys, "join_keys") |
| 118 | -+ | 66x |
- #' @param sid (`character`)+ self$set_join_keys(join_keys) |
| 119 | -+ | 66x |
- #' when specified, the method returns code containing conditions calls of+ child_parent <- sapply( |
| 120 | -+ | 66x |
- #' `FilterState` objects with `sid` different to this `sid` argument.+ names(data_objects), |
| 121 | -+ | 66x |
- #'+ function(i) teal.data::parent(join_keys, i), |
| 122 | -+ | 66x |
- #' @return Either a `list` of filter `call`s, or `NULL`.+ USE.NAMES = TRUE, |
| 123 | -+ | 66x |
- get_call = function(sid = "") {
+ simplify = FALSE |
| 124 | -47x | +
- filter_call <- Filter(+ ) |
|
| 125 | -47x | +66x |
- f = Negate(is.null),+ ordered_datanames <- topological_sort(child_parent) |
| 126 | -47x | +66x |
- x = lapply(private$get_filter_states(), function(x) x$get_call(sid))+ ordered_datanames <- intersect(ordered_datanames, names(data_objects)) |
| 127 |
- )+ |
||
| 128 | -47x | +66x |
- if (length(filter_call) == 0) {
+ for (dataname in ordered_datanames) {
|
| 129 | -29x | +100x |
- return(NULL)+ ds_object <- data_objects[[dataname]] |
| 130 | -+ | 100x |
- }+ self$set_dataset(data = ds_object, dataname = dataname) |
| 131 | -18x | +
- filter_call+ } |
|
| 132 |
- },+ |
||
| 133 | -+ | 66x |
-
+ self$set_available_teal_slices(x = reactive(NULL)) |
| 134 |
- #' @description+ |
||
| 135 | -+ | 66x |
- #' Gets states of all contained `FilterState` objects.+ invisible(self) |
| 136 |
- #'+ }, |
||
| 137 |
- #' @return A `teal_slices` object.+ |
||
| 138 |
- #'+ #' @description |
||
| 139 |
- get_filter_state = function() {
+ #' Gets `datanames`. |
||
| 140 | -184x | +
- states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state()))+ #' @details |
|
| 141 | -184x | +
- do.call(c, states)+ #' The `datanames` are returned in the order in which they must be evaluated (in case of dependencies). |
|
| 142 |
- },+ #' @return Character vector. |
||
| 143 |
-
+ datanames = function() {
|
||
| 144 | -+ | 118x |
- #' @description+ names(private$filtered_datasets) |
| 145 |
- #' Set filter state.+ }, |
||
| 146 |
- #'+ |
||
| 147 |
- #' @param state (`teal_slices`)+ #' @description |
||
| 148 |
- #'+ #' Gets data label for the dataset. |
||
| 149 |
- #' @return Virtual method, returns nothing and raises error.+ #' Useful to display in `Show R Code`. |
||
| 151 |
- set_filter_state = function(state) {
+ #' @param dataname (`character(1)`) name of the dataset |
||
| 152 | -! | +
- stop("set_filter_state is an abstract class method.")
+ #' @return Character string. |
|
| 153 |
- },+ get_datalabel = function(dataname) {
|
||
| 154 | -+ | 1x |
-
+ private$get_filtered_dataset(dataname)$get_dataset_label() |
| 155 |
- #' @description+ }, |
||
| 156 |
- #' Gets the number of `FilterState` objects in all `FilterStates` in this `FilteredDataset`.+ |
||
| 157 |
- #' @return `integer(1)`+ #' @description |
||
| 158 |
- get_filter_count = function() {
+ #' Set list of external filter states available for activation. |
||
| 159 | -16x | +
- length(self$get_filter_state())+ #' @details |
|
| 160 |
- },+ #' Unlike adding new filter from the column, these filters can come with some prespecified settings. |
||
| 161 |
-
+ #' `teal_slices` are wrapped in a `reactive` so they can be updated from elsewhere in the app. |
||
| 162 |
- #' @description+ #' Filters passed in `x` are limited to those that can be set for this `FilteredData` object, |
||
| 163 |
- #' Gets the name of the dataset.+ #' i.e. they have the correct `dataname` and `varname` (waived `teal_slice_fixed` as they do not have `varname`). |
||
| 164 |
- #'+ #' List is accessible in `ui/srv_active` through `ui/srv_available_filters`. |
||
| 165 |
- #' @return A character string.+ #' @param x (`reactive`) |
||
| 166 |
- get_dataname = function() {
+ #' should return `teal_slices` |
||
| 167 | -8x | +
- private$dataname+ #' @return `NULL`, invisibly. |
|
| 168 |
- },+ set_available_teal_slices = function(x) {
|
||
| 169 | -+ | 67x |
-
+ checkmate::assert_class(x, "reactive") |
| 170 | -+ | 67x |
- #' @description+ private$available_teal_slices <- reactive({
|
| 171 |
- #' Gets the dataset object in this `FilteredDataset`.+ # Available filters should be limited to the ones relevant for this FilteredData. |
||
| 172 | -+ | 4x |
- #'+ current_state <- isolate(self$get_filter_state()) |
| 173 | -+ | 4x |
- #' @param filtered (`logical(1)`)+ allowed <- attr(current_state, "include_varnames") |
| 174 | -+ | 4x |
- #'+ forbidden <- attr(current_state, "exclude_varnames") |
| 175 | -+ | 4x |
- #' @return+ foo <- function(slice) {
|
| 176 | -+ | 13x |
- #' The stored dataset. If `data.frame` or `MultiAssayExperiment`,+ if (slice$dataname %in% self$datanames()) {
|
| 177 | -+ | 13x |
- #' either raw or as a reactive with current filters applied (depending on `filtered`).+ if (slice$fixed) {
|
| 178 | -+ | 4x |
- #'+ TRUE |
| 179 |
- get_dataset = function(filtered = FALSE) {
+ } else {
|
||
| 180 | -51x | +9x |
- if (filtered) {
+ isTRUE(slice$varname %in% allowed[[slice$dataname]]) || |
| 181 | -33x | +9x |
- private$data_filtered+ isFALSE(slice$varname %in% forbidden[[slice$dataname]]) |
| 182 |
- } else {
+ } |
||
| 183 | -18x | +
- private$dataset+ } else {
|
|
| 184 | -+ | ! |
- }+ FALSE |
| 185 |
- },+ } |
||
| 186 |
-
+ } |
||
| 187 | -+ | 4x |
- #' @description+ Filter(foo, x()) |
| 188 |
- #' Get filter overview of a dataset.+ }) |
||
| 189 | -+ | 67x |
- #' @return Virtual method, returns nothing and raises an error.+ invisible(NULL) |
| 190 |
- get_filter_overview = function() {
+ }, |
||
| 191 | -! | +
- stop("get_filter_overview is an abstract class method")
+
|
|
| 192 |
- },+ #' @description |
||
| 193 |
-
+ #' Get list of filter states available for this object. |
||
| 194 |
- #' @description+ #' @details |
||
| 195 |
- #' Gets the key columns for this dataset.+ #' All `teal_slice` objects that have been created since the beginning of the app session |
||
| 196 |
- #' @return Character vector of variable names+ #' are stored in one `teal_slices` object. This returns a subset of that `teal_slices`, |
||
| 197 |
- get_keys = function() {
+ #' describing filter states that can be set for this object. |
||
| 198 | -133x | +
- private$keys+ #' @return `reactive` that returns `teal_slices`. |
|
| 199 |
- },+ get_available_teal_slices = function() {
|
||
| 200 | -+ | 4x |
-
+ private$available_teal_slices |
| 201 |
- #' @description+ }, |
||
| 202 |
- #' Gets the dataset label.+ |
||
| 203 |
- #' @return Character string.+ # datasets methods ---- |
||
| 204 |
- get_dataset_label = function() {
+
|
||
| 205 | -2x | +
- private$label+ #' @description |
|
| 206 |
- },+ #' Gets a `call` to filter the dataset according to the filter state. |
||
| 207 |
-
+ #' @details |
||
| 208 |
- # modules ------+ #' It returns a `call` to filter the dataset only, assuming the |
||
| 209 |
- #' @description+ #' other (filtered) datasets it depends on are available. |
||
| 210 |
- #' `shiny` module containing active filters for a dataset, along with a title and a remove button.+ #' |
||
| 211 |
- #' @param id (`character(1)`)+ #' Together with `self$datanames()` which returns the datasets in the correct |
||
| 212 |
- #' `shiny` module instance id.+ #' evaluation order, this generates the whole filter code, see the function |
||
| 213 |
- #'+ #' `FilteredData$get_filter_code`. |
||
| 214 |
- #' @return `shiny.tag`+ #' |
||
| 215 |
- ui_active = function(id) {
+ #' For the return type, note that `rlang::is_expression` returns `TRUE` on the |
||
| 216 | -! | +
- dataname <- self$get_dataname()+ #' return type, both for base `R` expressions and calls (single expression, |
|
| 217 | -! | +
- checkmate::assert_string(dataname)+ #' capturing a function call). |
|
| 218 |
-
+ #' |
||
| 219 | -! | +
- ns <- NS(id)+ #' The filtered dataset has the name given by `self$filtered_dataname(dataname)` |
|
| 220 | -! | +
- if_multiple_filter_states <- length(private$get_filter_states()) > 1+ #' |
|
| 221 | -! | +
- tags$span(+ #' This can be used for the `Show R Code` generation. |
|
| 222 | -! | +
- id = id,+ #' |
|
| 223 | -! | +
- include_css_files("filter-panel"),
+ #' @param dataname (`character(1)`) name of the dataset |
|
| 224 | -! | +
- tags$div(+ #' |
|
| 225 | -! | +
- id = ns("whole_ui"), # to hide it entirely
+ #' @return A list of `call`s. |
|
| 226 | -! | +
- fluidRow(+ #' |
|
| 227 | -! | +
- column(+ get_call = function(dataname) {
|
|
| 228 | -! | +10x |
- width = 8,+ checkmate::assert_subset(dataname, self$datanames()) |
| 229 | -! | +9x |
- tags$span(dataname, class = "filter_panel_dataname")+ private$get_filtered_dataset(dataname)$get_call() |
| 230 |
- ),+ }, |
||
| 231 | -! | +
- column(+ |
|
| 232 | -! | +
- width = 4,+ #' @description |
|
| 233 | -! | +
- tagList(+ #' Gets filtered or unfiltered dataset. |
|
| 234 | -! | +
- actionLink(+ #' |
|
| 235 | -! | +
- ns("remove_filters"),
+ #' For `filtered = FALSE`, the original data set with `set_data` is returned including all attributes. |
|
| 236 | -! | +
- label = "",+ #' |
|
| 237 | -! | +
- icon = icon("circle-xmark", lib = "font-awesome"),
+ #' @param dataname (`character(1)`) name of the dataset. |
|
| 238 | -! | +
- class = "remove pull-right"+ #' @param filtered (`logical(1)`) whether to return a filtered or unfiltered dataset. |
|
| 239 |
- ),+ #' |
||
| 240 | -! | +
- actionLink(+ #' @return A data object, a `data.frame` or a `MultiAssayExperiment`. |
|
| 241 | -! | +
- ns("collapse"),
+ #' |
|
| 242 | -! | +
- label = "",+ get_data = function(dataname, filtered = TRUE) {
|
|
| 243 | -! | +24x |
- icon = icon("angle-down", lib = "font-awesome"),
+ checkmate::assert_subset(dataname, self$datanames()) |
| 244 | -! | +23x |
- class = "remove pull-right"+ checkmate::assert_flag(filtered) |
| 245 | -+ | 22x |
- )+ data <- private$get_filtered_dataset(dataname)$get_dataset(filtered) |
| 246 | -+ | 3x |
- )+ if (filtered) data() else data |
| 247 |
- )+ }, |
||
| 248 |
- ),+ |
||
| 249 | -! | +
- shinyjs::hidden(+ #' @description |
|
| 250 | -! | +
- tags$div(+ #' Get join keys between two datasets. |
|
| 251 | -! | +
- id = ns("filter_count_ui"),
+ #' |
|
| 252 | -! | +
- tagList(+ #' @return `join_keys` |
|
| 253 | -! | +
- textOutput(ns("filter_count")),
+ #' |
|
| 254 | -! | +
- tags$br()+ get_join_keys = function() {
|
|
| 255 | -+ | 2x |
- )+ private$join_keys |
| 256 |
- )+ }, |
||
| 257 |
- ),+ |
||
| 258 | -! | +
- tags$div(+ #' @description |
|
| 259 |
- # id needed to insert and remove UI to filter single variable as needed+ #' Creates filter overview table to be displayed in the application. |
||
| 260 |
- # it is currently also used by the above module to entirely hide this panel+ #' One row is created per dataset, according to the `get_filter_overview` methods |
||
| 261 | -! | +
- id = ns("filters"),
+ #' of the contained `FilteredDataset` objects. |
|
| 262 | -! | +
- class = "parent-hideable-list-group",+ #' |
|
| 263 | -! | +
- tagList(+ #' @param datanames (`character`) vector of dataset names. |
|
| 264 | -! | +
- lapply(+ #' |
|
| 265 | -! | +
- names(private$get_filter_states()),+ #' @return A `data.frame` listing the numbers of observations in all datasets. |
|
| 266 | -! | +
- function(x) {
+ #' |
|
| 267 | -! | +
- tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x)))+ get_filter_overview = function(datanames) {
|
|
| 268 | -+ | 9x |
- }+ rows <- lapply( |
| 269 | -+ | 9x |
- )+ datanames, |
| 270 | -+ | 9x |
- )+ function(dataname) {
|
| 271 | -+ | 11x |
- )+ private$get_filtered_dataset(dataname)$get_filter_overview() |
| 272 |
- )+ } |
||
| 274 | -+ | 5x |
- },+ unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1)) |
| 275 | -+ | 5x |
-
+ dplyr::bind_rows(c(rows[!unssuported_idx], rows[unssuported_idx])) |
| 276 |
- #' @description+ }, |
||
| 277 |
- #' Server module for a dataset active filters.+ |
||
| 278 |
- #'+ #' @description |
||
| 279 |
- #' @param id (`character(1)`)+ #' Get keys for the dataset. |
||
| 280 |
- #' `shiny` module instance id.+ #' |
||
| 281 |
- #' @return `NULL`.+ #' @param dataname (`character(1)`) name of the dataset. |
||
| 282 |
- srv_active = function(id) {
+ #' |
||
| 283 | -7x | +
- moduleServer(+ #' @return Character vector of key column names. |
|
| 284 | -7x | +
- id = id,+ #' |
|
| 285 | -7x | +
- function(input, output, session) {
+ get_keys = function(dataname) {
|
|
| 286 | -7x | +1x |
- dataname <- self$get_dataname()+ private$get_filtered_dataset(dataname)$get_keys() |
| 287 | -7x | +
- logger::log_trace("FilteredDataset$srv_active initializing, dataname: { dataname }")
+ }, |
|
| 288 | -7x | +
- checkmate::assert_string(dataname)+ |
|
| 289 | -7x | +
- output$filter_count <- renderText(+ #' @description |
|
| 290 | -7x | +
- sprintf(+ #' Adds a dataset to this `FilteredData`. |
|
| 291 | -7x | +
- "%d filter%s applied",+ #' |
|
| 292 | -7x | +
- self$get_filter_count(),+ #' @details |
|
| 293 | -7x | +
- if (self$get_filter_count() != 1) "s" else ""+ #' `set_dataset` creates a `FilteredDataset` object which keeps `dataset` for the filtering purpose. |
|
| 294 |
- )+ #' If this data has a parent specified in the `join_keys` object stored in `private$join_keys` |
||
| 295 |
- )+ #' then created `FilteredDataset` (child) gets linked with other `FilteredDataset` (parent). |
||
| 296 |
-
+ #' "Child" dataset return filtered data then dependent on the reactive filtered data of the |
||
| 297 | -7x | +
- lapply(+ #' "parent". See more in documentation of `parent` argument in `DataframeFilteredDataset` constructor. |
|
| 298 | -7x | +
- names(private$get_filter_states()),+ #' |
|
| 299 | -7x | +
- function(x) {
+ #' @param data (`data.frame` or `MultiAssayExperiment`) |
|
| 300 | -12x | +
- private$get_filter_states()[[x]]$srv_active(id = x)+ #' data to be filtered. |
|
| 301 |
- }+ #' |
||
| 302 |
- )+ #' @param dataname (`character(1)`) |
||
| 303 |
-
+ #' the name of the `dataset` to be added to this object. |
||
| 304 | -7x | +
- observeEvent(self$get_filter_state(), {
+ #' |
|
| 305 | -8x | +
- shinyjs::hide("filter_count_ui")
+ #' @return `self`, invisibly. |
|
| 306 | -8x | +
- shinyjs::show("filters")
+ #' |
|
| 307 | -8x | +
- shinyjs::toggle("remove_filters", condition = length(self$get_filter_state()) != 0)
+ set_dataset = function(data, dataname) {
|
|
| 308 | -8x | +105x |
- shinyjs::toggle("collapse", condition = length(self$get_filter_state()) != 0)
+ checkmate::assert_string(dataname) |
| 309 | -+ | 105x |
- })+ logger::log_trace("FilteredData$set_dataset setting dataset, name: { dataname }")
|
| 310 |
-
+ # to include it nicely in the Show R Code; |
||
| 311 | -7x | +
- observeEvent(input$collapse, {
+ # the UI also uses `datanames` in ids, so no whitespaces allowed |
|
| 312 | -! | +105x |
- shinyjs::toggle("filter_count_ui")
+ check_simple_name(dataname) |
| 313 | -! | +
- shinyjs::toggle("filters")
+
|
|
| 314 | -! | +105x |
- toggle_icon(session$ns("collapse"), c("fa-angle-right", "fa-angle-down"))
+ parent_dataname <- teal.data::parent(private$join_keys, dataname) |
| 315 | -+ | 105x |
- })+ keys <- private$join_keys[dataname, dataname] |
| 316 | -+ | 104x |
-
+ if (is.null(keys)) keys <- character(0) |
| 317 | -7x | +
- observeEvent(input$remove_filters, {
+
|
|
| 318 | -1x | +105x |
- logger::log_trace("FilteredDataset$srv_active@1 removing all non-anchored filters, dataname: { dataname }")
+ if (length(parent_dataname) == 0) {
|
| 319 | -1x | +95x |
- self$clear_filter_states()+ private$filtered_datasets[[dataname]] <- init_filtered_dataset( |
| 320 | -1x | +95x |
- logger::log_trace("FilteredDataset$srv_active@1 removed all non-anchored filters, dataname: { dataname }")
+ dataset = data, |
| 321 | -+ | 95x |
- })+ dataname = dataname, |
| 322 | -+ | 95x |
-
+ keys = keys |
| 323 | -7x | +
- logger::log_trace("FilteredDataset$initialized, dataname: { dataname }")
+ ) |
|
| 324 |
-
+ } else {
|
||
| 325 | -7x | +10x |
- NULL+ join_keys <- private$join_keys[dataname, parent_dataname] |
| 326 | -+ | ! |
- }+ if (is.null(join_keys)) join_keys <- character(0) |
| 327 | -+ | 10x |
- )+ private$filtered_datasets[[dataname]] <- init_filtered_dataset( |
| 328 | -+ | 10x |
- },+ dataset = data, |
| 329 | -+ | 10x |
-
+ dataname = dataname, |
| 330 | -+ | 10x |
- #' @description+ keys = keys, |
| 331 | -+ | 10x |
- #' UI module to add filter variable for this dataset.+ parent_name = parent_dataname, |
| 332 | -+ | 10x |
- #'+ parent = reactive(self$get_data(parent_dataname, filtered = TRUE)), |
| 333 | -+ | 10x |
- #' @param id (`character(1)`)+ join_keys = join_keys |
| 334 |
- #' `shiny` module instance id.+ ) |
||
| 335 |
- #'+ } |
||
| 336 |
- #' @return Virtual method, returns nothing and raises error.+ |
||
| 337 | -+ | 105x |
- ui_add = function(id) {
+ invisible(self) |
| 338 | -1x | +
- stop("Pure virtual method")
+ }, |
|
| 339 |
- },+ |
||
| 340 |
-
+ #' @description |
||
| 341 |
- #' @description+ #' Set the `join_keys`. |
||
| 342 |
- #' Server module to add filter variable for this dataset.+ #' |
||
| 343 |
- #' For this class `srv_add` calls multiple modules+ #' @param join_keys (`join_keys`), see [`teal.data::join_keys()`]. |
||
| 344 |
- #' of the same name from `FilterStates` as `MAEFilteredDataset`+ #' |
||
| 345 |
- #' contains one `FilterStates` object for `colData` and one for each experiment.+ #' @return `self`, invisibly. |
||
| 347 |
- #' @param id (`character(1)`)+ set_join_keys = function(join_keys) {
|
||
| 348 | -+ | 66x |
- #' `shiny` module instance id.+ checkmate::assert_class(join_keys, "join_keys") |
| 349 | -+ | 66x |
- #'+ private$join_keys <- join_keys |
| 350 | -+ | 66x |
- #' @return `NULL`.+ invisible(self) |
| 351 |
- srv_add = function(id) {
+ }, |
||
| 352 | -2x | +
- moduleServer(+ |
|
| 353 | -2x | +
- id = id,+ # Functions useful for restoring from another dataset ---- |
|
| 354 | -2x | +
- function(input, output, session) {
+
|
|
| 355 | -2x | +
- logger::log_trace("MAEFilteredDataset$srv_add initializing, dataname: { deparse1(self$get_dataname()) }")
+ #' @description |
|
| 356 | -2x | +
- elems <- private$get_filter_states()+ #' Gets states of all contained `FilterState` objects. |
|
| 357 | -2x | +
- elem_names <- names(private$get_filter_states())+ #' |
|
| 358 | -2x | +
- lapply(+ #' @return A `teal_slices` object. |
|
| 359 | -2x | +
- elem_names,+ #' |
|
| 360 | -2x | +
- function(elem_name) elems[[elem_name]]$srv_add(elem_name)+ get_filter_state = function() {
|
|
| 361 | -+ | 53x |
- )+ states <- unname(lapply(private$filtered_datasets, function(x) x$get_filter_state())) |
| 362 | -2x | +53x |
- logger::log_trace("MAEFilteredDataset$srv_add initialized, dataname: { deparse1(self$get_dataname()) }")
+ slices <- Filter(Negate(is.null), states) |
| 363 | -2x | +53x |
- NULL+ slices <- do.call(c, slices) |
| 364 | -+ | 53x |
- }+ if (!is.null(slices)) {
|
| 365 | -+ | 53x |
- )+ attr(slices, "allow_add") <- private$allow_add |
| 366 |
- }+ } |
||
| 367 | -+ | 53x |
- ),+ slices |
| 368 |
- # private fields ----+ }, |
||
| 369 |
- private = list(+ |
||
| 370 |
- dataset = NULL, # data.frame or MultiAssayExperiment+ #' @description |
||
| 371 |
- data_filtered = NULL,+ #' Returns a formatted string representing this `FilteredData` object. |
||
| 372 |
- data_filtered_fun = NULL, # function+ #' |
||
| 373 |
- filter_states = list(),+ #' @param show_all (`logical(1)`) passed to `format.teal_slice`. |
||
| 374 |
- dataname = character(0),+ #' @param trim_lines (`logical(1)`) passed to `format.teal_slice`. |
||
| 375 |
- keys = character(0),+ #' |
||
| 376 |
- label = character(0),+ #' @return `character(1)` the formatted string. |
||
| 377 |
-
+ #' |
||
| 378 |
- # Adds `FilterStates` to the `private$filter_states`.+ format = function(show_all = FALSE, trim_lines = TRUE) {
|
||
| 379 | -+ | 5x |
- # `FilterStates` is added once for each element of the dataset.+ datasets <- lapply(self$datanames(), private$get_filtered_dataset) |
| 380 | -+ | 5x |
- # @param filter_states (`FilterStates`)+ ind <- vapply(datasets, inherits, logical(1L), what = "DefaultFilteredDataset") |
| 381 | -+ | 5x |
- # @param id (`character(1)`)+ states <- do.call(c, lapply(datasets[!ind], function(ds) ds$get_filter_state())) |
| 382 | -+ | 5x |
- add_filter_states = function(filter_states, id) {
+ states_fmt <- format(states, show_all = show_all, trim_lines = trim_lines) |
| 383 | -225x | +5x |
- checkmate::assert_class(filter_states, "FilterStates")+ holders_fmt <- vapply(datasets[ind], format, character(1L), show_all = show_all, trim_lines = trim_lines) |
| 384 | -225x | +
- checkmate::assert_string(id)+ |
|
| 385 | -225x | +5x |
- x <- stats::setNames(list(filter_states), id)+ sprintf( |
| 386 | -225x | +5x |
- private$filter_states <- c(private$get_filter_states(), x)+ "%s:\n%s", |
| 387 | -+ | 5x |
- },+ class(self)[1], |
| 388 | -+ | 5x |
-
+ paste(c(states_fmt, holders_fmt), collapse = "\n") |
| 389 |
- # @description+ ) |
||
| 390 |
- # Gets `FilterStates` objects in this `FilteredDataset`.+ }, |
||
| 391 |
- # @return list of `FilterStates` objects.+ |
||
| 392 |
- get_filter_states = function() {
+ #' @description |
||
| 393 | -684x | +
- private$filter_states+ #' Prints this `FilteredData` object. |
|
| 394 |
- }+ #' |
||
| 395 |
- )+ #' @param ... additional arguments passed to `format`. |
||
| 396 |
- )+ #' |
| 1 | +397 |
- # FilteredData ------+ print = function(...) {
|
||
| 2 | -+ | |||
| 398 | +! |
-
+ cat(isolate(self$format(...)), "\n") |
||
| 3 | +399 |
- #' @name FilteredData+ }, |
||
| 4 | +400 |
- #' @docType class+ |
||
| 5 | +401 |
- #'+ #' @description |
||
| 6 | +402 |
- #' @title Class to encapsulate filtered datasets+ #' Sets active filter states. |
||
| 7 | +403 |
- #'+ #' |
||
| 8 | +404 |
- #' @description+ #' @param state (`teal_slices`) |
||
| 9 | +405 |
- #' Manages filtering of all datasets in the application or module.+ #' |
||
| 10 | +406 |
- #'+ #' @return `NULL`, invisibly. |
||
| 11 | +407 |
- #' @details+ set_filter_state = function(state) {
|
||
| 12 | -+ | |||
| 408 | +31x |
- #' The main purpose of this class is to provide a collection of reactive datasets,+ isolate({
|
||
| 13 | -+ | |||
| 409 | +31x |
- #' each dataset having a filter state that determines how it is filtered.+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing")
|
||
| 14 | -+ | |||
| 410 | +31x |
- #'+ checkmate::assert_class(state, "teal_slices") |
||
| 15 | -+ | |||
| 411 | +31x |
- #' For each dataset, `get_filter_expr` returns the call to filter the dataset according+ allow_add <- attr(state, "allow_add") |
||
| 16 | -+ | |||
| 412 | +31x |
- #' to the filter state. The data itself can be obtained through `get_data`.+ if (!is.null(allow_add)) {
|
||
| 17 | -+ | |||
| 413 | +31x |
- #'+ private$allow_add <- allow_add |
||
| 18 | +414 |
- #' The datasets are filtered lazily, i.e. only when requested / needed in a `shiny` app.+ } |
||
| 19 | +415 |
- #'+ |
||
| 20 | -+ | |||
| 416 | +31x |
- #' By design, any `dataname` set through `set_dataset` cannot be removed because+ lapply(self$datanames(), function(dataname) {
|
||
| 21 | -+ | |||
| 417 | +63x |
- #' other code may already depend on it. As a workaround, the underlying+ states <- Filter(function(x) identical(x$dataname, dataname), state) |
||
| 22 | -+ | |||
| 418 | +63x |
- #' data can be set to `NULL`.+ private$get_filtered_dataset(dataname)$set_filter_state(states) |
||
| 23 | +419 |
- #'+ }) |
||
| 24 | +420 |
- #' The class currently supports variables of the following types within datasets:+ |
||
| 25 | -+ | |||
| 421 | +31x |
- #' - `choices`: variable of type `factor`, e.g. `ADSL$COUNTRY`, `iris$Species`+ logger::log_trace("{ class(self)[1] }$set_filter_state initialized")
|
||
| 26 | +422 |
- #' zero or more options can be selected, when the variable is a factor+ }) |
||
| 27 | +423 |
- #' - `logical`: variable of type `logical`, e.g. `ADSL$TRT_FLAG`+ |
||
| 28 | -+ | |||
| 424 | +31x |
- #' exactly one option must be selected, `TRUE` or `FALSE`+ invisible(NULL) |
||
| 29 | +425 |
- #' - `ranges`: variable of type `numeric`, e.g. `ADSL$AGE`, `iris$Sepal.Length`+ }, |
||
| 30 | +426 |
- #' numerical range, a range within this range can be selected+ |
||
| 31 | +427 |
- #' - `dates`: variable of type `Date`, `POSIXlt`+ #' @description |
||
| 32 | +428 |
- #' Other variables cannot be used for filtering the data in this class.+ #' Removes one or more `FilterState` from a `FilteredData` object. |
||
| 33 | +429 |
- #'+ #' |
||
| 34 | +430 |
- #' Common arguments are:+ #' @param state (`teal_slices`) |
||
| 35 | +431 |
- #' 1. `filtered`: whether to return a filtered result or not+ #' specifying `FilterState` objects to remove; |
||
| 36 | +432 |
- #' 2. `dataname`: the name of one of the datasets in this `FilteredData` object+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored. |
||
| 37 | +433 |
- #' 3. `varname`: one of the columns in a dataset+ #' |
||
| 38 | +434 |
- #'+ #' @return `NULL`, invisibly. |
||
| 39 | +435 |
- #' @examples+ #' |
||
| 40 | +436 |
- #' # use non-exported function from teal.slice+ remove_filter_state = function(state) {
|
||
| 41 | -+ | |||
| 437 | +8x |
- #' FilteredData <- getFromNamespace("FilteredData", "teal.slice")
+ isolate({
|
||
| 42 | -+ | |||
| 438 | +8x |
- #'+ checkmate::assert_class(state, "teal_slices") |
||
| 43 | -+ | |||
| 439 | +8x |
- #' library(shiny)+ datanames <- unique(vapply(state, "[[", character(1L), "dataname")) |
||
| 44 | -+ | |||
| 440 | +8x |
- #'+ checkmate::assert_subset(datanames, self$datanames()) |
||
| 45 | +441 |
- #' datasets <- FilteredData$new(list(iris = iris, mtcars = mtcars))+ |
||
| 46 | -+ | |||
| 442 | +8x |
- #'+ logger::log_trace( |
||
| 47 | -+ | |||
| 443 | +8x |
- #' # get datanames+ "{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }"
|
||
| 48 | +444 |
- #' datasets$datanames()+ ) |
||
| 49 | +445 |
- #'+ |
||
| 50 | -+ | |||
| 446 | +8x |
- #' datasets$set_filter_state(+ lapply(datanames, function(dataname) {
|
||
| 51 | -+ | |||
| 447 | +9x |
- #' teal_slices(teal_slice(dataname = "iris", varname = "Species", selected = "virginica"))+ slices <- Filter(function(x) identical(x$dataname, dataname), state) |
||
| 52 | -+ | |||
| 448 | +9x |
- #' )+ private$get_filtered_dataset(dataname)$remove_filter_state(slices) |
||
| 53 | +449 |
- #' isolate(datasets$get_call("iris"))
+ }) |
||
| 54 | +450 |
- #'+ |
||
| 55 | -+ | |||
| 451 | +8x |
- #' datasets$set_filter_state(+ logger::log_trace( |
||
| 56 | -+ | |||
| 452 | +8x |
- #' teal_slices(teal_slice(dataname = "mtcars", varname = "mpg", selected = c(15, 20)))+ "{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }"
|
||
| 57 | +453 |
- #' )+ ) |
||
| 58 | +454 |
- #'+ }) |
||
| 59 | +455 |
- #' isolate(datasets$get_filter_state())+ |
||
| 60 | -+ | |||
| 456 | +8x |
- #' isolate(datasets$get_call("iris"))
+ invisible(NULL) |
||
| 61 | +457 |
- #' isolate(datasets$get_call("mtcars"))
+ }, |
||
| 62 | +458 |
- #'+ |
||
| 63 | +459 |
- #' @examplesIf requireNamespace("MultiAssayExperiment")
+ #' @description |
||
| 64 | +460 |
- #' ### set_filter_state+ #' Remove all `FilterStates` of a `FilteredDataset` or all `FilterStates` of a `FilteredData` object. |
||
| 65 | +461 |
- #' library(shiny)+ #' |
||
| 66 | +462 |
- #'+ #' @param datanames (`character`) |
||
| 67 | +463 |
- #' data(miniACC, package = "MultiAssayExperiment")+ #' names of datasets for which to remove all filter states. |
||
| 68 | +464 |
- #' datasets <- FilteredData$new(list(iris = iris, mae = miniACC))+ #' Defaults to all datasets in this `FilteredData` object. |
||
| 69 | +465 |
- #' fs <- teal_slices(+ #' @param force (`logical(1)`) |
||
| 70 | +466 |
- #' teal_slice(+ #' flag specifying whether to include anchored filter states. |
||
| 71 | +467 |
- #' dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4),+ #' |
||
| 72 | +468 |
- #' keep_na = TRUE, keep_inf = FALSE+ #' @return `NULL`, invisibly. |
||
| 73 | +469 |
- #' ),+ #' |
||
| 74 | +470 |
- #' teal_slice(+ clear_filter_states = function(datanames = self$datanames(), force = FALSE) {
|
||
| 75 | -+ | |||
| 471 | +7x |
- #' dataname = "iris", varname = "Species", selected = c("setosa", "versicolor"),
+ logger::log_trace( |
||
| 76 | -+ | |||
| 472 | +7x |
- #' keep_na = FALSE+ "FilteredData$clear_filter_states called, datanames: { toString(datanames) }"
|
||
| 77 | +473 |
- #' ),+ ) |
||
| 78 | +474 |
- #' teal_slice(+ |
||
| 79 | -+ | |||
| 475 | +7x |
- #' dataname = "mae", varname = "years_to_birth", selected = c(30, 50),+ for (dataname in datanames) {
|
||
| 80 | -+ | |||
| 476 | +12x |
- #' keep_na = TRUE, keep_inf = FALSE+ fdataset <- private$get_filtered_dataset(dataname = dataname) |
||
| 81 | -+ | |||
| 477 | +12x |
- #' ),+ fdataset$clear_filter_states(force) |
||
| 82 | +478 |
- #' teal_slice(dataname = "mae", varname = "vital_status", selected = "1", keep_na = FALSE),+ } |
||
| 83 | +479 |
- #' teal_slice(dataname = "mae", varname = "gender", selected = "female", keep_na = TRUE),+ |
||
| 84 | -+ | |||
| 480 | +7x |
- #' teal_slice(+ logger::log_trace( |
||
| 85 | -+ | |||
| 481 | +7x |
- #' dataname = "mae", varname = "ARRAY_TYPE",+ paste( |
||
| 86 | -+ | |||
| 482 | +7x |
- #' selected = "", keep_na = TRUE, experiment = "RPPAArray", arg = "subset"+ "FilteredData$clear_filter_states removed all non-anchored FilterStates,", |
||
| 87 | -+ | |||
| 483 | +7x |
- #' )+ "datanames: { toString(datanames) }"
|
||
| 88 | +484 |
- #' )+ ) |
||
| 89 | +485 |
- #' datasets$set_filter_state(state = fs)+ ) |
||
| 90 | +486 |
- #' isolate(datasets$get_filter_state())+ |
||
| 91 | -+ | |||
| 487 | +7x |
- #'+ invisible(NULL) |
||
| 92 | +488 |
- #' @keywords internal+ }, |
||
| 93 | +489 |
- #'+ |
||
| 94 | +490 |
- FilteredData <- R6::R6Class( # nolint+ |
||
| 95 | +491 |
- "FilteredData",+ # shiny modules ----- |
||
| 96 | +492 |
- # public methods ----+ |
||
| 97 | +493 |
- public = list(+ #' @description |
||
| 98 | +494 |
- #' @description+ #' top-level `shiny` module for the filter panel in the `teal` app. |
||
| 99 | +495 |
- #' Initialize a `FilteredData` object.+ #' Contains 1) filter overview panel, 2) filter active panel, and 3) add filters panel. |
||
| 100 | +496 |
- #' @param data_objects (`named list`)+ #' |
||
| 101 | +497 |
- #' List of data objects.+ #' @param id (`character(1)`) |
||
| 102 | +498 |
- #' Names of the list will be used as `dataname` for respective datasets.+ #' `shiny` module instance id. |
||
| 103 | +499 |
- #' @param join_keys (`join_keys`) optional joining keys, see [`teal.data::join_keys()`].+ #' @return `shiny.tag` |
||
| 104 | +500 |
- #'+ ui_filter_panel = function(id) {
|
||
| 105 | -+ | |||
| 501 | +! |
- initialize = function(data_objects, join_keys = teal.data::join_keys()) {
+ ns <- NS(id) |
||
| 106 | -67x | +|||
| 502 | +! |
- checkmate::assert_list(data_objects, any.missing = FALSE, min.len = 0, names = "unique")+ tags$div( |
||
| 107 | -+ | |||
| 503 | +! |
- # unpack data.object from the nested list+ id = ns(NULL), # used for hiding / showing |
||
| 108 | -67x | +|||
| 504 | +! |
- data_objects <- lapply(data_objects, function(dataset) {
+ include_css_files(pattern = "filter-panel"), |
||
| 109 | -101x | +|||
| 505 | +! |
- if (is.list(dataset) && "dataset" %in% names(dataset)) {
+ self$ui_overview(ns("overview")),
|
||
| 110 | +506 | ! |
- dataset$dataset+ self$ui_active(ns("active")),
|
|
| 111 | -+ | |||
| 507 | +! |
- } else {
+ if (private$allow_add) {
|
||
| 112 | -101x | +|||
| 508 | +! |
- dataset+ self$ui_add(ns("add"))
|
||
| 113 | +509 |
} |
||
| 114 | +510 |
- })+ ) |
||
| 115 | +511 | ++ |
+ },+ |
+ |
| 512 | ||||
| 116 | +513 |
- # Note the internals of data_objects are checked in set_dataset+ #' @description |
||
| 117 | -67x | +|||
| 514 | +
- checkmate::assert_class(join_keys, "join_keys")+ #' Server function for filter panel. |
|||
| 118 | -66x | +|||
| 515 | +
- self$set_join_keys(join_keys)+ #' |
|||
| 119 | -66x | +|||
| 516 | +
- child_parent <- sapply(+ #' @param id (`character(1)`) |
|||
| 120 | -66x | +|||
| 517 | +
- names(data_objects),+ #' `shiny` module instance id. |
|||
| 121 | -66x | +|||
| 518 | +
- function(i) teal.data::parent(join_keys, i),+ #' @param active_datanames (`function` or `reactive`) |
|||
| 122 | -66x | +|||
| 519 | +
- USE.NAMES = TRUE,+ #' returning `datanames` that should be shown on the filter panel. |
|||
| 123 | -66x | +|||
| 520 | +
- simplify = FALSE+ #' Must be a subset of the `datanames` in this `FilteredData`. |
|||
| 124 | +521 |
- )+ #' If the function returns `NULL` (as opposed to `character(0)`), |
||
| 125 | -66x | +|||
| 522 | +
- ordered_datanames <- topological_sort(child_parent)+ #' the filter panel will be hidden. |
|||
| 126 | -66x | +|||
| 523 | +
- ordered_datanames <- intersect(ordered_datanames, names(data_objects))+ #' @return `NULL`. |
|||
| 127 | +524 |
-
+ srv_filter_panel = function(id, active_datanames = self$datanames) {
|
||
| 128 | -66x | +525 | +1x |
- for (dataname in ordered_datanames) {
+ checkmate::assert_function(active_datanames) |
| 129 | -100x | +526 | +1x |
- ds_object <- data_objects[[dataname]]+ moduleServer( |
| 130 | -100x | +527 | +1x |
- self$set_dataset(data = ds_object, dataname = dataname)+ id = id, |
| 131 | -+ | |||
| 528 | +1x |
- }+ function(input, output, session) {
+ |
+ ||
| 529 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_panel initializing")
|
||
| 132 | +530 | |||
| 133 | -66x | +531 | +1x |
- self$set_available_teal_slices(x = reactive(NULL))+ active_datanames_resolved <- reactive({
|
| 134 | -+ | |||
| 532 | +1x |
-
+ checkmate::assert_subset(active_datanames(), self$datanames()) |
||
| 135 | -66x | +|||
| 533 | +! |
- invisible(self)+ active_datanames() |
||
| 136 | +534 |
- },+ }) |
||
| 137 | +535 | |||
| 138 | -+ | |||
| 536 | +1x |
- #' @description+ self$srv_overview("overview", active_datanames_resolved)
|
||
| 139 | -+ | |||
| 537 | +1x |
- #' Gets `datanames`.+ self$srv_active("active", active_datanames_resolved)
|
||
| 140 | -+ | |||
| 538 | +1x |
- #' @details+ if (private$allow_add) {
|
||
| 141 | -+ | |||
| 539 | +1x |
- #' The `datanames` are returned in the order in which they must be evaluated (in case of dependencies).+ self$srv_add("add", active_datanames_resolved)
|
||
| 142 | +540 |
- #' @return Character vector.+ } |
||
| 143 | +541 |
- datanames = function() {
+
|
||
| 144 | -118x | +542 | +1x |
- names(private$filtered_datasets)+ logger::log_trace("FilteredData$srv_filter_panel initialized")
|
| 145 | -+ | |||
| 543 | +1x |
- },+ NULL |
||
| 146 | +544 |
-
+ } |
||
| 147 | +545 |
- #' @description+ ) |
||
| 148 | +546 |
- #' Gets data label for the dataset.+ }, |
||
| 149 | +547 |
- #' Useful to display in `Show R Code`.+ |
||
| 150 | +548 |
- #'+ #' @description |
||
| 151 | +549 |
- #' @param dataname (`character(1)`) name of the dataset+ #' Server module responsible for displaying active filters. |
||
| 152 | +550 |
- #' @return Character string.+ #' @param id (`character(1)`) |
||
| 153 | +551 |
- get_datalabel = function(dataname) {
- |
- ||
| 154 | -1x | -
- private$get_filtered_dataset(dataname)$get_dataset_label()+ #' `shiny` module instance id. |
||
| 155 | +552 |
- },+ #' @return `shiny.tag` |
||
| 156 | +553 |
-
+ ui_active = function(id) {
|
||
| 157 | -+ | |||
| 554 | +! |
- #' @description+ ns <- NS(id) |
||
| 158 | -+ | |||
| 555 | +! |
- #' Set list of external filter states available for activation.+ tags$div( |
||
| 159 | -+ | |||
| 556 | +! |
- #' @details+ id = id, # not used, can be used to customize CSS behavior |
||
| 160 | -+ | |||
| 557 | +! |
- #' Unlike adding new filter from the column, these filters can come with some prespecified settings.+ class = "well", |
||
| 161 | -+ | |||
| 558 | +! |
- #' `teal_slices` are wrapped in a `reactive` so they can be updated from elsewhere in the app.+ tags$div( |
||
| 162 | -+ | |||
| 559 | +! |
- #' Filters passed in `x` are limited to those that can be set for this `FilteredData` object,+ class = "filter-panel-active-header", |
||
| 163 | -+ | |||
| 560 | +! |
- #' i.e. they have the correct `dataname` and `varname` (waived `teal_slice_fixed` as they do not have `varname`).+ tags$span("Active Filter Variables", class = "text-primary mb-4"),
|
||
| 164 | -+ | |||
| 561 | +! |
- #' List is accessible in `ui/srv_active` through `ui/srv_available_filters`.+ private$ui_available_filters(ns("available_filters")),
|
||
| 165 | -+ | |||
| 562 | +! |
- #' @param x (`reactive`)+ actionLink( |
||
| 166 | -+ | |||
| 563 | +! |
- #' should return `teal_slices`+ inputId = ns("minimise_filter_active"),
|
||
| 167 | -+ | |||
| 564 | +! |
- #' @return `NULL`, invisibly.+ label = NULL, |
||
| 168 | -+ | |||
| 565 | +! |
- set_available_teal_slices = function(x) {
+ icon = icon("angle-down", lib = "font-awesome"),
|
||
| 169 | -67x | +|||
| 566 | +! |
- checkmate::assert_class(x, "reactive")+ title = "Minimise panel", |
||
| 170 | -67x | +|||
| 567 | +! |
- private$available_teal_slices <- reactive({
+ class = "remove_all pull-right" |
||
| 171 | +568 |
- # Available filters should be limited to the ones relevant for this FilteredData.+ ), |
||
| 172 | -4x | +|||
| 569 | +! |
- current_state <- isolate(self$get_filter_state())+ actionLink( |
||
| 173 | -4x | +|||
| 570 | +! |
- allowed <- attr(current_state, "include_varnames")+ inputId = ns("remove_all_filters"),
|
||
| 174 | -4x | +|||
| 571 | +! |
- forbidden <- attr(current_state, "exclude_varnames")+ label = "", |
||
| 175 | -4x | +|||
| 572 | +! |
- foo <- function(slice) {
+ icon("circle-xmark", lib = "font-awesome"),
|
||
| 176 | -13x | +|||
| 573 | +! |
- if (slice$dataname %in% self$datanames()) {
+ title = "Remove active filters", |
||
| 177 | -13x | +|||
| 574 | +! |
- if (slice$fixed) {
+ class = "remove_all pull-right" |
||
| 178 | -4x | +|||
| 575 | +
- TRUE+ ) |
|||
| 179 | +576 |
- } else {
+ ), |
||
| 180 | -9x | +|||
| 577 | +! |
- isTRUE(slice$varname %in% allowed[[slice$dataname]]) ||+ tags$div( |
||
| 181 | -9x | +|||
| 578 | +! |
- isFALSE(slice$varname %in% forbidden[[slice$dataname]])+ id = ns("filter_active_vars_contents"),
|
||
| 182 | -+ | |||
| 579 | +! |
- }+ tagList( |
||
| 183 | -+ | |||
| 580 | +! |
- } else {
+ lapply( |
||
| 184 | +581 | ! |
- FALSE+ self$datanames(), |
|
| 185 | -+ | |||
| 582 | +! |
- }+ function(dataname) {
|
||
| 186 | -+ | |||
| 583 | +! |
- }+ fdataset <- private$get_filtered_dataset(dataname) |
||
| 187 | -4x | +|||
| 584 | +! |
- Filter(foo, x())+ fdataset$ui_active(id = ns(dataname)) |
||
| 188 | +585 |
- })- |
- ||
| 189 | -67x | -
- invisible(NULL)+ } |
||
| 190 | +586 |
- },+ ) |
||
| 191 | +587 |
-
+ ) |
||
| 192 | +588 |
- #' @description+ ), |
||
| 193 | -+ | |||
| 589 | +! |
- #' Get list of filter states available for this object.+ shinyjs::hidden( |
||
| 194 | -+ | |||
| 590 | +! |
- #' @details+ tags$div( |
||
| 195 | -+ | |||
| 591 | +! |
- #' All `teal_slice` objects that have been created since the beginning of the app session+ id = ns("filters_active_count"),
|
||
| 196 | -+ | |||
| 592 | +! |
- #' are stored in one `teal_slices` object. This returns a subset of that `teal_slices`,+ textOutput(ns("teal_filters_count"))
|
||
| 197 | +593 |
- #' describing filter states that can be set for this object.+ ) |
||
| 198 | +594 |
- #' @return `reactive` that returns `teal_slices`.+ ) |
||
| 199 | +595 |
- get_available_teal_slices = function() {
- |
- ||
| 200 | -4x | -
- private$available_teal_slices+ ) |
||
| 201 | +596 |
}, |
||
| 202 | +597 | |||
| 203 | +598 |
- # datasets methods ----+ #' @description |
||
| 204 | +599 |
-
+ #' Server module responsible for displaying active filters. |
||
| 205 | +600 |
- #' @description+ #' @param id (`character(1)`) |
||
| 206 | +601 |
- #' Gets a `call` to filter the dataset according to the filter state.+ #' `shiny` module instance id. |
||
| 207 | +602 |
- #' @details+ #' @param active_datanames (`reactive`) |
||
| 208 | +603 |
- #' It returns a `call` to filter the dataset only, assuming the+ #' defining subset of `self$datanames()` to be displayed. |
||
| 209 | +604 |
- #' other (filtered) datasets it depends on are available.+ #' @return `NULL`. |
||
| 210 | +605 |
- #'+ srv_active = function(id, active_datanames = self$datanames) {
|
||
| 211 | -+ | |||
| 606 | +3x |
- #' Together with `self$datanames()` which returns the datasets in the correct+ checkmate::assert_function(active_datanames) |
||
| 212 | -+ | |||
| 607 | +3x |
- #' evaluation order, this generates the whole filter code, see the function+ moduleServer(id, function(input, output, session) {
|
||
| 213 | -+ | |||
| 608 | +3x |
- #' `FilteredData$get_filter_code`.+ logger::log_trace("FilteredData$srv_active initializing")
|
||
| 214 | +609 |
- #'+ |
||
| 215 | -+ | |||
| 610 | +3x |
- #' For the return type, note that `rlang::is_expression` returns `TRUE` on the+ private$srv_available_filters("available_filters")
|
||
| 216 | +611 |
- #' return type, both for base `R` expressions and calls (single expression,+ |
||
| 217 | -+ | |||
| 612 | +3x |
- #' capturing a function call).+ observeEvent(input$minimise_filter_active, {
|
||
| 218 | -+ | |||
| 613 | +! |
- #'+ shinyjs::toggle("filter_active_vars_contents")
|
||
| 219 | -+ | |||
| 614 | +! |
- #' The filtered dataset has the name given by `self$filtered_dataname(dataname)`+ shinyjs::toggle("filters_active_count")
|
||
| 220 | -+ | |||
| 615 | +! |
- #'+ toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"))
|
||
| 221 | -+ | |||
| 616 | +! |
- #' This can be used for the `Show R Code` generation.+ toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"))
|
||
| 222 | +617 |
- #'+ }) |
||
| 223 | +618 |
- #' @param dataname (`character(1)`) name of the dataset+ |
||
| 224 | -+ | |||
| 619 | +3x |
- #'+ observeEvent(private$get_filter_count(), {
|
||
| 225 | -+ | |||
| 620 | +3x |
- #' @return A list of `call`s.+ shinyjs::toggle("remove_all_filters", condition = private$get_filter_count() != 0)
|
||
| 226 | -+ | |||
| 621 | +3x |
- #'+ shinyjs::show("filter_active_vars_contents")
|
||
| 227 | -+ | |||
| 622 | +3x |
- get_call = function(dataname) {
+ shinyjs::hide("filters_active_count")
|
||
| 228 | -10x | +623 | +3x |
- checkmate::assert_subset(dataname, self$datanames())+ toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"), TRUE)
|
| 229 | -9x | +624 | +3x |
- private$get_filtered_dataset(dataname)$get_call()+ toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"), TRUE)
|
| 230 | +625 |
- },+ }) |
||
| 231 | +626 | |||
| 232 | -+ | |||
| 627 | +3x |
- #' @description+ observeEvent(active_datanames(), {
|
||
| 233 | -+ | |||
| 628 | +2x |
- #' Gets filtered or unfiltered dataset.+ lapply(self$datanames(), function(dataname) {
|
||
| 234 | -+ | |||
| 629 | +4x |
- #'+ if (dataname %in% active_datanames()) {
|
||
| 235 | -+ | |||
| 630 | +4x |
- #' For `filtered = FALSE`, the original data set with `set_data` is returned including all attributes.+ shinyjs::show(dataname) |
||
| 236 | +631 |
- #'+ } else {
+ |
+ ||
| 632 | +! | +
+ shinyjs::hide(dataname) |
||
| 237 | +633 |
- #' @param dataname (`character(1)`) name of the dataset.+ } |
||
| 238 | +634 |
- #' @param filtered (`logical(1)`) whether to return a filtered or unfiltered dataset.+ }) |
||
| 239 | +635 |
- #'+ }) |
||
| 240 | +636 |
- #' @return A data object, a `data.frame` or a `MultiAssayExperiment`.+ |
||
| 241 | +637 |
- #'+ # should not use for-loop as variables are otherwise only bound by reference |
||
| 242 | +638 |
- get_data = function(dataname, filtered = TRUE) {
+ # and last dataname would be used |
||
| 243 | -24x | +639 | +3x |
- checkmate::assert_subset(dataname, self$datanames())+ lapply( |
| 244 | -23x | +640 | +3x |
- checkmate::assert_flag(filtered)+ self$datanames(), |
| 245 | -22x | +641 | +3x |
- data <- private$get_filtered_dataset(dataname)$get_dataset(filtered)+ function(dataname) {
|
| 246 | -3x | +642 | +6x |
- if (filtered) data() else data+ fdataset <- private$get_filtered_dataset(dataname) |
| 247 | -+ | |||
| 643 | +6x |
- },+ fdataset$srv_active(id = dataname) |
||
| 248 | +644 |
-
+ } |
||
| 249 | +645 |
- #' @description+ ) |
||
| 250 | +646 |
- #' Get join keys between two datasets.+ |
||
| 251 | -+ | |||
| 647 | +3x |
- #'+ output$teal_filters_count <- renderText({
|
||
| 252 | -+ | |||
| 648 | +3x |
- #' @return `join_keys`+ n_filters_active <- private$get_filter_count() |
||
| 253 | -+ | |||
| 649 | +3x |
- #'+ req(n_filters_active > 0L) |
||
| 254 | -+ | |||
| 650 | +2x |
- get_join_keys = function() {
+ sprintf( |
||
| 255 | +651 | 2x |
- private$join_keys+ "%s filter%s applied across datasets",+ |
+ |
| 652 | +2x | +
+ n_filters_active,+ |
+ ||
| 653 | +2x | +
+ ifelse(n_filters_active == 1, "", "s") |
||
| 256 | +654 |
- },+ ) |
||
| 257 | +655 |
-
+ }) |
||
| 258 | +656 |
- #' @description+ + |
+ ||
| 657 | +3x | +
+ observeEvent(input$remove_all_filters, {
+ |
+ ||
| 658 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_panel@1 removing all non-anchored filters")
+ |
+ ||
| 659 | +1x | +
+ self$clear_filter_states()+ |
+ ||
| 660 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_panel@1 removed all non-anchored filters")
|
||
| 259 | +661 |
- #' Creates filter overview table to be displayed in the application.+ })+ |
+ ||
| 662 | +3x | +
+ logger::log_trace("FilteredData$srv_active initialized")
+ |
+ ||
| 663 | +3x | +
+ NULL |
||
| 260 | +664 |
- #' One row is created per dataset, according to the `get_filter_overview` methods+ }) |
||
| 261 | +665 |
- #' of the contained `FilteredDataset` objects.+ }, |
||
| 262 | +666 |
- #'+ |
||
| 263 | +667 |
- #' @param datanames (`character`) vector of dataset names.+ #' @description |
||
| 264 | +668 |
- #'+ #' Server module responsible for displaying drop-downs with variables to add a filter. |
||
| 265 | +669 |
- #' @return A `data.frame` listing the numbers of observations in all datasets.+ #' @param id (`character(1)`) |
||
| 266 | +670 |
- #'+ #' `shiny` module instance id. |
||
| 267 | +671 |
- get_filter_overview = function(datanames) {
+ #' @return `shiny.tag` |
||
| 268 | -9x | +|||
| 672 | +
- rows <- lapply(+ ui_add = function(id) {
|
|||
| 269 | -9x | +|||
| 673 | +! |
- datanames,+ ns <- NS(id) |
||
| 270 | -9x | +|||
| 674 | +! |
- function(dataname) {
+ tags$div( |
||
| 271 | -11x | +|||
| 675 | +! |
- private$get_filtered_dataset(dataname)$get_filter_overview()+ id = id, # not used, can be used to customize CSS behavior |
||
| 272 | -+ | |||
| 676 | +! |
- }+ class = "well", |
||
| 273 | -+ | |||
| 677 | +! |
- )+ tags$div( |
||
| 274 | -5x | +|||
| 678 | +! |
- unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1))+ class = "row", |
||
| 275 | -5x | +|||
| 679 | +! |
- dplyr::bind_rows(c(rows[!unssuported_idx], rows[unssuported_idx]))+ tags$div( |
||
| 276 | -+ | |||
| 680 | +! |
- },+ class = "col-sm-9", |
||
| 277 | -+ | |||
| 681 | +! |
-
+ tags$label("Add Filter Variables", class = "text-primary mb-4")
|
||
| 278 | +682 |
- #' @description+ ), |
||
| 279 | -+ | |||
| 683 | +! |
- #' Get keys for the dataset.+ tags$div( |
||
| 280 | -+ | |||
| 684 | +! |
- #'+ class = "col-sm-3", |
||
| 281 | -+ | |||
| 685 | +! |
- #' @param dataname (`character(1)`) name of the dataset.+ actionLink( |
||
| 282 | -+ | |||
| 686 | +! |
- #'+ ns("minimise_filter_add_vars"),
|
||
| 283 | -+ | |||
| 687 | +! |
- #' @return Character vector of key column names.+ label = NULL, |
||
| 284 | -+ | |||
| 688 | +! |
- #'+ icon = icon("angle-down", lib = "font-awesome"),
|
||
| 285 | -+ | |||
| 689 | +! |
- get_keys = function(dataname) {
+ title = "Minimise panel", |
||
| 286 | -1x | +|||
| 690 | +! |
- private$get_filtered_dataset(dataname)$get_keys()+ class = "remove pull-right" |
||
| 287 | +691 |
- },+ ) |
||
| 288 | +692 |
-
+ ) |
||
| 289 | +693 |
- #' @description+ ), |
||
| 290 | -+ | |||
| 694 | +! |
- #' Adds a dataset to this `FilteredData`.+ tags$div( |
||
| 291 | -+ | |||
| 695 | +! |
- #'+ id = ns("filter_add_vars_contents"),
|
||
| 292 | -+ | |||
| 696 | +! |
- #' @details+ tagList( |
||
| 293 | -+ | |||
| 697 | +! |
- #' `set_dataset` creates a `FilteredDataset` object which keeps `dataset` for the filtering purpose.+ lapply( |
||
| 294 | -+ | |||
| 698 | +! |
- #' If this data has a parent specified in the `join_keys` object stored in `private$join_keys`+ self$datanames(), |
||
| 295 | -+ | |||
| 699 | +! |
- #' then created `FilteredDataset` (child) gets linked with other `FilteredDataset` (parent).+ function(dataname) {
|
||
| 296 | -+ | |||
| 700 | +! |
- #' "Child" dataset return filtered data then dependent on the reactive filtered data of the+ fdataset <- private$get_filtered_dataset(dataname) |
||
| 297 | -+ | |||
| 701 | +! |
- #' "parent". See more in documentation of `parent` argument in `DataframeFilteredDataset` constructor.+ tags$span(id = ns(dataname), fdataset$ui_add(ns(dataname))) |
||
| 298 | +702 |
- #'+ } |
||
| 299 | +703 |
- #' @param data (`data.frame` or `MultiAssayExperiment`)+ ) |
||
| 300 | +704 |
- #' data to be filtered.+ ) |
||
| 301 | +705 |
- #'+ ) |
||
| 302 | +706 |
- #' @param dataname (`character(1)`)+ ) |
||
| 303 | +707 |
- #' the name of the `dataset` to be added to this object.+ }, |
||
| 304 | +708 |
- #'+ |
||
| 305 | +709 |
- #' @return `self`, invisibly.+ #' @description |
||
| 306 | +710 |
- #'+ #' Server module responsible for displaying drop-downs with variables to add a filter. |
||
| 307 | +711 |
- set_dataset = function(data, dataname) {
- |
- ||
| 308 | -105x | -
- checkmate::assert_string(dataname)- |
- ||
| 309 | -105x | -
- logger::log_trace("FilteredData$set_dataset setting dataset, name: { dataname }")
+ #' @param id (`character(1)`) |
||
| 310 | +712 |
- # to include it nicely in the Show R Code;+ #' `shiny` module instance id. |
||
| 311 | +713 |
- # the UI also uses `datanames` in ids, so no whitespaces allowed+ #' @param active_datanames (`reactive`) |
||
| 312 | -105x | +|||
| 714 | +
- check_simple_name(dataname)+ #' defining subset of `self$datanames()` to be displayed. |
|||
| 313 | +715 |
-
+ #' @return `NULL`. |
||
| 314 | -105x | +|||
| 716 | +
- parent_dataname <- teal.data::parent(private$join_keys, dataname)+ srv_add = function(id, active_datanames = reactive(self$datanames())) {
|
|||
| 315 | -105x | +717 | +1x |
- keys <- private$join_keys[dataname, dataname]+ checkmate::assert_class(active_datanames, "reactive") |
| 316 | -104x | -
- if (is.null(keys)) keys <- character(0)- |
- ||
| 317 | -+ | 718 | +1x |
-
+ moduleServer(id, function(input, output, session) {
|
| 318 | -105x | +719 | +1x |
- if (length(parent_dataname) == 0) {
+ logger::log_trace("FilteredData$srv_add initializing")
|
| 319 | -95x | +720 | +1x |
- private$filtered_datasets[[dataname]] <- init_filtered_dataset(+ observeEvent(input$minimise_filter_add_vars, {
|
| 320 | -95x | +|||
| 721 | +! |
- dataset = data,+ shinyjs::toggle("filter_add_vars_contents")
|
||
| 321 | -95x | +|||
| 722 | +! |
- dataname = dataname,+ toggle_icon(session$ns("minimise_filter_add_vars"), c("fa-angle-right", "fa-angle-down"))
|
||
| 322 | -95x | +|||
| 723 | +! |
- keys = keys+ toggle_title(session$ns("minimise_filter_add_vars"), c("Restore panel", "Minimise Panel"))
|
||
| 323 | +724 |
- )+ }) |
||
| 324 | +725 |
- } else {
+
|
||
| 325 | -10x | +726 | +1x |
- join_keys <- private$join_keys[dataname, parent_dataname]+ observeEvent(active_datanames(), {
|
| 326 | +727 | ! |
- if (is.null(join_keys)) join_keys <- character(0)+ lapply(self$datanames(), function(dataname) {
|
|
| 327 | -10x | +|||
| 728 | +! |
- private$filtered_datasets[[dataname]] <- init_filtered_dataset(+ if (dataname %in% active_datanames()) {
|
||
| 328 | -10x | +|||
| 729 | +! |
- dataset = data,+ shinyjs::show(dataname) |
||
| 329 | -10x | +|||
| 730 | +
- dataname = dataname,+ } else {
|
|||
| 330 | -10x | -
- keys = keys,- |
- ||
| 331 | -10x | -
- parent_name = parent_dataname,- |
- ||
| 332 | -10x | -
- parent = reactive(self$get_data(parent_dataname, filtered = TRUE)),- |
- ||
| 333 | -10x | +|||
| 731 | +! |
- join_keys = join_keys+ shinyjs::hide(dataname) |
||
| 334 | +732 |
- )+ } |
||
| 335 | +733 |
- }+ }) |
||
| 336 | +734 | - - | -||
| 337 | -105x | -
- invisible(self)+ }) |
||
| 338 | +735 |
- },+ |
||
| 339 | +736 |
-
+ # should not use for-loop as variables are otherwise only bound by reference |
||
| 340 | +737 |
- #' @description+ # and last dataname would be used |
||
| 341 | -+ | |||
| 738 | +1x |
- #' Set the `join_keys`.+ lapply( |
||
| 342 | -+ | |||
| 739 | +1x |
- #'+ self$datanames(), |
||
| 343 | -+ | |||
| 740 | +1x |
- #' @param join_keys (`join_keys`), see [`teal.data::join_keys()`].+ function(dataname) {
|
||
| 344 | -+ | |||
| 741 | +2x |
- #'+ fdataset <- private$get_filtered_dataset(dataname) |
||
| 345 | -+ | |||
| 742 | +2x |
- #' @return `self`, invisibly.+ fdataset$srv_add(id = dataname) |
||
| 346 | +743 |
- #'+ } |
||
| 347 | +744 |
- set_join_keys = function(join_keys) {
+ ) |
||
| 348 | -66x | +745 | +1x |
- checkmate::assert_class(join_keys, "join_keys")+ logger::log_trace("FilteredData$srv_filter_panel initialized")
|
| 349 | -66x | +746 | +1x |
- private$join_keys <- join_keys+ NULL |
| 350 | -66x | +|||
| 747 | +
- invisible(self)+ }) |
|||
| 351 | +748 |
}, |
||
| 352 | +749 | |||
| 353 | +750 |
- # Functions useful for restoring from another dataset ----+ #' @description |
||
| 354 | +751 |
-
+ #' Creates the UI definition for the module showing counts for each dataset |
||
| 355 | +752 |
- #' @description+ #' contrasting the filtered to the full unfiltered dataset. |
||
| 356 | +753 |
- #' Gets states of all contained `FilterState` objects.+ #' |
||
| 357 | +754 |
- #'+ #' Per dataset, it displays |
||
| 358 | +755 |
- #' @return A `teal_slices` object.+ #' the number of rows/observations in each dataset, |
||
| 359 | +756 |
- #'+ #' the number of unique subjects. |
||
| 360 | +757 |
- get_filter_state = function() {
+ #' |
||
| 361 | -53x | +|||
| 758 | +
- states <- unname(lapply(private$filtered_datasets, function(x) x$get_filter_state()))+ #' @param id (`character(1)`) |
|||
| 362 | -53x | +|||
| 759 | +
- slices <- Filter(Negate(is.null), states)+ #' `shiny` module instance id. |
|||
| 363 | -53x | +|||
| 760 | +
- slices <- do.call(c, slices)+ #' |
|||
| 364 | -53x | +|||
| 761 | +
- if (!is.null(slices)) {
+ ui_overview = function(id) {
|
|||
| 365 | -53x | +|||
| 762 | +! |
- attr(slices, "allow_add") <- private$allow_add+ ns <- NS(id) |
||
| 366 | -+ | |||
| 763 | +! |
- }+ tags$div( |
||
| 367 | -53x | +|||
| 764 | +! |
- slices+ id = id, # not used, can be used to customize CSS behavior |
||
| 368 | -+ | |||
| 765 | +! |
- },+ class = "well", |
||
| 369 | -+ | |||
| 766 | +! |
-
+ tags$div( |
||
| 370 | -+ | |||
| 767 | +! |
- #' @description+ class = "row", |
||
| 371 | -+ | |||
| 768 | +! |
- #' Returns a formatted string representing this `FilteredData` object.+ tags$div( |
||
| 372 | -+ | |||
| 769 | +! |
- #'+ class = "col-sm-9", |
||
| 373 | -+ | |||
| 770 | +! |
- #' @param show_all (`logical(1)`) passed to `format.teal_slice`.+ tags$label("Active Filter Summary", class = "text-primary mb-4")
|
||
| 374 | +771 |
- #' @param trim_lines (`logical(1)`) passed to `format.teal_slice`.+ ), |
||
| 375 | -+ | |||
| 772 | +! |
- #'+ tags$div( |
||
| 376 | -+ | |||
| 773 | +! |
- #' @return `character(1)` the formatted string.+ class = "col-sm-3", |
||
| 377 | -+ | |||
| 774 | +! |
- #'+ actionLink( |
||
| 378 | -+ | |||
| 775 | +! |
- format = function(show_all = FALSE, trim_lines = TRUE) {
+ ns("minimise_filter_overview"),
|
||
| 379 | -5x | +|||
| 776 | +! |
- datasets <- lapply(self$datanames(), private$get_filtered_dataset)+ label = NULL, |
||
| 380 | -5x | +|||
| 777 | +! |
- ind <- vapply(datasets, inherits, logical(1L), what = "DefaultFilteredDataset")+ icon = icon("angle-down", lib = "font-awesome"),
|
||
| 381 | -5x | +|||
| 778 | +! |
- states <- do.call(c, lapply(datasets[!ind], function(ds) ds$get_filter_state()))+ title = "Minimise panel", |
||
| 382 | -5x | +|||
| 779 | +! |
- states_fmt <- format(states, show_all = show_all, trim_lines = trim_lines)+ class = "remove pull-right" |
||
| 383 | -5x | +|||
| 780 | +
- holders_fmt <- vapply(datasets[ind], format, character(1L), show_all = show_all, trim_lines = trim_lines)+ ) |
|||
| 384 | +781 |
-
+ ) |
||
| 385 | -5x | +|||
| 782 | +
- sprintf(+ ), |
|||
| 386 | -5x | +|||
| 783 | +! |
- "%s:\n%s",+ tags$div( |
||
| 387 | -5x | +|||
| 784 | +! |
- class(self)[1],+ id = ns("filters_overview_contents"),
|
||
| 388 | -5x | +|||
| 785 | +! |
- paste(c(states_fmt, holders_fmt), collapse = "\n")+ tags$div( |
||
| 389 | -+ | |||
| 786 | +! |
- )+ class = "teal_active_summary_filter_panel", |
||
| 390 | -+ | |||
| 787 | +! |
- },+ tableOutput(ns("table"))
|
||
| 391 | +788 |
-
+ ) |
||
| 392 | +789 |
- #' @description+ ) |
||
| 393 | +790 |
- #' Prints this `FilteredData` object.+ ) |
||
| 394 | +791 |
- #'+ }, |
||
| 395 | +792 |
- #' @param ... additional arguments passed to `format`.+ |
||
| 396 | +793 |
- #'+ #' @description |
||
| 397 | +794 |
- print = function(...) {
+ #' Server function to display the number of records in the filtered and unfiltered |
||
| 398 | -! | +|||
| 795 | +
- cat(isolate(self$format(...)), "\n")+ #' data. |
|||
| 399 | +796 |
- },+ #' |
||
| 400 | +797 |
-
+ #' @param id (`character(1)`) |
||
| 401 | +798 |
- #' @description+ #' `shiny` module instance id. |
||
| 402 | +799 |
- #' Sets active filter states.+ #' @param active_datanames (`reactive`) |
||
| 403 | +800 |
- #'+ #' returning `datanames` that should be shown on the filter panel, |
||
| 404 | +801 |
- #' @param state (`teal_slices`)+ #' must be a subset of the `datanames` argument provided to `ui_filter_panel`; |
||
| 405 | +802 |
- #'+ #' if the function returns `NULL` (as opposed to `character(0)`), the filter |
||
| 406 | +803 |
- #' @return `NULL`, invisibly.+ #' panel will be hidden. |
||
| 407 | +804 |
- set_filter_state = function(state) {
+ #' @return `NULL`. |
||
| 408 | -31x | +|||
| 805 | +
- isolate({
+ srv_overview = function(id, active_datanames = self$datanames) {
|
|||
| 409 | -31x | +806 | +1x |
- logger::log_trace("{ class(self)[1] }$set_filter_state initializing")
+ checkmate::assert_class(active_datanames, "reactive") |
| 410 | -31x | +807 | +1x |
- checkmate::assert_class(state, "teal_slices")+ moduleServer( |
| 411 | -31x | +808 | +1x |
- allow_add <- attr(state, "allow_add")+ id = id, |
| 412 | -31x | +809 | +1x |
- if (!is.null(allow_add)) {
+ function(input, output, session) {
|
| 413 | -31x | -
- private$allow_add <- allow_add- |
- ||
| 414 | -+ | 810 | +1x |
- }+ logger::log_trace("FilteredData$srv_filter_overview initializing")
|
| 415 | +811 | |||
| 416 | -31x | -
- lapply(self$datanames(), function(dataname) {
- |
- ||
| 417 | -63x | -
- states <- Filter(function(x) identical(x$dataname, dataname), state)- |
- ||
| 418 | -63x | +812 | +1x |
- private$get_filtered_dataset(dataname)$set_filter_state(states)+ observeEvent(input$minimise_filter_overview, {
|
| 419 | -+ | |||
| 813 | +! |
- })+ shinyjs::toggle("filters_overview_contents")
|
||
| 420 | -+ | |||
| 814 | +! |
-
+ toggle_icon(session$ns("minimise_filter_overview"), c("fa-angle-right", "fa-angle-down"))
|
||
| 421 | -31x | +|||
| 815 | +! |
- logger::log_trace("{ class(self)[1] }$set_filter_state initialized")
+ toggle_title(session$ns("minimise_filter_overview"), c("Restore panel", "Minimise Panel"))
|
||
| 422 | +816 |
- })+ }) |
||
| 423 | +817 | |||
| 424 | -31x | +818 | +1x |
- invisible(NULL)+ output$table <- renderUI({
|
| 425 | -+ | |||
| 819 | +! |
- },+ logger::log_trace("FilteredData$srv_filter_overview@1 updating counts")
|
||
| 426 | -+ | |||
| 820 | +! |
-
+ if (length(active_datanames()) == 0) {
|
||
| 427 | -+ | |||
| 821 | +! |
- #' @description+ return(NULL) |
||
| 428 | +822 |
- #' Removes one or more `FilterState` from a `FilteredData` object.+ } |
||
| 429 | +823 |
- #'+ |
||
| 430 | -+ | |||
| 824 | +! |
- #' @param state (`teal_slices`)+ datasets_df <- self$get_filter_overview(datanames = active_datanames()) |
||
| 431 | +825 |
- #' specifying `FilterState` objects to remove;+ |
||
| 432 | -+ | |||
| 826 | +! |
- #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored.+ attr(datasets_df$dataname, "label") <- "Data Name" |
||
| 433 | +827 |
- #'+ |
||
| 434 | -+ | |||
| 828 | +! |
- #' @return `NULL`, invisibly.+ if (!is.null(datasets_df$obs)) {
|
||
| 435 | +829 |
- #'+ # some datasets (MAE colData) doesn't return obs column |
||
| 436 | -+ | |||
| 830 | +! |
- remove_filter_state = function(state) {
+ datasets_df <- transform( |
||
| 437 | -8x | +|||
| 831 | +! |
- isolate({
+ datasets_df, |
||
| 438 | -8x | +|||
| 832 | +! |
- checkmate::assert_class(state, "teal_slices")+ obs_str_summary = ifelse( |
||
| 439 | -8x | +|||
| 833 | +! |
- datanames <- unique(vapply(state, "[[", character(1L), "dataname"))+ !is.na(obs), |
||
| 440 | -8x | +|||
| 834 | +! |
- checkmate::assert_subset(datanames, self$datanames())+ sprintf("%s/%s", obs_filtered, obs),
|
||
| 441 | +835 | - - | -||
| 442 | -8x | -
- logger::log_trace(- |
- ||
| 443 | -8x | -
- "{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }"
+ "" |
||
| 444 | +836 |
- )+ ) |
||
| 445 | +837 | - - | -||
| 446 | -8x | -
- lapply(datanames, function(dataname) {
- |
- ||
| 447 | -9x | -
- slices <- Filter(function(x) identical(x$dataname, dataname), state)+ ) |
||
| 448 | -9x | +|||
| 838 | +! |
- private$get_filtered_dataset(dataname)$remove_filter_state(slices)+ attr(datasets_df$obs_str_summary, "label") <- "Obs" |
||
| 449 | +839 |
- })+ } |
||
| 450 | +840 | |||
| 451 | -8x | -
- logger::log_trace(- |
- ||
| 452 | -8x | -
- "{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }"
- |
- ||
| 453 | +841 |
- )+ |
||
| 454 | -+ | |||
| 842 | +! |
- })+ if (!is.null(datasets_df$subjects)) {
|
||
| 455 | +843 |
-
+ # some datasets (without keys) doesn't return subjects |
||
| 456 | -8x | +|||
| 844 | +! |
- invisible(NULL)+ datasets_df <- transform( |
||
| 457 | -+ | |||
| 845 | +! |
- },+ datasets_df, |
||
| 458 | -+ | |||
| 846 | +! |
-
+ subjects_summary = ifelse( |
||
| 459 | -+ | |||
| 847 | +! |
- #' @description+ !is.na(subjects), |
||
| 460 | -+ | |||
| 848 | +! |
- #' Remove all `FilterStates` of a `FilteredDataset` or all `FilterStates` of a `FilteredData` object.+ sprintf("%s/%s", subjects_filtered, subjects),
|
||
| 461 | +849 |
- #'+ "" |
||
| 462 | +850 |
- #' @param datanames (`character`)+ ) |
||
| 463 | +851 |
- #' names of datasets for which to remove all filter states.+ ) |
||
| 464 | -+ | |||
| 852 | +! |
- #' Defaults to all datasets in this `FilteredData` object.+ attr(datasets_df$subjects_summary, "label") <- "Subjects" |
||
| 465 | +853 |
- #' @param force (`logical(1)`)+ } |
||
| 466 | +854 |
- #' flag specifying whether to include anchored filter states.+ |
||
| 467 | -+ | |||
| 855 | +! |
- #'+ all_names <- c("dataname", "obs_str_summary", "subjects_summary")
|
||
| 468 | -+ | |||
| 856 | +! |
- #' @return `NULL`, invisibly.+ datasets_df <- datasets_df[, colnames(datasets_df) %in% all_names] |
||
| 469 | +857 |
- #'+ |
||
| 470 | -+ | |||
| 858 | +! |
- clear_filter_states = function(datanames = self$datanames(), force = FALSE) {
+ body_html <- apply( |
||
| 471 | -7x | +|||
| 859 | +! |
- logger::log_trace(+ datasets_df, |
||
| 472 | -7x | +|||
| 860 | +! |
- "FilteredData$clear_filter_states called, datanames: { toString(datanames) }"
+ 1, |
||
| 473 | -+ | |||
| 861 | +! |
- )+ function(x) {
|
||
| 474 | -+ | |||
| 862 | +! |
-
+ tags$tr( |
||
| 475 | -7x | +|||
| 863 | +! |
- for (dataname in datanames) {
+ tagList( |
||
| 476 | -12x | +|||
| 864 | +! |
- fdataset <- private$get_filtered_dataset(dataname = dataname)+ tags$td( |
||
| 477 | -12x | +|||
| 865 | +! |
- fdataset$clear_filter_states(force)+ if (all(x[-1] == "")) {
|
||
| 478 | -+ | |||
| 866 | +! |
- }+ icon( |
||
| 479 | -+ | |||
| 867 | +! |
-
+ name = "exclamation-triangle", |
||
| 480 | -7x | +|||
| 868 | +! |
- logger::log_trace(+ title = "Unsupported dataset", |
||
| 481 | -7x | +|||
| 869 | +! |
- paste(+ `data-container` = "body", |
||
| 482 | -7x | +|||
| 870 | +! |
- "FilteredData$clear_filter_states removed all non-anchored FilterStates,",+ `data-toggle` = "popover", |
||
| 483 | -7x | +|||
| 871 | +! |
- "datanames: { toString(datanames) }"
+ `data-content` = "object not supported by the filter panel" |
||
| 484 | +872 |
- )+ ) |
||
| 485 | +873 |
- )+ },+ |
+ ||
| 874 | +! | +
+ x[1] |
||
| 486 | +875 |
-
+ ), |
||
| 487 | -7x | +|||
| 876 | +! |
- invisible(NULL)+ lapply(x[-1], tags$td) |
||
| 488 | +877 |
- },+ ) |
||
| 489 | +878 |
-
+ ) |
||
| 490 | +879 |
-
+ } |
||
| 491 | +880 |
- # shiny modules -----+ ) |
||
| 492 | +881 | |||
| 493 | -+ | |||
| 882 | +! |
- #' @description+ header_labels <- vapply( |
||
| 494 | -+ | |||
| 883 | +! |
- #' top-level `shiny` module for the filter panel in the `teal` app.+ seq_along(datasets_df), |
||
| 495 | -- |
- #' Contains 1) filter overview panel, 2) filter active panel, and 3) add filters panel.+ | ||
| 884 | +! | +
+ function(i) {
|
||
| 496 | -+ | |||
| 885 | +! |
- #'+ label <- attr(datasets_df[[i]], "label") |
||
| 497 | -+ | |||
| 886 | +! |
- #' @param id (`character(1)`)+ ifelse(!is.null(label), label, names(datasets_df)[[i]]) |
||
| 498 | +887 |
- #' `shiny` module instance id.+ }, |
||
| 499 | -+ | |||
| 888 | +! |
- #' @return `shiny.tag`+ character(1) |
||
| 500 | +889 |
- ui_filter_panel = function(id) {
+ ) |
||
| 501 | +890 | ! |
- ns <- NS(id)+ header_html <- tags$tr(tagList(lapply(header_labels, tags$td))) |
|
| 502 | -! | +|||
| 891 | +
- tags$div(+ |
|||
| 503 | +892 | ! |
- id = ns(NULL), # used for hiding / showing+ table_html <- tags$table( |
|
| 504 | +893 | ! |
- include_css_files(pattern = "filter-panel"),+ class = "table custom-table", |
|
| 505 | +894 | ! |
- self$ui_overview(ns("overview")),
+ tags$thead(header_html), |
|
| 506 | +895 | ! |
- self$ui_active(ns("active")),
+ tags$tbody(body_html)+ |
+ |
| 896 | ++ |
+ ) |
||
| 507 | +897 | ! |
- if (private$allow_add) {
+ logger::log_trace("FilteredData$srv_filter_overview@1 updated counts")
|
|
| 508 | +898 | ! |
- self$ui_add(ns("add"))
+ table_html |
|
| 509 | +899 | ++ |
+ })+ |
+ |
| 900 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_overview initialized")
+ |
+ ||
| 901 | +1x | +
+ NULL+ |
+ ||
| 902 |
} |
|||
| 510 | +903 |
) |
||
| 511 | +904 |
- },+ } |
||
| 512 | +905 | ++ |
+ ),+ |
+ |
| 906 | ||||
| 513 | +907 |
- #' @description+ # private members ---- |
||
| 514 | +908 |
- #' Server function for filter panel.+ private = list( |
||
| 515 | +909 |
- #'+ # selectively hide / show to only show `active_datanames` out of all datanames |
||
| 516 | +910 |
- #' @param id (`character(1)`)+ |
||
| 517 | +911 |
- #' `shiny` module instance id.+ # private attributes ---- |
||
| 518 | +912 |
- #' @param active_datanames (`function` or `reactive`)+ filtered_datasets = list(), |
||
| 519 | +913 |
- #' returning `datanames` that should be shown on the filter panel.+ |
||
| 520 | +914 |
- #' Must be a subset of the `datanames` in this `FilteredData`.+ # activate/deactivate filter panel |
||
| 521 | +915 |
- #' If the function returns `NULL` (as opposed to `character(0)`),+ filter_panel_active = TRUE, |
||
| 522 | +916 |
- #' the filter panel will be hidden.+ |
||
| 523 | +917 |
- #' @return `NULL`.+ # `reactive` containing teal_slices that can be selected; only active in module-specific mode |
||
| 524 | +918 |
- srv_filter_panel = function(id, active_datanames = self$datanames) {
+ available_teal_slices = NULL, |
||
| 525 | -1x | +|||
| 919 | +
- checkmate::assert_function(active_datanames)+ |
|||
| 526 | -1x | +|||
| 920 | +
- moduleServer(+ # keys used for joining/filtering data a join_keys object (see teal.data) |
|||
| 527 | -1x | +|||
| 921 | +
- id = id,+ join_keys = NULL, |
|||
| 528 | -1x | +|||
| 922 | +
- function(input, output, session) {
+
|
|||
| 529 | -1x | +|||
| 923 | +
- logger::log_trace("FilteredData$srv_filter_panel initializing")
+ # flag specifying whether the user may add filters |
|||
| 530 | +924 | ++ |
+ allow_add = TRUE,+ |
+ |
| 925 | ||||
| 531 | -1x | +|||
| 926 | +
- active_datanames_resolved <- reactive({
+ # private methods ---- |
|||
| 532 | -1x | +|||
| 927 | +
- checkmate::assert_subset(active_datanames(), self$datanames())+ |
|||
| 533 | -! | +|||
| 928 | +
- active_datanames()+ # @description |
|||
| 534 | +929 |
- })+ # Gets `FilteredDataset` object which contains all information |
||
| 535 | +930 |
-
+ # pertaining to the specified dataset. |
||
| 536 | -1x | +|||
| 931 | +
- self$srv_overview("overview", active_datanames_resolved)
+ # |
|||
| 537 | -1x | +|||
| 932 | +
- self$srv_active("active", active_datanames_resolved)
+ # @param dataname (`character(1)`) |
|||
| 538 | -1x | +|||
| 933 | +
- if (private$allow_add) {
+ # name of the dataset |
|||
| 539 | -1x | +|||
| 934 | +
- self$srv_add("add", active_datanames_resolved)
+ # |
|||
| 540 | +935 |
- }+ # @return `FilteredDataset` object or list of `FilteredDataset`s |
||
| 541 | +936 |
-
+ # |
||
| 542 | -1x | +|||
| 937 | +
- logger::log_trace("FilteredData$srv_filter_panel initialized")
+ get_filtered_dataset = function(dataname = character(0)) {
|
|||
| 543 | -1x | +938 | +147x |
- NULL+ if (length(dataname) == 0) {
+ |
+
| 939 | +! | +
+ private$filtered_datasets |
||
| 544 | +940 |
- }+ } else {
+ |
+ ||
| 941 | +147x | +
+ private$filtered_datasets[[dataname]] |
||
| 545 | +942 |
- )+ } |
||
| 546 | +943 |
}, |
||
| 547 | +944 | |||
| 548 | +945 |
- #' @description+ # we implement these functions as checks rather than returning logicals so they can |
||
| 549 | +946 |
- #' Server module responsible for displaying active filters.+ # give informative error messages immediately |
||
| 550 | +947 |
- #' @param id (`character(1)`)+ |
||
| 551 | +948 |
- #' `shiny` module instance id.+ # @description |
||
| 552 | +949 |
- #' @return `shiny.tag`+ # Gets the number of active `FilterState` objects in all `FilterStates` |
||
| 553 | +950 |
- ui_active = function(id) {
+ # in all `FilteredDataset`s in this `FilteredData` object. |
||
| 554 | -! | +|||
| 951 | +
- ns <- NS(id)+ # @return `integer(1)` |
|||
| 555 | -! | +|||
| 952 | +
- tags$div(+ get_filter_count = function() {
|
|||
| 556 | -! | +|||
| 953 | +11x |
- id = id, # not used, can be used to customize CSS behavior+ length(self$get_filter_state())+ |
+ ||
| 954 | ++ |
+ },+ |
+ ||
| 955 | ++ | + + | +||
| 956 | ++ |
+ # @description+ |
+ ||
| 957 | ++ |
+ # Activate available filters.+ |
+ ||
| 958 | ++ |
+ # Module is composed from plus button and dropdown menu. Menu is shown when+ |
+ ||
| 959 | ++ |
+ # the button is clicked. Menu contains available/active filters list+ |
+ ||
| 960 | ++ |
+ # passed via `set_available_teal_slice`.+ |
+ ||
| 961 | ++ |
+ ui_available_filters = function(id) {
|
||
| 557 | +962 | ! |
- class = "well",+ ns <- NS(id)+ |
+ |
| 963 | ++ | + | ||
| 558 | +964 | ! |
- tags$div(+ active_slices_id <- isolate(vapply(self$get_filter_state(), `[[`, character(1), "id")) |
|
| 559 | +965 | ! |
- class = "filter-panel-active-header",+ tags$div( |
|
| 560 | +966 | ! |
- tags$span("Active Filter Variables", class = "text-primary mb-4"),
+ id = ns("available_menu"),
|
|
| 561 | +967 | ! |
- private$ui_available_filters(ns("available_filters")),
+ shinyWidgets::dropMenu( |
|
| 562 | +968 | ! |
actionLink( |
|
| 563 | +969 | ! |
- inputId = ns("minimise_filter_active"),
+ ns("show"),
|
|
| 564 | +970 | ! |
label = NULL, |
|
| 565 | +971 | ! |
- icon = icon("angle-down", lib = "font-awesome"),
+ icon = icon("plus", lib = "font-awesome"),
|
|
| 566 | +972 | ! |
- title = "Minimise panel",+ title = "Available filters", |
|
| 567 | +973 | ! |
- class = "remove_all pull-right"+ class = "remove pull-right" |
|
| 568 | +974 |
), |
||
| 569 | +975 | ! |
- actionLink(+ tags$div( |
|
| 570 | +976 | ! |
- inputId = ns("remove_all_filters"),
+ class = "menu-content", |
|
| 571 | +977 | ! |
- label = "",+ shinycssloaders::withSpinner( |
|
| 572 | +978 | ! |
- icon("circle-xmark", lib = "font-awesome"),
+ uiOutput(ns("checkbox")),
|
|
| 573 | +979 | ! |
- title = "Remove active filters",+ type = 4, |
|
| 574 | +980 | ! |
- class = "remove_all pull-right"+ size = 0.25 |
|
| 575 | +981 |
- )+ ) |
||
| 576 | +982 |
- ),- |
- ||
| 577 | -! | -
- tags$div(- |
- ||
| 578 | -! | -
- id = ns("filter_active_vars_contents"),
- |
- ||
| 579 | -! | -
- tagList(- |
- ||
| 580 | -! | -
- lapply(- |
- ||
| 581 | -! | -
- self$datanames(),- |
- ||
| 582 | -! | -
- function(dataname) {
- |
- ||
| 583 | -! | -
- fdataset <- private$get_filtered_dataset(dataname)- |
- ||
| 584 | -! | -
- fdataset$ui_active(id = ns(dataname))+ ) |
||
| 585 | -- |
- }- |
- ||
| 586 | +983 |
- )+ ) |
||
| 587 | +984 |
- )+ ) |
||
| 588 | +985 |
- ),- |
- ||
| 589 | -! | -
- shinyjs::hidden(- |
- ||
| 590 | -! | -
- tags$div(- |
- ||
| 591 | -! | -
- id = ns("filters_active_count"),
- |
- ||
| 592 | -! | -
- textOutput(ns("teal_filters_count"))
+ }, |
||
| 593 | +986 |
- )+ # @description |
||
| 594 | +987 |
- )+ # Activate available filters. When a filter is selected or removed, |
||
| 595 | +988 |
- )+ # `set_filter_state` or `remove_filter_state` is executed for |
||
| 596 | +989 |
- },+ # the appropriate filter state id. |
||
| 597 | +990 |
-
+ srv_available_filters = function(id) {
|
||
| 598 | -+ | |||
| 991 | +4x |
- #' @description+ moduleServer(id, function(input, output, session) {
|
||
| 599 | -+ | |||
| 992 | +4x |
- #' Server module responsible for displaying active filters.+ slices_available <- self$get_available_teal_slices() |
||
| 600 | -+ | |||
| 993 | +4x |
- #' @param id (`character(1)`)+ slices_interactive <- reactive( |
||
| 601 | -+ | |||
| 994 | +4x |
- #' `shiny` module instance id.+ Filter(function(slice) isFALSE(slice$fixed), slices_available()) |
||
| 602 | +995 |
- #' @param active_datanames (`reactive`)+ ) |
||
| 603 | -+ | |||
| 996 | +4x |
- #' defining subset of `self$datanames()` to be displayed.+ slices_fixed <- reactive( |
||
| 604 | -+ | |||
| 997 | +4x |
- #' @return `NULL`.+ Filter(function(slice) isTRUE(slice$fixed), slices_available()) |
||
| 605 | +998 |
- srv_active = function(id, active_datanames = self$datanames) {
+ ) |
||
| 606 | -3x | +999 | +4x |
- checkmate::assert_function(active_datanames)+ available_slices_id <- reactive(vapply(slices_available(), `[[`, character(1), "id")) |
| 607 | -3x | +1000 | +4x |
- moduleServer(id, function(input, output, session) {
+ active_slices_id <- reactive(vapply(self$get_filter_state(), `[[`, character(1), "id")) |
| 608 | -3x | +1001 | +4x |
- logger::log_trace("FilteredData$srv_active initializing")
+ duplicated_slice_references <- reactive({
|
| 609 | +1002 |
-
+ # slice refers to a particular column |
||
| 610 | -3x | -
- private$srv_available_filters("available_filters")
- |
- ||
| 611 | -+ | 1003 | +8x |
-
+ slice_reference <- vapply(slices_available(), get_default_slice_id, character(1)) |
| 612 | -3x | -
- observeEvent(input$minimise_filter_active, {
- |
- ||
| 613 | -! | +1004 | +8x |
- shinyjs::toggle("filter_active_vars_contents")
+ is_duplicated_reference <- duplicated(slice_reference) | duplicated(slice_reference, fromLast = TRUE) |
| 614 | -! | +|||
| 1005 | +8x |
- shinyjs::toggle("filters_active_count")
+ is_active <- available_slices_id() %in% active_slices_id() |
||
| 615 | -! | +|||
| 1006 | +8x |
- toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"))
+ is_not_expr <- !vapply(slices_available(), inherits, logical(1), "teal_slice_expr") |
||
| 616 | -! | +|||
| 1007 | +8x |
- toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"))
+ slice_reference[is_duplicated_reference & is_active & is_not_expr] |
||
| 617 | +1008 |
}) |
||
| 618 | +1009 | |||
| 619 | -3x | +1010 | +4x |
- observeEvent(private$get_filter_count(), {
+ checkbox_group_element <- function(name, value, label, checked, disabled = FALSE) {
|
| 620 | -3x | +1011 | +35x |
- shinyjs::toggle("remove_all_filters", condition = private$get_filter_count() != 0)
+ tags$div( |
| 621 | -3x | +1012 | +35x |
- shinyjs::show("filter_active_vars_contents")
+ class = "checkbox available-filters", |
| 622 | -3x | +1013 | +35x |
- shinyjs::hide("filters_active_count")
+ tags$label( |
| 623 | -3x | +1014 | +35x |
- toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"), TRUE)
+ tags$input( |
| 624 | -3x | -
- toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"), TRUE)
- |
- ||
| 625 | -- |
- })- |
- ||
| 626 | -+ | 1015 | +35x |
-
+ type = "checkbox", |
| 627 | -3x | +1016 | +35x |
- observeEvent(active_datanames(), {
+ name = name, |
| 628 | -2x | +1017 | +35x |
- lapply(self$datanames(), function(dataname) {
+ value = value, |
| 629 | -4x | +1018 | +35x |
- if (dataname %in% active_datanames()) {
+ checked = checked, |
| 630 | -4x | +1019 | +35x |
- shinyjs::show(dataname)+ disabled = if (disabled) "disabled" |
| 631 | +1020 |
- } else {
+ ), |
||
| 632 | -! | +|||
| 1021 | +35x |
- shinyjs::hide(dataname)+ tags$span(label, disabled = if (disabled) disabled) |
||
| 633 | +1022 |
- }+ ) |
||
| 634 | +1023 |
- })+ ) |
||
| 635 | +1024 |
- })+ } |
||
| 636 | +1025 | |||
| 637 | -+ | |||
| 1026 | +4x |
- # should not use for-loop as variables are otherwise only bound by reference+ output$checkbox <- renderUI({
|
||
| 638 | -+ | |||
| 1027 | +8x |
- # and last dataname would be used+ checkbox <- checkboxGroupInput( |
||
| 639 | -3x | +1028 | +8x |
- lapply(+ session$ns("available_slices_id"),
|
| 640 | -3x | +1029 | +8x |
- self$datanames(),+ label = NULL, |
| 641 | -3x | +1030 | +8x |
- function(dataname) {
+ choices = NULL, |
| 642 | -6x | +1031 | +8x |
- fdataset <- private$get_filtered_dataset(dataname)+ selected = NULL+ |
+
| 1032 | ++ |
+ ) |
||
| 643 | -6x | +1033 | +8x |
- fdataset$srv_active(id = dataname)+ active_slices_ids <- active_slices_id() |
| 644 | -+ | |||
| 1034 | +8x |
- }+ duplicated_slice_refs <- duplicated_slice_references() |
||
| 645 | +1035 |
- )+ + |
+ ||
| 1036 | +8x | +
+ checkbox_group_slice <- function(slice) {
|
||
| 646 | +1037 |
-
+ # we need to isolate changes in the fields of the slice (teal_slice) |
||
| 647 | -3x | +1038 | +35x |
- output$teal_filters_count <- renderText({
+ isolate({
|
| 648 | -3x | +1039 | +35x |
- n_filters_active <- private$get_filter_count()+ checkbox_group_element( |
| 649 | -3x | +1040 | +35x |
- req(n_filters_active > 0L)+ name = session$ns("available_slices_id"),
|
| 650 | -2x | +1041 | +35x |
- sprintf(+ value = slice$id, |
| 651 | -2x | +1042 | +35x |
- "%s filter%s applied across datasets",+ label = slice$id, |
| 652 | -2x | +1043 | +35x |
- n_filters_active,+ checked = if (slice$id %in% active_slices_ids) "checked", |
| 653 | -2x | +1044 | +35x |
- ifelse(n_filters_active == 1, "", "s")+ disabled = slice$anchored ||+ |
+
| 1045 | +35x | +
+ get_default_slice_id(slice) %in% duplicated_slice_refs &&+ |
+ ||
| 1046 | +35x | +
+ !slice$id %in% active_slices_ids |
||
| 654 | +1047 |
- )+ ) |
||
| 655 | +1048 |
- })+ }) |
||
| 656 | +1049 | ++ |
+ }+ |
+ |
| 1050 | ||||
| 657 | -3x | +1051 | +8x |
- observeEvent(input$remove_all_filters, {
+ interactive_choice_mock <- lapply(slices_interactive(), checkbox_group_slice) |
| 658 | -1x | +1052 | +8x |
- logger::log_trace("FilteredData$srv_filter_panel@1 removing all non-anchored filters")
+ non_interactive_choice_mock <- lapply(slices_fixed(), checkbox_group_slice) |
| 659 | -1x | +|||
| 1053 | +
- self$clear_filter_states()+ |
|||
| 660 | -1x | -
- logger::log_trace("FilteredData$srv_filter_panel@1 removed all non-anchored filters")
- |
- ||
| 661 | -+ | 1054 | +8x |
- })+ htmltools::tagInsertChildren( |
| 662 | -3x | +1055 | +8x |
- logger::log_trace("FilteredData$srv_active initialized")
+ checkbox, |
| 663 | -3x | +1056 | +8x |
- NULL+ tags$br(), |
| 664 | -+ | |||
| 1057 | +8x |
- })+ if (length(non_interactive_choice_mock)) tags$strong("Fixed filters"),
|
||
| 665 | -+ | |||
| 1058 | +8x |
- },+ non_interactive_choice_mock, |
||
| 666 | -+ | |||
| 1059 | +8x |
-
+ if (length(interactive_choice_mock)) tags$strong("Interactive filters"),
|
||
| 667 | -+ | |||
| 1060 | +8x |
- #' @description+ interactive_choice_mock, |
||
| 668 | -+ | |||
| 1061 | +8x |
- #' Server module responsible for displaying drop-downs with variables to add a filter.+ .cssSelector = "div.shiny-options-group", |
||
| 669 | -+ | |||
| 1062 | +8x |
- #' @param id (`character(1)`)+ after = 0 |
||
| 670 | +1063 |
- #' `shiny` module instance id.+ ) |
||
| 671 | +1064 |
- #' @return `shiny.tag`+ }) |
||
| 672 | +1065 |
- ui_add = function(id) {
+
|
||
| 673 | -! | +|||
| 1066 | +4x |
- ns <- NS(id)+ observeEvent(input$available_slices_id, ignoreNULL = FALSE, ignoreInit = TRUE, {
|
||
| 674 | -! | +|||
| 1067 | +5x |
- tags$div(+ new_slices_id <- setdiff(input$available_slices_id, active_slices_id()) |
||
| 675 | -! | +|||
| 1068 | +5x |
- id = id, # not used, can be used to customize CSS behavior+ removed_slices_id <- setdiff(active_slices_id(), input$available_slices_id) |
||
| 676 | -! | +|||
| 1069 | +5x |
- class = "well",+ if (length(new_slices_id)) {
|
||
| 677 | -! | +|||
| 1070 | +3x |
- tags$div(+ new_teal_slices <- Filter( |
||
| 678 | -! | +|||
| 1071 | +3x |
- class = "row",+ function(slice) slice$id %in% new_slices_id, |
||
| 679 | -! | +|||
| 1072 | +3x |
- tags$div(+ private$available_teal_slices() |
||
| 680 | -! | +|||
| 1073 | +
- class = "col-sm-9",+ ) |
|||
| 681 | -! | +|||
| 1074 | +3x |
- tags$label("Add Filter Variables", class = "text-primary mb-4")
+ self$set_filter_state(new_teal_slices) |
||
| 682 | +1075 |
- ),- |
- ||
| 683 | -! | -
- tags$div(+ } |
||
| 684 | -! | +|||
| 1076 | +
- class = "col-sm-3",+ |
|||
| 685 | -! | +|||
| 1077 | +5x |
- actionLink(+ if (length(removed_slices_id)) {
|
||
| 686 | -! | +|||
| 1078 | +4x |
- ns("minimise_filter_add_vars"),
+ removed_teal_slices <- Filter( |
||
| 687 | -! | +|||
| 1079 | +4x |
- label = NULL,+ function(slice) slice$id %in% removed_slices_id, |
||
| 688 | -! | +|||
| 1080 | +4x |
- icon = icon("angle-down", lib = "font-awesome"),
+ self$get_filter_state() |
||
| 689 | -! | +|||
| 1081 | +
- title = "Minimise panel",+ ) |
|||
| 690 | -! | +|||
| 1082 | +4x |
- class = "remove pull-right"+ self$remove_filter_state(removed_teal_slices) |
||
| 691 | +1083 |
- )+ } |
||
| 692 | +1084 |
- )+ }) |
||
| 693 | +1085 |
- ),+ |
||
| 694 | -! | +|||
| 1086 | +4x |
- tags$div(+ observeEvent(private$available_teal_slices(), ignoreNULL = FALSE, {
|
||
| 695 | -! | +|||
| 1087 | +3x |
- id = ns("filter_add_vars_contents"),
+ if (length(private$available_teal_slices())) {
|
||
| 696 | -! | +|||
| 1088 | +1x |
- tagList(+ shinyjs::show("available_menu")
|
||
| 697 | -! | +|||
| 1089 | +
- lapply(+ } else {
|
|||
| 698 | -! | +|||
| 1090 | +2x |
- self$datanames(),+ shinyjs::hide("available_menu")
|
||
| 699 | -! | +|||
| 1091 | +
- function(dataname) {
+ } |
|||
| 700 | -! | +|||
| 1092 | +
- fdataset <- private$get_filtered_dataset(dataname)+ }) |
|||
| 701 | -! | +|||
| 1093 | +
- tags$span(id = ns(dataname), fdataset$ui_add(ns(dataname)))+ }) |
|||
| 702 | +1094 |
- }+ } |
||
| 703 | +1095 |
- )+ ) |
||
| 704 | +1096 |
- )+ ) |
| 705 | +1 |
- )+ # RangeFilterState ------ |
||
| 706 | +2 |
- )+ |
||
| 707 | +3 |
- },+ #' @name RangeFilterState |
||
| 708 | +4 |
-
+ #' @docType class |
||
| 709 | +5 |
- #' @description+ #' |
||
| 710 | +6 |
- #' Server module responsible for displaying drop-downs with variables to add a filter.+ #' @title `FilterState` object for numeric data |
||
| 711 | +7 |
- #' @param id (`character(1)`)+ #' |
||
| 712 | +8 |
- #' `shiny` module instance id.+ #' @description Manages choosing a numeric range. |
||
| 713 | +9 |
- #' @param active_datanames (`reactive`)+ #' |
||
| 714 | +10 |
- #' defining subset of `self$datanames()` to be displayed.+ #' @examples |
||
| 715 | +11 |
- #' @return `NULL`.+ #' # use non-exported function from teal.slice |
||
| 716 | +12 |
- srv_add = function(id, active_datanames = reactive(self$datanames())) {
+ #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
||
| 717 | -1x | +|||
| 13 | +
- checkmate::assert_class(active_datanames, "reactive")+ #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|||
| 718 | -1x | +|||
| 14 | +
- moduleServer(id, function(input, output, session) {
+ #' RangeFilterState <- getFromNamespace("RangeFilterState", "teal.slice")
|
|||
| 719 | -1x | +|||
| 15 | +
- logger::log_trace("FilteredData$srv_add initializing")
+ #' |
|||
| 720 | -1x | +|||
| 16 | +
- observeEvent(input$minimise_filter_add_vars, {
+ #' library(shiny) |
|||
| 721 | -! | +|||
| 17 | +
- shinyjs::toggle("filter_add_vars_contents")
+ #' |
|||
| 722 | -! | +|||
| 18 | +
- toggle_icon(session$ns("minimise_filter_add_vars"), c("fa-angle-right", "fa-angle-down"))
+ #' filter_state <- RangeFilterState$new( |
|||
| 723 | -! | +|||
| 19 | +
- toggle_title(session$ns("minimise_filter_add_vars"), c("Restore panel", "Minimise Panel"))
+ #' x = c(NA, Inf, seq(1:10)), |
|||
| 724 | +20 |
- })+ #' slice = teal_slice(varname = "x", dataname = "data") |
||
| 725 | +21 |
-
+ #' ) |
||
| 726 | -1x | +|||
| 22 | +
- observeEvent(active_datanames(), {
+ #' isolate(filter_state$get_call()) |
|||
| 727 | -! | +|||
| 23 | +
- lapply(self$datanames(), function(dataname) {
+ #' filter_state$set_state( |
|||
| 728 | -! | +|||
| 24 | +
- if (dataname %in% active_datanames()) {
+ #' teal_slice( |
|||
| 729 | -! | +|||
| 25 | +
- shinyjs::show(dataname)+ #' dataname = "data", |
|||
| 730 | +26 |
- } else {
+ #' varname = "x", |
||
| 731 | -! | +|||
| 27 | +
- shinyjs::hide(dataname)+ #' selected = c(3L, 8L), |
|||
| 732 | +28 |
- }+ #' keep_na = TRUE, |
||
| 733 | +29 |
- })+ #' keep_inf = TRUE |
||
| 734 | +30 |
- })+ #' ) |
||
| 735 | +31 |
-
+ #' ) |
||
| 736 | +32 |
- # should not use for-loop as variables are otherwise only bound by reference+ #' isolate(filter_state$get_call()) |
||
| 737 | +33 |
- # and last dataname would be used+ #' |
||
| 738 | -1x | +|||
| 34 | +
- lapply(+ #' # working filter in an app |
|||
| 739 | -1x | +|||
| 35 | +
- self$datanames(),+ #' library(shinyjs) |
|||
| 740 | -1x | +|||
| 36 | +
- function(dataname) {
+ #' |
|||
| 741 | -2x | +|||
| 37 | +
- fdataset <- private$get_filtered_dataset(dataname)+ #' data_range <- c(runif(100, 0, 1), NA, Inf) |
|||
| 742 | -2x | +|||
| 38 | +
- fdataset$srv_add(id = dataname)+ #' fs <- RangeFilterState$new( |
|||
| 743 | +39 |
- }+ #' x = data_range, |
||
| 744 | +40 |
- )+ #' slice = teal_slice( |
||
| 745 | -1x | +|||
| 41 | +
- logger::log_trace("FilteredData$srv_filter_panel initialized")
+ #' dataname = "data", |
|||
| 746 | -1x | +|||
| 42 | +
- NULL+ #' varname = "x", |
|||
| 747 | +43 |
- })+ #' selected = c(0.15, 0.93), |
||
| 748 | +44 |
- },+ #' keep_na = TRUE, |
||
| 749 | +45 |
-
+ #' keep_inf = TRUE |
||
| 750 | +46 |
- #' @description+ #' ) |
||
| 751 | +47 |
- #' Creates the UI definition for the module showing counts for each dataset+ #' ) |
||
| 752 | +48 |
- #' contrasting the filtered to the full unfiltered dataset.+ #' |
||
| 753 | +49 |
- #'+ #' ui <- fluidPage( |
||
| 754 | +50 |
- #' Per dataset, it displays+ #' useShinyjs(), |
||
| 755 | +51 |
- #' the number of rows/observations in each dataset,+ #' include_css_files(pattern = "filter-panel"), |
||
| 756 | +52 |
- #' the number of unique subjects.+ #' include_js_files(pattern = "count-bar-labels"), |
||
| 757 | +53 |
- #'+ #' column(4, tags$div( |
||
| 758 | +54 |
- #' @param id (`character(1)`)+ #' tags$h4("RangeFilterState"),
|
||
| 759 | +55 |
- #' `shiny` module instance id.+ #' fs$ui("fs")
|
||
| 760 | +56 |
- #'+ #' )), |
||
| 761 | +57 |
- ui_overview = function(id) {
+ #' column(4, tags$div( |
||
| 762 | -! | +|||
| 58 | +
- ns <- NS(id)+ #' id = "outputs", # div id is needed for toggling the element |
|||
| 763 | -! | +|||
| 59 | +
- tags$div(+ #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|||
| 764 | -! | +|||
| 60 | +
- id = id, # not used, can be used to customize CSS behavior+ #' textOutput("condition_range"), tags$br(),
|
|||
| 765 | -! | +|||
| 61 | +
- class = "well",+ #' tags$h4("Unformatted state"), # display raw filter state
|
|||
| 766 | -! | +|||
| 62 | +
- tags$div(+ #' textOutput("unformatted_range"), tags$br(),
|
|||
| 767 | -! | +|||
| 63 | +
- class = "row",+ #' tags$h4("Formatted state"), # display human readable filter state
|
|||
| 768 | -! | +|||
| 64 | +
- tags$div(+ #' textOutput("formatted_range"), tags$br()
|
|||
| 769 | -! | +|||
| 65 | +
- class = "col-sm-9",+ #' )), |
|||
| 770 | -! | +|||
| 66 | +
- tags$label("Active Filter Summary", class = "text-primary mb-4")
+ #' column(4, tags$div( |
|||
| 771 | +67 |
- ),+ #' tags$h4("Programmatic filter control"),
|
||
| 772 | -! | +|||
| 68 | +
- tags$div(+ #' actionButton("button1_range", "set drop NA", width = "100%"), tags$br(),
|
|||
| 773 | -! | +|||
| 69 | +
- class = "col-sm-3",+ #' actionButton("button2_range", "set keep NA", width = "100%"), tags$br(),
|
|||
| 774 | -! | +|||
| 70 | +
- actionLink(+ #' actionButton("button3_range", "set drop Inf", width = "100%"), tags$br(),
|
|||
| 775 | -! | +|||
| 71 | +
- ns("minimise_filter_overview"),
+ #' actionButton("button4_range", "set keep Inf", width = "100%"), tags$br(),
|
|||
| 776 | -! | +|||
| 72 | +
- label = NULL,+ #' actionButton("button5_range", "set a range", width = "100%"), tags$br(),
|
|||
| 777 | -! | +|||
| 73 | +
- icon = icon("angle-down", lib = "font-awesome"),
+ #' actionButton("button6_range", "set full range", width = "100%"), tags$br(),
|
|||
| 778 | -! | +|||
| 74 | +
- title = "Minimise panel",+ #' actionButton("button0_range", "set initial state", width = "100%"), tags$br()
|
|||
| 779 | -! | +|||
| 75 | +
- class = "remove pull-right"+ #' )) |
|||
| 780 | +76 |
- )+ #' ) |
||
| 781 | +77 |
- )+ #' |
||
| 782 | +78 |
- ),+ #' server <- function(input, output, session) {
|
||
| 783 | -! | +|||
| 79 | +
- tags$div(+ #' fs$server("fs")
|
|||
| 784 | -! | +|||
| 80 | +
- id = ns("filters_overview_contents"),
+ #' output$condition_range <- renderPrint(fs$get_call()) |
|||
| 785 | -! | +|||
| 81 | +
- tags$div(+ #' output$formatted_range <- renderText(fs$format()) |
|||
| 786 | -! | +|||
| 82 | +
- class = "teal_active_summary_filter_panel",+ #' output$unformatted_range <- renderPrint(fs$get_state()) |
|||
| 787 | -! | +|||
| 83 | +
- tableOutput(ns("table"))
+ #' # modify filter state programmatically |
|||
| 788 | +84 |
- )+ #' observeEvent( |
||
| 789 | +85 |
- )+ #' input$button1_range, |
||
| 790 | +86 |
- )+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) |
||
| 791 | +87 |
- },+ #' ) |
||
| 792 | +88 |
-
+ #' observeEvent( |
||
| 793 | +89 |
- #' @description+ #' input$button2_range, |
||
| 794 | +90 |
- #' Server function to display the number of records in the filtered and unfiltered+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
||
| 795 | +91 |
- #' data.+ #' ) |
||
| 796 | +92 |
- #'+ #' observeEvent( |
||
| 797 | +93 |
- #' @param id (`character(1)`)+ #' input$button3_range, |
||
| 798 | +94 |
- #' `shiny` module instance id.+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = FALSE)) |
||
| 799 | +95 |
- #' @param active_datanames (`reactive`)+ #' ) |
||
| 800 | +96 |
- #' returning `datanames` that should be shown on the filter panel,+ #' observeEvent( |
||
| 801 | +97 |
- #' must be a subset of the `datanames` argument provided to `ui_filter_panel`;+ #' input$button4_range, |
||
| 802 | +98 |
- #' if the function returns `NULL` (as opposed to `character(0)`), the filter+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = TRUE)) |
||
| 803 | +99 |
- #' panel will be hidden.+ #' ) |
||
| 804 | +100 |
- #' @return `NULL`.+ #' observeEvent( |
||
| 805 | +101 |
- srv_overview = function(id, active_datanames = self$datanames) {
+ #' input$button5_range, |
||
| 806 | -1x | +|||
| 102 | +
- checkmate::assert_class(active_datanames, "reactive")+ #' fs$set_state( |
|||
| 807 | -1x | +|||
| 103 | +
- moduleServer(+ #' teal_slice(dataname = "data", varname = "x", selected = c(0.2, 0.74)) |
|||
| 808 | -1x | +|||
| 104 | +
- id = id,+ #' ) |
|||
| 809 | -1x | +|||
| 105 | +
- function(input, output, session) {
+ #' ) |
|||
| 810 | -1x | +|||
| 106 | +
- logger::log_trace("FilteredData$srv_filter_overview initializing")
+ #' observeEvent( |
|||
| 811 | +107 |
-
+ #' input$button6_range, |
||
| 812 | -1x | +|||
| 108 | +
- observeEvent(input$minimise_filter_overview, {
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = c(0, 1))) |
|||
| 813 | -! | +|||
| 109 | +
- shinyjs::toggle("filters_overview_contents")
+ #' ) |
|||
| 814 | -! | +|||
| 110 | +
- toggle_icon(session$ns("minimise_filter_overview"), c("fa-angle-right", "fa-angle-down"))
+ #' observeEvent( |
|||
| 815 | -! | +|||
| 111 | +
- toggle_title(session$ns("minimise_filter_overview"), c("Restore panel", "Minimise Panel"))
+ #' input$button0_range, |
|||
| 816 | +112 |
- })+ #' fs$set_state( |
||
| 817 | +113 |
-
+ #' teal_slice("data", "variable", selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)
|
||
| 818 | -1x | +|||
| 114 | +
- output$table <- renderUI({
+ #' ) |
|||
| 819 | -! | +|||
| 115 | +
- logger::log_trace("FilteredData$srv_filter_overview@1 updating counts")
+ #' ) |
|||
| 820 | -! | +|||
| 116 | +
- if (length(active_datanames()) == 0) {
+ #' } |
|||
| 821 | -! | +|||
| 117 | +
- return(NULL)+ #' |
|||
| 822 | +118 |
- }+ #' if (interactive()) {
|
||
| 823 | +119 | - - | -||
| 824 | -! | -
- datasets_df <- self$get_filter_overview(datanames = active_datanames())+ #' shinyApp(ui, server) |
||
| 825 | +120 | - - | -||
| 826 | -! | -
- attr(datasets_df$dataname, "label") <- "Data Name"+ #' } |
||
| 827 | +121 | - - | -||
| 828 | -! | -
- if (!is.null(datasets_df$obs)) {
+ #' @keywords internal |
||
| 829 | +122 |
- # some datasets (MAE colData) doesn't return obs column+ #' |
||
| 830 | -! | +|||
| 123 | +
- datasets_df <- transform(+ RangeFilterState <- R6::R6Class( # nolint |
|||
| 831 | -! | +|||
| 124 | +
- datasets_df,+ "RangeFilterState", |
|||
| 832 | -! | +|||
| 125 | +
- obs_str_summary = ifelse(+ inherit = FilterState, |
|||
| 833 | -! | +|||
| 126 | +
- !is.na(obs),+ |
|||
| 834 | -! | +|||
| 127 | +
- sprintf("%s/%s", obs_filtered, obs),
+ # public methods ---- |
|||
| 835 | +128 |
- ""+ public = list( |
||
| 836 | +129 |
- )+ |
||
| 837 | +130 |
- )+ #' @description |
||
| 838 | -! | +|||
| 131 | +
- attr(datasets_df$obs_str_summary, "label") <- "Obs"+ #' Initialize a `FilterState` object for range selection. |
|||
| 839 | +132 |
- }+ #' @param x (`numeric`) |
||
| 840 | +133 |
-
+ #' variable to be filtered. |
||
| 841 | +134 |
-
+ #' @param x_reactive (`reactive`) |
||
| 842 | -! | +|||
| 135 | +
- if (!is.null(datasets_df$subjects)) {
+ #' returning vector of the same type as `x`. Is used to update |
|||
| 843 | +136 |
- # some datasets (without keys) doesn't return subjects+ #' counts following the change in values of the filtered dataset. |
||
| 844 | -! | +|||
| 137 | +
- datasets_df <- transform(+ #' If it is set to `reactive(NULL)` then counts based on filtered |
|||
| 845 | -! | +|||
| 138 | +
- datasets_df,+ #' dataset are not shown. |
|||
| 846 | -! | +|||
| 139 | +
- subjects_summary = ifelse(+ #' @param slice (`teal_slice`) |
|||
| 847 | -! | +|||
| 140 | +
- !is.na(subjects),+ #' specification of this filter state. |
|||
| 848 | -! | +|||
| 141 | +
- sprintf("%s/%s", subjects_filtered, subjects),
+ #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|||
| 849 | +142 |
- ""+ #' `get_state` returns `teal_slice` object which can be reused in other places. |
||
| 850 | +143 |
- )+ #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
||
| 851 | +144 |
- )+ #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
||
| 852 | -! | +|||
| 145 | +
- attr(datasets_df$subjects_summary, "label") <- "Subjects"+ #' @param extract_type (`character`) |
|||
| 853 | +146 |
- }+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
||
| 854 | +147 |
-
+ #' - `character(0)` (default) `varname` in the condition call will not be prefixed |
||
| 855 | -! | +|||
| 148 | +
- all_names <- c("dataname", "obs_str_summary", "subjects_summary")
+ #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|||
| 856 | -! | +|||
| 149 | +
- datasets_df <- datasets_df[, colnames(datasets_df) %in% all_names]+ #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|||
| 857 | +150 |
-
+ #' |
||
| 858 | -! | +|||
| 151 | +
- body_html <- apply(+ #' @return Object of class `RangeFilterState`, invisibly. |
|||
| 859 | -! | +|||
| 152 | +
- datasets_df,+ #' |
|||
| 860 | -! | +|||
| 153 | +
- 1,+ initialize = function(x, |
|||
| 861 | -! | +|||
| 154 | +
- function(x) {
+ x_reactive = reactive(NULL), |
|||
| 862 | -! | +|||
| 155 | +
- tags$tr(+ extract_type = character(0), |
|||
| 863 | -! | +|||
| 156 | +
- tagList(+ slice) {
|
|||
| 864 | -! | +|||
| 157 | +121x |
- tags$td(+ isolate({
|
||
| 865 | -! | +|||
| 158 | +121x |
- if (all(x[-1] == "")) {
+ checkmate::assert_numeric(x, all.missing = FALSE) |
||
| 866 | -! | +|||
| 159 | +2x |
- icon(+ if (!any(is.finite(x))) stop("\"x\" contains no finite values")
|
||
| 867 | -! | +|||
| 160 | +118x |
- name = "exclamation-triangle",+ super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type) |
||
| 868 | -! | +|||
| 161 | +118x |
- title = "Unsupported dataset",+ private$is_integer <- checkmate::test_integerish(x) |
||
| 869 | -! | +|||
| 162 | +118x |
- `data-container` = "body",+ private$inf_count <- sum(is.infinite(x)) |
||
| 870 | -! | +|||
| 163 | +118x |
- `data-toggle` = "popover",+ private$inf_filtered_count <- reactive( |
||
| 871 | -! | +|||
| 164 | +118x |
- `data-content` = "object not supported by the filter panel"+ if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive())) |
||
| 872 | +165 |
- )+ ) |
||
| 873 | +166 |
- },- |
- ||
| 874 | -! | -
- x[1]+ |
||
| 875 | -+ | |||
| 167 | +118x |
- ),+ checkmate::assert_numeric(slice$choices, null.ok = TRUE) |
||
| 876 | -! | +|||
| 168 | +3x |
- lapply(x[-1], tags$td)+ if (is.null(slice$keep_inf) && any(is.infinite(x))) slice$keep_inf <- TRUE |
||
| 877 | +169 |
- )+ |
||
| 878 | -+ | |||
| 170 | +117x |
- )+ private$set_choices(slice$choices) |
||
| 879 | -+ | |||
| 171 | +42x |
- }+ if (is.null(slice$selected)) slice$selected <- slice$choices |
||
| 880 | -+ | |||
| 172 | +117x |
- )+ private$set_selected(slice$selected) |
||
| 881 | +173 | |||
| 882 | -! | -
- header_labels <- vapply(- |
- ||
| 883 | -! | -
- seq_along(datasets_df),- |
- ||
| 884 | -! | +|||
| 174 | +114x |
- function(i) {
+ private$is_integer <- checkmate::test_integerish(x) |
||
| 885 | -! | +|||
| 175 | +114x |
- label <- attr(datasets_df[[i]], "label")+ private$inf_filtered_count <- reactive( |
||
| 886 | -! | +|||
| 176 | +114x |
- ifelse(!is.null(label), label, names(datasets_df)[[i]])+ if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive())) |
||
| 887 | +177 |
- },+ ) |
||
| 888 | -! | +|||
| 178 | +114x |
- character(1)+ private$inf_count <- sum(is.infinite(x)) |
||
| 889 | +179 |
- )+ |
||
| 890 | -! | +|||
| 180 | +114x |
- header_html <- tags$tr(tagList(lapply(header_labels, tags$td)))+ private$plot_data <- list( |
||
| 891 | -+ | |||
| 181 | +114x |
-
+ type = "histogram", |
||
| 892 | -! | +|||
| 182 | +114x |
- table_html <- tags$table(+ nbinsx = 50, |
||
| 893 | -! | +|||
| 183 | +114x |
- class = "table custom-table",+ x = Filter(Negate(is.na), Filter(is.finite, private$x)), |
||
| 894 | -! | +|||
| 184 | +114x |
- tags$thead(header_html),+ color = I(fetch_bs_color("secondary")),
|
||
| 895 | -! | +|||
| 185 | +114x |
- tags$tbody(body_html)+ alpha = 0.2, |
||
| 896 | -+ | |||
| 186 | +114x |
- )+ bingroup = 1, |
||
| 897 | -! | +|||
| 187 | +114x |
- logger::log_trace("FilteredData$srv_filter_overview@1 updated counts")
+ showlegend = FALSE, |
||
| 898 | -! | +|||
| 188 | +114x |
- table_html+ hoverinfo = "none" |
||
| 899 | +189 |
- })+ ) |
||
| 900 | -1x | +190 | +114x |
- logger::log_trace("FilteredData$srv_filter_overview initialized")
+ private$plot_mask <- list(list( |
| 901 | -1x | +191 | +114x |
- NULL+ type = "rect", fillcolor = rgb(1, 1, 1, .65), line = list(width = 0), |
| 902 | -+ | |||
| 192 | +114x |
- }+ x0 = -0.5, x1 = 1.5, y0 = -0.5, y1 = 1.5, xref = "paper", yref = "paper" |
||
| 903 | +193 |
- )+ )) |
||
| 904 | -+ | |||
| 194 | +114x |
- }+ private$plot_layout <- reactive({
|
||
| 905 | -+ | |||
| 195 | +5x |
- ),+ shapes <- private$get_shape_properties(private$get_selected()) |
||
| 906 | -+ | |||
| 196 | +5x |
-
+ list( |
||
| 907 | -+ | |||
| 197 | +5x |
- # private members ----+ barmode = "overlay", |
||
| 908 | -+ | |||
| 198 | +5x |
- private = list(+ xaxis = list( |
||
| 909 | -+ | |||
| 199 | +5x |
- # selectively hide / show to only show `active_datanames` out of all datanames+ range = private$get_choices() * c(0.995, 1.005), |
||
| 910 | -+ | |||
| 200 | +5x |
-
+ rangeslider = list(thickness = 0), |
||
| 911 | -+ | |||
| 201 | +5x |
- # private attributes ----+ showticklabels = TRUE, |
||
| 912 | -+ | |||
| 202 | +5x |
- filtered_datasets = list(),+ ticks = "outside", |
||
| 913 | -+ | |||
| 203 | +5x |
-
+ ticklen = 1.5, |
||
| 914 | -+ | |||
| 204 | +5x |
- # activate/deactivate filter panel+ tickmode = "auto", |
||
| 915 | -+ | |||
| 205 | +5x |
- filter_panel_active = TRUE,+ nticks = 10 |
||
| 916 | +206 |
-
+ ), |
||
| 917 | -+ | |||
| 207 | +5x |
- # `reactive` containing teal_slices that can be selected; only active in module-specific mode+ yaxis = list(showgrid = FALSE, showticklabels = FALSE),+ |
+ ||
| 208 | +5x | +
+ margin = list(b = 17, l = 0, r = 0, t = 0, autoexpand = FALSE),+ |
+ ||
| 209 | +5x | +
+ plot_bgcolor = "#FFFFFF00",+ |
+ ||
| 210 | +5x | +
+ paper_bgcolor = "#FFFFFF00",+ |
+ ||
| 211 | +5x | +
+ shapes = shapes |
||
| 918 | +212 |
- available_teal_slices = NULL,+ ) |
||
| 919 | +213 |
-
+ })+ |
+ ||
| 214 | +114x | +
+ private$plot_config <- reactive({
+ |
+ ||
| 215 | +5x | +
+ list(+ |
+ ||
| 216 | +5x | +
+ doubleClick = "reset",+ |
+ ||
| 217 | +5x | +
+ displayModeBar = FALSE,+ |
+ ||
| 218 | +5x | +
+ edits = list(shapePosition = TRUE) |
||
| 920 | +219 |
- # keys used for joining/filtering data a join_keys object (see teal.data)+ ) |
||
| 921 | +220 |
- join_keys = NULL,+ })+ |
+ ||
| 221 | +114x | +
+ private$plot_filtered <- reactive({
+ |
+ ||
| 222 | +5x | +
+ finite_values <- Filter(is.finite, private$x_reactive())+ |
+ ||
| 223 | +5x | +
+ if (!identical(finite_values, numeric(0))) {
+ |
+ ||
| 224 | +5x | +
+ list(+ |
+ ||
| 225 | +5x | +
+ x = finite_values,+ |
+ ||
| 226 | +5x | +
+ bingroup = 1,+ |
+ ||
| 227 | +5x | +
+ color = I(fetch_bs_color("primary"))
|
||
| 922 | +228 |
-
+ ) |
||
| 923 | +229 |
- # flag specifying whether the user may add filters+ } |
||
| 924 | +230 |
- allow_add = TRUE,+ })+ |
+ ||
| 231 | +114x | +
+ invisible(self) |
||
| 925 | +232 |
-
+ }) |
||
| 926 | +233 |
- # private methods ----+ }, |
||
| 927 | +234 | |||
| 928 | +235 |
- # @description+ #' @description |
||
| 929 | +236 |
- # Gets `FilteredDataset` object which contains all information+ #' Returns reproducible condition call for current selection. |
||
| 930 | +237 |
- # pertaining to the specified dataset.+ #' For this class returned call looks like |
||
| 931 | +238 |
- #+ #' `<varname> >= <min value> & <varname> <= <max value>` with |
||
| 932 | +239 |
- # @param dataname (`character(1)`)+ #' optional `is.na(<varname>)` and `is.finite(<varname>)`. |
||
| 933 | +240 |
- # name of the dataset+ #' @param dataname name of data set; defaults to `private$get_dataname()` |
||
| 934 | +241 |
- #+ #' @return `call` |
||
| 935 | +242 |
- # @return `FilteredDataset` object or list of `FilteredDataset`s+ #' |
||
| 936 | +243 |
- #+ get_call = function(dataname) {
+ |
+ ||
| 244 | +35x | +
+ if (isFALSE(private$is_any_filtered())) {
+ |
+ ||
| 245 | +1x | +
+ return(NULL) |
||
| 937 | +246 |
- get_filtered_dataset = function(dataname = character(0)) {
+ } |
||
| 938 | -147x | +247 | +4x |
- if (length(dataname) == 0) {
+ if (missing(dataname)) dataname <- private$get_dataname() |
| 939 | -! | +|||
| 248 | +34x |
- private$filtered_datasets+ varname <- private$get_varname_prefixed(dataname)+ |
+ ||
| 249 | +34x | +
+ filter_call <-+ |
+ ||
| 250 | +34x | +
+ call( |
||
| 940 | +251 |
- } else {
+ "&", |
||
| 941 | -147x | +252 | +34x |
- private$filtered_datasets[[dataname]]+ call(">=", varname, private$get_selected()[1L]),
+ |
+
| 253 | +34x | +
+ call("<=", varname, private$get_selected()[2L])
|
||
| 942 | +254 |
- }+ )+ |
+ ||
| 255 | +34x | +
+ private$add_keep_na_call(private$add_keep_inf_call(filter_call, varname), varname) |
||
| 943 | +256 |
}, |
||
| 944 | +257 | |||
| 945 | +258 |
- # we implement these functions as checks rather than returning logicals so they can+ #' @description |
||
| 946 | +259 |
- # give informative error messages immediately+ #' Returns current `keep_inf` selection. |
||
| 947 | +260 |
-
+ #' @return `logical(1)` |
||
| 948 | +261 |
- # @description+ get_keep_inf = function() {
+ |
+ ||
| 262 | +! | +
+ private$teal_slice$keep_inf |
||
| 949 | +263 |
- # Gets the number of active `FilterState` objects in all `FilterStates`+ } |
||
| 950 | +264 |
- # in all `FilteredDataset`s in this `FilteredData` object.+ ), |
||
| 951 | +265 |
- # @return `integer(1)`+ |
||
| 952 | +266 |
- get_filter_count = function() {
+ # private fields---- |
||
| 953 | -11x | +|||
| 267 | +
- length(self$get_filter_state())+ private = list( |
|||
| 954 | +268 |
- },+ inf_count = integer(0), |
||
| 955 | +269 |
-
+ inf_filtered_count = NULL, |
||
| 956 | +270 |
- # @description+ is_integer = logical(0), |
||
| 957 | +271 |
- # Activate available filters.+ numeric_step = numeric(0), # step for the slider input widget, calculated from input data (x) |
||
| 958 | +272 |
- # Module is composed from plus button and dropdown menu. Menu is shown when+ plot_data = NULL, |
||
| 959 | +273 |
- # the button is clicked. Menu contains available/active filters list+ plot_mask = list(), |
||
| 960 | +274 |
- # passed via `set_available_teal_slice`.+ plot_layout = NULL, |
||
| 961 | +275 |
- ui_available_filters = function(id) {
+ plot_config = NULL, |
||
| 962 | -! | +|||
| 276 | +
- ns <- NS(id)+ plot_filtered = NULL, |
|||
| 963 | +277 | |||
| 964 | -! | +|||
| 278 | +
- active_slices_id <- isolate(vapply(self$get_filter_state(), `[[`, character(1), "id"))+ # private methods ---- |
|||
| 965 | -! | +|||
| 279 | +
- tags$div(+ |
|||
| 966 | -! | +|||
| 280 | +
- id = ns("available_menu"),
+ set_choices = function(choices) {
|
|||
| 967 | -! | +|||
| 281 | +117x |
- shinyWidgets::dropMenu(+ x <- private$x[is.finite(private$x)] |
||
| 968 | -! | +|||
| 282 | +117x |
- actionLink(+ if (is.null(choices)) {
|
||
| 969 | -! | +|||
| 283 | +105x |
- ns("show"),
+ choices <- range(x) |
||
| 970 | -! | +|||
| 284 | +
- label = NULL,+ } else {
|
|||
| 971 | -! | +|||
| 285 | +12x |
- icon = icon("plus", lib = "font-awesome"),
+ choices_adjusted <- c(max(choices[1L], min(x)), min(choices[2L], max(x))) |
||
| 972 | -! | +|||
| 286 | +12x |
- title = "Available filters",+ if (any(choices != choices_adjusted)) {
|
||
| 973 | -! | +|||
| 287 | +1x |
- class = "remove pull-right"+ warning(sprintf( |
||
| 974 | -+ | |||
| 288 | +1x |
- ),+ "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", |
||
| 975 | -! | +|||
| 289 | +1x |
- tags$div(+ private$get_varname(), private$get_dataname() |
||
| 976 | -! | +|||
| 290 | +
- class = "menu-content",+ )) |
|||
| 977 | -! | +|||
| 291 | +1x |
- shinycssloaders::withSpinner(+ choices <- choices_adjusted |
||
| 978 | -! | +|||
| 292 | +
- uiOutput(ns("checkbox")),
+ } |
|||
| 979 | -! | +|||
| 293 | +12x |
- type = 4,+ if (choices[1L] > choices[2L]) {
|
||
| 980 | -! | +|||
| 294 | +1x |
- size = 0.25+ warning(sprintf( |
||
| 981 | -+ | |||
| 295 | +1x |
- )+ "Invalid choices: lower is higher / equal to upper, or not in range of variable values. |
||
| 982 | -+ | |||
| 296 | +1x |
- )+ Setting defaults. Varname: %s, dataname: %s.", |
||
| 983 | -+ | |||
| 297 | +1x |
- )+ private$get_varname(), private$get_dataname() |
||
| 984 | +298 |
- )+ )) |
||
| 985 | -+ | |||
| 299 | +1x |
- },+ choices <- range(x) |
||
| 986 | +300 |
- # @description+ } |
||
| 987 | +301 |
- # Activate available filters. When a filter is selected or removed,+ } |
||
| 988 | +302 |
- # `set_filter_state` or `remove_filter_state` is executed for+ |
||
| 989 | -+ | |||
| 303 | +117x |
- # the appropriate filter state id.+ private$set_is_choice_limited(private$x, choices) |
||
| 990 | -+ | |||
| 304 | +117x |
- srv_available_filters = function(id) {
+ private$x <- private$x[ |
||
| 991 | -4x | +305 | +117x |
- moduleServer(id, function(input, output, session) {
+ (private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x) | !is.finite(private$x) |
| 992 | -4x | +|||
| 306 | +
- slices_available <- self$get_available_teal_slices()+ ] |
|||
| 993 | -4x | +|||
| 307 | +
- slices_interactive <- reactive(+ |
|||
| 994 | -4x | +308 | +117x |
- Filter(function(slice) isFALSE(slice$fixed), slices_available())+ x_range <- range(private$x, finite = TRUE) |
| 995 | +309 |
- )+ + |
+ ||
| 310 | ++ |
+ # Required for displaying ticks on the slider, can modify choices! |
||
| 996 | -4x | +311 | +117x |
- slices_fixed <- reactive(+ if (identical(diff(x_range), 0)) {
|
| 997 | -4x | +312 | +2x |
- Filter(function(slice) isTRUE(slice$fixed), slices_available())+ choices <- x_range |
| 998 | +313 |
- )+ } else {
|
||
| 999 | -4x | +314 | +115x |
- available_slices_id <- reactive(vapply(slices_available(), `[[`, character(1), "id"))+ x_pretty <- pretty(x_range, 100L) |
| 1000 | -4x | +315 | +115x |
- active_slices_id <- reactive(vapply(self$get_filter_state(), `[[`, character(1), "id"))+ choices <- range(x_pretty) |
| 1001 | -4x | +316 | +115x |
- duplicated_slice_references <- reactive({
+ private$numeric_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10) |
| 1002 | +317 |
- # slice refers to a particular column+ } |
||
| 1003 | -8x | +318 | +117x |
- slice_reference <- vapply(slices_available(), get_default_slice_id, character(1))+ private$teal_slice$choices <- choices |
| 1004 | -8x | +319 | +117x |
- is_duplicated_reference <- duplicated(slice_reference) | duplicated(slice_reference, fromLast = TRUE)+ invisible(NULL) |
| 1005 | -8x | +|||
| 320 | +
- is_active <- available_slices_id() %in% active_slices_id()+ }, |
|||
| 1006 | -8x | +|||
| 321 | +
- is_not_expr <- !vapply(slices_available(), inherits, logical(1), "teal_slice_expr")+ |
|||
| 1007 | -8x | +|||
| 322 | +
- slice_reference[is_duplicated_reference & is_active & is_not_expr]+ # @description |
|||
| 1008 | +323 |
- })+ # Check whether the initial choices filter out some values of x and set the flag in case. |
||
| 1009 | +324 |
-
+ set_is_choice_limited = function(xl, choices) {
|
||
| 1010 | -4x | +325 | +117x |
- checkbox_group_element <- function(name, value, label, checked, disabled = FALSE) {
+ xl <- xl[!is.na(xl)] |
| 1011 | -35x | +326 | +117x |
- tags$div(+ xl <- xl[is.finite(xl)] |
| 1012 | -35x | +327 | +117x |
- class = "checkbox available-filters",+ private$is_choice_limited <- (any(xl < choices[1L]) | any(xl > choices[2L])) |
| 1013 | -35x | +328 | +117x |
- tags$label(+ invisible(NULL) |
| 1014 | -35x | +|||
| 329 | +
- tags$input(+ }, |
|||
| 1015 | -35x | +|||
| 330 | +
- type = "checkbox",+ |
|||
| 1016 | -35x | +|||
| 331 | +
- name = name,+ # Adds is.infinite(varname) before existing condition calls if keep_inf is selected |
|||
| 1017 | -35x | +|||
| 332 | +
- value = value,+ # returns a call+ |
+ |||
| 333 | ++ |
+ add_keep_inf_call = function(filter_call, varname) {
|
||
| 1018 | -35x | +334 | +34x |
- checked = checked,+ if (isTRUE(private$get_keep_inf())) {
|
| 1019 | -35x | +335 | +2x |
- disabled = if (disabled) "disabled"+ call("|", call("is.infinite", varname), filter_call)
|
| 1020 | +336 |
- ),+ } else {
|
||
| 1021 | -35x | +337 | +32x |
- tags$span(label, disabled = if (disabled) disabled)+ filter_call |
| 1022 | +338 |
- )+ } |
||
| 1023 | +339 |
- )+ }, |
||
| 1024 | +340 |
- }+ |
||
| 1025 | +341 |
-
+ # @description gets pretty step size for range slider |
||
| 1026 | -4x | +|||
| 342 | +
- output$checkbox <- renderUI({
+ # adaptation of shiny's method (see shiny/R/input-slider.R function findStepSize) |
|||
| 1027 | -8x | +|||
| 343 | +
- checkbox <- checkboxGroupInput(+ # @param pretty_range (numeric(n)) vector of pretty values |
|||
| 1028 | -8x | +|||
| 344 | +
- session$ns("available_slices_id"),
+ # @return numeric(1) pretty step size for the sliderInput |
|||
| 1029 | -8x | +|||
| 345 | +
- label = NULL,+ get_pretty_range_step = function(pretty_range) {
|
|||
| 1030 | -8x | +346 | +117x |
- choices = NULL,+ if (private$is_integer && diff(range(pretty_range) > 2)) {
|
| 1031 | -8x | +347 | +46x |
- selected = NULL+ return(1L) |
| 1032 | +348 |
- )+ } else {
|
||
| 1033 | -8x | +349 | +71x |
- active_slices_ids <- active_slices_id()+ n_steps <- length(pretty_range) - 1 |
| 1034 | -8x | +350 | +71x |
- duplicated_slice_refs <- duplicated_slice_references()+ return(signif(digits = 10, (max(pretty_range) - min(pretty_range)) / n_steps)) |
| 1035 | +351 |
-
+ } |
||
| 1036 | -8x | +|||
| 352 | +
- checkbox_group_slice <- function(slice) {
+ }, |
|||
| 1037 | +353 |
- # we need to isolate changes in the fields of the slice (teal_slice)+ cast_and_validate = function(values) {
|
||
| 1038 | -35x | +354 | +133x |
- isolate({
+ tryCatch( |
| 1039 | -35x | +355 | +133x |
- checkbox_group_element(+ expr = {
|
| 1040 | -35x | +356 | +133x |
- name = session$ns("available_slices_id"),
+ values <- as.numeric(values) |
| 1041 | -35x | +357 | +4x |
- value = slice$id,+ if (anyNA(values)) stop() |
| 1042 | -35x | +358 | +129x |
- label = slice$id,+ values |
| 1043 | -35x | +|||
| 359 | +
- checked = if (slice$id %in% active_slices_ids) "checked",+ }, |
|||
| 1044 | -35x | -
- disabled = slice$anchored ||- |
- ||
| 1045 | -35x | -
- get_default_slice_id(slice) %in% duplicated_slice_refs &&- |
- ||
| 1046 | -35x | +360 | +133x |
- !slice$id %in% active_slices_ids+ error = function(e) stop("Vector of set values must contain values coercible to numeric")
|
| 1047 | +361 |
- )+ ) |
||
| 1048 | +362 |
- })+ }, |
||
| 1049 | +363 |
- }+ # Also validates that selection is sorted. |
||
| 1050 | +364 |
-
+ check_length = function(values) {
|
||
| 1051 | -8x | +365 | +2x |
- interactive_choice_mock <- lapply(slices_interactive(), checkbox_group_slice)+ if (length(values) != 2L) stop("Vector of set values must have length two.")
|
| 1052 | -8x | -
- non_interactive_choice_mock <- lapply(slices_fixed(), checkbox_group_slice)- |
- ||
| 1053 | -+ | 366 | +2x |
-
+ if (values[1L] > values[2L]) stop("Vector of set values must be sorted.")
|
| 1054 | -8x | +367 | +125x |
- htmltools::tagInsertChildren(+ values |
| 1055 | -8x | +|||
| 368 | +
- checkbox,+ }, |
|||
| 1056 | -8x | +|||
| 369 | +
- tags$br(),+ # Trim selection to limits imposed by private$get_choices() |
|||
| 1057 | -8x | +|||
| 370 | +
- if (length(non_interactive_choice_mock)) tags$strong("Fixed filters"),
+ remove_out_of_bounds_values = function(values) {
|
|||
| 1058 | -8x | +371 | +2x |
- non_interactive_choice_mock,+ if (values[1L] < private$get_choices()[1L]) values[1L] <- private$get_choices()[1L] |
| 1059 | -8x | +372 | +2x |
- if (length(interactive_choice_mock)) tags$strong("Interactive filters"),
+ if (values[2L] > private$get_choices()[2L]) values[2L] <- private$get_choices()[2L] |
| 1060 | -8x | +373 | +125x |
- interactive_choice_mock,+ values |
| 1061 | -8x | +|||
| 374 | +
- .cssSelector = "div.shiny-options-group",+ }, |
|||
| 1062 | -8x | +|||
| 375 | +
- after = 0+ |
|||
| 1063 | +376 |
- )+ # Answers the question of whether the current settings and values selected actually filters out any values. |
||
| 1064 | +377 |
- })+ # @return logical scalar |
||
| 1065 | +378 |
-
+ is_any_filtered = function() {
|
||
| 1066 | -4x | +379 | +35x |
- observeEvent(input$available_slices_id, ignoreNULL = FALSE, ignoreInit = TRUE, {
+ if (private$is_choice_limited) {
|
| 1067 | -5x | +380 | +1x |
- new_slices_id <- setdiff(input$available_slices_id, active_slices_id())+ TRUE |
| 1068 | -5x | +381 | +34x |
- removed_slices_id <- setdiff(active_slices_id(), input$available_slices_id)+ } else if (!isTRUE(all.equal(private$get_selected(), private$get_choices()))) {
|
| 1069 | -5x | +382 | +32x |
- if (length(new_slices_id)) {
+ TRUE |
| 1070 | -3x | +383 | +2x |
- new_teal_slices <- Filter(+ } else if (!isTRUE(private$get_keep_inf()) && private$inf_count > 0) {
+ |
+
| 384 | +! | +
+ TRUE |
||
| 1071 | -3x | +385 | +2x |
- function(slice) slice$id %in% new_slices_id,+ } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
|
| 1072 | -3x | +386 | +1x |
- private$available_teal_slices()+ TRUE |
| 1073 | +387 |
- )+ } else {
|
||
| 1074 | -3x | +388 | +1x |
- self$set_filter_state(new_teal_slices)+ FALSE |
| 1075 | +389 |
- }+ } |
||
| 1076 | +390 | - - | -||
| 1077 | -5x | -
- if (length(removed_slices_id)) {
- |
- ||
| 1078 | -4x | -
- removed_teal_slices <- Filter(- |
- ||
| 1079 | -4x | -
- function(slice) slice$id %in% removed_slices_id,- |
- ||
| 1080 | -4x | -
- self$get_filter_state()+ }, |
||
| 1081 | +391 |
- )- |
- ||
| 1082 | -4x | -
- self$remove_filter_state(removed_teal_slices)+ |
||
| 1083 | +392 |
- }+ # obtain shape determination for histogram |
||
| 1084 | +393 |
- })+ # returns a list that is passed to plotly's layout.shapes property |
||
| 1085 | +394 |
-
+ get_shape_properties = function(values) {
|
||
| 1086 | -4x | +395 | +5x |
- observeEvent(private$available_teal_slices(), ignoreNULL = FALSE, {
+ list( |
| 1087 | -3x | +396 | +5x |
- if (length(private$available_teal_slices())) {
+ list(type = "line", x0 = values[1], x1 = values[1], y0 = -100, y1 = 100, yref = "paper"), |
| 1088 | -1x | +397 | +5x |
- shinyjs::show("available_menu")
+ list(type = "line", x0 = values[2], x1 = values[2], y0 = -100, y1 = 100, yref = "paper") |
| 1089 | +398 |
- } else {
+ ) |
||
| 1090 | -2x | +|||
| 399 | +
- shinyjs::hide("available_menu")
+ }, |
|||
| 1091 | +400 |
- }+ |
||
| 1092 | +401 |
- })+ # shiny modules ---- |
||
| 1093 | +402 |
- })+ |
||
| 1094 | +403 |
- }+ # UI Module for `RangeFilterState`. |
||
| 1095 | +404 |
- )+ # This UI element contains two values for `min` and `max` |
||
| 1096 | +405 |
- )+ # of the range and two checkboxes whether to keep the `NA` or `Inf` values. |
| 1 | +406 |
- # RangeFilterState ------+ # @param id (`character(1)`) `shiny` module instance id. |
||
| 2 | +407 |
-
+ ui_inputs = function(id) {
|
||
| 3 | -+ | |||
| 408 | +5x |
- #' @name RangeFilterState+ ns <- NS(id) |
||
| 4 | -+ | |||
| 409 | +5x |
- #' @docType class+ isolate({
|
||
| 5 | -+ | |||
| 410 | +5x |
- #'+ ui_input <- shinyWidgets::numericRangeInput( |
||
| 6 | -+ | |||
| 411 | +5x |
- #' @title `FilterState` object for numeric data+ inputId = ns("selection_manual"),
|
||
| 7 | -+ | |||
| 412 | +5x |
- #'+ label = NULL, |
||
| 8 | -+ | |||
| 413 | +5x |
- #' @description Manages choosing a numeric range.+ min = private$get_choices()[1L], |
||
| 9 | -+ | |||
| 414 | +5x |
- #'+ max = private$get_choices()[2L], |
||
| 10 | -+ | |||
| 415 | +5x |
- #' @examples+ value = private$get_selected(), |
||
| 11 | -+ | |||
| 416 | +5x |
- #' # use non-exported function from teal.slice+ step = private$numeric_step, |
||
| 12 | -+ | |||
| 417 | +5x |
- #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
+ width = "100%" |
||
| 13 | +418 |
- #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
+ ) |
||
| 14 | -+ | |||
| 419 | +5x |
- #' RangeFilterState <- getFromNamespace("RangeFilterState", "teal.slice")
+ tagList( |
||
| 15 | -+ | |||
| 420 | +5x |
- #'+ tags$div( |
||
| 16 | -+ | |||
| 421 | +5x |
- #' library(shiny)+ class = "choices_state", |
||
| 17 | -+ | |||
| 422 | +5x |
- #'+ tags$head(tags$script( |
||
| 18 | +423 |
- #' filter_state <- RangeFilterState$new(+ # Inline JS code for popover functionality. |
||
| 19 | +424 |
- #' x = c(NA, Inf, seq(1:10)),+ # Adding the script inline because when added from a file with include_js_files(), |
||
| 20 | +425 |
- #' slice = teal_slice(varname = "x", dataname = "data")+ # it only works in the first info_button instance and not others. |
||
| 21 | -+ | |||
| 426 | +5x |
- #' )+ HTML( |
||
| 22 | -+ | |||
| 427 | +5x |
- #' isolate(filter_state$get_call())+ '$(document).ready(function() {
|
||
| 23 | -+ | |||
| 428 | +5x |
- #' filter_state$set_state(+ $("[data-toggle=\'popover\']").popover();
|
||
| 24 | +429 |
- #' teal_slice(+ |
||
| 25 | -+ | |||
| 430 | +5x |
- #' dataname = "data",+ $(document).on("click", function (e) {
|
||
| 26 | -+ | |||
| 431 | +5x |
- #' varname = "x",+ if (!$("[data-toggle=\'popover\']").is(e.target) &&
|
||
| 27 | -+ | |||
| 432 | +5x |
- #' selected = c(3L, 8L),+ $("[data-toggle=\'popover\']").has(e.target).length === 0 &&
|
||
| 28 | -+ | |||
| 433 | +5x |
- #' keep_na = TRUE,+ $(".popover").has(e.target).length === 0) {
|
||
| 29 | -+ | |||
| 434 | +5x |
- #' keep_inf = TRUE+ $("[data-toggle=\'popover\']").popover("hide");
|
||
| 30 | +435 |
- #' )+ } |
||
| 31 | +436 |
- #' )+ }); |
||
| 32 | +437 |
- #' isolate(filter_state$get_call())+ });' |
||
| 33 | +438 |
- #'+ ) |
||
| 34 | +439 |
- #' # working filter in an app+ )), |
||
| 35 | -+ | |||
| 440 | +5x |
- #' library(shinyjs)+ tags$div( |
||
| 36 | -+ | |||
| 441 | +5x |
- #'+ actionLink( |
||
| 37 | -+ | |||
| 442 | +5x |
- #' data_range <- c(runif(100, 0, 1), NA, Inf)+ ns("plotly_info"),
|
||
| 38 | -+ | |||
| 443 | +5x |
- #' fs <- RangeFilterState$new(+ label = NULL, |
||
| 39 | -+ | |||
| 444 | +5x |
- #' x = data_range,+ icon = icon("question-circle"),
|
||
| 40 | -+ | |||
| 445 | +5x |
- #' slice = teal_slice(+ "data-toggle" = "popover", |
||
| 41 | -+ | |||
| 446 | +5x |
- #' dataname = "data",+ "data-html" = "true", |
||
| 42 | -+ | |||
| 447 | +5x |
- #' varname = "x",+ "data-placement" = "left", |
||
| 43 | -+ | |||
| 448 | +5x |
- #' selected = c(0.15, 0.93),+ "data-trigger" = "click", |
||
| 44 | -+ | |||
| 449 | +5x |
- #' keep_na = TRUE,+ "data-title" = "Plot actions", |
||
| 45 | -+ | |||
| 450 | +5x |
- #' keep_inf = TRUE+ "data-content" = "<p> |
||
| 46 | -+ | |||
| 451 | +5x |
- #' )+ Drag vertical lines to set selection.<br> |
||
| 47 | -+ | |||
| 452 | +5x |
- #' )+ Drag across plot to zoom in.<br> |
||
| 48 | -+ | |||
| 453 | +5x |
- #'+ Drag axis to pan.<br> |
||
| 49 | -+ | |||
| 454 | +5x |
- #' ui <- fluidPage(+ Double click to zoom out." |
||
| 50 | +455 |
- #' useShinyjs(),+ ), |
||
| 51 | -+ | |||
| 456 | +5x |
- #' include_css_files(pattern = "filter-panel"),+ style = "text-align: right; font-size: 0.7em; margin-bottom: -1em; position: relative; z-index: 9;" |
||
| 52 | +457 |
- #' include_js_files(pattern = "count-bar-labels"),+ ), |
||
| 53 | -+ | |||
| 458 | +5x |
- #' column(4, tags$div(+ shinycssloaders::withSpinner( |
||
| 54 | -+ | |||
| 459 | +5x |
- #' tags$h4("RangeFilterState"),
+ plotly::plotlyOutput(ns("plot"), height = "50px"),
|
||
| 55 | -+ | |||
| 460 | +5x |
- #' fs$ui("fs")
+ type = 4, |
||
| 56 | -+ | |||
| 461 | +5x |
- #' )),+ size = 0.25, |
||
| 57 | -+ | |||
| 462 | +5x |
- #' column(4, tags$div(+ hide.ui = FALSE |
||
| 58 | +463 |
- #' id = "outputs", # div id is needed for toggling the element+ ), |
||
| 59 | -+ | |||
| 464 | +5x |
- #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
+ ui_input |
||
| 60 | +465 |
- #' textOutput("condition_range"), tags$br(),
+ ), |
||
| 61 | -+ | |||
| 466 | +5x |
- #' tags$h4("Unformatted state"), # display raw filter state
+ tags$div( |
||
| 62 | -+ | |||
| 467 | +5x |
- #' textOutput("unformatted_range"), tags$br(),
+ class = "filter-card-body-keep-na-inf", |
||
| 63 | -+ | |||
| 468 | +5x |
- #' tags$h4("Formatted state"), # display human readable filter state
+ private$keep_inf_ui(ns("keep_inf")),
|
||
| 64 | -+ | |||
| 469 | +5x |
- #' textOutput("formatted_range"), tags$br()
+ private$keep_na_ui(ns("keep_na"))
|
||
| 65 | +470 |
- #' )),+ ) |
||
| 66 | +471 |
- #' column(4, tags$div(+ ) |
||
| 67 | +472 |
- #' tags$h4("Programmatic filter control"),
+ }) |
||
| 68 | +473 |
- #' actionButton("button1_range", "set drop NA", width = "100%"), tags$br(),
+ }, |
||
| 69 | +474 |
- #' actionButton("button2_range", "set keep NA", width = "100%"), tags$br(),
+
|
||
| 70 | +475 |
- #' actionButton("button3_range", "set drop Inf", width = "100%"), tags$br(),
+ # @description |
||
| 71 | +476 |
- #' actionButton("button4_range", "set keep Inf", width = "100%"), tags$br(),
+ # Server module |
||
| 72 | +477 |
- #' actionButton("button5_range", "set a range", width = "100%"), tags$br(),
+ # @param id (`character(1)`) `shiny` module instance id. |
||
| 73 | +478 |
- #' actionButton("button6_range", "set full range", width = "100%"), tags$br(),
+ # return `NULL`. |
||
| 74 | +479 |
- #' actionButton("button0_range", "set initial state", width = "100%"), tags$br()
+ server_inputs = function(id) {
|
||
| 75 | -+ | |||
| 480 | +5x |
- #' ))+ moduleServer( |
||
| 76 | -+ | |||
| 481 | +5x |
- #' )+ id = id, |
||
| 77 | -+ | |||
| 482 | +5x |
- #'+ function(input, output, session) {
|
||
| 78 | -+ | |||
| 483 | +5x |
- #' server <- function(input, output, session) {
+ logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }")
|
||
| 79 | +484 |
- #' fs$server("fs")
+
|
||
| 80 | +485 |
- #' output$condition_range <- renderPrint(fs$get_call())+ # Capture manual input with debounce. |
||
| 81 | -+ | |||
| 486 | +5x |
- #' output$formatted_range <- renderText(fs$format())+ selection_manual <- debounce(reactive(input$selection_manual), 200) |
||
| 82 | +487 |
- #' output$unformatted_range <- renderPrint(fs$get_state())+ |
||
| 83 | +488 |
- #' # modify filter state programmatically+ # Prepare for histogram construction. |
||
| 84 | -+ | |||
| 489 | +5x |
- #' observeEvent(+ plot_data <- c(private$plot_data, source = session$ns("histogram_plot"))
|
||
| 85 | +490 |
- #' input$button1_range,+ |
||
| 86 | +491 |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))+ # Display histogram, adding a second trace that contains filtered data. |
||
| 87 | -+ | |||
| 492 | +5x |
- #' )+ output$plot <- plotly::renderPlotly({
|
||
| 88 | -+ | |||
| 493 | +5x |
- #' observeEvent(+ histogram <- do.call(plotly::plot_ly, plot_data) |
||
| 89 | -+ | |||
| 494 | +5x |
- #' input$button2_range,+ histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout())) |
||
| 90 | -+ | |||
| 495 | +5x |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ histogram <- do.call(plotly::config, c(list(p = histogram), private$plot_config())) |
||
| 91 | -+ | |||
| 496 | +5x |
- #' )+ histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered())) |
||
| 92 | -+ | |||
| 497 | +5x |
- #' observeEvent(+ histogram |
||
| 93 | +498 |
- #' input$button3_range,+ }) |
||
| 94 | +499 |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = FALSE))+ |
||
| 95 | +500 |
- #' )+ # Dragging shapes (lines) on plot updates selection. |
||
| 96 | -+ | |||
| 501 | +5x |
- #' observeEvent(+ private$observers$relayout <- |
||
| 97 | -+ | |||
| 502 | +5x |
- #' input$button4_range,+ observeEvent( |
||
| 98 | -+ | |||
| 503 | +5x |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = TRUE))+ ignoreNULL = FALSE, |
||
| 99 | -+ | |||
| 504 | +5x |
- #' )+ ignoreInit = TRUE, |
||
| 100 | -+ | |||
| 505 | +5x |
- #' observeEvent(+ eventExpr = plotly::event_data("plotly_relayout", source = session$ns("histogram_plot")),
|
||
| 101 | -+ | |||
| 506 | +5x |
- #' input$button5_range,+ handlerExpr = {
|
||
| 102 | -+ | |||
| 507 | +1x |
- #' fs$set_state(+ logger::log_trace("RangeFilterState$server@1 selection changed, id: { private$get_id() }")
|
||
| 103 | -+ | |||
| 508 | +1x |
- #' teal_slice(dataname = "data", varname = "x", selected = c(0.2, 0.74))+ event <- plotly::event_data("plotly_relayout", source = session$ns("histogram_plot"))
|
||
| 104 | -+ | |||
| 509 | +1x |
- #' )+ if (any(grepl("shapes", names(event)))) {
|
||
| 105 | -+ | |||
| 510 | +! |
- #' )+ line_positions <- private$get_selected() |
||
| 106 | -+ | |||
| 511 | +! |
- #' observeEvent(+ if (any(grepl("shapes[0]", names(event), fixed = TRUE))) {
|
||
| 107 | -+ | |||
| 512 | +! |
- #' input$button6_range,+ line_positions[1] <- event[["shapes[0].x0"]] |
||
| 108 | -+ | |||
| 513 | +! |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = c(0, 1)))+ } else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) {
|
||
| 109 | -+ | |||
| 514 | +! |
- #' )+ line_positions[2] <- event[["shapes[1].x0"]] |
||
| 110 | +515 |
- #' observeEvent(+ } |
||
| 111 | +516 |
- #' input$button0_range,+ # If one line was dragged past the other, abort action and reset lines. |
||
| 112 | -+ | |||
| 517 | +! |
- #' fs$set_state(+ if (line_positions[1] > line_positions[2]) {
|
||
| 113 | -+ | |||
| 518 | +! |
- #' teal_slice("data", "variable", selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)
+ showNotification( |
||
| 114 | -+ | |||
| 519 | +! |
- #' )+ "Numeric range start value must be less than end value.", |
||
| 115 | -+ | |||
| 520 | +! |
- #' )+ type = "warning" |
||
| 116 | +521 |
- #' }+ ) |
||
| 117 | -+ | |||
| 522 | +! |
- #'+ plotly::plotlyProxyInvoke( |
||
| 118 | -+ | |||
| 523 | +! |
- #' if (interactive()) {
+ plotly::plotlyProxy("plot"),
|
||
| 119 | -+ | |||
| 524 | +! |
- #' shinyApp(ui, server)+ "relayout", |
||
| 120 | -+ | |||
| 525 | +! |
- #' }+ shapes = private$get_shape_properties(private$get_selected()) |
||
| 121 | +526 |
- #' @keywords internal+ ) |
||
| 122 | -+ | |||
| 527 | +! |
- #'+ return(NULL) |
||
| 123 | +528 |
- RangeFilterState <- R6::R6Class( # nolint+ } |
||
| 124 | +529 |
- "RangeFilterState",+ |
||
| 125 | -+ | |||
| 530 | +! |
- inherit = FilterState,+ private$set_selected(signif(line_positions, digits = 4L)) |
||
| 126 | +531 |
-
+ } |
||
| 127 | +532 |
- # public methods ----+ } |
||
| 128 | +533 |
- public = list(+ ) |
||
| 129 | +534 | |||
| 130 | +535 |
- #' @description+ # Change in selection updates shapes (lines) on plot and numeric input. |
||
| 131 | -+ | |||
| 536 | +5x |
- #' Initialize a `FilterState` object for range selection.+ private$observers$selection_api <- |
||
| 132 | -+ | |||
| 537 | +5x |
- #' @param x (`numeric`)+ observeEvent( |
||
| 133 | -+ | |||
| 538 | +5x |
- #' variable to be filtered.+ ignoreNULL = FALSE, |
||
| 134 | -+ | |||
| 539 | +5x |
- #' @param x_reactive (`reactive`)+ ignoreInit = TRUE, |
||
| 135 | -+ | |||
| 540 | +5x |
- #' returning vector of the same type as `x`. Is used to update+ eventExpr = private$get_selected(), |
||
| 136 | -+ | |||
| 541 | +5x |
- #' counts following the change in values of the filtered dataset.+ handlerExpr = {
|
||
| 137 | -+ | |||
| 542 | +! |
- #' If it is set to `reactive(NULL)` then counts based on filtered+ logger::log_trace("RangeFilterState$server@2 state changed, id: {private$get_id() }")
|
||
| 138 | -+ | |||
| 543 | +! |
- #' dataset are not shown.+ if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) {
|
||
| 139 | -+ | |||
| 544 | +! |
- #' @param slice (`teal_slice`)+ shinyWidgets::updateNumericRangeInput( |
||
| 140 | -+ | |||
| 545 | +! |
- #' specification of this filter state.+ session = session, |
||
| 141 | -+ | |||
| 546 | +! |
- #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.+ inputId = "selection_manual", |
||
| 142 | -+ | |||
| 547 | +! |
- #' `get_state` returns `teal_slice` object which can be reused in other places.+ value = private$get_selected() |
||
| 143 | +548 |
- #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.+ ) |
||
| 144 | +549 |
- #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.+ } |
||
| 145 | +550 |
- #' @param extract_type (`character`)+ } |
||
| 146 | +551 |
- #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ ) |
||
| 147 | +552 |
- #' - `character(0)` (default) `varname` in the condition call will not be prefixed+ |
||
| 148 | +553 |
- #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`+ # Manual input updates selection. |
||
| 149 | -+ | |||
| 554 | +5x |
- #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`+ private$observers$selection_manual <- observeEvent( |
||
| 150 | -+ | |||
| 555 | +5x |
- #'+ ignoreNULL = FALSE, |
||
| 151 | -+ | |||
| 556 | +5x |
- #' @return Object of class `RangeFilterState`, invisibly.+ ignoreInit = TRUE, |
||
| 152 | -+ | |||
| 557 | +5x |
- #'+ eventExpr = selection_manual(), |
||
| 153 | -+ | |||
| 558 | +5x |
- initialize = function(x,+ handlerExpr = {
|
||
| 154 | -+ | |||
| 559 | +! |
- x_reactive = reactive(NULL),+ selection <- selection_manual() |
||
| 155 | +560 |
- extract_type = character(0),+ # Abort and reset if non-numeric values is entered. |
||
| 156 | -+ | |||
| 561 | +! |
- slice) {
+ if (any(is.na(selection))) {
|
||
| 157 | -121x | +|||
| 562 | +! |
- isolate({
+ showNotification( |
||
| 158 | -121x | +|||
| 563 | +! |
- checkmate::assert_numeric(x, all.missing = FALSE)+ "Numeric range values must be numbers.", |
||
| 159 | -2x | +|||
| 564 | +! |
- if (!any(is.finite(x))) stop("\"x\" contains no finite values")
+ type = "warning" |
||
| 160 | -118x | +|||
| 565 | +
- super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type)+ ) |
|||
| 161 | -118x | +|||
| 566 | +! |
- private$is_integer <- checkmate::test_integerish(x)+ shinyWidgets::updateNumericRangeInput( |
||
| 162 | -118x | +|||
| 567 | +! |
- private$inf_count <- sum(is.infinite(x))+ session = session, |
||
| 163 | -118x | +|||
| 568 | +! |
- private$inf_filtered_count <- reactive(+ inputId = "selection_manual", |
||
| 164 | -118x | +|||
| 569 | +! |
- if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive()))+ value = private$get_selected() |
||
| 165 | +570 |
- )+ ) |
||
| 166 | -+ | |||
| 571 | +! |
-
+ return(NULL) |
||
| 167 | -118x | +|||
| 572 | +
- checkmate::assert_numeric(slice$choices, null.ok = TRUE)+ } |
|||
| 168 | -3x | +|||
| 573 | +
- if (is.null(slice$keep_inf) && any(is.infinite(x))) slice$keep_inf <- TRUE+ |
|||
| 169 | +574 |
-
+ # Abort and reset if reversed choices are specified. |
||
| 170 | -117x | +|||
| 575 | +! |
- private$set_choices(slice$choices)+ if (selection[1] > selection[2]) {
|
||
| 171 | -42x | +|||
| 576 | +! |
- if (is.null(slice$selected)) slice$selected <- slice$choices+ showNotification( |
||
| 172 | -117x | +|||
| 577 | +! |
- private$set_selected(slice$selected)+ "Numeric range start value must be less than end value.",+ |
+ ||
| 578 | +! | +
+ type = "warning" |
||
| 173 | +579 |
-
+ ) |
||
| 174 | -114x | +|||
| 580 | +! |
- private$is_integer <- checkmate::test_integerish(x)+ shinyWidgets::updateNumericRangeInput( |
||
| 175 | -114x | +|||
| 581 | +! |
- private$inf_filtered_count <- reactive(+ session = session, |
||
| 176 | -114x | +|||
| 582 | +! |
- if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive()))+ inputId = "selection_manual",+ |
+ ||
| 583 | +! | +
+ value = private$get_selected() |
||
| 177 | +584 |
- )+ ) |
||
| 178 | -114x | +|||
| 585 | +! |
- private$inf_count <- sum(is.infinite(x))+ return(NULL) |
||
| 179 | +586 |
-
+ } |
||
| 180 | -114x | +|||
| 587 | +
- private$plot_data <- list(+ |
|||
| 181 | -114x | +|||
| 588 | +
- type = "histogram",+ |
|||
| 182 | -114x | -
- nbinsx = 50,- |
- ||
| 183 | -114x | -
- x = Filter(Negate(is.na), Filter(is.finite, private$x)),- |
- ||
| 184 | -114x | -
- color = I(fetch_bs_color("secondary")),
- |
- ||
| 185 | -114x | -
- alpha = 0.2,- |
- ||
| 186 | -114x | +|||
| 589 | +! |
- bingroup = 1,+ if (!isTRUE(all.equal(selection, private$get_selected()))) {
|
||
| 187 | -114x | +|||
| 590 | +! |
- showlegend = FALSE,+ logger::log_trace("RangeFilterState$server@3 manual selection changed, id: { private$get_id() }")
|
||
| 188 | -114x | +|||
| 591 | +! |
- hoverinfo = "none"+ private$set_selected(selection) |
||
| 189 | +592 |
- )- |
- ||
| 190 | -114x | -
- private$plot_mask <- list(list(- |
- ||
| 191 | -114x | -
- type = "rect", fillcolor = rgb(1, 1, 1, .65), line = list(width = 0),- |
- ||
| 192 | -114x | -
- x0 = -0.5, x1 = 1.5, y0 = -0.5, y1 = 1.5, xref = "paper", yref = "paper"+ } |
||
| 193 | +593 |
- ))+ } |
||
| 194 | -114x | +|||
| 594 | +
- private$plot_layout <- reactive({
+ ) |
|||
| 195 | -5x | +|||
| 595 | +
- shapes <- private$get_shape_properties(private$get_selected())+ |
|||
| 196 | +596 | 5x |
- list(+ private$keep_inf_srv("keep_inf")
|
|
| 197 | +597 | 5x |
- barmode = "overlay",+ private$keep_na_srv("keep_na")
|
|
| 198 | -5x | +|||
| 598 | +
- xaxis = list(+ |
|||
| 199 | +599 | 5x |
- range = private$get_choices() * c(0.995, 1.005),+ logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
|
|
| 200 | +600 | 5x |
- rangeslider = list(thickness = 0),+ NULL |
|
| 201 | -5x | +|||
| 601 | +
- showticklabels = TRUE,+ } |
|||
| 202 | -5x | +|||
| 602 | +
- ticks = "outside",+ ) |
|||
| 203 | -5x | +|||
| 603 | +
- ticklen = 1.5,+ }, |
|||
| 204 | -5x | +|||
| 604 | +
- tickmode = "auto",+ server_inputs_fixed = function(id) {
|
|||
| 205 | -5x | +|||
| 605 | +! |
- nticks = 10+ moduleServer( |
||
| 206 | -+ | |||
| 606 | +! |
- ),+ id = id, |
||
| 207 | -5x | +|||
| 607 | +! |
- yaxis = list(showgrid = FALSE, showticklabels = FALSE),+ function(input, output, session) {
|
||
| 208 | -5x | +|||
| 608 | +! |
- margin = list(b = 17, l = 0, r = 0, t = 0, autoexpand = FALSE),+ logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }")
|
||
| 209 | -5x | +|||
| 609 | +
- plot_bgcolor = "#FFFFFF00",+ |
|||
| 210 | -5x | +|||
| 610 | +! |
- paper_bgcolor = "#FFFFFF00",+ plot_config <- private$plot_config() |
||
| 211 | -5x | +|||
| 611 | +! |
- shapes = shapes+ plot_config$staticPlot <- TRUE |
||
| 212 | +612 |
- )+ |
||
| 213 | -+ | |||
| 613 | +! |
- })+ output$plot <- plotly::renderPlotly({
|
||
| 214 | -114x | +|||
| 614 | +! |
- private$plot_config <- reactive({
+ histogram <- do.call(plotly::plot_ly, private$plot_data) |
||
| 215 | -5x | +|||
| 615 | +! |
- list(+ histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout())) |
||
| 216 | -5x | +|||
| 616 | +! |
- doubleClick = "reset",+ histogram <- do.call(plotly::config, c(list(p = histogram), plot_config)) |
||
| 217 | -5x | +|||
| 617 | +! |
- displayModeBar = FALSE,+ histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered())) |
||
| 218 | -5x | +|||
| 618 | +! |
- edits = list(shapePosition = TRUE)+ histogram |
||
| 219 | +619 |
- )+ }) |
||
| 220 | +620 |
- })- |
- ||
| 221 | -114x | -
- private$plot_filtered <- reactive({
- |
- ||
| 222 | -5x | -
- finite_values <- Filter(is.finite, private$x_reactive())+ |
||
| 223 | -5x | +|||
| 621 | +! |
- if (!identical(finite_values, numeric(0))) {
+ output$selection <- renderUI({
|
||
| 224 | -5x | +|||
| 622 | +! |
- list(+ shinycssloaders::withSpinner( |
||
| 225 | -5x | +|||
| 623 | +! |
- x = finite_values,+ plotly::plotlyOutput(session$ns("plot"), height = "50px"),
|
||
| 226 | -5x | +|||
| 624 | +! |
- bingroup = 1,+ type = 4, |
||
| 227 | -5x | +|||
| 625 | +! |
- color = I(fetch_bs_color("primary"))
+ size = 0.25 |
||
| 228 | +626 |
) |
||
| 229 | +627 |
- }+ }) |
||
| 230 | +628 |
- })- |
- ||
| 231 | -114x | -
- invisible(self)+ |
||
| 232 | -+ | |||
| 629 | +! |
- })+ logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
|
||
| 233 | -+ | |||
| 630 | +! |
- },+ NULL |
||
| 234 | +631 |
-
+ } |
||
| 235 | +632 |
- #' @description+ ) |
||
| 236 | +633 |
- #' Returns reproducible condition call for current selection.+ }, |
||
| 237 | +634 |
- #' For this class returned call looks like+ |
||
| 238 | +635 |
- #' `<varname> >= <min value> & <varname> <= <max value>` with+ # @description |
||
| 239 | +636 |
- #' optional `is.na(<varname>)` and `is.finite(<varname>)`.+ # Server module to display filter summary |
||
| 240 | +637 |
- #' @param dataname name of data set; defaults to `private$get_dataname()`+ # renders text describing selected range and |
||
| 241 | +638 |
- #' @return `call`+ # if NA or Inf are included also |
||
| 242 | +639 |
- #'+ # @return `shiny.tag` to include in the `ui_summary` |
||
| 243 | +640 |
- get_call = function(dataname) {
+ content_summary = function() {
|
||
| 244 | -35x | +641 | +5x |
- if (isFALSE(private$is_any_filtered())) {
+ selection <- private$get_selected() |
| 245 | -1x | +642 | +5x |
- return(NULL)+ tagList( |
| 246 | -+ | |||
| 643 | +5x |
- }+ tags$span(HTML(selection[1], "–", selection[2]), class = "filter-card-summary-value"), |
||
| 247 | -4x | +644 | +5x |
- if (missing(dataname)) dataname <- private$get_dataname()+ tags$span( |
| 248 | -34x | +645 | +5x |
- varname <- private$get_varname_prefixed(dataname)+ class = "filter-card-summary-controls", |
| 249 | -34x | +646 | +5x |
- filter_call <-+ if (private$na_count > 0) {
|
| 250 | -34x | +|||
| 647 | +! |
- call(+ tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
|
||
| 251 | +648 |
- "&",+ }, |
||
| 252 | -34x | +649 | +5x |
- call(">=", varname, private$get_selected()[1L]),
+ if (private$inf_count > 0) {
|
| 253 | -34x | +|||
| 650 | +! |
- call("<=", varname, private$get_selected()[2L])
+ tags$span("Inf", if (isTRUE(private$get_keep_inf())) icon("check") else icon("xmark"))
|
||
| 254 | +651 |
- )- |
- ||
| 255 | -34x | -
- private$add_keep_na_call(private$add_keep_inf_call(filter_call, varname), varname)+ } |
||
| 256 | +652 |
- },+ ) |
||
| 257 | +653 |
-
+ ) |
||
| 258 | +654 |
- #' @description+ }, |
||
| 259 | +655 |
- #' Returns current `keep_inf` selection.+ |
||
| 260 | +656 |
- #' @return `logical(1)`+ # @description |
||
| 261 | +657 |
- get_keep_inf = function() {
- |
- ||
| 262 | -! | -
- private$teal_slice$keep_inf+ # Module displaying input to keep or remove NA in the `FilterState` call. |
||
| 263 | +658 |
- }+ # Renders a checkbox input only when variable with which the `FilterState` has been created contains Infs. |
||
| 264 | +659 |
- ),+ # @param id (`character(1)`) `shiny` module instance id. |
||
| 265 | +660 |
-
+ keep_inf_ui = function(id) {
|
||
| 266 | -+ | |||
| 661 | +5x |
- # private fields----+ ns <- NS(id) |
||
| 267 | +662 |
- private = list(+ |
||
| 268 | -+ | |||
| 663 | +5x |
- inf_count = integer(0),+ if (private$inf_count > 0) {
|
||
| 269 | -+ | |||
| 664 | +! |
- inf_filtered_count = NULL,+ countmax <- private$na_count |
||
| 270 | -+ | |||
| 665 | +! |
- is_integer = logical(0),+ countnow <- isolate(private$filtered_na_count()) |
||
| 271 | -+ | |||
| 666 | +! |
- numeric_step = numeric(0), # step for the slider input widget, calculated from input data (x)+ ui_input <- checkboxInput( |
||
| 272 | -+ | |||
| 667 | +! |
- plot_data = NULL,+ inputId = ns("value"),
|
||
| 273 | -+ | |||
| 668 | +! |
- plot_mask = list(),+ label = tags$span( |
||
| 274 | -+ | |||
| 669 | +! |
- plot_layout = NULL,+ id = ns("count_label"),
|
||
| 275 | -+ | |||
| 670 | +! |
- plot_config = NULL,+ make_count_text( |
||
| 276 | -+ | |||
| 671 | +! |
- plot_filtered = NULL,+ label = "Keep Inf", |
||
| 277 | -+ | |||
| 672 | +! |
-
+ countmax = countmax, |
||
| 278 | -+ | |||
| 673 | +! |
- # private methods ----+ countnow = countnow |
||
| 279 | +674 |
-
+ ) |
||
| 280 | +675 |
- set_choices = function(choices) {
+ ), |
||
| 281 | -117x | +|||
| 676 | +! |
- x <- private$x[is.finite(private$x)]+ value = isolate(private$get_keep_inf()) |
||
| 282 | -117x | +|||
| 677 | +
- if (is.null(choices)) {
+ ) |
|||
| 283 | -105x | +|||
| 678 | +! |
- choices <- range(x)+ tags$div( |
||
| 284 | -+ | |||
| 679 | +! |
- } else {
+ uiOutput(ns("trigger_visible"), inline = TRUE),
|
||
| 285 | -12x | +|||
| 680 | +! |
- choices_adjusted <- c(max(choices[1L], min(x)), min(choices[2L], max(x)))+ ui_input |
||
| 286 | -12x | +|||
| 681 | +
- if (any(choices != choices_adjusted)) {
+ ) |
|||
| 287 | -1x | +|||
| 682 | +
- warning(sprintf(+ } else {
|
|||
| 288 | -1x | +683 | +5x |
- "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",+ NULL |
| 289 | -1x | +|||
| 684 | +
- private$get_varname(), private$get_dataname()+ } |
|||
| 290 | +685 |
- ))+ }, |
||
| 291 | -1x | +|||
| 686 | +
- choices <- choices_adjusted+ |
|||
| 292 | +687 |
- }+ # @description |
||
| 293 | -12x | +|||
| 688 | +
- if (choices[1L] > choices[2L]) {
+ # Module to handle Inf values in the FilterState |
|||
| 294 | -1x | +|||
| 689 | +
- warning(sprintf(+ # Sets `private$slice$keep_inf` according to the selection |
|||
| 295 | -1x | +|||
| 690 | +
- "Invalid choices: lower is higher / equal to upper, or not in range of variable values.+ # and updates the relevant UI element if `private$slice$keep_inf` has been changed by the api. |
|||
| 296 | -1x | +|||
| 691 | +
- Setting defaults. Varname: %s, dataname: %s.",+ # @param id (`character(1)`) `shiny` module instance id. |
|||
| 297 | -1x | +|||
| 692 | +
- private$get_varname(), private$get_dataname()+ # @return `NULL`. |
|||
| 298 | +693 |
- ))+ keep_inf_srv = function(id) {
|
||
| 299 | -1x | +694 | +5x |
- choices <- range(x)+ moduleServer(id, function(input, output, session) {
|
| 300 | +695 |
- }+ # 1. renderUI is used here as an observer which triggers only if output is visible |
||
| 301 | +696 |
- }+ # and if the reactive changes - reactive triggers only if the output is visible. |
||
| 302 | +697 |
-
+ # 2. We want to trigger change of the labels only if reactive count changes (not underlying data) |
||
| 303 | -117x | +698 | +5x |
- private$set_is_choice_limited(private$x, choices)+ output$trigger_visible <- renderUI({
|
| 304 | -117x | +699 | +5x |
- private$x <- private$x[+ updateCountText( |
| 305 | -117x | +700 | +5x |
- (private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x) | !is.finite(private$x)+ inputId = "count_label", |
| 306 | -+ | |||
| 701 | +5x |
- ]+ label = "Keep Inf",+ |
+ ||
| 702 | +5x | +
+ countmax = private$inf_count,+ |
+ ||
| 703 | +5x | +
+ countnow = private$inf_filtered_count() |
||
| 307 | +704 |
-
+ ) |
||
| 308 | -117x | +705 | +5x |
- x_range <- range(private$x, finite = TRUE)+ NULL |
| 309 | +706 |
-
+ }) |
||
| 310 | +707 |
- # Required for displaying ticks on the slider, can modify choices!+ |
||
| 311 | -117x | +|||
| 708 | +
- if (identical(diff(x_range), 0)) {
+ # this observer is needed in the situation when private$teal_slice$keep_inf has been |
|||
| 312 | -2x | +|||
| 709 | +
- choices <- x_range+ # changed directly by the api - then it's needed to rerender UI element |
|||
| 313 | +710 |
- } else {
+ # to show relevant values |
||
| 314 | -115x | +711 | +5x |
- x_pretty <- pretty(x_range, 100L)+ private$observers$keep_inf_api <- observeEvent( |
| 315 | -115x | +712 | +5x |
- choices <- range(x_pretty)+ ignoreNULL = TRUE, # its not possible for range that NULL is selected |
| 316 | -115x | +713 | +5x |
- private$numeric_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10)+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 317 | -+ | |||
| 714 | +5x |
- }+ eventExpr = private$get_keep_inf(), |
||
| 318 | -117x | +715 | +5x |
- private$teal_slice$choices <- choices+ handlerExpr = {
|
| 319 | -117x | +|||
| 716 | +! |
- invisible(NULL)+ if (!setequal(private$get_keep_inf(), input$value)) {
+ |
+ ||
| 717 | +! | +
+ logger::log_trace("RangeFilterState$keep_inf_srv@1 changed reactive value, id: { private$get_id() }")
+ |
+ ||
| 718 | +! | +
+ updateCheckboxInput(+ |
+ ||
| 719 | +! | +
+ inputId = "value",+ |
+ ||
| 720 | +! | +
+ value = private$get_keep_inf() |
||
| 320 | +721 |
- },+ ) |
||
| 321 | +722 |
-
+ } |
||
| 322 | +723 |
- # @description+ } |
||
| 323 | +724 |
- # Check whether the initial choices filter out some values of x and set the flag in case.+ ) |
||
| 324 | +725 |
- set_is_choice_limited = function(xl, choices) {
+
|
||
| 325 | -117x | +726 | +5x |
- xl <- xl[!is.na(xl)]+ private$observers$keep_inf <- observeEvent( |
| 326 | -117x | +727 | +5x |
- xl <- xl[is.finite(xl)]+ ignoreNULL = TRUE, # it's not possible for range that NULL is selected |
| 327 | -117x | +728 | +5x |
- private$is_choice_limited <- (any(xl < choices[1L]) | any(xl > choices[2L]))+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 328 | -117x | +729 | +5x |
- invisible(NULL)+ eventExpr = input$value, |
| 329 | -+ | |||
| 730 | +5x |
- },+ handlerExpr = {
|
||
| 330 | -+ | |||
| 731 | +! |
-
+ logger::log_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
|
||
| 331 | -+ | |||
| 732 | +! |
- # Adds is.infinite(varname) before existing condition calls if keep_inf is selected+ keep_inf <- input$value |
||
| 332 | -+ | |||
| 733 | +! |
- # returns a call+ private$set_keep_inf(keep_inf) |
||
| 333 | +734 |
- add_keep_inf_call = function(filter_call, varname) {
- |
- ||
| 334 | -34x | -
- if (isTRUE(private$get_keep_inf())) {
+ } |
||
| 335 | -2x | +|||
| 735 | +
- call("|", call("is.infinite", varname), filter_call)
+ ) |
|||
| 336 | +736 |
- } else {
+
|
||
| 337 | -32x | +737 | +5x |
- filter_call+ invisible(NULL) |
| 338 | +738 |
- }+ }) |
||
| 339 | +739 |
- },+ } |
||
| 340 | +740 |
-
+ ) |
||
| 341 | +741 |
- # @description gets pretty step size for range slider+ ) |
| 342 | +1 |
- # adaptation of shiny's method (see shiny/R/input-slider.R function findStepSize)+ #' Initialize `FilterStates` object |
||
| 343 | +2 |
- # @param pretty_range (numeric(n)) vector of pretty values+ #' |
||
| 344 | +3 |
- # @return numeric(1) pretty step size for the sliderInput+ #' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`) |
||
| 345 | +4 |
- get_pretty_range_step = function(pretty_range) {
+ #' object to subset. |
||
| 346 | -117x | +|||
| 5 | +
- if (private$is_integer && diff(range(pretty_range) > 2)) {
+ #' @param data_reactive (`function(sid)`) |
|||
| 347 | -46x | +|||
| 6 | +
- return(1L)+ #' should return an object of the same type as `data` or `NULL`. |
|||
| 348 | +7 |
- } else {
+ #' This function is needed for the `FilterState` `shiny` module to update counts if filtered data changes. |
||
| 349 | -71x | +|||
| 8 | +
- n_steps <- length(pretty_range) - 1+ #' If function returns `NULL` then filtered counts are not shown. |
|||
| 350 | -71x | +|||
| 9 | +
- return(signif(digits = 10, (max(pretty_range) - min(pretty_range)) / n_steps))+ #' Function has to have `sid` argument being a character which is related to `sid` argument in the `get_call` method. |
|||
| 351 | +10 |
- }+ #' @param dataname (`character(1)`) |
||
| 352 | +11 |
- },+ #' name of the data used in the subset expression, |
||
| 353 | +12 |
- cast_and_validate = function(values) {
+ #' passed to the function argument attached to this `FilterStates`. |
||
| 354 | -133x | +|||
| 13 | +
- tryCatch(+ #' @param datalabel (`character(1)`) optional |
|||
| 355 | -133x | +|||
| 14 | +
- expr = {
+ #' text label. |
|||
| 356 | -133x | +|||
| 15 | +
- values <- as.numeric(values)+ #' @param ... optional, |
|||
| 357 | -4x | +|||
| 16 | +
- if (anyNA(values)) stop()+ #' additional arguments for specific classes: keys. |
|||
| 358 | -129x | +|||
| 17 | +
- values+ #' |
|||
| 359 | +18 |
- },+ #' @return Object of class `FilterStates`. |
||
| 360 | -133x | +|||
| 19 | +
- error = function(e) stop("Vector of set values must contain values coercible to numeric")
+ #' |
|||
| 361 | +20 |
- )+ #' @keywords internal |
||
| 362 | +21 |
- },+ #' @examples |
||
| 363 | +22 |
- # Also validates that selection is sorted.+ #' # use non-exported function from teal.slice |
||
| 364 | +23 |
- check_length = function(values) {
+ #' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
|
||
| 365 | -2x | +|||
| 24 | +
- if (length(values) != 2L) stop("Vector of set values must have length two.")
+ #' |
|||
| 366 | -2x | +|||
| 25 | +
- if (values[1L] > values[2L]) stop("Vector of set values must be sorted.")
+ #' df <- data.frame( |
|||
| 367 | -125x | +|||
| 26 | +
- values+ #' character = letters, |
|||
| 368 | +27 |
- },+ #' numeric = seq_along(letters), |
||
| 369 | +28 |
- # Trim selection to limits imposed by private$get_choices()+ #' date = seq(Sys.Date(), length.out = length(letters), by = "1 day"), |
||
| 370 | +29 |
- remove_out_of_bounds_values = function(values) {
+ #' datetime = seq(Sys.time(), length.out = length(letters), by = "33.33 hours") |
||
| 371 | -2x | +|||
| 30 | +
- if (values[1L] < private$get_choices()[1L]) values[1L] <- private$get_choices()[1L]+ #' ) |
|||
| 372 | -2x | +|||
| 31 | +
- if (values[2L] > private$get_choices()[2L]) values[2L] <- private$get_choices()[2L]+ #' rf <- init_filter_states( |
|||
| 373 | -125x | +|||
| 32 | +
- values+ #' data = df, |
|||
| 374 | +33 |
- },+ #' dataname = "DF" |
||
| 375 | +34 |
-
+ #' ) |
||
| 376 | +35 |
- # Answers the question of whether the current settings and values selected actually filters out any values.+ #' |
||
| 377 | +36 |
- # @return logical scalar+ #' library(shiny) |
||
| 378 | +37 |
- is_any_filtered = function() {
+ #' ui <- fluidPage( |
||
| 379 | -35x | +|||
| 38 | +
- if (private$is_choice_limited) {
+ #' actionButton("clear", tags$span(icon("xmark"), "Remove all filters")),
|
|||
| 380 | -1x | +|||
| 39 | +
- TRUE+ #' rf$ui_add(id = "add"), |
|||
| 381 | -34x | +|||
| 40 | +
- } else if (!isTRUE(all.equal(private$get_selected(), private$get_choices()))) {
+ #' rf$ui_active("states"),
|
|||
| 382 | -32x | +|||
| 41 | +
- TRUE+ #' verbatimTextOutput("expr"),
|
|||
| 383 | -2x | +|||
| 42 | +
- } else if (!isTRUE(private$get_keep_inf()) && private$inf_count > 0) {
+ #' ) |
|||
| 384 | -! | +|||
| 43 | +
- TRUE+ #' |
|||
| 385 | -2x | +|||
| 44 | +
- } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ #' server <- function(input, output, session) {
|
|||
| 386 | -1x | +|||
| 45 | +
- TRUE+ #' rf$srv_add(id = "add") |
|||
| 387 | +46 |
- } else {
+ #' rf$srv_active(id = "states") |
||
| 388 | -1x | +|||
| 47 | +
- FALSE+ #' output$expr <- renderText({
|
|||
| 389 | +48 |
- }+ #' deparse1(rf$get_call(), collapse = "\n") |
||
| 390 | +49 |
- },+ #' }) |
||
| 391 | +50 |
-
+ #' observeEvent(input$clear, rf$clear_filter_states()) |
||
| 392 | +51 |
- # obtain shape determination for histogram+ #' } |
||
| 393 | +52 |
- # returns a list that is passed to plotly's layout.shapes property+ #' |
||
| 394 | +53 |
- get_shape_properties = function(values) {
+ #' if (interactive()) {
|
||
| 395 | -5x | +|||
| 54 | +
- list(+ #' shinyApp(ui, server) |
|||
| 396 | -5x | +|||
| 55 | +
- list(type = "line", x0 = values[1], x1 = values[1], y0 = -100, y1 = 100, yref = "paper"),+ #' } |
|||
| 397 | -5x | +|||
| 56 | +
- list(type = "line", x0 = values[2], x1 = values[2], y0 = -100, y1 = 100, yref = "paper")+ #' |
|||
| 398 | +57 |
- )+ #' @export |
||
| 399 | +58 |
- },+ #' |
||
| 400 | +59 |
-
+ init_filter_states <- function(data, |
||
| 401 | +60 |
- # shiny modules ----+ data_reactive = reactive(NULL), |
||
| 402 | +61 |
-
+ dataname, |
||
| 403 | +62 |
- # UI Module for `RangeFilterState`.+ datalabel = NULL, |
||
| 404 | +63 |
- # This UI element contains two values for `min` and `max`+ ...) {
|
||
| 405 | -+ | |||
| 64 | +229x |
- # of the range and two checkboxes whether to keep the `NA` or `Inf` values.+ UseMethod("init_filter_states")
|
||
| 406 | +65 |
- # @param id (`character(1)`) `shiny` module instance id.+ } |
||
| 407 | +66 |
- ui_inputs = function(id) {
+
|
||
| 408 | -5x | +|||
| 67 | +
- ns <- NS(id)+ #' @keywords internal |
|||
| 409 | -5x | +|||
| 68 | +
- isolate({
+ #' @export |
|||
| 410 | -5x | +|||
| 69 | +
- ui_input <- shinyWidgets::numericRangeInput(+ init_filter_states.data.frame <- function(data, # nolint |
|||
| 411 | -5x | +|||
| 70 | +
- inputId = ns("selection_manual"),
+ data_reactive = function(sid = "") NULL, |
|||
| 412 | -5x | +|||
| 71 | +
- label = NULL,+ dataname, |
|||
| 413 | -5x | +|||
| 72 | +
- min = private$get_choices()[1L],+ datalabel = NULL, |
|||
| 414 | -5x | +|||
| 73 | +
- max = private$get_choices()[2L],+ keys = character(0), |
|||
| 415 | -5x | +|||
| 74 | +
- value = private$get_selected(),+ ...) {
|
|||
| 416 | -5x | +75 | +100x |
- step = private$numeric_step,+ DFFilterStates$new( |
| 417 | -5x | -
- width = "100%"- |
- ||
| 418 | -+ | 76 | +100x |
- )+ data = data, |
| 419 | -5x | +77 | +100x |
- tagList(+ data_reactive = data_reactive, |
| 420 | -5x | +78 | +100x |
- tags$div(+ dataname = dataname, |
| 421 | -5x | +79 | +100x |
- class = "choices_state",+ datalabel = datalabel, |
| 422 | -5x | +80 | +100x |
- tags$head(tags$script(+ keys = keys |
| 423 | +81 |
- # Inline JS code for popover functionality.+ ) |
||
| 424 | +82 |
- # Adding the script inline because when added from a file with include_js_files(),+ } |
||
| 425 | +83 |
- # it only works in the first info_button instance and not others.+ |
||
| 426 | -5x | +|||
| 84 | +
- HTML(+ #' @keywords internal |
|||
| 427 | -5x | +|||
| 85 | +
- '$(document).ready(function() {
+ #' @export |
|||
| 428 | -5x | +|||
| 86 | +
- $("[data-toggle=\'popover\']").popover();
+ init_filter_states.matrix <- function(data, # nolint |
|||
| 429 | +87 |
-
+ data_reactive = function(sid = "") NULL,+ |
+ ||
| 88 | ++ |
+ dataname,+ |
+ ||
| 89 | ++ |
+ datalabel = NULL,+ |
+ ||
| 90 | ++ |
+ ...) {
|
||
| 430 | -5x | +91 | +22x |
- $(document).on("click", function (e) {
+ MatrixFilterStates$new( |
| 431 | -5x | +92 | +22x |
- if (!$("[data-toggle=\'popover\']").is(e.target) &&
+ data = data, |
| 432 | -5x | +93 | +22x |
- $("[data-toggle=\'popover\']").has(e.target).length === 0 &&
+ data_reactive = data_reactive, |
| 433 | -5x | +94 | +22x |
- $(".popover").has(e.target).length === 0) {
+ dataname = dataname, |
| 434 | -5x | +95 | +22x |
- $("[data-toggle=\'popover\']").popover("hide");
+ datalabel = datalabel |
| 435 | +96 |
- }+ ) |
||
| 436 | +97 |
- });+ } |
||
| 437 | +98 |
- });'+ |
||
| 438 | +99 |
- )+ #' @keywords internal |
||
| 439 | +100 |
- )),+ #' @export |
||
| 440 | -5x | +|||
| 101 | +
- tags$div(+ init_filter_states.MultiAssayExperiment <- function(data, # nolint |
|||
| 441 | -5x | +|||
| 102 | +
- actionLink(+ data_reactive = function(sid = "") NULL, |
|||
| 442 | -5x | +|||
| 103 | +
- ns("plotly_info"),
+ dataname, |
|||
| 443 | -5x | +|||
| 104 | +
- label = NULL,+ datalabel = "subjects", |
|||
| 444 | -5x | +|||
| 105 | +
- icon = icon("question-circle"),
+ keys = character(0), |
|||
| 445 | -5x | +|||
| 106 | +
- "data-toggle" = "popover",+ ...) {
|
|||
| 446 | -5x | +107 | +22x |
- "data-html" = "true",+ if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
| 447 | -5x | +|||
| 108 | +! |
- "data-placement" = "left",+ stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
|
||
| 448 | -5x | +|||
| 109 | +
- "data-trigger" = "click",+ } |
|||
| 449 | -5x | +110 | +22x |
- "data-title" = "Plot actions",+ MAEFilterStates$new( |
| 450 | -5x | +111 | +22x |
- "data-content" = "<p>+ data = data, |
| 451 | -5x | +112 | +22x |
- Drag vertical lines to set selection.<br>+ data_reactive = data_reactive, |
| 452 | -5x | +113 | +22x |
- Drag across plot to zoom in.<br>+ dataname = dataname, |
| 453 | -5x | +114 | +22x |
- Drag axis to pan.<br>+ datalabel = datalabel, |
| 454 | -5x | +115 | +22x |
- Double click to zoom out."+ keys = keys |
| 455 | +116 |
- ),+ ) |
||
| 456 | -5x | +|||
| 117 | +
- style = "text-align: right; font-size: 0.7em; margin-bottom: -1em; position: relative; z-index: 9;"+ } |
|||
| 457 | +118 |
- ),+ |
||
| 458 | -5x | +|||
| 119 | +
- shinycssloaders::withSpinner(+ #' @keywords internal |
|||
| 459 | -5x | +|||
| 120 | +
- plotly::plotlyOutput(ns("plot"), height = "50px"),
+ #' @export |
|||
| 460 | -5x | +|||
| 121 | +
- type = 4,+ init_filter_states.SummarizedExperiment <- function(data, # nolint |
|||
| 461 | -5x | +|||
| 122 | +
- size = 0.25,+ data_reactive = function(sid = "") NULL, |
|||
| 462 | -5x | +|||
| 123 | +
- hide.ui = FALSE+ dataname, |
|||
| 463 | +124 |
- ),+ datalabel = NULL,+ |
+ ||
| 125 | ++ |
+ ...) {
|
||
| 464 | -5x | +126 | +85x |
- ui_input+ if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
+ |
+
| 127 | +! | +
+ stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
|
||
| 465 | +128 |
- ),+ } |
||
| 466 | -5x | +129 | +85x |
- tags$div(+ SEFilterStates$new( |
| 467 | -5x | +130 | +85x |
- class = "filter-card-body-keep-na-inf",+ data = data, |
| 468 | -5x | +131 | +85x |
- private$keep_inf_ui(ns("keep_inf")),
+ data_reactive = data_reactive, |
| 469 | -5x | +132 | +85x |
- private$keep_na_ui(ns("keep_na"))
+ dataname = dataname, |
| 470 | -+ | |||
| 133 | +85x |
- )+ datalabel = datalabel |
||
| 471 | +134 |
- )+ ) |
||
| 472 | +135 |
- })+ } |
||
| 473 | +136 |
- },+ |
||
| 474 | +137 |
-
+ #' Gets supported filterable variable names |
||
| 475 | +138 |
- # @description+ #' |
||
| 476 | +139 |
- # Server module+ #' Gets filterable variable names from a given object. The names match variables |
||
| 477 | +140 |
- # @param id (`character(1)`) `shiny` module instance id.+ #' of classes in an vector `teal.slice:::.filterable_class`. |
||
| 478 | +141 |
- # return `NULL`.+ #' @param data |
||
| 479 | +142 |
- server_inputs = function(id) {
+ #' the `R` object containing elements which class can be checked through `vapply` or `apply`. |
||
| 480 | -5x | +|||
| 143 | +
- moduleServer(+ #' @return `character` vector of variable names. |
|||
| 481 | -5x | +|||
| 144 | +
- id = id,+ #' @examples |
|||
| 482 | -5x | +|||
| 145 | +
- function(input, output, session) {
+ #' # use non-exported function from teal.slice |
|||
| 483 | -5x | +|||
| 146 | +
- logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }")
+ #' get_supported_filter_varnames <- getFromNamespace("get_supported_filter_varnames", "teal.slice")
|
|||
| 484 | +147 |
-
+ #' |
||
| 485 | +148 |
- # Capture manual input with debounce.+ #' df <- data.frame( |
||
| 486 | -5x | +|||
| 149 | +
- selection_manual <- debounce(reactive(input$selection_manual), 200)+ #' a = letters[1:3], |
|||
| 487 | +150 |
-
+ #' b = 1:3, |
||
| 488 | +151 |
- # Prepare for histogram construction.+ #' c = Sys.Date() + 1:3, |
||
| 489 | -5x | +|||
| 152 | +
- plot_data <- c(private$plot_data, source = session$ns("histogram_plot"))
+ #' d = Sys.time() + 1:3, |
|||
| 490 | +153 |
-
+ #' z = complex(3) |
||
| 491 | +154 |
- # Display histogram, adding a second trace that contains filtered data.+ #' ) |
||
| 492 | -5x | +|||
| 155 | +
- output$plot <- plotly::renderPlotly({
+ #' get_supported_filter_varnames(df) |
|||
| 493 | -5x | +|||
| 156 | +
- histogram <- do.call(plotly::plot_ly, plot_data)+ #' @keywords internal |
|||
| 494 | -5x | +|||
| 157 | +
- histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout()))+ #' @export |
|||
| 495 | -5x | +|||
| 158 | +
- histogram <- do.call(plotly::config, c(list(p = histogram), private$plot_config()))+ get_supported_filter_varnames <- function(data) {
|
|||
| 496 | -5x | +159 | +227x |
- histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered()))+ UseMethod("get_supported_filter_varnames")
|
| 497 | -5x | +|||
| 160 | +
- histogram+ } |
|||
| 498 | +161 |
- })+ |
||
| 499 | +162 |
-
+ #' @keywords internal |
||
| 500 | +163 |
- # Dragging shapes (lines) on plot updates selection.+ #' @export |
||
| 501 | -5x | +|||
| 164 | +
- private$observers$relayout <-+ get_supported_filter_varnames.default <- function(data) { # nolint
|
|||
| 502 | -5x | +165 | +198x |
- observeEvent(+ is_expected_class <- vapply( |
| 503 | -5x | +166 | +198x |
- ignoreNULL = FALSE,+ X = data, |
| 504 | -5x | +167 | +198x |
- ignoreInit = TRUE,+ FUN = function(x) any(class(x) %in% .filterable_class), |
| 505 | -5x | +168 | +198x |
- eventExpr = plotly::event_data("plotly_relayout", source = session$ns("histogram_plot")),
+ FUN.VALUE = logical(1) |
| 506 | -5x | +|||
| 169 | +
- handlerExpr = {
+ ) |
|||
| 507 | -1x | +170 | +198x |
- logger::log_trace("RangeFilterState$server@1 selection changed, id: { private$get_id() }")
+ names(is_expected_class[is_expected_class]) |
| 508 | -1x | +|||
| 171 | +
- event <- plotly::event_data("plotly_relayout", source = session$ns("histogram_plot"))
+ } |
|||
| 509 | -1x | +|||
| 172 | +
- if (any(grepl("shapes", names(event)))) {
+
|
|||
| 510 | -! | +|||
| 173 | +
- line_positions <- private$get_selected()+ #' @keywords internal |
|||
| 511 | -! | +|||
| 174 | +
- if (any(grepl("shapes[0]", names(event), fixed = TRUE))) {
+ #' @export |
|||
| 512 | -! | +|||
| 175 | +
- line_positions[1] <- event[["shapes[0].x0"]]+ get_supported_filter_varnames.matrix <- function(data) { # nolint
|
|||
| 513 | -! | +|||
| 176 | +
- } else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) {
+ # all columns are the same type in matrix |
|||
| 514 | -! | +|||
| 177 | +29x |
- line_positions[2] <- event[["shapes[1].x0"]]+ is_expected_class <- class(data[, 1]) %in% .filterable_class+ |
+ ||
| 178 | +29x | +
+ if (is_expected_class && !is.null(colnames(data))) {
+ |
+ ||
| 179 | +26x | +
+ colnames(data) |
||
| 515 | +180 |
- }+ } else {
+ |
+ ||
| 181 | +3x | +
+ character(0) |
||
| 516 | +182 |
- # If one line was dragged past the other, abort action and reset lines.+ } |
||
| 517 | -! | +|||
| 183 | +
- if (line_positions[1] > line_positions[2]) {
+ } |
|||
| 518 | -! | +|||
| 184 | +
- showNotification(+ |
|||
| 519 | -! | +|||
| 185 | +
- "Numeric range start value must be less than end value.",+ #' @keywords internal |
|||
| 520 | -! | +|||
| 186 | +
- type = "warning"+ #' @export |
|||
| 521 | +187 |
- )+ get_supported_filter_varnames.MultiAssayExperiment <- function(data) { # nolint
|
||
| 522 | +188 | ! |
- plotly::plotlyProxyInvoke(+ data <- SummarizedExperiment::colData(data)+ |
+ |
| 189 | ++ |
+ # all columns are the same type in matrix |
||
| 523 | +190 | ! |
- plotly::plotlyProxy("plot"),
+ is_expected_class <- class(data[, 1]) %in% .filterable_class |
|
| 524 | +191 | ! |
- "relayout",+ if (is_expected_class && !is.null(names(data))) {
|
|
| 525 | +192 | ! |
- shapes = private$get_shape_properties(private$get_selected())+ names(data) |
|
| 526 | +193 |
- )+ } else {
|
||
| 527 | +194 | ! |
- return(NULL)+ character(0) |
|
| 528 | +195 |
- }+ } |
||
| 529 | +196 | ++ |
+ }+ |
+ |
| 197 | ||||
| 530 | -! | +|||
| 198 | +
- private$set_selected(signif(line_positions, digits = 4L))+ #' Returns a `choices_labeled` object |
|||
| 531 | +199 |
- }+ #' |
||
| 532 | +200 |
- }+ #' @param data (`data.frame` or `DFrame` or `list`) |
||
| 533 | +201 |
- )+ #' where labels can be taken from in case when `varlabels` is not specified. |
||
| 534 | +202 |
-
+ #' `data` must be specified if `varlabels` is not specified. |
||
| 535 | +203 |
- # Change in selection updates shapes (lines) on plot and numeric input.+ #' @param choices (`character`) |
||
| 536 | -5x | +|||
| 204 | +
- private$observers$selection_api <-+ #' the vector of chosen variables |
|||
| 537 | -5x | +|||
| 205 | +
- observeEvent(+ #' @param varlabels (`character`) |
|||
| 538 | -5x | +|||
| 206 | +
- ignoreNULL = FALSE,+ #' the labels of variables in data |
|||
| 539 | -5x | +|||
| 207 | +
- ignoreInit = TRUE,+ #' @param keys (`character`) |
|||
| 540 | -5x | +|||
| 208 | +
- eventExpr = private$get_selected(),+ #' the names of the key columns in data |
|||
| 541 | -5x | +|||
| 209 | +
- handlerExpr = {
+ #' @return `character(0)` if choices are empty; a `choices_labeled` object otherwise |
|||
| 542 | -! | +|||
| 210 | +
- logger::log_trace("RangeFilterState$server@2 state changed, id: {private$get_id() }")
+ #' @keywords internal |
|||
| 543 | -! | +|||
| 211 | +
- if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) {
+ data_choices_labeled <- function(data, |
|||
| 544 | -! | +|||
| 212 | +
- shinyWidgets::updateNumericRangeInput(+ choices, |
|||
| 545 | -! | +|||
| 213 | +
- session = session,+ varlabels = teal.data::col_labels(data, fill = TRUE), |
|||
| 546 | -! | +|||
| 214 | +
- inputId = "selection_manual",+ keys = character(0)) {
|
|||
| 547 | -! | +|||
| 215 | +9x |
- value = private$get_selected()+ if (length(choices) == 0) {
|
||
| 548 | -+ | |||
| 216 | +! |
- )+ return(character(0)) |
||
| 549 | +217 |
- }+ } |
||
| 550 | -+ | |||
| 218 | +9x |
- }+ choice_types <- variable_types(data = data, columns = choices) |
||
| 551 | -+ | |||
| 219 | +9x |
- )+ choice_types[keys] <- "primary_key" |
||
| 552 | +220 | |||
| 553 | -+ | |||
| 221 | +9x |
- # Manual input updates selection.+ choices_labeled( |
||
| 554 | -5x | +222 | +9x |
- private$observers$selection_manual <- observeEvent(+ choices = choices, |
| 555 | -5x | +223 | +9x |
- ignoreNULL = FALSE,+ labels = unname(varlabels[choices]), |
| 556 | -5x | +224 | +9x |
- ignoreInit = TRUE,+ types = choice_types[choices] |
| 557 | -5x | +|||
| 225 | +
- eventExpr = selection_manual(),+ ) |
|||
| 558 | -5x | +|||
| 226 | +
- handlerExpr = {
+ } |
|||
| 559 | -! | +|||
| 227 | +
- selection <- selection_manual()+ |
|||
| 560 | +228 |
- # Abort and reset if non-numeric values is entered.+ #' @noRd |
||
| 561 | -! | +|||
| 229 | +
- if (any(is.na(selection))) {
+ #' @keywords internal |
|||
| 562 | -! | +|||
| 230 | +
- showNotification(+ get_varlabels <- function(data) {
|
|||
| 563 | -! | +|||
| 231 | +9x |
- "Numeric range values must be numbers.",+ if (!is.array(data)) {
|
||
| 564 | -! | +|||
| 232 | +9x |
- type = "warning"+ vapply( |
||
| 565 | -+ | |||
| 233 | +9x |
- )+ colnames(data), |
||
| 566 | -! | +|||
| 234 | +9x |
- shinyWidgets::updateNumericRangeInput(+ FUN = function(x) {
|
||
| 567 | -! | +|||
| 235 | +42x |
- session = session,+ label <- attr(data[[x]], "label") |
||
| 568 | -! | +|||
| 236 | +42x |
- inputId = "selection_manual",+ if (is.null(label)) {
|
||
| 569 | -! | +|||
| 237 | +40x |
- value = private$get_selected()+ x |
||
| 570 | +238 |
- )+ } else {
|
||
| 571 | -! | +|||
| 239 | +2x |
- return(NULL)+ label |
||
| 572 | +240 |
- }+ } |
||
| 573 | +241 |
-
+ },+ |
+ ||
| 242 | +9x | +
+ FUN.VALUE = character(1) |
||
| 574 | +243 |
- # Abort and reset if reversed choices are specified.+ ) |
||
| 575 | -! | +|||
| 244 | +
- if (selection[1] > selection[2]) {
+ } else {
|
|||
| 576 | +245 | ! |
- showNotification(- |
- |
| 577 | -! | -
- "Numeric range start value must be less than end value.",- |
- ||
| 578 | -! | -
- type = "warning"+ character(0) |
||
| 579 | +246 |
- )- |
- ||
| 580 | -! | -
- shinyWidgets::updateNumericRangeInput(- |
- ||
| 581 | -! | -
- session = session,- |
- ||
| 582 | -! | -
- inputId = "selection_manual",- |
- ||
| 583 | -! | -
- value = private$get_selected()+ } |
||
| 584 | +247 |
- )- |
- ||
| 585 | -! | -
- return(NULL)+ } |
| 586 | +1 |
- }+ # FilterStates ------ |
||
| 587 | +2 | |||
| 588 | +3 | - - | -||
| 589 | -! | -
- if (!isTRUE(all.equal(selection, private$get_selected()))) {
+ #' @name FilterStates |
||
| 590 | -! | +|||
| 4 | +
- logger::log_trace("RangeFilterState$server@3 manual selection changed, id: { private$get_id() }")
+ #' @docType class |
|||
| 591 | -! | +|||
| 5 | +
- private$set_selected(selection)+ #' @title `FilterStates` `R6` class |
|||
| 592 | +6 |
- }+ #' |
||
| 593 | +7 |
- }+ #' @description |
||
| 594 | +8 |
- )+ #' Abstract class that manages adding and removing `FilterState` objects |
||
| 595 | +9 |
-
+ #' and builds a *subset expression*. |
||
| 596 | -5x | +|||
| 10 | +
- private$keep_inf_srv("keep_inf")
+ #' |
|||
| 597 | -5x | +|||
| 11 | +
- private$keep_na_srv("keep_na")
+ #' A `FilterStates` object tracks all condition calls |
|||
| 598 | +12 |
-
+ #' (logical predicates that limit observations) associated with a given dataset |
||
| 599 | -5x | +|||
| 13 | +
- logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
+ #' and composes them into a single reproducible `R` expression |
|||
| 600 | -5x | +|||
| 14 | +
- NULL+ #' that will assign a subset of the original data to a new variable. |
|||
| 601 | +15 |
- }+ #' This expression is hereafter referred to as *subset expression*. |
||
| 602 | +16 |
- )+ #' |
||
| 603 | +17 |
- },+ #' The *subset expression* is constructed differently for different |
||
| 604 | +18 |
- server_inputs_fixed = function(id) {
+ #' classes of the underlying data object and `FilterStates` sub-classes. |
||
| 605 | -! | +|||
| 19 | +
- moduleServer(+ #' Currently implemented for `data.frame`, `matrix`, |
|||
| 606 | -! | +|||
| 20 | +
- id = id,+ #' `SummarizedExperiment`, and `MultiAssayExperiment`. |
|||
| 607 | -! | +|||
| 21 | +
- function(input, output, session) {
+ #' |
|||
| 608 | -! | +|||
| 22 | +
- logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }")
+ #' @keywords internal |
|||
| 609 | +23 |
-
+ #' |
||
| 610 | -! | +|||
| 24 | +
- plot_config <- private$plot_config()+ FilterStates <- R6::R6Class( # nolint |
|||
| 611 | -! | +|||
| 25 | +
- plot_config$staticPlot <- TRUE+ classname = "FilterStates", |
|||
| 612 | +26 | |||
| 613 | -! | -
- output$plot <- plotly::renderPlotly({
- |
- ||
| 614 | -! | -
- histogram <- do.call(plotly::plot_ly, private$plot_data)- |
- ||
| 615 | -! | +|||
| 27 | +
- histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout()))+ # public members ---- |
|||
| 616 | -! | +|||
| 28 | +
- histogram <- do.call(plotly::config, c(list(p = histogram), plot_config))+ public = list( |
|||
| 617 | -! | +|||
| 29 | +
- histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered()))+ #' @description |
|||
| 618 | -! | +|||
| 30 | +
- histogram+ #' Initializes `FilterStates` object by setting |
|||
| 619 | +31 |
- })+ #' `dataname`, and `datalabel`. |
||
| 620 | +32 |
-
+ #' |
||
| 621 | -! | +|||
| 33 | +
- output$selection <- renderUI({
+ #' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`) |
|||
| 622 | -! | +|||
| 34 | +
- shinycssloaders::withSpinner(+ #' the `R` object which `subset` function is applied on. |
|||
| 623 | -! | +|||
| 35 | +
- plotly::plotlyOutput(session$ns("plot"), height = "50px"),
+ #' @param data_reactive (`function(sid)`) |
|||
| 624 | -! | +|||
| 36 | +
- type = 4,+ #' should return an object of the same type as `data` object or `NULL`. |
|||
| 625 | -! | +|||
| 37 | +
- size = 0.25+ #' This object is needed for the `FilterState` counts being updated |
|||
| 626 | +38 |
- )+ #' on a change in filters. If function returns `NULL` then filtered counts are not shown. |
||
| 627 | +39 |
- })+ #' Function has to have `sid` argument being a character. |
||
| 628 | +40 |
-
+ #' @param dataname (`character(1)`) |
||
| 629 | -! | +|||
| 41 | +
- logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
+ #' name of the dataset, used in the subset expression. |
|||
| 630 | -! | +|||
| 42 | +
- NULL+ #' Passed to the function argument attached to this `FilterStates`. |
|||
| 631 | +43 |
- }+ #' @param datalabel (`character(1)`) optional |
||
| 632 | +44 |
- )+ #' text label. |
||
| 633 | +45 |
- },+ #' |
||
| 634 | +46 |
-
+ #' @return |
||
| 635 | +47 |
- # @description+ #' Object of class `FilterStates`, invisibly. |
||
| 636 | +48 |
- # Server module to display filter summary+ #' |
||
| 637 | +49 |
- # renders text describing selected range and+ initialize = function(data, |
||
| 638 | +50 |
- # if NA or Inf are included also+ data_reactive = function(sid = "") NULL, |
||
| 639 | +51 |
- # @return `shiny.tag` to include in the `ui_summary`+ dataname, |
||
| 640 | +52 |
- content_summary = function() {
+ datalabel = NULL) {
|
||
| 641 | -5x | +53 | +274x |
- selection <- private$get_selected()+ checkmate::assert_string(dataname) |
| 642 | -5x | +54 | +272x |
- tagList(+ logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
|
| 643 | -5x | +55 | +272x |
- tags$span(HTML(selection[1], "–", selection[2]), class = "filter-card-summary-value"),+ checkmate::assert_function(data_reactive, args = "sid") |
| 644 | -5x | +56 | +272x |
- tags$span(+ checkmate::assert_string(datalabel, null.ok = TRUE)+ |
+
| 57 | ++ | + | ||
| 645 | -5x | +58 | +272x |
- class = "filter-card-summary-controls",+ private$dataname <- dataname |
| 646 | -5x | +59 | +272x |
- if (private$na_count > 0) {
+ private$datalabel <- datalabel |
| 647 | -! | +|||
| 60 | +272x |
- tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
+ private$dataname_prefixed <- dataname |
||
| 648 | -+ | |||
| 61 | +272x |
- },+ private$data <- data |
||
| 649 | -5x | +62 | +272x |
- if (private$inf_count > 0) {
+ private$data_reactive <- data_reactive |
| 650 | -! | +|||
| 63 | +272x |
- tags$span("Inf", if (isTRUE(private$get_keep_inf())) icon("check") else icon("xmark"))
+ private$state_list <- reactiveVal() |
||
| 651 | +64 |
- }+ |
||
| 652 | -+ | |||
| 65 | +272x |
- )+ logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
|
||
| 653 | -+ | |||
| 66 | +272x |
- )+ invisible(self) |
||
| 654 | +67 |
}, |
||
| 655 | +68 | |||
| 656 | +69 |
- # @description+ #' @description |
||
| 657 | +70 |
- # Module displaying input to keep or remove NA in the `FilterState` call.+ #' Returns a formatted string representing this `FilterStates` object. |
||
| 658 | +71 |
- # Renders a checkbox input only when variable with which the `FilterState` has been created contains Infs.+ #' |
||
| 659 | +72 |
- # @param id (`character(1)`) `shiny` module instance id.+ #' @param show_all (`logical(1)`) passed to `format.teal_slices` |
||
| 660 | +73 |
- keep_inf_ui = function(id) {
+ #' @param trim_lines (`logical(1)`) passed to `format.teal_slices` |
||
| 661 | -5x | +|||
| 74 | +
- ns <- NS(id)+ #' |
|||
| 662 | +75 |
-
+ #' @return `character(1)` the formatted string |
||
| 663 | -5x | -
- if (private$inf_count > 0) {
- |
- ||
| 664 | -! | +|||
| 76 | +
- countmax <- private$na_count+ #' |
|||
| 665 | -! | +|||
| 77 | +
- countnow <- isolate(private$filtered_na_count())+ format = function(show_all = FALSE, trim_lines = TRUE) {
|
|||
| 666 | +78 | ! |
- ui_input <- checkboxInput(+ sprintf( |
|
| 667 | +79 | ! |
- inputId = ns("value"),
+ "%s:\n%s", |
|
| 668 | +80 | ! |
- label = tags$span(+ class(self)[1], |
|
| 669 | +81 | ! |
- id = ns("count_label"),
+ format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines) |
|
| 670 | -! | +|||
| 82 | +
- make_count_text(+ ) |
|||
| 671 | -! | +|||
| 83 | +
- label = "Keep Inf",+ }, |
|||
| 672 | -! | +|||
| 84 | +
- countmax = countmax,+ |
|||
| 673 | -! | +|||
| 85 | +
- countnow = countnow+ #' @description |
|||
| 674 | +86 |
- )+ #' Filter call |
||
| 675 | +87 |
- ),+ #' |
||
| 676 | -! | +|||
| 88 | +
- value = isolate(private$get_keep_inf())+ #' Builds *subset expression* from condition calls generated by `FilterState`. |
|||
| 677 | +89 |
- )+ #' The `lhs` of the expression is a `dataname_prefixed`, where word prefixed refers to |
||
| 678 | -! | +|||
| 90 | +
- tags$div(+ #' situation when call is evaluated on elements of the original data, for example `dataname[[x]]`. |
|||
| 679 | -! | +|||
| 91 | +
- uiOutput(ns("trigger_visible"), inline = TRUE),
+ #' By default `dataname_prefixed = dataname` and it's not alterable through class methods. |
|||
| 680 | -! | +|||
| 92 | +
- ui_input+ #' Customization of `private$dataname_prefixed` is done through inheriting classes. |
|||
| 681 | +93 |
- )+ #' |
||
| 682 | +94 |
- } else {
+ #' The `rhs` is a call to `private$fun` with following arguments: |
||
| 683 | -5x | +|||
| 95 | +
- NULL+ #' - `dataname_prefixed` |
|||
| 684 | +96 |
- }+ #' - list of logical expressions generated by `FilterState` objects |
||
| 685 | +97 |
- },+ #' stored in `private$state_list`. Each logical predicate is combined with `&` operator. |
||
| 686 | +98 |
-
+ #' Variables in these logical expressions by default are not prefixed but this can be changed |
||
| 687 | +99 |
- # @description+ #' by setting `private$extract_type` (change in the similar way as `dataname_prefixed`) |
||
| 688 | +100 |
- # Module to handle Inf values in the FilterState+ #' Possible call outputs depending on a custom fields/options: |
||
| 689 | +101 |
- # Sets `private$slice$keep_inf` according to the selection+ #' ``` |
||
| 690 | +102 |
- # and updates the relevant UI element if `private$slice$keep_inf` has been changed by the api.+ #' # default |
||
| 691 | +103 |
- # @param id (`character(1)`) `shiny` module instance id.+ #' dataname <- subset(dataname, col == "x") |
||
| 692 | +104 |
- # @return `NULL`.+ #' |
||
| 693 | +105 |
- keep_inf_srv = function(id) {
+ #' # fun = dplyr::filter |
||
| 694 | -5x | +|||
| 106 | +
- moduleServer(id, function(input, output, session) {
+ #' dataname <- dplyr::filter(dataname, col == "x") |
|||
| 695 | +107 |
- # 1. renderUI is used here as an observer which triggers only if output is visible+ #' |
||
| 696 | +108 |
- # and if the reactive changes - reactive triggers only if the output is visible.+ #' # fun = MultiAssayExperiment::subsetByColData; extract_type = "list" |
||
| 697 | +109 |
- # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)+ #' dataname <- MultiAssayExperiment::subsetByColData(dataname, dataname$col == "x") |
||
| 698 | -5x | +|||
| 110 | +
- output$trigger_visible <- renderUI({
+ #' |
|||
| 699 | -5x | +|||
| 111 | +
- updateCountText(+ #' # teal_slice objects having `arg = "subset"` and `arg = "select"` |
|||
| 700 | -5x | +|||
| 112 | +
- inputId = "count_label",+ #' dataname <- subset(dataname, subset = row_col == "x", select = col_col == "x") |
|||
| 701 | -5x | +|||
| 113 | +
- label = "Keep Inf",+ #' |
|||
| 702 | -5x | +|||
| 114 | +
- countmax = private$inf_count,+ #' # dataname = dataname[[element]] |
|||
| 703 | -5x | +|||
| 115 | +
- countnow = private$inf_filtered_count()+ #' dataname[[element]] <- subset(dataname[[element]], subset = col == "x") |
|||
| 704 | +116 |
- )+ #' ``` |
||
| 705 | -5x | +|||
| 117 | +
- NULL+ #' |
|||
| 706 | +118 |
- })+ #' If no filters are applied, `NULL` is returned to avoid no-op calls such as `dataname <- dataname`. |
||
| 707 | +119 |
-
+ #' |
||
| 708 | +120 |
- # this observer is needed in the situation when private$teal_slice$keep_inf has been+ #' @param sid (`character`) |
||
| 709 | +121 |
- # changed directly by the api - then it's needed to rerender UI element+ #' when specified then method returns code containing condition calls (logical predicates) of |
||
| 710 | +122 |
- # to show relevant values+ #' `FilterState` objects which `"sid"` attribute is different than this `sid` argument. |
||
| 711 | -5x | +|||
| 123 | +
- private$observers$keep_inf_api <- observeEvent(+ #' |
|||
| 712 | -5x | +|||
| 124 | +
- ignoreNULL = TRUE, # its not possible for range that NULL is selected+ #' @return `call` or `NULL` |
|||
| 713 | -5x | +|||
| 125 | +
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ #' |
|||
| 714 | -5x | +|||
| 126 | +
- eventExpr = private$get_keep_inf(),+ get_call = function(sid = "") {
|
|||
| 715 | -5x | -
- handlerExpr = {
- |
- ||
| 716 | -! | -
- if (!setequal(private$get_keep_inf(), input$value)) {
- |
- ||
| 717 | -! | -
- logger::log_trace("RangeFilterState$keep_inf_srv@1 changed reactive value, id: { private$get_id() }")
- |
- ||
| 718 | -! | -
- updateCheckboxInput(- |
- ||
| 719 | -! | -
- inputId = "value",- |
- ||
| 720 | -! | +127 | +88x |
- value = private$get_keep_inf()+ logger::log_trace("FilterStates$get_call initializing")
|
| 721 | +128 |
- )+ |
||
| 722 | +129 |
- }+ # `arg` must be the same as argument of the function where |
||
| 723 | +130 |
- }+ # predicate is passed to. |
||
| 724 | +131 |
- )+ # For unnamed arguments state_list should have `arg = NULL` |
||
| 725 | -+ | |||
| 132 | +88x |
-
+ states_list <- private$state_list_get() |
||
| 726 | -5x | +133 | +88x |
- private$observers$keep_inf <- observeEvent(+ if (length(states_list) == 0) {
|
| 727 | -5x | +134 | +52x |
- ignoreNULL = TRUE, # it's not possible for range that NULL is selected+ return(NULL) |
| 728 | -5x | +|||
| 135 | +
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ } |
|||
| 729 | -5x | +136 | +36x |
- eventExpr = input$value,+ args <- vapply( |
| 730 | -5x | +137 | +36x |
- handlerExpr = {
+ states_list, |
| 731 | -! | +|||
| 138 | +36x |
- logger::log_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
+ function(x) {
|
||
| 732 | -! | +|||
| 139 | +57x |
- keep_inf <- input$value+ arg <- x$get_state()$arg |
||
| 733 | -! | +|||
| 140 | +7x |
- private$set_keep_inf(keep_inf)+ `if`(is.null(arg), "", arg) # converting NULL -> "" to enable tapply. |
||
| 734 | +141 |
- }+ },+ |
+ ||
| 142 | +36x | +
+ character(1) |
||
| 735 | +143 |
- )+ ) |
||
| 736 | +144 | |||
| 737 | -5x | +145 | +36x |
- invisible(NULL)+ filter_items <- tapply( |
| 738 | -+ | |||
| 146 | +36x |
- })+ X = states_list, |
||
| 739 | -+ | |||
| 147 | +36x |
- }+ INDEX = args, |
||
| 740 | -+ | |||
| 148 | +36x |
- )+ simplify = FALSE, |
||
| 741 | -+ | |||
| 149 | +36x |
- )+ function(items) {
|
| 1 | +150 |
- # FilterStates ------+ # removing filters identified by sid |
||
| 2 | -+ | |||
| 151 | +38x |
-
+ other_filter_idx <- !names(items) %in% sid |
||
| 3 | -+ | |||
| 152 | +38x |
- #' @name FilterStates+ filtered_items <- items[other_filter_idx] |
||
| 4 | +153 |
- #' @docType class+ |
||
| 5 | -- |
- #' @title `FilterStates` `R6` class- |
- ||
| 6 | -+ | |||
| 154 | +38x |
- #'+ calls <- Filter( |
||
| 7 | -+ | |||
| 155 | +38x |
- #' @description+ Negate(is.null), |
||
| 8 | -+ | |||
| 156 | +38x |
- #' Abstract class that manages adding and removing `FilterState` objects+ lapply( |
||
| 9 | -+ | |||
| 157 | +38x |
- #' and builds a *subset expression*.+ filtered_items, |
||
| 10 | -+ | |||
| 158 | +38x |
- #'+ function(state) {
|
||
| 11 | -+ | |||
| 159 | +51x |
- #' A `FilterStates` object tracks all condition calls+ state$get_call(dataname = private$dataname_prefixed) |
||
| 12 | +160 |
- #' (logical predicates that limit observations) associated with a given dataset+ } |
||
| 13 | +161 |
- #' and composes them into a single reproducible `R` expression+ ) |
||
| 14 | +162 |
- #' that will assign a subset of the original data to a new variable.+ ) |
||
| 15 | -+ | |||
| 163 | +38x |
- #' This expression is hereafter referred to as *subset expression*.+ calls_combine_by(calls, operator = "&") |
||
| 16 | +164 |
- #'+ } |
||
| 17 | +165 |
- #' The *subset expression* is constructed differently for different+ ) |
||
| 18 | -+ | |||
| 166 | +36x |
- #' classes of the underlying data object and `FilterStates` sub-classes.+ filter_items <- Filter( |
||
| 19 | -+ | |||
| 167 | +36x |
- #' Currently implemented for `data.frame`, `matrix`,+ x = filter_items, |
||
| 20 | -+ | |||
| 168 | +36x |
- #' `SummarizedExperiment`, and `MultiAssayExperiment`.+ f = Negate(is.null) |
||
| 21 | +169 |
- #'+ ) |
||
| 22 | -+ | |||
| 170 | +36x |
- #' @keywords internal+ if (length(filter_items) > 0L) {
|
||
| 23 | -+ | |||
| 171 | +35x |
- #'+ filter_function <- private$fun |
||
| 24 | -+ | |||
| 172 | +35x |
- FilterStates <- R6::R6Class( # nolint+ data_name <- str2lang(private$dataname_prefixed) |
||
| 25 | -+ | |||
| 173 | +35x |
- classname = "FilterStates",+ substitute( |
||
| 26 | -+ | |||
| 174 | +35x |
-
+ env = list( |
||
| 27 | -+ | |||
| 175 | +35x |
- # public members ----+ lhs = data_name, |
||
| 28 | -+ | |||
| 176 | +35x |
- public = list(+ rhs = as.call(c(filter_function, c(list(data_name), filter_items))) |
||
| 29 | +177 |
- #' @description+ ), |
||
| 30 | -+ | |||
| 178 | +35x |
- #' Initializes `FilterStates` object by setting+ expr = lhs <- rhs |
||
| 31 | +179 |
- #' `dataname`, and `datalabel`.+ ) |
||
| 32 | +180 |
- #'+ } else {
|
||
| 33 | +181 |
- #' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`)+ # return NULL to avoid no-op call |
||
| 34 | -+ | |||
| 182 | +1x |
- #' the `R` object which `subset` function is applied on.+ NULL |
||
| 35 | +183 |
- #' @param data_reactive (`function(sid)`)+ } |
||
| 36 | +184 |
- #' should return an object of the same type as `data` object or `NULL`.+ }, |
||
| 37 | +185 |
- #' This object is needed for the `FilterState` counts being updated+ |
||
| 38 | +186 |
- #' on a change in filters. If function returns `NULL` then filtered counts are not shown.+ #' @description |
||
| 39 | +187 |
- #' Function has to have `sid` argument being a character.+ #' Prints this `FilterStates` object. |
||
| 40 | +188 |
- #' @param dataname (`character(1)`)+ #' |
||
| 41 | +189 |
- #' name of the dataset, used in the subset expression.+ #' @param ... additional arguments passed to `format`. |
||
| 42 | +190 |
- #' Passed to the function argument attached to this `FilterStates`.+ print = function(...) {
|
||
| 43 | -+ | |||
| 191 | +! |
- #' @param datalabel (`character(1)`) optional+ cat(isolate(self$format(...)), "\n") |
||
| 44 | +192 |
- #' text label.+ }, |
||
| 45 | +193 |
- #'+ |
||
| 46 | +194 |
- #' @return+ #' @description |
||
| 47 | +195 |
- #' Object of class `FilterStates`, invisibly.+ #' Remove one or more `FilterState`s from the `state_list` along with their UI elements. |
||
| 48 | +196 |
#' |
||
| 49 | +197 |
- initialize = function(data,+ #' @param state (`teal_slices`) |
||
| 50 | +198 |
- data_reactive = function(sid = "") NULL,+ #' specifying `FilterState` objects to remove; |
||
| 51 | +199 |
- dataname,+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored |
||
| 52 | +200 |
- datalabel = NULL) {
- |
- ||
| 53 | -274x | -
- checkmate::assert_string(dataname)- |
- ||
| 54 | -272x | -
- logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
- |
- ||
| 55 | -272x | -
- checkmate::assert_function(data_reactive, args = "sid")+ #' |
||
| 56 | -272x | +|||
| 201 | +
- checkmate::assert_string(datalabel, null.ok = TRUE)+ #' @return `NULL`, invisibly. |
|||
| 57 | +202 |
-
+ #' |
||
| 58 | -272x | +|||
| 203 | +
- private$dataname <- dataname+ remove_filter_state = function(state) {
|
|||
| 59 | -272x | +204 | +17x |
- private$datalabel <- datalabel+ checkmate::assert_class(state, "teal_slices") |
| 60 | -272x | +205 | +17x |
- private$dataname_prefixed <- dataname+ isolate({
|
| 61 | -272x | +206 | +17x |
- private$data <- data+ state_ids <- vapply(state, `[[`, character(1), "id") |
| 62 | -272x | +207 | +17x |
- private$data_reactive <- data_reactive+ logger::log_trace("{ class(self)[1] }$remove_filter_state removing filters, state_id: { toString(state_ids) }")
|
| 63 | -272x | +208 | +17x |
- private$state_list <- reactiveVal()+ private$state_list_remove(state_ids) |
| 64 | +209 | - - | -||
| 65 | -272x | -
- logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
+ }) |
||
| 66 | -272x | +210 | +17x |
- invisible(self)+ invisible(NULL) |
| 67 | +211 |
}, |
||
| 68 | +212 | |||
| 69 | +213 |
#' @description |
||
| 70 | +214 |
- #' Returns a formatted string representing this `FilterStates` object.+ #' Gets reactive values from active `FilterState` objects. |
||
| 71 | +215 |
#' |
||
| 72 | +216 |
- #' @param show_all (`logical(1)`) passed to `format.teal_slices`+ #' Get active filter state from `FilterState` objects stored in `state_list`(s). |
||
| 73 | +217 |
- #' @param trim_lines (`logical(1)`) passed to `format.teal_slices`+ #' The output is a list compatible with input to `self$set_filter_state`. |
||
| 74 | +218 |
#' |
||
| 75 | +219 |
- #' @return `character(1)` the formatted string+ #' @return Object of class `teal_slices`. |
||
| 76 | +220 |
#' |
||
| 77 | +221 |
- format = function(show_all = FALSE, trim_lines = TRUE) {
+ get_filter_state = function() {
|
||
| 78 | -! | +|||
| 222 | +364x |
- sprintf(+ slices <- unname(lapply(private$state_list(), function(x) x$get_state())) |
||
| 79 | -! | +|||
| 223 | +364x |
- "%s:\n%s",+ fs <- do.call(teal_slices, c(slices, list(count_type = private$count_type))) |
||
| 80 | -! | +|||
| 224 | +
- class(self)[1],+ |
|||
| 81 | -! | +|||
| 225 | +364x |
- format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)+ include_varnames <- private$include_varnames |
||
| 82 | -+ | |||
| 226 | +364x |
- )+ if (length(include_varnames)) {
|
||
| 83 | -+ | |||
| 227 | +214x |
- },+ attr(fs, "include_varnames") <- structure( |
||
| 84 | -+ | |||
| 228 | +214x |
-
+ list(include_varnames), |
||
| 85 | -+ | |||
| 229 | +214x |
- #' @description+ names = private$dataname |
||
| 86 | +230 |
- #' Filter call+ ) |
||
| 87 | +231 |
- #'+ } |
||
| 88 | +232 |
- #' Builds *subset expression* from condition calls generated by `FilterState`.+ |
||
| 89 | -+ | |||
| 233 | +364x |
- #' The `lhs` of the expression is a `dataname_prefixed`, where word prefixed refers to+ exclude_varnames <- private$exclude_varnames |
||
| 90 | -+ | |||
| 234 | +364x |
- #' situation when call is evaluated on elements of the original data, for example `dataname[[x]]`.+ if (length(exclude_varnames)) {
|
||
| 91 | -+ | |||
| 235 | +9x |
- #' By default `dataname_prefixed = dataname` and it's not alterable through class methods.+ attr(fs, "exclude_varnames") <- structure( |
||
| 92 | -+ | |||
| 236 | +9x |
- #' Customization of `private$dataname_prefixed` is done through inheriting classes.+ list(exclude_varnames), |
||
| 93 | -+ | |||
| 237 | +9x |
- #'+ names = private$dataname |
||
| 94 | +238 |
- #' The `rhs` is a call to `private$fun` with following arguments:+ ) |
||
| 95 | +239 |
- #' - `dataname_prefixed`+ } |
||
| 96 | +240 |
- #' - list of logical expressions generated by `FilterState` objects+ |
||
| 97 | -+ | |||
| 241 | +364x |
- #' stored in `private$state_list`. Each logical predicate is combined with `&` operator.+ fs |
||
| 98 | +242 |
- #' Variables in these logical expressions by default are not prefixed but this can be changed+ }, |
||
| 99 | +243 |
- #' by setting `private$extract_type` (change in the similar way as `dataname_prefixed`)+ |
||
| 100 | +244 |
- #' Possible call outputs depending on a custom fields/options:+ #' @description |
||
| 101 | +245 |
- #' ```+ #' Sets active `FilterState` objects. |
||
| 102 | +246 |
- #' # default+ #' @param state (`teal_slices`) |
||
| 103 | +247 |
- #' dataname <- subset(dataname, col == "x")+ #' @return Function that raises an error. |
||
| 104 | +248 |
- #'+ set_filter_state = function(state) {
|
||
| 105 | -+ | |||
| 249 | +135x |
- #' # fun = dplyr::filter+ isolate({
|
||
| 106 | -+ | |||
| 250 | +135x |
- #' dataname <- dplyr::filter(dataname, col == "x")+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
|
||
| 107 | -+ | |||
| 251 | +135x |
- #'+ checkmate::assert_class(state, "teal_slices") |
||
| 108 | -+ | |||
| 252 | +135x |
- #' # fun = MultiAssayExperiment::subsetByColData; extract_type = "list"+ lapply(state, function(x) {
|
||
| 109 | -+ | |||
| 253 | +177x |
- #' dataname <- MultiAssayExperiment::subsetByColData(dataname, dataname$col == "x")+ checkmate::assert_true( |
||
| 110 | -+ | |||
| 254 | +177x |
- #'+ x$dataname == private$dataname, |
||
| 111 | -+ | |||
| 255 | +177x |
- #' # teal_slice objects having `arg = "subset"` and `arg = "select"`+ .var.name = "dataname matches private$dataname" |
||
| 112 | +256 |
- #' dataname <- subset(dataname, subset = row_col == "x", select = col_col == "x")+ ) |
||
| 113 | +257 |
- #'+ }) |
||
| 114 | +258 |
- #' # dataname = dataname[[element]]+ |
||
| 115 | -+ | |||
| 259 | +135x |
- #' dataname[[element]] <- subset(dataname[[element]], subset = col == "x")+ private$set_filterable_varnames( |
||
| 116 | -+ | |||
| 260 | +135x |
- #' ```+ include_varnames = attr(state, "include_varnames")[[private$dataname]], |
||
| 117 | -+ | |||
| 261 | +135x |
- #'+ exclude_varnames = attr(state, "exclude_varnames")[[private$dataname]] |
||
| 118 | +262 |
- #' If no filters are applied, `NULL` is returned to avoid no-op calls such as `dataname <- dataname`.+ ) |
||
| 119 | -+ | |||
| 263 | +135x |
- #'+ count_type <- attr(state, "count_type") |
||
| 120 | -+ | |||
| 264 | +135x |
- #' @param sid (`character`)+ if (length(count_type)) {
|
||
| 121 | -+ | |||
| 265 | +21x |
- #' when specified then method returns code containing condition calls (logical predicates) of+ private$count_type <- count_type |
||
| 122 | +266 |
- #' `FilterState` objects which `"sid"` attribute is different than this `sid` argument.+ } |
||
| 123 | +267 |
- #'+ |
||
| 124 | +268 |
- #' @return `call` or `NULL`+ # Drop teal_slices that refer to excluded variables. |
||
| 125 | -+ | |||
| 269 | +135x |
- #'+ varnames <- unique(unlist(lapply(state, "[[", "varname"))) |
||
| 126 | -+ | |||
| 270 | +135x |
- get_call = function(sid = "") {
+ excluded_varnames <- setdiff(varnames, private$get_filterable_varnames()) |
||
| 127 | -88x | +271 | +135x |
- logger::log_trace("FilterStates$get_call initializing")
+ if (length(excluded_varnames)) {
|
| 128 | -+ | |||
| 272 | +3x |
-
+ state <- Filter(function(x) !isTRUE(x$varname %in% excluded_varnames), state) |
||
| 129 | -+ | |||
| 273 | +3x |
- # `arg` must be the same as argument of the function where+ warning(sprintf("filters for columns: %s excluded from %s", toString(excluded_varnames), private$dataname))
|
||
| 130 | +274 |
- # predicate is passed to.+ } |
||
| 131 | +275 |
- # For unnamed arguments state_list should have `arg = NULL`+ |
||
| 132 | -88x | +276 | +135x |
- states_list <- private$state_list_get()+ if (length(state) > 0) {
|
| 133 | -88x | +277 | +93x |
- if (length(states_list) == 0) {
+ private$set_filter_state_impl( |
| 134 | -52x | +278 | +93x |
- return(NULL)+ state = state, |
| 135 | -+ | |||
| 279 | +93x |
- }+ data = private$data, |
||
| 136 | -36x | +280 | +93x |
- args <- vapply(+ data_reactive = private$data_reactive |
| 137 | -36x | +|||
| 281 | +
- states_list,+ ) |
|||
| 138 | -36x | +|||
| 282 | +
- function(x) {
+ } |
|||
| 139 | -57x | +283 | +135x |
- arg <- x$get_state()$arg+ logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
|
| 140 | -7x | +|||
| 284 | +
- `if`(is.null(arg), "", arg) # converting NULL -> "" to enable tapply.+ }) |
|||
| 141 | +285 |
- },+ |
||
| 142 | -36x | +286 | +135x |
- character(1)+ invisible(NULL) |
| 143 | +287 |
- )+ }, |
||
| 144 | +288 | |||
| 145 | -36x | +|||
| 289 | +
- filter_items <- tapply(+ #' @description |
|||
| 146 | -36x | +|||
| 290 | +
- X = states_list,+ #' Remove all `FilterState` objects from this `FilterStates` object. |
|||
| 147 | -36x | +|||
| 291 | +
- INDEX = args,+ #' |
|||
| 148 | -36x | +|||
| 292 | +
- simplify = FALSE,+ #' @param force (`logical(1)`) |
|||
| 149 | -36x | +|||
| 293 | +
- function(items) {
+ #' flag specifying whether to include anchored filter states. |
|||
| 150 | +294 |
- # removing filters identified by sid+ #' |
||
| 151 | -38x | +|||
| 295 | +
- other_filter_idx <- !names(items) %in% sid+ #' @return `NULL`, invisibly. |
|||
| 152 | -38x | +|||
| 296 | +
- filtered_items <- items[other_filter_idx]+ #' |
|||
| 153 | +297 |
-
+ clear_filter_states = function(force = FALSE) {
|
||
| 154 | -38x | +298 | +25x |
- calls <- Filter(+ private$state_list_empty(force) |
| 155 | -38x | +299 | +25x |
- Negate(is.null),+ invisible(NULL) |
| 156 | -38x | +|||
| 300 | +
- lapply(+ }, |
|||
| 157 | -38x | +|||
| 301 | +
- filtered_items,+ |
|||
| 158 | -38x | +|||
| 302 | +
- function(state) {
+ # shiny modules ---- |
|||
| 159 | -51x | +|||
| 303 | +
- state$get_call(dataname = private$dataname_prefixed)+ |
|||
| 160 | +304 |
- }+ #' @description |
||
| 161 | +305 |
- )+ #' `shiny` UI definition that stores `FilterState` UI elements. |
||
| 162 | +306 |
- )+ #' Populated with elements created with `renderUI` in the module server. |
||
| 163 | -38x | +|||
| 307 | +
- calls_combine_by(calls, operator = "&")+ #' |
|||
| 164 | +308 |
- }+ #' @param id (`character(1)`) |
||
| 165 | +309 |
- )+ #' `shiny` module instance id. |
||
| 166 | -36x | +|||
| 310 | +
- filter_items <- Filter(+ #' |
|||
| 167 | -36x | +|||
| 311 | +
- x = filter_items,+ #' @return `shiny.tag` |
|||
| 168 | -36x | +|||
| 312 | +
- f = Negate(is.null)+ #' |
|||
| 169 | +313 |
- )+ ui_active = function(id) {
|
||
| 170 | -36x | +|||
| 314 | +! |
- if (length(filter_items) > 0L) {
+ ns <- NS(id) |
||
| 171 | -35x | +|||
| 315 | +! |
- filter_function <- private$fun+ tagList( |
||
| 172 | -35x | +|||
| 316 | +! |
- data_name <- str2lang(private$dataname_prefixed)+ include_css_files(pattern = "filter-panel"), |
||
| 173 | -35x | +|||
| 317 | +! |
- substitute(+ uiOutput(ns("trigger_visible_state_change"), inline = TRUE),
|
||
| 174 | -35x | +|||
| 318 | +! |
- env = list(+ uiOutput( |
||
| 175 | -35x | +|||
| 319 | +! |
- lhs = data_name,+ ns("cards"),
|
||
| 176 | -35x | +|||
| 320 | +! |
- rhs = as.call(c(filter_function, c(list(data_name), filter_items)))+ class = "accordion",+ |
+ ||
| 321 | +! | +
+ `data-label` = ifelse(length(private$datalabel), paste0("> ", private$datalabel), ""),
|
||
| 177 | +322 |
- ),+ ) |
||
| 178 | -35x | +|||
| 323 | +
- expr = lhs <- rhs+ ) |
|||
| 179 | +324 |
- )+ }, |
||
| 180 | +325 |
- } else {
+
|
||
| 181 | +326 |
- # return NULL to avoid no-op call+ #' @description |
||
| 182 | -1x | +|||
| 327 | +
- NULL+ #' `shiny` server module. |
|||
| 183 | +328 |
- }+ #' |
||
| 184 | +329 |
- },+ #' @param id (`character(1)`) |
||
| 185 | +330 |
-
+ #' `shiny` module instance id. |
||
| 186 | +331 |
- #' @description+ #' |
||
| 187 | +332 |
- #' Prints this `FilterStates` object.+ #' @return `NULL`. |
||
| 188 | +333 |
#' |
||
| 189 | +334 |
- #' @param ... additional arguments passed to `format`.+ srv_active = function(id) {
|
||
| 190 | -+ | |||
| 335 | +12x |
- print = function(...) {
+ moduleServer( |
||
| 191 | -! | +|||
| 336 | +12x |
- cat(isolate(self$format(...)), "\n")+ id = id, |
||
| 192 | -+ | |||
| 337 | +12x |
- },+ function(input, output, session) {
|
||
| 193 | -+ | |||
| 338 | +12x |
-
+ logger::log_trace("FilterState$srv_active initializing, dataname: { private$dataname }")
|
||
| 194 | -+ | |||
| 339 | +12x |
- #' @description+ current_state <- reactive(private$state_list_get()) |
||
| 195 | -+ | |||
| 340 | +12x |
- #' Remove one or more `FilterState`s from the `state_list` along with their UI elements.+ previous_state <- reactiveVal(NULL) # FilterState list |
||
| 196 | -+ | |||
| 341 | +12x |
- #'+ added_states <- reactiveVal(NULL) # FilterState list |
||
| 197 | +342 |
- #' @param state (`teal_slices`)+ |
||
| 198 | +343 |
- #' specifying `FilterState` objects to remove;+ # gives a valid shiny ns based on a default slice id |
||
| 199 | -+ | |||
| 344 | +12x |
- #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored+ fs_to_shiny_ns <- function(x) {
|
||
| 200 | -+ | |||
| 345 | +24x |
- #'+ checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
|
||
| 201 | -+ | |||
| 346 | +24x |
- #' @return `NULL`, invisibly.+ gsub("[^[:alnum:]]+", "_", get_default_slice_id(x$get_state()))
|
||
| 202 | +347 |
- #'+ } |
||
| 203 | +348 |
- remove_filter_state = function(state) {
+
|
||
| 204 | -17x | +349 | +12x |
- checkmate::assert_class(state, "teal_slices")+ output$trigger_visible_state_change <- renderUI({
|
| 205 | -17x | +350 | +14x |
- isolate({
+ current_state() |
| 206 | -17x | +351 | +14x |
- state_ids <- vapply(state, `[[`, character(1), "id")+ isolate({
|
| 207 | -17x | +352 | +14x |
- logger::log_trace("{ class(self)[1] }$remove_filter_state removing filters, state_id: { toString(state_ids) }")
+ logger::log_trace("FilterStates$srv_active@1 determining added and removed filter states")
+ |
+
| 353 | ++ |
+ # Be aware this returns a list because `current_state` is a list and not `teal_slices`. |
||
| 208 | -17x | +354 | +14x |
- private$state_list_remove(state_ids)+ added_states(setdiff_teal_slices(current_state(), previous_state())) |
| 209 | -+ | |||
| 355 | +14x |
- })+ previous_state(current_state()) |
||
| 210 | -17x | +356 | +14x |
- invisible(NULL)+ NULL |
| 211 | +357 |
- },+ }) |
||
| 212 | +358 |
-
+ }) |
||
| 213 | +359 |
- #' @description+ |
||
| 214 | -+ | |||
| 360 | +12x |
- #' Gets reactive values from active `FilterState` objects.+ output[["cards"]] <- renderUI({
|
||
| 215 | -+ | |||
| 361 | +14x |
- #'+ lapply( |
||
| 216 | -+ | |||
| 362 | +14x |
- #' Get active filter state from `FilterState` objects stored in `state_list`(s).+ current_state(), # observes only if added/removed+ |
+ ||
| 363 | +14x | +
+ function(state) {
+ |
+ ||
| 364 | +12x | +
+ isolate( # isolates when existing state changes+ |
+ ||
| 365 | +12x | +
+ state$ui(id = session$ns(fs_to_shiny_ns(state)), parent_id = session$ns("cards"))
|
||
| 217 | +366 |
- #' The output is a list compatible with input to `self$set_filter_state`.+ ) |
||
| 218 | +367 |
- #'+ } |
||
| 219 | +368 |
- #' @return Object of class `teal_slices`.+ ) |
||
| 220 | +369 |
- #'+ }) |
||
| 221 | +370 |
- get_filter_state = function() {
+
|
||
| 222 | -364x | +371 | +12x |
- slices <- unname(lapply(private$state_list(), function(x) x$get_state()))+ observeEvent( |
| 223 | -364x | +372 | +12x |
- fs <- do.call(teal_slices, c(slices, list(count_type = private$count_type)))+ added_states(), # we want to call FilterState module only once when it's added |
| 224 | -+ | |||
| 373 | +12x |
-
+ ignoreNULL = TRUE, |
||
| 225 | -364x | +|||
| 374 | +
- include_varnames <- private$include_varnames+ {
|
|||
| 226 | -364x | +375 | +10x |
- if (length(include_varnames)) {
+ added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L)) |
| 227 | -214x | +376 | +10x |
- attr(fs, "include_varnames") <- structure(+ logger::log_trace("FilterStates$srv_active@2 triggered by added states: { toString(added_state_names) }")
|
| 228 | -214x | +377 | +10x |
- list(include_varnames),+ lapply(added_states(), function(state) {
|
| 229 | -214x | +378 | +12x |
- names = private$dataname+ fs_callback <- state$server(id = fs_to_shiny_ns(state)) |
| 230 | -+ | |||
| 379 | +12x |
- )+ observeEvent( |
||
| 231 | -+ | |||
| 380 | +12x |
- }+ once = TRUE, # remove button can be called once, should be destroyed afterwards |
||
| 232 | -+ | |||
| 381 | +12x |
-
+ ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI |
||
| 233 | -364x | +382 | +12x |
- exclude_varnames <- private$exclude_varnames+ eventExpr = fs_callback(), # when remove button is clicked in the FilterState ui |
| 234 | -364x | +383 | +12x |
- if (length(exclude_varnames)) {
+ handlerExpr = private$state_list_remove(state$get_state()$id) |
| 235 | -9x | +|||
| 384 | +
- attr(fs, "exclude_varnames") <- structure(+ ) |
|||
| 236 | -9x | +|||
| 385 | +
- list(exclude_varnames),+ }) |
|||
| 237 | -9x | +386 | +10x |
- names = private$dataname+ added_states(NULL) |
| 238 | +387 |
- )+ } |
||
| 239 | +388 |
- }+ ) |
||
| 240 | +389 | |||
| 241 | -364x | +390 | +12x |
- fs+ NULL |
| 242 | +391 |
- },+ } |
||
| 243 | +392 |
-
+ ) |
||
| 244 | +393 |
- #' @description+ }, |
||
| 245 | +394 |
- #' Sets active `FilterState` objects.+ |
||
| 246 | +395 |
- #' @param state (`teal_slices`)+ #' @description |
||
| 247 | +396 |
- #' @return Function that raises an error.+ #' `shiny` UI module to add filter variable. |
||
| 248 | +397 |
- set_filter_state = function(state) {
+ #' |
||
| 249 | -135x | +|||
| 398 | +
- isolate({
+ #' @param id (`character(1)`) |
|||
| 250 | -135x | +|||
| 399 | +
- logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
+ #' `shiny` module instance id. |
|||
| 251 | -135x | +|||
| 400 | +
- checkmate::assert_class(state, "teal_slices")+ #' |
|||
| 252 | -135x | +|||
| 401 | +
- lapply(state, function(x) {
+ #' @return `shiny.tag` |
|||
| 253 | -177x | +|||
| 402 | +
- checkmate::assert_true(+ #' |
|||
| 254 | -177x | +|||
| 403 | +
- x$dataname == private$dataname,+ ui_add = function(id) {
|
|||
| 255 | -177x | +404 | +1x |
- .var.name = "dataname matches private$dataname"+ checkmate::assert_string(id) |
| 256 | -+ | |||
| 405 | +1x |
- )+ data <- private$data |
||
| 257 | -- |
- })- |
- ||
| 258 | +406 | |||
| 259 | -135x | -
- private$set_filterable_varnames(- |
- ||
| 260 | -135x | -
- include_varnames = attr(state, "include_varnames")[[private$dataname]],- |
- ||
| 261 | -135x | +407 | +1x |
- exclude_varnames = attr(state, "exclude_varnames")[[private$dataname]]+ ns <- NS(id) |
| 262 | +408 |
- )- |
- ||
| 263 | -135x | -
- count_type <- attr(state, "count_type")+ |
||
| 264 | -135x | +409 | +1x |
- if (length(count_type)) {
+ if (ncol(data) == 0) {
|
| 265 | -21x | +410 | +1x |
- private$count_type <- count_type+ tags$div("no sample variables available")
|
| 266 | -+ | |||
| 411 | +! |
- }+ } else if (nrow(data) == 0) {
|
||
| 267 | -+ | |||
| 412 | +! |
-
+ tags$div("no samples available")
|
||
| 268 | +413 |
- # Drop teal_slices that refer to excluded variables.- |
- ||
| 269 | -135x | -
- varnames <- unique(unlist(lapply(state, "[[", "varname")))- |
- ||
| 270 | -135x | -
- excluded_varnames <- setdiff(varnames, private$get_filterable_varnames())- |
- ||
| 271 | -135x | -
- if (length(excluded_varnames)) {
+ } else {
|
||
| 272 | -3x | +|||
| 414 | +! |
- state <- Filter(function(x) !isTRUE(x$varname %in% excluded_varnames), state)+ uiOutput(ns("add_filter"))
|
||
| 273 | -3x | +|||
| 415 | +
- warning(sprintf("filters for columns: %s excluded from %s", toString(excluded_varnames), private$dataname))
+ } |
|||
| 274 | +416 |
- }+ }, |
||
| 275 | +417 | |||
| 276 | -135x | -
- if (length(state) > 0) {
- |
- ||
| 277 | -93x | -
- private$set_filter_state_impl(- |
- ||
| 278 | -93x | -
- state = state,- |
- ||
| 279 | -93x | +|||
| 418 | +
- data = private$data,+ #' @description |
|||
| 280 | -93x | +|||
| 419 | +
- data_reactive = private$data_reactive+ #' `shiny` server module to add filter variable. |
|||
| 281 | +420 |
- )+ #' |
||
| 282 | +421 |
- }+ #' This module controls available choices to select as a filter variable. |
||
| 283 | -135x | +|||
| 422 | +
- logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
+ #' Once selected, a variable is removed from available choices. |
|||
| 284 | +423 |
- })+ #' Removing a filter variable adds it back to available choices. |
||
| 285 | +424 |
-
+ #' |
||
| 286 | -135x | +|||
| 425 | +
- invisible(NULL)+ #' @param id (`character(1)`) |
|||
| 287 | +426 |
- },+ #' `shiny` module instance id. |
||
| 288 | +427 |
-
+ #' |
||
| 289 | +428 |
- #' @description+ #' @return `NULL`. |
||
| 290 | +429 |
- #' Remove all `FilterState` objects from this `FilterStates` object.+ srv_add = function(id) {
|
||
| 291 | -+ | |||
| 430 | +8x |
- #'+ moduleServer( |
||
| 292 | -+ | |||
| 431 | +8x |
- #' @param force (`logical(1)`)+ id = id, |
||
| 293 | -+ | |||
| 432 | +8x |
- #' flag specifying whether to include anchored filter states.+ function(input, output, session) {
|
||
| 294 | -+ | |||
| 433 | +8x |
- #'+ logger::log_trace("FilterStates$srv_add initializing, dataname: { private$dataname }")
|
||
| 295 | +434 |
- #' @return `NULL`, invisibly.+ |
||
| 296 | +435 |
- #'+ # available choices to display |
||
| 297 | -+ | |||
| 436 | +8x |
- clear_filter_states = function(force = FALSE) {
+ avail_column_choices <- reactive({
|
||
| 298 | -25x | +437 | +9x |
- private$state_list_empty(force)+ data <- private$data |
| 299 | -25x | +438 | +9x |
- invisible(NULL)+ vars_include <- private$get_filterable_varnames() |
| 300 | -+ | |||
| 439 | +9x |
- },+ active_filter_vars <- unique(unlist(lapply(self$get_filter_state(), "[[", "varname"))) |
||
| 301 | -+ | |||
| 440 | +9x |
-
+ choices <- setdiff(vars_include, active_filter_vars) |
||
| 302 | -+ | |||
| 441 | +9x |
- # shiny modules ----+ varlabels <- get_varlabels(data) |
||
| 303 | +442 | |||
| 304 | -+ | |||
| 443 | +9x |
- #' @description+ data_choices_labeled( |
||
| 305 | -+ | |||
| 444 | +9x |
- #' `shiny` UI definition that stores `FilterState` UI elements.+ data = data, |
||
| 306 | -+ | |||
| 445 | +9x |
- #' Populated with elements created with `renderUI` in the module server.+ choices = choices, |
||
| 307 | -+ | |||
| 446 | +9x |
- #'+ varlabels = varlabels, |
||
| 308 | -+ | |||
| 447 | +9x |
- #' @param id (`character(1)`)+ keys = private$keys |
||
| 309 | +448 |
- #' `shiny` module instance id.+ ) |
||
| 310 | +449 |
- #'+ }) |
||
| 311 | +450 |
- #' @return `shiny.tag`+ |
||
| 312 | +451 |
- #'+ |
||
| 313 | -+ | |||
| 452 | +8x |
- ui_active = function(id) {
+ output$add_filter <- renderUI({
|
||
| 314 | -! | +|||
| 453 | +6x |
- ns <- NS(id)+ logger::log_trace( |
||
| 315 | -! | +|||
| 454 | +6x |
- tagList(+ "FilterStates$srv_add@1 updating available column choices, dataname: { private$dataname }"
|
||
| 316 | -! | +|||
| 455 | +
- include_css_files(pattern = "filter-panel"),+ ) |
|||
| 317 | -! | +|||
| 456 | +6x |
- uiOutput(ns("trigger_visible_state_change"), inline = TRUE),
+ if (length(avail_column_choices()) == 0) {
|
||
| 318 | +457 | ! |
- uiOutput(+ tags$span("No available columns to add.")
|
|
| 319 | -! | +|||
| 458 | +
- ns("cards"),
+ } else {
|
|||
| 320 | -! | +|||
| 459 | +6x |
- class = "accordion",+ tags$div( |
||
| 321 | -! | +|||
| 460 | +6x |
- `data-label` = ifelse(length(private$datalabel), paste0("> ", private$datalabel), ""),
+ teal.widgets::optionalSelectInput( |
||
| 322 | -+ | |||
| 461 | +6x |
- )+ session$ns("var_to_add"),
|
||
| 323 | -+ | |||
| 462 | +6x |
- )+ choices = avail_column_choices(), |
||
| 324 | -+ | |||
| 463 | +6x |
- },+ selected = NULL, |
||
| 325 | -+ | |||
| 464 | +6x |
-
+ options = shinyWidgets::pickerOptions( |
||
| 326 | -+ | |||
| 465 | +6x |
- #' @description+ liveSearch = TRUE, |
||
| 327 | -+ | |||
| 466 | +6x |
- #' `shiny` server module.+ noneSelectedText = "Select variable to filter" |
||
| 328 | +467 |
- #'+ ) |
||
| 329 | +468 |
- #' @param id (`character(1)`)+ ) |
||
| 330 | +469 |
- #' `shiny` module instance id.+ ) |
||
| 331 | +470 |
- #'+ } |
||
| 332 | +471 |
- #' @return `NULL`.+ }) |
||
| 333 | +472 |
- #'+ |
||
| 334 | -+ | |||
| 473 | +8x |
- srv_active = function(id) {
+ observeEvent( |
||
| 335 | -12x | +474 | +8x |
- moduleServer(+ eventExpr = input$var_to_add, |
| 336 | -12x | +475 | +8x |
- id = id,+ handlerExpr = {
|
| 337 | -12x | +476 | +3x |
- function(input, output, session) {
+ logger::log_trace( |
| 338 | -12x | +477 | +3x |
- logger::log_trace("FilterState$srv_active initializing, dataname: { private$dataname }")
+ sprintf( |
| 339 | -12x | +478 | +3x |
- current_state <- reactive(private$state_list_get())+ "FilterStates$srv_add@2 adding FilterState of variable %s, dataname: %s", |
| 340 | -12x | +479 | +3x |
- previous_state <- reactiveVal(NULL) # FilterState list+ input$var_to_add, |
| 341 | -12x | +480 | +3x |
- added_states <- reactiveVal(NULL) # FilterState list+ private$dataname |
| 342 | +481 |
-
+ ) |
||
| 343 | +482 |
- # gives a valid shiny ns based on a default slice id+ ) |
||
| 344 | -12x | +483 | +3x |
- fs_to_shiny_ns <- function(x) {
+ self$set_filter_state( |
| 345 | -24x | +484 | +3x |
- checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
+ teal_slices( |
| 346 | -24x | +485 | +3x |
- gsub("[^[:alnum:]]+", "_", get_default_slice_id(x$get_state()))
+ teal_slice(dataname = private$dataname, varname = input$var_to_add) |
| 347 | +486 |
- }+ ) |
||
| 348 | +487 |
-
+ ) |
||
| 349 | -12x | +488 | +3x |
- output$trigger_visible_state_change <- renderUI({
+ logger::log_trace( |
| 350 | -14x | +489 | +3x |
- current_state()+ sprintf( |
| 351 | -14x | +490 | +3x |
- isolate({
+ "FilterStates$srv_add@2 added FilterState of variable %s, dataname: %s", |
| 352 | -14x | -
- logger::log_trace("FilterStates$srv_active@1 determining added and removed filter states")
- |
- ||
| 353 | -+ | 491 | +3x |
- # Be aware this returns a list because `current_state` is a list and not `teal_slices`.+ input$var_to_add, |
| 354 | -14x | +492 | +3x |
- added_states(setdiff_teal_slices(current_state(), previous_state()))+ private$dataname |
| 355 | -14x | +|||
| 493 | +
- previous_state(current_state())+ ) |
|||
| 356 | -14x | +|||
| 494 | +
- NULL+ ) |
|||
| 357 | +495 |
- })+ } |
||
| 358 | +496 |
- })+ ) |
||
| 359 | +497 | |||
| 360 | -12x | -
- output[["cards"]] <- renderUI({
- |
- ||
| 361 | -14x | -
- lapply(- |
- ||
| 362 | -14x | -
- current_state(), # observes only if added/removed- |
- ||
| 363 | -14x | -
- function(state) {
- |
- ||
| 364 | -12x | +498 | +8x |
- isolate( # isolates when existing state changes+ logger::log_trace("FilterStates$srv_add initialized, dataname: { private$dataname }")
|
| 365 | -12x | +499 | +8x |
- state$ui(id = session$ns(fs_to_shiny_ns(state)), parent_id = session$ns("cards"))
+ NULL |
| 366 | +500 |
- )+ } |
||
| 367 | +501 |
- }+ ) |
||
| 368 | +502 |
- )+ } |
||
| 369 | +503 |
- })+ ), |
||
| 370 | +504 | - - | -||
| 371 | -12x | -
- observeEvent(+ private = list( |
||
| 372 | -12x | +|||
| 505 | +
- added_states(), # we want to call FilterState module only once when it's added+ # private fields ---- |
|||
| 373 | -12x | +|||
| 506 | +
- ignoreNULL = TRUE,+ count_type = "none", # specifies how observation numbers are displayed in filter cards, |
|||
| 374 | +507 |
- {
+ data = NULL, # data.frame, MAE, SE or matrix |
||
| 375 | -10x | +|||
| 508 | +
- added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L))+ data_reactive = NULL, # reactive |
|||
| 376 | -10x | +|||
| 509 | +
- logger::log_trace("FilterStates$srv_active@2 triggered by added states: { toString(added_state_names) }")
+ datalabel = NULL, # to follow default `experiment = NULL` in `teal_slice` |
|||
| 377 | -10x | +|||
| 510 | +
- lapply(added_states(), function(state) {
+ dataname = NULL, # because it holds object of class name |
|||
| 378 | -12x | +|||
| 511 | +
- fs_callback <- state$server(id = fs_to_shiny_ns(state))+ dataname_prefixed = character(0), # name used in call returned from get_call |
|||
| 379 | -12x | +|||
| 512 | +
- observeEvent(+ exclude_varnames = character(0), # holds column names |
|||
| 380 | -12x | +|||
| 513 | +
- once = TRUE, # remove button can be called once, should be destroyed afterwards+ include_varnames = character(0), # holds column names |
|||
| 381 | -12x | +|||
| 514 | +
- ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI+ extract_type = character(0), # type of the prefix in a subset call (eg. "list": x$var; "matrix": x[["var"]]) |
|||
| 382 | -12x | +|||
| 515 | +
- eventExpr = fs_callback(), # when remove button is clicked in the FilterState ui+ fun = quote(subset), # function used to generate subset call |
|||
| 383 | -12x | +|||
| 516 | +
- handlerExpr = private$state_list_remove(state$get_state()$id)+ keys = character(0), |
|||
| 384 | +517 |
- )+ ns = NULL, # shiny ns() |
||
| 385 | +518 |
- })+ observers = list(), # observers |
||
| 386 | -10x | +|||
| 519 | +
- added_states(NULL)+ state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes, |
|||
| 387 | +520 |
- }+ |
||
| 388 | +521 |
- )+ # private methods ---- |
||
| 389 | +522 | |||
| 390 | -12x | -
- NULL- |
- ||
| 391 | +523 |
- }+ # @description |
||
| 392 | +524 |
- )+ # Set the allowed filterable variables |
||
| 393 | +525 |
- },+ # @param include_varnames (`character`) Names of variables included in filtering. |
||
| 394 | +526 |
-
+ # @param exclude_varnames (`character`) Names of variables excluded from filtering. |
||
| 395 | +527 |
- #' @description+ # |
||
| 396 | +528 |
- #' `shiny` UI module to add filter variable.+ # @details When retrieving the filtered variables only |
||
| 397 | +529 |
- #'+ # those which have filtering supported (i.e. are of the permitted types). |
||
| 398 | +530 |
- #' @param id (`character(1)`)+ # Only one from `include_varnames` and `exclude_varnames` can be used in one call. When `exclude_varnames` |
||
| 399 | +531 |
- #' `shiny` module instance id.+ # is called `include_varnames` is cleared - same otherwise. |
||
| 400 | +532 |
- #'+ # are included. |
||
| 401 | +533 |
- #' @return `shiny.tag`+ # |
||
| 402 | +534 |
- #'+ # @return `NULL`, invisibly. |
||
| 403 | +535 |
- ui_add = function(id) {
+ set_filterable_varnames = function(include_varnames = character(0), exclude_varnames = character(0)) {
|
||
| 404 | -1x | +536 | +288x |
- checkmate::assert_string(id)+ if ((length(include_varnames) + length(exclude_varnames)) == 0L) {
|
| 405 | -1x | +537 | +113x |
- data <- private$data+ return(invisible(NULL)) |
| 406 | +538 |
-
+ } |
||
| 407 | -1x | -
- ns <- NS(id)- |
- ||
| 408 | -+ | 539 | +175x |
-
+ checkmate::assert_character(include_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE) |
| 409 | -1x | +540 | +175x |
- if (ncol(data) == 0) {
+ checkmate::assert_character(exclude_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE) |
| 410 | -1x | +541 | +175x |
- tags$div("no sample variables available")
+ if (length(include_varnames) && length(exclude_varnames)) {
|
| 411 | +542 | ! |
- } else if (nrow(data) == 0) {
+ stop( |
|
| 412 | +543 | ! |
- tags$div("no samples available")
+ "`include_varnames` and `exclude_varnames` has been both specified for", |
|
| 413 | -+ | |||
| 544 | +! |
- } else {
+ private$dataname, |
||
| 414 | +545 | ! |
- uiOutput(ns("add_filter"))
+ ". Only one per dataset is allowed.", |
|
| 415 | +546 |
- }+ ) |
||
| 416 | +547 |
- },+ } |
||
| 417 | -+ | |||
| 548 | +175x |
-
+ supported_vars <- get_supported_filter_varnames(private$data) |
||
| 418 | -+ | |||
| 549 | +175x |
- #' @description+ if (length(include_varnames)) {
|
||
| 419 | -+ | |||
| 550 | +161x |
- #' `shiny` server module to add filter variable.+ private$include_varnames <- intersect(include_varnames, supported_vars) |
||
| 420 | -+ | |||
| 551 | +161x |
- #'+ private$exclude_varnames <- character(0) |
||
| 421 | +552 |
- #' This module controls available choices to select as a filter variable.+ } else {
|
||
| 422 | -+ | |||
| 553 | +14x |
- #' Once selected, a variable is removed from available choices.+ private$exclude_varnames <- exclude_varnames |
||
| 423 | -+ | |||
| 554 | +14x |
- #' Removing a filter variable adds it back to available choices.+ private$include_varnames <- character(0) |
||
| 424 | +555 |
- #'+ }+ |
+ ||
| 556 | +175x | +
+ invisible(NULL) |
||
| 425 | +557 |
- #' @param id (`character(1)`)+ }, |
||
| 426 | +558 |
- #' `shiny` module instance id.+ |
||
| 427 | +559 |
- #'+ # @description |
||
| 428 | +560 |
- #' @return `NULL`.+ # Get vector of filterable varnames |
||
| 429 | +561 |
- srv_add = function(id) {
- |
- ||
| 430 | -8x | -
- moduleServer(- |
- ||
| 431 | -8x | -
- id = id,- |
- ||
| 432 | -8x | -
- function(input, output, session) {
- |
- ||
| 433 | -8x | -
- logger::log_trace("FilterStates$srv_add initializing, dataname: { private$dataname }")
+ # |
||
| 434 | +562 |
-
+ # @details |
||
| 435 | +563 |
- # available choices to display- |
- ||
| 436 | -8x | -
- avail_column_choices <- reactive({
+ # These are the only columns which can be used in the filter panel |
||
| 437 | -9x | +|||
| 564 | +
- data <- private$data+ # |
|||
| 438 | -9x | +|||
| 565 | +
- vars_include <- private$get_filterable_varnames()+ # @return character vector with names of the columns |
|||
| 439 | -9x | +|||
| 566 | +
- active_filter_vars <- unique(unlist(lapply(self$get_filter_state(), "[[", "varname")))+ get_filterable_varnames = function() {
|
|||
| 440 | -9x | +567 | +144x |
- choices <- setdiff(vars_include, active_filter_vars)+ if (length(private$include_varnames)) {
|
| 441 | -9x | +568 | +97x |
- varlabels <- get_varlabels(data)+ private$include_varnames |
| 442 | +569 | - - | -||
| 443 | -9x | -
- data_choices_labeled(- |
- ||
| 444 | -9x | -
- data = data,+ } else {
|
||
| 445 | -9x | +570 | +47x |
- choices = choices,+ supported_varnames <- get_supported_filter_varnames(private$data) |
| 446 | -9x | +571 | +47x |
- varlabels = varlabels,+ setdiff(supported_varnames, private$exclude_varnames) |
| 447 | -9x | +|||
| 572 | +
- keys = private$keys+ } |
|||
| 448 | +573 |
- )+ }, |
||
| 449 | +574 |
- })+ |
||
| 450 | +575 |
-
+ # state_list methods ---- |
||
| 451 | +576 | |||
| 452 | -8x | +|||
| 577 | +
- output$add_filter <- renderUI({
+ # @description |
|||
| 453 | -6x | +|||
| 578 | +
- logger::log_trace(+ # Returns a list of `FilterState` objects stored in this `FilterStates`. |
|||
| 454 | -6x | +|||
| 579 | +
- "FilterStates$srv_add@1 updating available column choices, dataname: { private$dataname }"
+ # |
|||
| 455 | +580 |
- )+ # @param state_id (`character(1)`) |
||
| 456 | -6x | +|||
| 581 | +
- if (length(avail_column_choices()) == 0) {
+ # name of element in a filter state (which is a `reactiveVal` containing a list) |
|||
| 457 | -! | +|||
| 582 | +
- tags$span("No available columns to add.")
+ # |
|||
| 458 | +583 |
- } else {
+ # @return `list` of `FilterState` objects |
||
| 459 | -6x | +|||
| 584 | +
- tags$div(+ # |
|||
| 460 | -6x | +|||
| 585 | +
- teal.widgets::optionalSelectInput(+ state_list_get = function(state_id = NULL) {
|
|||
| 461 | -6x | +586 | +212x |
- session$ns("var_to_add"),
+ checkmate::assert_string(state_id, null.ok = TRUE) |
| 462 | -6x | +|||
| 587 | +
- choices = avail_column_choices(),+ |
|||
| 463 | -6x | +588 | +212x |
- selected = NULL,+ if (is.null(state_id)) {
|
| 464 | -6x | +589 | +212x |
- options = shinyWidgets::pickerOptions(+ private$state_list() |
| 465 | -6x | +|||
| 590 | +
- liveSearch = TRUE,+ } else {
|
|||
| 466 | -6x | +|||
| 591 | +! |
- noneSelectedText = "Select variable to filter"+ private$state_list()[[state_id]] |
||
| 467 | +592 |
- )+ } |
||
| 468 | +593 |
- )+ }, |
||
| 469 | +594 |
- )+ |
||
| 470 | +595 |
- }+ # @description |
||
| 471 | +596 |
- })+ # Adds a new `FilterState` object to this `FilterStates`. |
||
| 472 | +597 | - - | -||
| 473 | -8x | -
- observeEvent(- |
- ||
| 474 | -8x | -
- eventExpr = input$var_to_add,- |
- ||
| 475 | -8x | -
- handlerExpr = {
- |
- ||
| 476 | -3x | -
- logger::log_trace(- |
- ||
| 477 | -3x | -
- sprintf(- |
- ||
| 478 | -3x | -
- "FilterStates$srv_add@2 adding FilterState of variable %s, dataname: %s",+ # Raises error if the length of `x` does not match the length of `state_id`. |
||
| 479 | -3x | +|||
| 598 | +
- input$var_to_add,+ # |
|||
| 480 | -3x | +|||
| 599 | +
- private$dataname+ # @param x (`FilterState`) |
|||
| 481 | +600 |
- )+ # object to be added to filter state list |
||
| 482 | +601 |
- )+ # @param state_id (`character(1)`) |
||
| 483 | -3x | +|||
| 602 | +
- self$set_filter_state(+ # name of element in a filter state (which is a `reactiveVal` containing a list) |
|||
| 484 | -3x | +|||
| 603 | +
- teal_slices(+ # |
|||
| 485 | -3x | +|||
| 604 | +
- teal_slice(dataname = private$dataname, varname = input$var_to_add)+ # @return `NULL`. |
|||
| 486 | +605 |
- )+ # |
||
| 487 | +606 |
- )+ state_list_push = function(x, state_id) {
|
||
| 488 | -3x | +607 | +183x |
- logger::log_trace(+ logger::log_trace("{ class(self)[1] } pushing into state_list, dataname: { private$dataname }")
|
| 489 | -3x | +608 | +183x |
- sprintf(+ checkmate::assert_string(state_id) |
| 490 | -3x | +609 | +183x |
- "FilterStates$srv_add@2 added FilterState of variable %s, dataname: %s",+ checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
|
| 491 | -3x | +610 | +183x |
- input$var_to_add,+ state <- stats::setNames(list(x), state_id) |
| 492 | -3x | +611 | +183x |
- private$dataname+ new_state_list <- c( |
| 493 | -+ | |||
| 612 | +183x |
- )+ isolate(private$state_list()), |
||
| 494 | -+ | |||
| 613 | +183x |
- )+ state |
||
| 495 | +614 |
- }+ ) |
||
| 496 | -+ | |||
| 615 | +183x |
- )+ isolate(private$state_list(new_state_list)) |
||
| 497 | +616 | |||
| 498 | -8x | +617 | +183x |
- logger::log_trace("FilterStates$srv_add initialized, dataname: { private$dataname }")
+ logger::log_trace("{ class(self)[1] } pushed into queue, dataname: { private$dataname }")
|
| 499 | -8x | +618 | +183x |
- NULL+ invisible(NULL) |
| 500 | +619 |
- }+ }, |
||
| 501 | +620 |
- )+ |
||
| 502 | +621 |
- }+ # @description |
||
| 503 | +622 |
- ),+ # Removes a single filter state with all associated shiny elements: |
||
| 504 | +623 |
- private = list(+ # * specified `FilterState` from `private$state_list` |
||
| 505 | +624 |
- # private fields ----+ # * UI card created for this filter |
||
| 506 | +625 |
- count_type = "none", # specifies how observation numbers are displayed in filter cards,+ # * observers tracking the selection and remove button |
||
| 507 | +626 |
- data = NULL, # data.frame, MAE, SE or matrix+ # |
||
| 508 | +627 |
- data_reactive = NULL, # reactive+ # @param state_id (`character`) |
||
| 509 | +628 |
- datalabel = NULL, # to follow default `experiment = NULL` in `teal_slice`+ # identifiers of elements in a filter state (which is a `reactiveVal` containing a list). |
||
| 510 | +629 |
- dataname = NULL, # because it holds object of class name+ # @param force (`logical(1)`) |
||
| 511 | +630 |
- dataname_prefixed = character(0), # name used in call returned from get_call+ # flag specifying whether to include anchored filter states. |
||
| 512 | +631 |
- exclude_varnames = character(0), # holds column names+ # |
||
| 513 | +632 |
- include_varnames = character(0), # holds column names+ # @return `NULL`, invisibly. |
||
| 514 | +633 |
- extract_type = character(0), # type of the prefix in a subset call (eg. "list": x$var; "matrix": x[["var"]])+ # |
||
| 515 | +634 |
- fun = quote(subset), # function used to generate subset call+ state_list_remove = function(state_id, force = FALSE) {
|
||
| 516 | -+ | |||
| 635 | +32x |
- keys = character(0),+ checkmate::assert_character(state_id) |
||
| 517 | -+ | |||
| 636 | +32x |
- ns = NULL, # shiny ns()+ logger::log_trace("{ class(self)[1] } removing a filter, state_id: { toString(state_id) }")
|
||
| 518 | +637 |
- observers = list(), # observers+ |
||
| 519 | -+ | |||
| 638 | +32x |
- state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes,+ isolate({
|
||
| 520 | -+ | |||
| 639 | +32x |
-
+ current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1)) |
||
| 521 | -+ | |||
| 640 | +32x |
- # private methods ----+ to_remove <- state_id %in% current_state_ids |
||
| 522 | -+ | |||
| 641 | +32x |
-
+ if (any(to_remove)) {
|
||
| 523 | -+ | |||
| 642 | +31x |
- # @description+ new_state_list <- Filter( |
||
| 524 | -+ | |||
| 643 | +31x |
- # Set the allowed filterable variables+ function(state) {
|
||
| 525 | -+ | |||
| 644 | +68x |
- # @param include_varnames (`character`) Names of variables included in filtering.+ if (state$get_state()$id %in% state_id) {
|
||
| 526 | -+ | |||
| 645 | +54x |
- # @param exclude_varnames (`character`) Names of variables excluded from filtering.+ if (state$get_state()$anchored && !force) {
|
||
| 527 | -+ | |||
| 646 | +7x |
- #+ return(TRUE) |
||
| 528 | +647 |
- # @details When retrieving the filtered variables only+ } else {
|
||
| 529 | -+ | |||
| 648 | +47x |
- # those which have filtering supported (i.e. are of the permitted types).+ state$destroy_observers() |
||
| 530 | -+ | |||
| 649 | +47x |
- # Only one from `include_varnames` and `exclude_varnames` can be used in one call. When `exclude_varnames`+ FALSE |
||
| 531 | +650 |
- # is called `include_varnames` is cleared - same otherwise.+ } |
||
| 532 | +651 |
- # are included.+ } else {
|
||
| 533 | -+ | |||
| 652 | +14x |
- #+ TRUE |
||
| 534 | +653 |
- # @return `NULL`, invisibly.+ } |
||
| 535 | +654 |
- set_filterable_varnames = function(include_varnames = character(0), exclude_varnames = character(0)) {
- |
- ||
| 536 | -288x | -
- if ((length(include_varnames) + length(exclude_varnames)) == 0L) {
+ }, |
||
| 537 | -113x | +655 | +31x |
- return(invisible(NULL))+ private$state_list() |
| 538 | +656 |
- }+ ) |
||
| 539 | -175x | +657 | +31x |
- checkmate::assert_character(include_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE)+ private$state_list(new_state_list) |
| 540 | -175x | +|||
| 658 | +
- checkmate::assert_character(exclude_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE)+ } else {
|
|||
| 541 | -175x | +659 | +1x |
- if (length(include_varnames) && length(exclude_varnames)) {
+ warning(sprintf("\"%s\" not found in state list", state_id))
|
| 542 | -! | +|||
| 660 | +
- stop(+ } |
|||
| 543 | -! | +|||
| 661 | +
- "`include_varnames` and `exclude_varnames` has been both specified for",+ }) |
|||
| 544 | -! | +|||
| 662 | +
- private$dataname,+ |
|||
| 545 | -! | +|||
| 663 | +32x |
- ". Only one per dataset is allowed.",+ invisible(NULL) |
||
| 546 | +664 |
- )+ }, |
||
| 547 | +665 |
- }- |
- ||
| 548 | -175x | -
- supported_vars <- get_supported_filter_varnames(private$data)+ |
||
| 549 | -175x | +|||
| 666 | +
- if (length(include_varnames)) {
+ # @description |
|||
| 550 | -161x | +|||
| 667 | +
- private$include_varnames <- intersect(include_varnames, supported_vars)+ # Remove all `FilterState` objects from this `FilterStates` object. |
|||
| 551 | -161x | +|||
| 668 | +
- private$exclude_varnames <- character(0)+ # @param force (`logical(1)`) |
|||
| 552 | +669 |
- } else {
+ # flag specifying whether to include anchored filter states. |
||
| 553 | -14x | +|||
| 670 | +
- private$exclude_varnames <- exclude_varnames+ # @return `NULL`, invisibly. |
|||
| 554 | -14x | +|||
| 671 | +
- private$include_varnames <- character(0)+ # |
|||
| 555 | +672 |
- }+ state_list_empty = function(force = FALSE) {
|
||
| 556 | -175x | +673 | +25x |
- invisible(NULL)+ isolate({
|
| 557 | -+ | |||
| 674 | +25x |
- },+ logger::log_trace( |
||
| 558 | -+ | |||
| 675 | +25x |
-
+ "{ class(self)[1] }$state_list_empty removing all non-anchored filters for dataname: { private$dataname }"
|
||
| 559 | +676 |
- # @description+ ) |
||
| 560 | +677 |
- # Get vector of filterable varnames+ |
||
| 561 | -+ | |||
| 678 | +25x |
- #+ state_list <- private$state_list() |
||
| 562 | -+ | |||
| 679 | +25x |
- # @details+ if (length(state_list)) {
|
||
| 563 | -+ | |||
| 680 | +15x |
- # These are the only columns which can be used in the filter panel+ state_ids <- vapply(state_list, function(x) x$get_state()$id, character(1)) |
||
| 564 | -+ | |||
| 681 | +15x |
- #+ private$state_list_remove(state_ids, force) |
||
| 565 | +682 |
- # @return character vector with names of the columns+ } |
||
| 566 | +683 |
- get_filterable_varnames = function() {
- |
- ||
| 567 | -144x | -
- if (length(private$include_varnames)) {
- |
- ||
| 568 | -97x | -
- private$include_varnames+ }) |
||
| 569 | +684 |
- } else {
+
|
||
| 570 | -47x | +685 | +25x |
- supported_varnames <- get_supported_filter_varnames(private$data)+ invisible(NULL) |
| 571 | -47x | +|||
| 686 | +
- setdiff(supported_varnames, private$exclude_varnames)+ }, |
|||
| 572 | +687 |
- }+ |
||
| 573 | +688 |
- },+ # @description |
||
| 574 | +689 |
-
+ # Set filter state |
||
| 575 | +690 |
- # state_list methods ----+ # |
||
| 576 | +691 |
-
+ # Utility method for `set_filter_state` to create or modify `FilterState` using a single |
||
| 577 | +692 |
- # @description+ # `teal_slice`. |
||
| 578 | +693 |
- # Returns a list of `FilterState` objects stored in this `FilterStates`.+ # @param state (`teal_slices`) |
||
| 579 | +694 |
- #+ # @param data (`data.frame`, `matrix` or `DataFrame`) |
||
| 580 | +695 |
- # @param state_id (`character(1)`)+ # @param data_reactive (`function`) |
||
| 581 | +696 |
- # name of element in a filter state (which is a `reactiveVal` containing a list)+ # function having `sid` as argument. |
||
| 582 | +697 |
# |
||
| 583 | +698 |
- # @return `list` of `FilterState` objects+ # @return `NULL`, invisibly. |
||
| 584 | +699 |
# |
||
| 585 | +700 |
- state_list_get = function(state_id = NULL) {
+ set_filter_state_impl = function(state, |
||
| 586 | -212x | +|||
| 701 | +
- checkmate::assert_string(state_id, null.ok = TRUE)+ data, |
|||
| 587 | +702 |
-
+ data_reactive) {
|
||
| 588 | -212x | +703 | +211x |
- if (is.null(state_id)) {
+ checkmate::assert_class(state, "teal_slices") |
| 589 | -212x | +704 | +211x |
- private$state_list()+ checkmate::assert_multi_class(data, c("data.frame", "matrix", "DataFrame", "HermesData"))
|
| 590 | -+ | |||
| 705 | +211x |
- } else {
+ checkmate::assert_function(data_reactive, args = "sid") |
||
| 591 | -! | +|||
| 706 | +211x |
- private$state_list()[[state_id]]+ if (length(state) == 0L) {
|
||
| 592 | -+ | |||
| 707 | +101x |
- }+ return(invisible(NULL)) |
||
| 593 | +708 |
- },+ } |
||
| 594 | +709 | |||
| 595 | -+ | |||
| 710 | +110x |
- # @description+ slices_hashed <- vapply(state, `[[`, character(1L), "id") |
||
| 596 | -+ | |||
| 711 | +110x |
- # Adds a new `FilterState` object to this `FilterStates`.+ if (any(duplicated(slices_hashed))) {
|
||
| 597 | -+ | |||
| 712 | +! |
- # Raises error if the length of `x` does not match the length of `state_id`.+ stop( |
||
| 598 | -+ | |||
| 713 | +! |
- #+ "Some of the teal_slice objects refer to the same filter. ", |
||
| 599 | -+ | |||
| 714 | +! |
- # @param x (`FilterState`)+ "Please specify different 'id' when calling teal_slice" |
||
| 600 | +715 |
- # object to be added to filter state list+ ) |
||
| 601 | +716 |
- # @param state_id (`character(1)`)+ } |
||
| 602 | +717 |
- # name of element in a filter state (which is a `reactiveVal` containing a list)- |
- ||
| 603 | -- |
- #- |
- ||
| 604 | -- |
- # @return `NULL`.- |
- ||
| 605 | -- |
- #- |
- ||
| 606 | -- |
- state_list_push = function(x, state_id) {
- |
- ||
| 607 | -183x | -
- logger::log_trace("{ class(self)[1] } pushing into state_list, dataname: { private$dataname }")
+
|
||
| 608 | -183x | +718 | +110x |
- checkmate::assert_string(state_id)+ state_list <- isolate(private$state_list_get()) |
| 609 | -183x | +719 | +110x |
- checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
+ lapply(state, function(slice) {
|
| 610 | -183x | +720 | +191x |
- state <- stats::setNames(list(x), state_id)+ state_id <- slice$id |
| 611 | -183x | +721 | +191x |
- new_state_list <- c(+ if (state_id %in% names(state_list)) {
|
| 612 | -183x | +|||
| 722 | +
- isolate(private$state_list()),+ # Modify existing filter states. |
|||
| 613 | -183x | +723 | +8x |
- state+ state_list[[state_id]]$set_state(slice) |
| 614 | +724 |
- )+ } else {
|
||
| 615 | +725 | 183x |
- isolate(private$state_list(new_state_list))+ if (inherits(slice, "teal_slice_expr")) {
|
|
| 616 | +726 | - - | -||
| 617 | -183x | -
- logger::log_trace("{ class(self)[1] } pushed into queue, dataname: { private$dataname }")
+ # create a new FilterStateExpr |
||
| 618 | -183x | -
- invisible(NULL)- |
- ||
| 619 | -+ | 727 | +6x |
- },+ fstate <- init_filter_state_expr(slice) |
| 620 | +728 |
-
+ } else {
|
||
| 621 | +729 |
- # @description+ # create a new FilterState |
||
| 622 | -+ | |||
| 730 | +177x |
- # Removes a single filter state with all associated shiny elements:+ fstate <- init_filter_state( |
||
| 623 | -+ | |||
| 731 | +177x |
- # * specified `FilterState` from `private$state_list`+ x = data[, slice$varname, drop = TRUE], |
||
| 624 | +732 |
- # * UI card created for this filter+ # data_reactive is a function which eventually calls get_call(sid). |
||
| 625 | +733 |
- # * observers tracking the selection and remove button+ # This chain of calls returns column from the data filtered by everything |
||
| 626 | +734 |
- #+ # but filter identified by the sid argument. FilterState then get x_reactive |
||
| 627 | +735 |
- # @param state_id (`character`)+ # and this no longer needs to be a function to pass sid. reactive in the FilterState |
||
| 628 | +736 |
- # identifiers of elements in a filter state (which is a `reactiveVal` containing a list).+ # is also beneficial as it can be cached and retriger filter counts only if |
||
| 629 | +737 |
- # @param force (`logical(1)`)+ # returned vector is different. |
||
| 630 | -+ | |||
| 738 | +177x |
- # flag specifying whether to include anchored filter states.+ x_reactive = if (private$count_type == "none") {
|
||
| 631 | -+ | |||
| 739 | +171x |
- #+ reactive(NULL) |
||
| 632 | +740 |
- # @return `NULL`, invisibly.+ } else {
|
||
| 633 | -+ | |||
| 741 | +6x |
- #+ reactive(data_reactive(state_id)[, slice$varname, drop = TRUE]) |
||
| 634 | +742 |
- state_list_remove = function(state_id, force = FALSE) {
+ }, |
||
| 635 | -32x | +743 | +177x |
- checkmate::assert_character(state_id)+ slice = slice, |
| 636 | -32x | +744 | +177x |
- logger::log_trace("{ class(self)[1] } removing a filter, state_id: { toString(state_id) }")
+ extract_type = private$extract_type |
| 637 | +745 | - - | -||
| 638 | -32x | -
- isolate({
+ ) |
||
| 639 | -32x | +|||
| 746 | +
- current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1))+ } |
|||
| 640 | -32x | +747 | +183x |
- to_remove <- state_id %in% current_state_ids+ private$state_list_push(x = fstate, state_id = state_id) |
| 641 | -32x | +|||
| 748 | +
- if (any(to_remove)) {
+ } |
|||
| 642 | -31x | +|||
| 749 | +
- new_state_list <- Filter(+ }) |
|||
| 643 | -31x | +|||
| 750 | +
- function(state) {
+
|
|||
| 644 | -68x | +751 | +110x |
- if (state$get_state()$id %in% state_id) {
+ invisible(NULL) |
| 645 | -54x | +|||
| 752 | +
- if (state$get_state()$anchored && !force) {
+ } |
|||
| 646 | -7x | +|||
| 753 | +
- return(TRUE)+ ) |
|||
| 647 | +754 |
- } else {
+ ) |
||
| 648 | -47x | +
| 1 | +
- state$destroy_observers()+ #' Specify single filter |
||
| 649 | -47x | +||
| 2 | +
- FALSE+ #' |
||
| 650 | +3 |
- }+ #' Create a `teal_slice` object that holds complete information on filtering one variable. |
|
| 651 | +4 |
- } else {
+ #' Check out [`teal_slice-utilities`] functions for working with `teal_slice` object. |
|
| 652 | -14x | +||
| 5 | +
- TRUE+ #' |
||
| 653 | +6 |
- }+ #' `teal_slice` object fully describes filter state and can be used to create, |
|
| 654 | +7 |
- },+ #' modify, and delete a filter state. A `teal_slice` contains a number of common fields |
|
| 655 | -31x | +||
| 8 | +
- private$state_list()+ #' (all named arguments of `teal_slice`), some of which are mandatory, but only |
||
| 656 | +9 |
- )+ #' `dataname` and either `varname` or `expr` must be specified, while the others have default |
|
| 657 | -31x | +||
| 10 | +
- private$state_list(new_state_list)+ #' values. |
||
| 658 | +11 |
- } else {
+ #' |
|
| 659 | -1x | +||
| 12 | +
- warning(sprintf("\"%s\" not found in state list", state_id))
+ #' Setting any of the other values to `NULL` means that those properties will not be modified |
||
| 660 | +13 |
- }+ #' (when setting an existing state) or that they will be determined by data (when creating new a new one). |
|
| 661 | +14 |
- })+ #' Entire object is `FilterState` class member and can be accessed with `FilterState$get_state()`. |
|
| 662 | +15 |
-
+ #' |
|
| 663 | -32x | +||
| 16 | +
- invisible(NULL)+ #' A `teal_slice` can come in two flavors: |
||
| 664 | +17 |
- },+ #' 1. `teal_slice_var` - |
|
| 665 | +18 |
-
+ #' this describes a typical interactive filter that refers to a single variable, managed by the `FilterState` class. |
|
| 666 | +19 |
- # @description+ #' This class is created when `varname` is specified. |
|
| 667 | +20 |
- # Remove all `FilterState` objects from this `FilterStates` object.+ #' The object retains all fields specified in the call. `id` can be created by default and need not be specified. |
|
| 668 | +21 |
- # @param force (`logical(1)`)+ #' 2. `teal_slice_expr` - |
|
| 669 | +22 |
- # flag specifying whether to include anchored filter states.+ #' this describes a filter state that refers to an expression, which can potentially include multiple variables, |
|
| 670 | +23 |
- # @return `NULL`, invisibly.+ #' managed by the `FilterStateExpr` class. |
|
| 671 | +24 |
- #+ #' This class is created when `expr` is specified. |
|
| 672 | +25 |
- state_list_empty = function(force = FALSE) {
+ #' `dataname` and `anchored` are retained, `fixed` is set to `TRUE`, `id` becomes mandatory, `title` |
|
| 673 | -25x | +||
| 26 | +
- isolate({
+ #' remains optional, while other arguments are disregarded. |
||
| 674 | -25x | +||
| 27 | +
- logger::log_trace(+ #' |
||
| 675 | -25x | +||
| 28 | +
- "{ class(self)[1] }$state_list_empty removing all non-anchored filters for dataname: { private$dataname }"
+ #' A teal_slice can be passed `FilterState`/`FilterStateExpr` constructors to instantiate an object. |
||
| 676 | +29 |
- )+ #' It can also be passed to `FilterState$set_state` to modify the state. |
|
| 677 | +30 |
-
+ #' However, once a `FilterState` is created, only the mutable features can be set with a teal_slice: |
|
| 678 | -25x | +||
| 31 | +
- state_list <- private$state_list()+ #' `selected`, `keep_na` and `keep_inf`. |
||
| 679 | -25x | +||
| 32 | +
- if (length(state_list)) {
+ #' |
||
| 680 | -15x | +||
| 33 | +
- state_ids <- vapply(state_list, function(x) x$get_state()$id, character(1))+ #' Special consideration is given to two fields: `fixed` and `anchored`. |
||
| 681 | -15x | +||
| 34 | +
- private$state_list_remove(state_ids, force)+ #' These are always immutable logical flags that default to `FALSE`. |
||
| 682 | +35 |
- }+ #' In a `FilterState` instantiated with `fixed = TRUE` the features |
|
| 683 | +36 |
- })+ #' `selected`, `keep_na`, `keep_inf` cannot be changed. |
|
| 684 | +37 |
-
+ #' Note that a `FilterStateExpr` is always considered to have `fixed = TRUE`. |
|
| 685 | -25x | +||
| 38 | +
- invisible(NULL)+ #' A `FilterState` instantiated with `anchored = TRUE` cannot be removed. |
||
| 686 | +39 |
- },+ #' |
|
| 687 | +40 |
-
+ #' @section Filters in `SumarizedExperiment` and `MultiAssayExperiment` objects: |
|
| 688 | +41 |
- # @description+ #' |
|
| 689 | +42 |
- # Set filter state+ #' To establish a filter on a column in a `data.frame`, `dataname` and `varname` are sufficient. |
|
| 690 | +43 |
- #+ #' `MultiAssayExperiment` objects can be filtered either on their `colData` slot (which contains subject information) |
|
| 691 | +44 |
- # Utility method for `set_filter_state` to create or modify `FilterState` using a single+ #' or on their experiments, which are stored in the `experimentList` slot. |
|
| 692 | +45 |
- # `teal_slice`.+ #' For filters referring to `colData` no extra arguments are needed. |
|
| 693 | +46 |
- # @param state (`teal_slices`)+ #' If a filter state is created for an experiment, that experiment name must be specified in the `experiment` argument. |
|
| 694 | +47 |
- # @param data (`data.frame`, `matrix` or `DataFrame`)+ #' Furthermore, to specify filter for an `SummarizedExperiment` one must also set `arg` |
|
| 695 | +48 |
- # @param data_reactive (`function`)+ #' (`"subset"` or `"select"`, arguments in the [subset()] function for `SummarizedExperiment`) |
|
| 696 | +49 |
- # function having `sid` as argument.+ #' in order to determine whether the filter refers to the `SE`'s `rowData` or `colData`. |
|
| 697 | +50 |
- #+ #' |
|
| 698 | +51 |
- # @return `NULL`, invisibly.+ #' @param dataname (`character(1)`) name of data set |
|
| 699 | +52 |
- #+ #' @param varname (`character(1)`) name of variable |
|
| 700 | +53 |
- set_filter_state_impl = function(state,+ #' @param id (`character(1)`) identifier of the filter. Must be specified when `expr` is set. |
|
| 701 | +54 |
- data,+ #' When `varname` is specified then `id` is set to `"{dataname} {varname}"` by default.
|
|
| 702 | +55 |
- data_reactive) {
- |
- |
| 703 | -211x | -
- checkmate::assert_class(state, "teal_slices")- |
- |
| 704 | -211x | -
- checkmate::assert_multi_class(data, c("data.frame", "matrix", "DataFrame", "HermesData"))
- |
- |
| 705 | -211x | -
- checkmate::assert_function(data_reactive, args = "sid")- |
- |
| 706 | -211x | -
- if (length(state) == 0L) {
- |
- |
| 707 | -101x | -
- return(invisible(NULL))+ #' @param expr (`character(1)`) string providing a logical expression. |
|
| 708 | +56 |
- }+ #' Must be a valid `R` expression which can be evaluated in the context of the data set. |
|
| 709 | +57 | - - | -|
| 710 | -110x | -
- slices_hashed <- vapply(state, `[[`, character(1L), "id")- |
- |
| 711 | -110x | -
- if (any(duplicated(slices_hashed))) {
- |
- |
| 712 | -! | -
- stop(- |
- |
| 713 | -! | -
- "Some of the teal_slice objects refer to the same filter. ",- |
- |
| 714 | -! | -
- "Please specify different 'id' when calling teal_slice"+ #' For a `data.frame` `var == "x"` is sufficient, but `MultiAssayExperiment::subsetByColData` |
|
| 715 | +58 |
- )+ #' requires `dataname` prefix, *e.g.* `data$var == "x"`. |
|
| 716 | +59 |
- }+ #' @param choices (`vector`) optional, specifies allowed choices; |
|
| 717 | +60 | - - | -|
| 718 | -110x | -
- state_list <- isolate(private$state_list_get())- |
- |
| 719 | -110x | -
- lapply(state, function(slice) {
- |
- |
| 720 | -191x | -
- state_id <- slice$id- |
- |
| 721 | -191x | -
- if (state_id %in% names(state_list)) {
+ #' When specified it should be a subset of values in variable denoted by `varname`; |
|
| 722 | +61 |
- # Modify existing filter states.- |
- |
| 723 | -8x | -
- state_list[[state_id]]$set_state(slice)+ #' Type and size depends on variable type. Factors are coerced to character. |
|
| 724 | +62 |
- } else {
- |
- |
| 725 | -183x | -
- if (inherits(slice, "teal_slice_expr")) {
+ #' @param selected (`vector`) optional, specifies selected values from `choices`; |
|
| 726 | +63 |
- # create a new FilterStateExpr- |
- |
| 727 | -6x | -
- fstate <- init_filter_state_expr(slice)+ #' Type and size depends on variable type. Factors are coerced to character. |
|
| 728 | +64 |
- } else {
+ #' @param multiple (`logical(1)`) optional flag specifying whether more than one value can be selected; |
|
| 729 | +65 |
- # create a new FilterState- |
- |
| 730 | -177x | -
- fstate <- init_filter_state(- |
- |
| 731 | -177x | -
- x = data[, slice$varname, drop = TRUE],+ #' only applicable to `ChoicesFilterState` and `LogicalFilterState` |
|
| 732 | +66 |
- # data_reactive is a function which eventually calls get_call(sid).+ #' @param keep_na (`logical(1)`) optional flag specifying whether to keep missing values |
|
| 733 | +67 |
- # This chain of calls returns column from the data filtered by everything+ #' @param keep_inf (`logical(1)`) optional flag specifying whether to keep infinite values |
|
| 734 | +68 |
- # but filter identified by the sid argument. FilterState then get x_reactive+ #' @param fixed (`logical(1)`) flag specifying whether to fix this filter state (forbid setting state) |
|
| 735 | +69 |
- # and this no longer needs to be a function to pass sid. reactive in the FilterState+ #' @param anchored (`logical(1)`) flag specifying whether to lock this filter state (forbid removing and inactivating) |
|
| 736 | +70 |
- # is also beneficial as it can be cached and retriger filter counts only if+ #' @param title (`character(1)`) optional title of the filter. Ignored when `varname` is set. |
|
| 737 | +71 |
- # returned vector is different.- |
- |
| 738 | -177x | -
- x_reactive = if (private$count_type == "none") {
- |
- |
| 739 | -171x | -
- reactive(NULL)+ #' @param ... additional arguments which can be handled by extensions of `teal.slice` classes. |
|
| 740 | +72 |
- } else {
- |
- |
| 741 | -6x | -
- reactive(data_reactive(state_id)[, slice$varname, drop = TRUE])+ #' |
|
| 742 | +73 |
- },- |
- |
| 743 | -177x | -
- slice = slice,- |
- |
| 744 | -177x | -
- extract_type = private$extract_type+ #' @return A `teal.slice` object. Depending on whether `varname` or `expr` was specified, the resulting |
|
| 745 | +74 |
- )+ #' `teal_slice` also receives class `teal_slice_var` or `teal_slice_expr`, respectively. |
|
| 746 | +75 |
- }- |
- |
| 747 | -183x | -
- private$state_list_push(x = fstate, state_id = state_id)+ #' |
|
| 748 | +76 |
- }+ #' @note Date time objects of `POSIX*t` classes are printed as strings after converting to UTC timezone. |
|
| 749 | +77 |
- })+ #' |
|
| 750 | +78 | - - | -|
| 751 | -110x | -
- invisible(NULL)+ #' @examples |
|
| 752 | +79 |
- }+ #' x1 <- teal_slice( |
|
| 753 | +80 |
- )+ #' dataname = "data", |
|
| 754 | +81 |
- )+ #' id = "Female adults", |
| 1 | +82 |
- #' Specify single filter+ #' expr = "SEX == 'F' & AGE >= 18", |
||
| 2 | +83 |
- #'+ #' title = "Female adults" |
||
| 3 | +84 |
- #' Create a `teal_slice` object that holds complete information on filtering one variable.+ #' ) |
||
| 4 | +85 |
- #' Check out [`teal_slice-utilities`] functions for working with `teal_slice` object.+ #' x2 <- teal_slice( |
||
| 5 | +86 |
- #'+ #' dataname = "data", |
||
| 6 | +87 |
- #' `teal_slice` object fully describes filter state and can be used to create,+ #' varname = "var", |
||
| 7 | +88 |
- #' modify, and delete a filter state. A `teal_slice` contains a number of common fields+ #' choices = c("F", "M", "U"),
|
||
| 8 | +89 |
- #' (all named arguments of `teal_slice`), some of which are mandatory, but only+ #' selected = "F", |
||
| 9 | +90 |
- #' `dataname` and either `varname` or `expr` must be specified, while the others have default+ #' keep_na = TRUE, |
||
| 10 | +91 |
- #' values.+ #' keep_inf = TRUE, |
||
| 11 | +92 |
- #'+ #' fixed = FALSE, |
||
| 12 | +93 |
- #' Setting any of the other values to `NULL` means that those properties will not be modified+ #' anchored = FALSE, |
||
| 13 | +94 |
- #' (when setting an existing state) or that they will be determined by data (when creating new a new one).+ #' multiple = TRUE, |
||
| 14 | +95 |
- #' Entire object is `FilterState` class member and can be accessed with `FilterState$get_state()`.+ #' id = "Gender", |
||
| 15 | +96 |
- #'+ #' extra_arg = "extra" |
||
| 16 | +97 |
- #' A `teal_slice` can come in two flavors:+ #' ) |
||
| 17 | +98 |
- #' 1. `teal_slice_var` -+ #' |
||
| 18 | +99 |
- #' this describes a typical interactive filter that refers to a single variable, managed by the `FilterState` class.+ #' is.teal_slice(x1) |
||
| 19 | +100 |
- #' This class is created when `varname` is specified.+ #' as.list(x1) |
||
| 20 | +101 |
- #' The object retains all fields specified in the call. `id` can be created by default and need not be specified.+ #' as.teal_slice(list(dataname = "a", varname = "var")) |
||
| 21 | +102 |
- #' 2. `teal_slice_expr` -+ #' format(x1) |
||
| 22 | +103 |
- #' this describes a filter state that refers to an expression, which can potentially include multiple variables,+ #' format(x1, show_all = TRUE, trim_lines = FALSE) |
||
| 23 | +104 |
- #' managed by the `FilterStateExpr` class.+ #' print(x1) |
||
| 24 | +105 |
- #' This class is created when `expr` is specified.+ #' print(x1, show_all = TRUE, trim_lines = FALSE) |
||
| 25 | +106 |
- #' `dataname` and `anchored` are retained, `fixed` is set to `TRUE`, `id` becomes mandatory, `title`+ #' |
||
| 26 | +107 |
- #' remains optional, while other arguments are disregarded.+ #' @seealso [`teal_slices`], |
||
| 27 | +108 |
- #'+ #' [`is.teal_slice`], [`as.teal_slice`], [`as.list.teal_slice`], [`print.teal_slice`], [`format.teal_slice`] |
||
| 28 | +109 |
- #' A teal_slice can be passed `FilterState`/`FilterStateExpr` constructors to instantiate an object.+ #' |
||
| 29 | +110 |
- #' It can also be passed to `FilterState$set_state` to modify the state.+ #' @export |
||
| 30 | +111 |
- #' However, once a `FilterState` is created, only the mutable features can be set with a teal_slice:+ teal_slice <- function(dataname, |
||
| 31 | +112 |
- #' `selected`, `keep_na` and `keep_inf`.+ varname, |
||
| 32 | +113 |
- #'+ id, |
||
| 33 | +114 |
- #' Special consideration is given to two fields: `fixed` and `anchored`.+ expr, |
||
| 34 | +115 |
- #' These are always immutable logical flags that default to `FALSE`.+ choices = NULL, |
||
| 35 | +116 |
- #' In a `FilterState` instantiated with `fixed = TRUE` the features+ selected = NULL, |
||
| 36 | +117 |
- #' `selected`, `keep_na`, `keep_inf` cannot be changed.+ keep_na = NULL, |
||
| 37 | +118 |
- #' Note that a `FilterStateExpr` is always considered to have `fixed = TRUE`.+ keep_inf = NULL, |
||
| 38 | +119 |
- #' A `FilterState` instantiated with `anchored = TRUE` cannot be removed.+ fixed = FALSE, |
||
| 39 | +120 |
- #'+ anchored = FALSE, |
||
| 40 | +121 |
- #' @section Filters in `SumarizedExperiment` and `MultiAssayExperiment` objects:+ multiple = TRUE, |
||
| 41 | +122 |
- #'+ title = NULL, |
||
| 42 | +123 |
- #' To establish a filter on a column in a `data.frame`, `dataname` and `varname` are sufficient.+ ...) {
|
||
| 43 | -+ | |||
| 124 | +580x |
- #' `MultiAssayExperiment` objects can be filtered either on their `colData` slot (which contains subject information)+ checkmate::assert_string(dataname) |
||
| 44 | -+ | |||
| 125 | +573x |
- #' or on their experiments, which are stored in the `experimentList` slot.+ checkmate::assert_flag(fixed) |
||
| 45 | -+ | |||
| 126 | +571x |
- #' For filters referring to `colData` no extra arguments are needed.+ checkmate::assert_flag(anchored) |
||
| 46 | +127 |
- #' If a filter state is created for an experiment, that experiment name must be specified in the `experiment` argument.+ |
||
| 47 | -+ | |||
| 128 | +569x |
- #' Furthermore, to specify filter for an `SummarizedExperiment` one must also set `arg`+ formal_args <- as.list(environment()) |
||
| 48 | +129 |
- #' (`"subset"` or `"select"`, arguments in the [subset()] function for `SummarizedExperiment`)+ |
||
| 49 | -+ | |||
| 130 | +569x |
- #' in order to determine whether the filter refers to the `SE`'s `rowData` or `colData`.+ if (!missing(expr) && !missing(varname)) {
|
||
| 50 | -+ | |||
| 131 | +! |
- #'+ stop("Must provide either `expr` or `varname`.")
|
||
| 51 | -+ | |||
| 132 | +569x |
- #' @param dataname (`character(1)`) name of data set+ } else if (!missing(expr)) {
|
||
| 52 | -+ | |||
| 133 | +30x |
- #' @param varname (`character(1)`) name of variable+ checkmate::assert_string(id) |
||
| 53 | -+ | |||
| 134 | +27x |
- #' @param id (`character(1)`) identifier of the filter. Must be specified when `expr` is set.+ checkmate::assert_string(title) |
||
| 54 | -+ | |||
| 135 | +24x |
- #' When `varname` is specified then `id` is set to `"{dataname} {varname}"` by default.
+ checkmate::assert_string(expr) |
||
| 55 | +136 |
- #' @param expr (`character(1)`) string providing a logical expression.+ |
||
| 56 | -+ | |||
| 137 | +23x |
- #' Must be a valid `R` expression which can be evaluated in the context of the data set.+ formal_args$fixed <- TRUE |
||
| 57 | -+ | |||
| 138 | +23x |
- #' For a `data.frame` `var == "x"` is sufficient, but `MultiAssayExperiment::subsetByColData`+ ts_expr_args <- c("dataname", "id", "expr", "fixed", "anchored", "title")
|
||
| 58 | -+ | |||
| 139 | +23x |
- #' requires `dataname` prefix, *e.g.* `data$var == "x"`.+ formal_args <- formal_args[ts_expr_args] |
||
| 59 | -+ | |||
| 140 | +23x |
- #' @param choices (`vector`) optional, specifies allowed choices;+ ans <- do.call(reactiveValues, c(formal_args, list(...))) |
||
| 60 | -+ | |||
| 141 | +23x |
- #' When specified it should be a subset of values in variable denoted by `varname`;+ class(ans) <- c("teal_slice_expr", "teal_slice", class(ans))
|
||
| 61 | -+ | |||
| 142 | +539x |
- #' Type and size depends on variable type. Factors are coerced to character.+ } else if (!missing(varname)) {
|
||
| 62 | -+ | |||
| 143 | +538x |
- #' @param selected (`vector`) optional, specifies selected values from `choices`;+ checkmate::assert_string(varname) |
||
| 63 | -+ | |||
| 144 | +535x |
- #' Type and size depends on variable type. Factors are coerced to character.+ checkmate::assert_multi_class(choices, .filterable_class, null.ok = TRUE) |
||
| 64 | -+ | |||
| 145 | +534x |
- #' @param multiple (`logical(1)`) optional flag specifying whether more than one value can be selected;+ checkmate::assert_multi_class(selected, .filterable_class, null.ok = TRUE) |
||
| 65 | -+ | |||
| 146 | +532x |
- #' only applicable to `ChoicesFilterState` and `LogicalFilterState`+ checkmate::assert_flag(keep_na, null.ok = TRUE) |
||
| 66 | -+ | |||
| 147 | +531x |
- #' @param keep_na (`logical(1)`) optional flag specifying whether to keep missing values+ checkmate::assert_flag(keep_inf, null.ok = TRUE) |
||
| 67 | -+ | |||
| 148 | +530x |
- #' @param keep_inf (`logical(1)`) optional flag specifying whether to keep infinite values+ checkmate::assert_flag(multiple) |
||
| 68 | +149 |
- #' @param fixed (`logical(1)`) flag specifying whether to fix this filter state (forbid setting state)+ |
||
| 69 | -+ | |||
| 150 | +530x |
- #' @param anchored (`logical(1)`) flag specifying whether to lock this filter state (forbid removing and inactivating)+ ts_var_args <- c( |
||
| 70 | -+ | |||
| 151 | +530x |
- #' @param title (`character(1)`) optional title of the filter. Ignored when `varname` is set.+ "dataname", "varname", "id", "choices", "selected", "keep_na", "keep_inf", |
||
| 71 | -+ | |||
| 152 | +530x |
- #' @param ... additional arguments which can be handled by extensions of `teal.slice` classes.+ "fixed", "anchored", "multiple" |
||
| 72 | +153 |
- #'+ ) |
||
| 73 | -+ | |||
| 154 | +530x |
- #' @return A `teal.slice` object. Depending on whether `varname` or `expr` was specified, the resulting+ formal_args <- formal_args[ts_var_args] |
||
| 74 | -+ | |||
| 155 | +530x |
- #' `teal_slice` also receives class `teal_slice_var` or `teal_slice_expr`, respectively.+ args <- c(formal_args, list(...)) |
||
| 75 | -+ | |||
| 156 | +530x |
- #'+ args[c("choices", "selected")] <-
|
||
| 76 | -+ | |||
| 157 | +530x |
- #' @note Date time objects of `POSIX*t` classes are printed as strings after converting to UTC timezone.+ lapply(args[c("choices", "selected")], function(x) if (is.factor(x)) as.character(x) else x)
|
||
| 77 | -+ | |||
| 158 | +530x |
- #'+ if (missing(id)) {
|
||
| 78 | -+ | |||
| 159 | +521x |
- #' @examples+ args$id <- get_default_slice_id(args) |
||
| 79 | +160 |
- #' x1 <- teal_slice(+ } else {
|
||
| 80 | -+ | |||
| 161 | +9x |
- #' dataname = "data",+ checkmate::assert_string(id) |
||
| 81 | +162 |
- #' id = "Female adults",+ } |
||
| 82 | -+ | |||
| 163 | +527x |
- #' expr = "SEX == 'F' & AGE >= 18",+ ans <- do.call(reactiveValues, args) |
||
| 83 | -+ | |||
| 164 | +527x |
- #' title = "Female adults"+ class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
|
||
| 84 | +165 |
- #' )+ } else {
|
||
| 85 | -+ | |||
| 166 | +1x |
- #' x2 <- teal_slice(+ stop("Must provide either `expr` or `varname`.")
|
||
| 86 | +167 |
- #' dataname = "data",+ } |
||
| 87 | +168 |
- #' varname = "var",+ |
||
| 88 | -+ | |||
| 169 | +550x |
- #' choices = c("F", "M", "U"),
+ ans |
||
| 89 | +170 |
- #' selected = "F",+ } |
||
| 90 | +171 |
- #' keep_na = TRUE,+ |
||
| 91 | +172 |
- #' keep_inf = TRUE,+ #' `teal_slice` utility functions |
||
| 92 | +173 |
- #' fixed = FALSE,+ #' |
||
| 93 | +174 |
- #' anchored = FALSE,+ #' Helper functions for working with [`teal_slice`] object. |
||
| 94 | +175 |
- #' multiple = TRUE,+ #' @param x (`teal.slice`) |
||
| 95 | +176 |
- #' id = "Gender",+ #' @param show_all (`logical(1)`) indicating whether to show all fields. If set to `FALSE`, |
||
| 96 | +177 |
- #' extra_arg = "extra"+ #' only non-NULL elements will be printed. |
||
| 97 | +178 |
- #' )+ #' @param trim_lines (`logical(1)`) indicating whether to trim lines when printing. |
||
| 98 | +179 |
- #'+ #' @param ... additional arguments passed to other functions. |
||
| 99 | +180 |
- #' is.teal_slice(x1)+ #' @name teal_slice-utilities |
||
| 100 | +181 |
- #' as.list(x1)+ #' @inherit teal_slice examples |
||
| 101 | +182 |
- #' as.teal_slice(list(dataname = "a", varname = "var"))+ #' @keywords internal |
||
| 102 | +183 |
- #' format(x1)+ |
||
| 103 | +184 |
- #' format(x1, show_all = TRUE, trim_lines = FALSE)+ #' @rdname teal_slice-utilities |
||
| 104 | +185 |
- #' print(x1)+ #' @export |
||
| 105 | +186 |
- #' print(x1, show_all = TRUE, trim_lines = FALSE)+ #' |
||
| 106 | +187 |
- #'+ is.teal_slice <- function(x) { # nolint
|
||
| 107 | -+ | |||
| 188 | +4x |
- #' @seealso [`teal_slices`],+ inherits(x, "teal_slice") |
||
| 108 | +189 |
- #' [`is.teal_slice`], [`as.teal_slice`], [`as.list.teal_slice`], [`print.teal_slice`], [`format.teal_slice`]+ } |
||
| 109 | +190 |
- #'+ |
||
| 110 | +191 |
- #' @export+ #' @rdname teal_slice-utilities |
||
| 111 | +192 |
- teal_slice <- function(dataname,+ #' @export |
||
| 112 | +193 |
- varname,+ #' |
||
| 113 | +194 |
- id,+ as.teal_slice <- function(x) { # nolint
|
||
| 114 | -+ | |||
| 195 | +! |
- expr,+ checkmate::assert_list(x, names = "named") |
||
| 115 | -+ | |||
| 196 | +! |
- choices = NULL,+ do.call(teal_slice, x) |
||
| 116 | +197 |
- selected = NULL,+ } |
||
| 117 | +198 |
- keep_na = NULL,+ |
||
| 118 | +199 |
- keep_inf = NULL,+ #' @rdname teal_slice-utilities |
||
| 119 | +200 |
- fixed = FALSE,+ #' @export |
||
| 120 | +201 |
- anchored = FALSE,+ #' |
||
| 121 | +202 |
- multiple = TRUE,+ as.list.teal_slice <- function(x, ...) {
|
||
| 122 | -+ | |||
| 203 | +283x |
- title = NULL,+ formal_args <- setdiff(names(formals(teal_slice)), "...") |
||
| 123 | +204 |
- ...) {
- |
- ||
| 124 | -579x | -
- checkmate::assert_string(dataname)+ |
||
| 125 | -572x | +205 | +283x |
- checkmate::assert_flag(fixed)+ x <- if (isRunning()) {
|
| 126 | -570x | +|||
| 206 | +! |
- checkmate::assert_flag(anchored)+ reactiveValuesToList(x) |
||
| 127 | +207 |
-
+ } else {
|
||
| 128 | -568x | +208 | +283x |
- formal_args <- as.list(environment())+ isolate(reactiveValuesToList(x)) |
| 129 | +209 |
-
+ } |
||
| 130 | -568x | +|||
| 210 | +
- if (!missing(expr) && !missing(varname)) {
+
|
|||
| 131 | -! | +|||
| 211 | +283x |
- stop("Must provide either `expr` or `varname`.")
+ formal_args <- intersect(formal_args, names(x)) |
||
| 132 | -568x | +212 | +283x |
- } else if (!missing(expr)) {
- |
-
| 133 | -30x | -
- checkmate::assert_string(id)- |
- ||
| 134 | -27x | -
- checkmate::assert_string(title)- |
- ||
| 135 | -24x | -
- checkmate::assert_string(expr)+ extra_args <- rev(setdiff(names(x), formal_args)) |
||
| 136 | +213 | |||
| 137 | -23x | -
- formal_args$fixed <- TRUE- |
- ||
| 138 | -23x | -
- ts_expr_args <- c("dataname", "id", "expr", "fixed", "anchored", "title")
- |
- ||
| 139 | -23x | +214 | +283x |
- formal_args <- formal_args[ts_expr_args]+ x[c(formal_args, extra_args)] |
| 140 | -23x | +|||
| 215 | +
- ans <- do.call(reactiveValues, c(formal_args, list(...)))+ } |
|||
| 141 | -23x | +|||
| 216 | +
- class(ans) <- c("teal_slice_expr", "teal_slice", class(ans))
+
|
|||
| 142 | -538x | +|||
| 217 | +
- } else if (!missing(varname)) {
+
|
|||
| 143 | -537x | +|||
| 218 | +
- checkmate::assert_string(varname)+ #' @rdname teal_slice-utilities |
|||
| 144 | -534x | +|||
| 219 | +
- checkmate::assert_multi_class(choices, .filterable_class, null.ok = TRUE)+ #' @export |
|||
| 145 | -533x | +|||
| 220 | +
- checkmate::assert_multi_class(selected, .filterable_class, null.ok = TRUE)+ #' |
|||
| 146 | -531x | +|||
| 221 | +
- checkmate::assert_flag(keep_na, null.ok = TRUE)+ format.teal_slice <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
|
|||
| 147 | -530x | +222 | +116x |
- checkmate::assert_flag(keep_inf, null.ok = TRUE)+ checkmate::assert_flag(show_all) |
| 148 | -529x | +223 | +92x |
- checkmate::assert_flag(multiple)+ checkmate::assert_flag(trim_lines) |
| 149 | +224 | |||
| 150 | -529x | -
- ts_var_args <- c(- |
- ||
| 151 | -529x | +225 | +86x |
- "dataname", "varname", "id", "choices", "selected", "keep_na", "keep_inf",+ x_list <- as.list(x) |
| 152 | -529x | +226 | +47x |
- "fixed", "anchored", "multiple"+ if (!show_all) x_list <- Filter(Negate(is.null), x_list) |
| 153 | +227 |
- )- |
- ||
| 154 | -529x | -
- formal_args <- formal_args[ts_var_args]- |
- ||
| 155 | -529x | -
- args <- c(formal_args, list(...))- |
- ||
| 156 | -529x | -
- args[c("choices", "selected")] <-
- |
- ||
| 157 | -529x | -
- lapply(args[c("choices", "selected")], function(x) if (is.factor(x)) as.character(x) else x)
- |
- ||
| 158 | -529x | -
- if (missing(id)) {
+
|
||
| 159 | -520x | +228 | +86x |
- args$id <- get_default_slice_id(args)+ jsonify(x_list, trim_lines) |
| 160 | +229 |
- } else {
+ } |
||
| 161 | -9x | +|||
| 230 | +
- checkmate::assert_string(id)+ |
|||
| 162 | +231 |
- }+ #' @rdname teal_slice-utilities |
||
| 163 | -526x | +|||
| 232 | +
- ans <- do.call(reactiveValues, args)+ #' @export |
|||
| 164 | -526x | +|||
| 233 | +
- class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
+ #' |
|||
| 165 | +234 |
- } else {
+ print.teal_slice <- function(x, ...) {
|
||
| 166 | -1x | +235 | +15x |
- stop("Must provide either `expr` or `varname`.")
+ cat(format(x, ...)) |
| 167 | +236 |
- }+ } |
||
| 168 | +237 | |||
| 169 | -549x | +|||
| 238 | +
- ans+ |
|||
| 170 | +239 |
- }+ # format utils ----- |
||
| 171 | +240 | |||
| 172 | +241 |
- #' `teal_slice` utility functions+ #' Convert a list to a justified `JSON` string |
||
| 173 | +242 |
#' |
||
| 174 | +243 |
- #' Helper functions for working with [`teal_slice`] object.+ #' This function takes a list and converts it to a `JSON` string. |
||
| 175 | +244 |
- #' @param x (`teal.slice`)+ #' The resulting `JSON` string is then optionally justified to improve readability |
||
| 176 | +245 |
- #' @param show_all (`logical(1)`) indicating whether to show all fields. If set to `FALSE`,+ #' and trimmed to easier fit in the console when printing. |
||
| 177 | +246 |
- #' only non-NULL elements will be printed.+ #' |
||
| 178 | +247 |
- #' @param trim_lines (`logical(1)`) indicating whether to trim lines when printing.+ #' @param x (`list`), possibly recursive, obtained from `teal_slice` or `teal_slices`. |
||
| 179 | +248 |
- #' @param ... additional arguments passed to other functions.+ #' @param trim_lines (`logical(1)`) flag specifying whether to trim lines of the `JSON` string. |
||
| 180 | +249 |
- #' @name teal_slice-utilities+ #' @return A `JSON` string representation of the input list. |
||
| 181 | +250 |
- #' @inherit teal_slice examples+ #' @keywords internal |
||
| 182 | +251 |
- #' @keywords internal+ #' |
||
| 183 | +252 |
-
+ jsonify <- function(x, trim_lines) {
|
||
| 184 | -+ | |||
| 253 | +131x |
- #' @rdname teal_slice-utilities+ checkmate::assert_list(x) |
||
| 185 | +254 |
- #' @export+ |
||
| 186 | -+ | |||
| 255 | +131x |
- #'+ x_json <- to_json(x) |
||
| 187 | -+ | |||
| 256 | +131x |
- is.teal_slice <- function(x) { # nolint
+ x_json_justified <- justify_json(x_json) |
||
| 188 | -4x | +257 | +121x |
- inherits(x, "teal_slice")+ if (trim_lines) x_json_justified <- trim_lines_json(x_json_justified)+ |
+
| 258 | +131x | +
+ paste(x_json_justified, collapse = "\n") |
||
| 189 | +259 |
} |
||
| 190 | +260 | |||
| 191 | +261 |
- #' @rdname teal_slice-utilities+ #' Converts a list to a `JSON` string |
||
| 192 | +262 |
- #' @export+ #' |
||
| 193 | +263 |
- #'+ #' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string. |
||
| 194 | +264 |
- as.teal_slice <- function(x) { # nolint
+ #' Ensures proper unboxing of list elements. |
||
| 195 | -! | +|||
| 265 | +
- checkmate::assert_list(x, names = "named")+ #' This function is used by the `format` methods for `teal_slice` and `teal_slices`. |
|||
| 196 | -! | +|||
| 266 | +
- do.call(teal_slice, x)+ #' @param x (`list`) possibly recursive, obtained from `teal_slice` or `teal_slices`. |
|||
| 197 | +267 |
- }+ #' @return A `JSON` string. |
||
| 198 | +268 |
-
+ # |
||
| 199 | +269 |
- #' @rdname teal_slice-utilities+ #' @param x (`list`) representation of `teal_slices` object. |
||
| 200 | +270 |
- #' @export+ #' @keywords internal |
||
| 201 | +271 |
#' |
||
| 202 | +272 |
- as.list.teal_slice <- function(x, ...) {
+ to_json <- function(x) {
|
||
| 203 | -283x | +273 | +131x |
- formal_args <- setdiff(names(formals(teal_slice)), "...")+ no_unbox <- function(x) {
|
| 204 | -+ | |||
| 274 | +2390x |
-
+ vars <- c("selected", "choices")
|
||
| 205 | -283x | +275 | +2390x |
- x <- if (isRunning()) {
+ if (is.list(x)) {
|
| 206 | -! | +|||
| 276 | +385x |
- reactiveValuesToList(x)+ for (var in vars) {
+ |
+ ||
| 277 | +307x | +
+ if (!is.null(x[[var]])) x[[var]] <- I(format_time(x[[var]])) |
||
| 207 | +278 |
- } else {
+ } |
||
| 208 | -283x | +279 | +385x |
- isolate(reactiveValuesToList(x))+ lapply(x, no_unbox) |
| 209 | +280 |
- }+ } else {
|
||
| 210 | -+ | |||
| 281 | +2005x |
-
+ x |
||
| 211 | -283x | +|||
| 282 | +
- formal_args <- intersect(formal_args, names(x))+ } |
|||
| 212 | -283x | +|||
| 283 | +
- extra_args <- rev(setdiff(names(x), formal_args))+ } |
|||
| 213 | +284 | |||
| 214 | -283x | +285 | +131x |
- x[c(formal_args, extra_args)]+ jsonlite::toJSON(no_unbox(x), pretty = TRUE, auto_unbox = TRUE, digits = 16, null = "null") |
| 215 | +286 |
} |
||
| 216 | +287 | |||
| 217 | +288 |
-
+ #' Format `POSIXt` for storage |
||
| 218 | +289 |
- #' @rdname teal_slice-utilities+ #' |
||
| 219 | +290 |
- #' @export+ #' Convert `POSIXt` date time object to character representation in UTC time zone. |
||
| 220 | +291 |
#' |
||
| 221 | +292 |
- format.teal_slice <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
+ #' Date times are stored as string representations expressed in the UTC time zone. |
||
| 222 | -116x | +|||
| 293 | +
- checkmate::assert_flag(show_all)+ #' The storage format is `YYYY-MM-DD HH:MM:SS`. |
|||
| 223 | -92x | +|||
| 294 | +
- checkmate::assert_flag(trim_lines)+ #' |
|||
| 224 | +295 |
-
+ #' @param x (`POSIXt`) vector of date time values or anything else |
||
| 225 | -86x | +|||
| 296 | +
- x_list <- as.list(x)+ #' |
|||
| 226 | -47x | +|||
| 297 | +
- if (!show_all) x_list <- Filter(Negate(is.null), x_list)+ #' @return If `x` is of class `POSIXt`, a character vector, otherwise `x` itself. |
|||
| 227 | -- | - - | -||
| 228 | -86x | -
- jsonify(x_list, trim_lines)- |
- ||
| 229 | -- |
- }- |
- ||
| 230 | -- | - - | -||
| 231 | -- |
- #' @rdname teal_slice-utilities- |
- ||
| 232 | -- |
- #' @export- |
- ||
| 233 | -- |
- #'- |
- ||
| 234 | -- |
- print.teal_slice <- function(x, ...) {
- |
- ||
| 235 | -15x | -
- cat(format(x, ...))- |
- ||
| 236 | -- |
- }- |
- ||
| 237 | -- | - - | -||
| 238 | -- | - - | -||
| 239 | -- |
- # format utils ------ |
- ||
| 240 | -- | - - | -||
| 241 | -- |
- #' Convert a list to a justified `JSON` string- |
- ||
| 242 | -- |
- #'- |
- ||
| 243 | -- |
- #' This function takes a list and converts it to a `JSON` string.- |
- ||
| 244 | -- |
- #' The resulting `JSON` string is then optionally justified to improve readability- |
- ||
| 245 | -- |
- #' and trimmed to easier fit in the console when printing.- |
- ||
| 246 | -- |
- #'- |
- ||
| 247 | -- |
- #' @param x (`list`), possibly recursive, obtained from `teal_slice` or `teal_slices`.- |
- ||
| 248 | -- |
- #' @param trim_lines (`logical(1)`) flag specifying whether to trim lines of the `JSON` string.- |
- ||
| 249 | -- |
- #' @return A `JSON` string representation of the input list.- |
- ||
| 250 | -- |
- #' @keywords internal- |
- ||
| 251 | -- |
- #'- |
- ||
| 252 | -- |
- jsonify <- function(x, trim_lines) {
- |
- ||
| 253 | -131x | -
- checkmate::assert_list(x)- |
- ||
| 254 | -- | - - | -||
| 255 | -131x | -
- x_json <- to_json(x)- |
- ||
| 256 | -131x | -
- x_json_justified <- justify_json(x_json)- |
- ||
| 257 | -121x | -
- if (trim_lines) x_json_justified <- trim_lines_json(x_json_justified)- |
- ||
| 258 | -131x | -
- paste(x_json_justified, collapse = "\n")- |
- ||
| 259 | -- |
- }- |
- ||
| 260 | -- | - - | -||
| 261 | -- |
- #' Converts a list to a `JSON` string- |
- ||
| 262 | -- |
- #'- |
- ||
| 263 | -- |
- #' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string.- |
- ||
| 264 | -- |
- #' Ensures proper unboxing of list elements.- |
- ||
| 265 | -- |
- #' This function is used by the `format` methods for `teal_slice` and `teal_slices`.- |
- ||
| 266 | -- |
- #' @param x (`list`) possibly recursive, obtained from `teal_slice` or `teal_slices`.- |
- ||
| 267 | -- |
- #' @return A `JSON` string.- |
- ||
| 268 | -- |
- #- |
- ||
| 269 | -- |
- #' @param x (`list`) representation of `teal_slices` object.- |
- ||
| 270 | -- |
- #' @keywords internal- |
- ||
| 271 | -- |
- #'- |
- ||
| 272 | -- |
- to_json <- function(x) {
- |
- ||
| 273 | -131x | -
- no_unbox <- function(x) {
- |
- ||
| 274 | -2390x | -
- vars <- c("selected", "choices")
- |
- ||
| 275 | -2390x | -
- if (is.list(x)) {
- |
- ||
| 276 | -385x | -
- for (var in vars) {
- |
- ||
| 277 | -307x | -
- if (!is.null(x[[var]])) x[[var]] <- I(format_time(x[[var]]))- |
- ||
| 278 | -- |
- }- |
- ||
| 279 | -385x | -
- lapply(x, no_unbox)- |
- ||
| 280 | -- |
- } else {
- |
- ||
| 281 | -2005x | -
- x- |
- ||
| 282 | -- |
- }- |
- ||
| 283 | -- |
- }- |
- ||
| 284 | -- | - - | -||
| 285 | -131x | -
- jsonlite::toJSON(no_unbox(x), pretty = TRUE, auto_unbox = TRUE, digits = 16, null = "null")- |
- ||
| 286 | -- |
- }- |
- ||
| 287 | -- | - - | -||
| 288 | -- |
- #' Format `POSIXt` for storage- |
- ||
| 289 | -- |
- #'- |
- ||
| 290 | -- |
- #' Convert `POSIXt` date time object to character representation in UTC time zone.- |
- ||
| 291 | -- |
- #'- |
- ||
| 292 | -- |
- #' Date times are stored as string representations expressed in the UTC time zone.- |
- ||
| 293 | -- |
- #' The storage format is `YYYY-MM-DD HH:MM:SS`.- |
- ||
| 294 | -- |
- #'- |
- ||
| 295 | -- |
- #' @param x (`POSIXt`) vector of date time values or anything else- |
- ||
| 296 | -- |
- #'- |
- ||
| 297 | -- |
- #' @return If `x` is of class `POSIXt`, a character vector, otherwise `x` itself.- |
- ||
| 298 | +298 |
#'@@ -23661,21 +22618,21 @@ teal.slice coverage - 65.96% | ||
| 374 | -609x | +610x |
checkmate::assert_multi_class(x, c("teal_slice", "list"))
|
|
| 375 | -609x | +610x |
isolate({
|
|
| 376 | -609x | +610x |
if (inherits(x, "teal_slice_expr") || is.null(x$varname)) {
|
@@ -23696,28 +22653,28 @@ |
| 379 | -599x | +600x |
paste( |
|
| 380 | -599x | +600x |
Filter( |
|
| 381 | -599x | +600x |
length, |
|
| 382 | -599x | +600x |
as.list(x)[c("dataname", "varname", "experiment", "arg")]
|
@@ -23731,7 +22688,7 @@ |
| 384 | -599x | +600x |
collapse = " " |
@@ -23767,1169 +22724,1169 @@
| 1 |
- # SEFilterStates ------+ #' Progress bars with labels |
||
| 2 |
-
+ #' |
||
| 3 |
- #' @name SEFilterStates+ #' `shiny` element displaying a series of progress bars and observation counts. |
||
| 4 |
- #' @docType class+ #' |
||
| 5 |
- #' @title `FilterStates` subclass for `SummarizedExperiment`s+ #' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input). |
||
| 6 |
- #' @description Handles filter states in a `SummaryExperiment`.+ #' @param choices (`vector`) Available values. Used to determine label text. |
||
| 7 |
- #' @keywords internal+ #' @param countsmax (`numeric`) Maximum counts of each element. Must be the same length `choices`. |
||
| 8 |
- #'+ #' @param countsnow (`numeric`) Current counts of each element. Must be the same length `choices`. |
||
| 9 |
- SEFilterStates <- R6::R6Class( # nolint+ #' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`. |
||
| 10 |
- classname = "SEFilterStates",+ #' |
||
| 11 |
- inherit = FilterStates,+ #' @return List of `shiny.tag`s. |
||
| 12 |
-
+ #' |
||
| 13 |
- # public methods ----+ #' Creates a number of progress bar elements, one for each value of `choices`. |
||
| 14 |
- public = list(+ #' The widths of all progress bars add up to the full width of the container. |
||
| 15 |
- #' @description+ #' Each progress bar has a text label that contains the name of the value and the number of counts. |
||
| 16 |
- #' Initialize `SEFilterStates` object.+ #' |
||
| 17 |
- #'+ #' If the filter panel is used with `count_type = "all"`, the progress bars will be filled |
||
| 18 |
- #' @param data (`SummarizedExperiment`)+ #' according to the number of counts remaining in the current selection and the label will show |
||
| 19 |
- #' the `R` object which `subset` function is applied on.+ #' both the current and the total number of counts. |
||
| 20 |
- #' @param data_reactive (`function(sid)`)+ #' |
||
| 21 |
- #' should return a `SummarizedExperiment` object or `NULL`.+ #' Each child element can have a unique `id` attribute to be used independently. |
||
| 22 |
- #' This object is needed for the `FilterState` counts being updated on a change in filters.+ #' |
||
| 23 |
- #' If function returns `NULL` then filtered counts are not shown.+ #' @examples |
||
| 24 |
- #' Function has to have `sid` argument being a character.+ #' # use non-exported function from teal.slice |
||
| 25 |
- #' @param dataname (`character(1)`)+ #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
||
| 26 |
- #' name of the data used in the expression+ #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
||
| 27 |
- #' specified to the function argument attached to this `FilterStates`.+ #' countBars <- getFromNamespace("countBars", "teal.slice")
|
||
| 28 |
- #' @param datalabel (`character(1)`) optional+ #' updateCountBars <- getFromNamespace("updateCountBars", "teal.slice")
|
||
| 29 |
- #' text label. Should be the name of experiment.+ #' |
||
| 30 |
- #'+ #' library(shiny) |
||
| 31 |
- initialize = function(data,+ #' |
||
| 32 |
- data_reactive = function(sid = "") NULL,+ #' choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE)
|
||
| 33 |
- dataname,+ #' counts <- table(choices) |
||
| 34 |
- datalabel = NULL) {
+ #' labels <- countBars( |
||
| 35 | -92x | +
- if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
+ #' inputId = "counts", |
|
| 36 | -! | +
- stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
+ #' choices = c("a", "b", "c"),
|
|
| 37 |
- }+ #' countsmax = counts, |
||
| 38 | -92x | +
- checkmate::assert_function(data_reactive, args = "sid")+ #' countsnow = unname(counts) |
|
| 39 | -92x | +
- checkmate::assert_class(data, "SummarizedExperiment")+ #' ) |
|
| 40 | -91x | +
- super$initialize(data, data_reactive, dataname, datalabel)+ #' |
|
| 41 | -91x | +
- if (!is.null(datalabel)) {
+ #' ui <- fluidPage( |
|
| 42 | -84x | +
- private$dataname_prefixed <- sprintf("%s[['%s']]", dataname, datalabel)
+ #' tags$div( |
|
| 43 |
- }+ #' class = "choices_state", |
||
| 44 |
- },+ #' include_js_files("count-bar-labels.js"),
|
||
| 45 |
-
+ #' include_css_files(pattern = "filter-panel"), |
||
| 46 |
- #' @description+ #' checkboxGroupInput( |
||
| 47 |
- #' Set filter state.+ #' inputId = "choices", |
||
| 48 |
- #'+ #' selected = levels(choices), |
||
| 49 |
- #' @param state (`teal_slices`)+ #' choiceNames = labels, |
||
| 50 |
- #' `teal_slice` objects should contain the field `arg %in% c("subset", "select")`
+ #' choiceValues = levels(choices), |
||
| 51 |
- #'+ #' label = NULL |
||
| 52 |
- #' @return `NULL`, invisibly.+ #' ) |
||
| 53 |
- #'+ #' ) |
||
| 54 |
- set_filter_state = function(state) {
+ #' ) |
||
| 55 | -61x | +
- isolate({
+ #' server <- function(input, output, session) {
|
|
| 56 | -61x | +
- logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
+ #' observeEvent(input$choices, {
|
|
| 57 | -61x | +
- checkmate::assert_class(state, "teal_slices")+ #' new_counts <- counts |
|
| 58 | -59x | +
- lapply(state, function(x) {
+ #' new_counts[!names(new_counts) %in% input$choices] <- 0 |
|
| 59 | -17x | +
- checkmate::assert_choice(x$arg, choices = c("subset", "select"), null.ok = TRUE, .var.name = "teal_slice$arg")
+ #' updateCountBars( |
|
| 60 |
- })+ #' inputId = "counts", |
||
| 61 | -59x | +
- count_type <- attr(state, "count_type")+ #' choices = levels(choices), |
|
| 62 | -59x | +
- if (length(count_type)) {
+ #' countsmax = counts, |
|
| 63 | -8x | +
- private$count_type <- count_type+ #' countsnow = unname(new_counts) |
|
| 64 |
- }+ #' ) |
||
| 65 |
-
+ #' }) |
||
| 66 | -59x | +
- subset_states <- Filter(function(x) x$arg == "subset", state)+ #' } |
|
| 67 | -59x | +
- private$set_filter_state_impl(+ #' |
|
| 68 | -59x | +
- state = subset_states,+ #' if (interactive()) {
|
|
| 69 | -59x | +
- data = SummarizedExperiment::rowData(private$data),+ #' shinyApp(ui, server) |
|
| 70 | -59x | +
- data_reactive = function(sid = "") {
+ #' } |
|
| 71 | -! | +
- data <- private$data_reactive()+ #' |
|
| 72 | -! | +
- if (!is.null(data)) {
+ #' @keywords internal |
|
| 73 | -! | +
- SummarizedExperiment::rowData(data)+ #' |
|
| 74 |
- }+ countBars <- function(inputId, choices, countsmax, countsnow = NULL) { # nolint
|
||
| 75 | -+ | 25x |
- }+ checkmate::assert_string(inputId) |
| 76 | -+ | 21x |
- )+ checkmate::assert_vector(choices) |
| 77 | -+ | 20x |
-
+ checkmate::assert_numeric(countsmax, len = length(choices)) |
| 78 | -59x | +17x |
- select_states <- Filter(function(x) x$arg == "select", state)+ checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE) |
| 79 | -59x | +15x |
- private$set_filter_state_impl(+ if (!is.null(countsnow)) {
|
| 80 | -59x | +7x |
- state = select_states,+ checkmate::assert_true(all(countsnow <= countsmax)) |
| 81 | -59x | +
- data = SummarizedExperiment::colData(private$data),+ } |
|
| 82 | -59x | +
- data_reactive = function(sid = "") {
+
|
|
| 83 | -! | +14x |
- data <- private$data_reactive()+ ns <- NS(inputId) |
| 84 | -! | +
- if (!is.null(data)) {
+
|
|
| 85 | -! | +14x |
- SummarizedExperiment::colData(data)+ mapply( |
| 86 | -+ | 14x |
- }+ countBar, |
| 87 | -+ | 14x |
- }+ inputId = ns(seq_along(choices)), |
| 88 | -+ | 14x |
- )+ label = as.character(choices), |
| 89 | -+ | 14x |
-
+ countmax = countsmax, |
| 90 | -59x | +14x |
- logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
+ countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow, |
| 91 | -59x | +14x |
- invisible(NULL)+ MoreArgs = list( |
| 92 | -+ | 14x |
- })+ counttotal = sum(countsmax) |
| 93 |
- },+ ), |
||
| 94 | -+ | 14x |
-
+ SIMPLIFY = FALSE, USE.NAMES = FALSE |
| 95 |
- #' @description+ ) |
||
| 96 |
- #' `shiny` UI module to add filter variable.+ } |
||
| 97 |
- #' @param id (`character(1)`)+ |
||
| 98 |
- #' `shiny` module instance id.+ #' Progress bar with label |
||
| 99 |
- #' @return `shiny.tag`+ #' |
||
| 100 |
- ui_add = function(id) {
+ #' `shiny` element displaying a progress bar and observation count. |
||
| 101 | -2x | +
- data <- private$data+ #' |
|
| 102 | -2x | +
- checkmate::assert_string(id)+ #' A progress bar is created to visualize the number of counts in a variable, with filling and a text label. |
|
| 103 | -2x | +
- ns <- NS(id)+ #' - progress bar width is derived as a fraction of the container width: `style = "width: <countmax> / <counttotal>%"`, |
|
| 104 | -2x | +
- row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
+ #' - progress bar is filled up to the fraction `<countnow> / <countmax>`, |
|
| 105 | -1x | +
- tags$div("no sample variables available")
+ #' - text label is obtained by `<label> (<countnow> / <countmax>)`. |
|
| 106 | -2x | +
- } else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
+ #' |
|
| 107 | -1x | +
- tags$div("no samples available")
+ #' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input). |
|
| 108 |
- } else {
+ #' @param label (`character(1)`) Text to display followed by counts. |
||
| 109 | -! | +
- teal.widgets::optionalSelectInput(+ #' @param countmax (`numeric(1)`) Maximum count for a single element. |
|
| 110 | -! | +
- ns("row_to_add"),
+ #' @param countnow (`numeric(1)`) Current count for a single element. |
|
| 111 | -! | +
- choices = NULL,+ #' @param counttotal (`numeric(1)`) Sum total of maximum counts of all elements, see `Details`. |
|
| 112 | -! | +
- options = shinyWidgets::pickerOptions(+ #' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`. |
|
| 113 | -! | +
- liveSearch = TRUE,+ #' |
|
| 114 | -! | +
- noneSelectedText = "Select gene variable"+ #' @return `shiny.tag` object with a progress bar and a label. |
|
| 115 |
- )+ #' |
||
| 116 |
- )+ #' @keywords internal |
||
| 117 |
- }+ #' |
||
| 118 |
-
+ countBar <- function(inputId, label, countmax, countnow = NULL, counttotal = countmax) { # nolint
|
||
| 119 | -2x | +62x |
- col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
+ checkmate::assert_string(inputId) |
| 120 | -1x | +58x |
- tags$div("no sample variables available")
+ checkmate::assert_string(label) |
| 121 | -2x | +55x |
- } else if (nrow(SummarizedExperiment::colData(data)) == 0) {
+ checkmate::assert_number(countmax) |
| 122 | -1x | +53x |
- tags$div("no samples available")
+ checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax) |
| 123 | -+ | 51x |
- } else {
+ checkmate::assert_number(counttotal, lower = countmax) |
| 124 | -! | +
- teal.widgets::optionalSelectInput(+ |
|
| 125 | -! | +49x |
- ns("col_to_add"),
+ label <- make_count_text(label, countmax = countmax, countnow = countnow) |
| 126 | -! | +49x |
- choices = NULL,+ ns <- NS(inputId) |
| 127 | -! | +26x |
- options = shinyWidgets::pickerOptions(+ if (is.null(countnow)) countnow <- 0 |
| 128 | -! | +49x |
- liveSearch = TRUE,+ tags$div( |
| 129 | -! | +49x |
- noneSelectedText = "Select sample variable"+ class = "progress state-count-container", |
| 130 |
- )+ # * .9 to not exceed width of the parent html element |
||
| 131 | -+ | 49x |
- )+ tags$div( |
| 132 | -+ | 49x |
- }+ id = ns("count_bar_filtered"),
|
| 133 | -+ | 49x |
-
+ class = "progress-bar state-count-bar-filtered", |
| 134 | -2x | +49x |
- tags$div(+ style = sprintf("width: %s%%", countnow / counttotal * 100),
|
| 135 | -2x | +49x |
- row_input,+ role = "progressbar", |
| 136 | -2x | +49x |
- col_input+ label |
| 137 |
- )+ ), |
||
| 138 | -+ | 49x |
- },+ tags$div( |
| 139 | -+ | 49x |
-
+ id = ns("count_bar_unfiltered"),
|
| 140 | -+ | 49x |
- #' @description+ class = "progress-bar state-count-bar-unfiltered", |
| 141 | -+ | 49x |
- #' `shiny` server module to add filter variable.+ style = sprintf("width: %s%%", (countmax - countnow) / counttotal * 100),
|
| 142 | -+ | 49x |
- #'+ role = "progressbar" |
| 143 |
- #' Module controls available choices to select as a filter variable.+ ) |
||
| 144 |
- #' Selected filter variable is being removed from available choices.+ ) |
||
| 145 |
- #' Removed filter variable gets back to available choices.+ } |
||
| 146 |
- #' This module unlike other `FilterStates` classes manages two+ |
||
| 147 |
- #' sets of filter variables - one for `colData` and another for+ #' @rdname countBars |
||
| 148 |
- #' `rowData`.+ updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, countsmax, countsnow = NULL) { # nolint
|
||
| 149 | -+ | 7x |
- #'+ checkmate::assert_string(inputId) |
| 150 | -+ | 7x |
- #' @param id (`character(1)`)+ checkmate::assert_vector(choices) |
| 151 | -+ | 7x |
- #' `shiny` module instance id.+ checkmate::assert_numeric(countsmax, len = length(choices)) |
| 152 | -+ | 7x |
- #' @return `NULL`+ checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE) |
| 153 |
- srv_add = function(id) {
+
|
||
| 154 | -! | +7x |
- data <- private$data+ ns <- NS(inputId) |
| 155 | -! | +7x |
- data_reactive <- private$data_reactive+ mapply( |
| 156 | -! | +7x |
- moduleServer(+ updateCountBar, |
| 157 | -! | +7x |
- id = id,+ inputId = ns(seq_along(choices)), |
| 158 | -! | +7x |
- function(input, output, session) {
+ label = choices, |
| 159 | -! | +7x |
- logger::log_trace("SEFilterState$srv_add initializing, dataname: { private$dataname }")
+ countmax = countsmax, |
| 160 | -+ | 7x |
-
+ countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow, |
| 161 | -! | +7x |
- row_data <- SummarizedExperiment::rowData(data)+ MoreArgs = list( |
| 162 | -! | +7x |
- col_data <- SummarizedExperiment::colData(data)+ counttotal = sum(countsmax) |
| 163 |
-
+ ) |
||
| 164 | -! | +
- avail_row_data_choices <- reactive({
+ ) |
|
| 165 | -! | +7x |
- slices_for_subset <- Filter(function(x) x$arg == "subset", self$get_filter_state())+ invisible(NULL) |
| 166 | -! | +
- active_filter_row_vars <- unique(unlist(lapply(slices_for_subset, "[[", "varname")))+ } |
|
| 168 | -! | +
- choices <- setdiff(+ #' @rdname countBar |
|
| 169 | -! | +
- get_supported_filter_varnames(data = row_data),+ updateCountBar <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow = NULL, counttotal) { # nolint
|
|
| 170 | -! | +18x |
- active_filter_row_vars+ checkmate::assert_string(inputId) |
| 171 | -+ | 18x |
- )+ checkmate::assert_string(label) |
| 172 | -+ | 18x |
-
+ checkmate::assert_number(countmax) |
| 173 | -! | +18x |
- data_choices_labeled(+ checkmate::assert_number(countnow, null.ok = TRUE) |
| 174 | -! | +18x |
- data = row_data,+ checkmate::assert_number(counttotal) |
| 175 | -! | +
- choices = choices,+ |
|
| 176 | -! | +18x |
- varlabels = character(0),+ label <- make_count_text(label, countmax = countmax, countnow = countnow) |
| 177 | -! | +18x |
- keys = NULL+ if (is.null(countnow)) countnow <- countmax |
| 178 | -+ | 18x |
- )+ session$sendCustomMessage( |
| 179 | -+ | 18x |
- })+ type = "updateCountBar", |
| 180 | -+ | 18x |
-
+ message = list( |
| 181 | -! | +18x |
- avail_col_data_choices <- reactive({
+ id = session$ns(inputId), |
| 182 | -! | +18x |
- slices_for_select <- Filter(function(x) x$arg == "select", self$get_filter_state())+ label = label, |
| 183 | -! | +18x |
- active_filter_col_vars <- unique(unlist(lapply(slices_for_select, "[[", "varname")))+ countmax = countmax, |
| 184 | -+ | 18x |
-
+ countnow = countnow, |
| 185 | -! | +18x |
- choices <- setdiff(+ counttotal = counttotal |
| 186 | -! | +
- get_supported_filter_varnames(data = col_data),+ ) |
|
| 187 | -! | +
- active_filter_col_vars+ ) |
|
| 188 |
- )+ |
||
| 189 | -+ | 18x |
-
+ invisible(NULL) |
| 190 | -! | +
- data_choices_labeled(+ } |
|
| 191 | -! | +
- data = col_data,+ |
|
| 192 | -! | +
- choices = choices,+ #' @rdname countBar |
|
| 193 | -! | +
- varlabels = character(0),+ updateCountText <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow) { # nolint
|
|
| 194 | -! | +17x |
- keys = NULL+ checkmate::assert_string(inputId) |
| 195 | -+ | 17x |
- )+ checkmate::assert_string(label) |
| 196 | -+ | 17x |
- })+ checkmate::assert_number(countmax) |
| 197 | -+ | 17x |
-
+ checkmate::assert_number(countnow, null.ok = TRUE) |
| 198 | -! | +17x |
- observeEvent(+ label <- make_count_text(label, countmax = countmax, countnow = countnow) |
| 199 | -! | +17x |
- avail_row_data_choices(),+ session$sendCustomMessage( |
| 200 | -! | +17x |
- ignoreNULL = TRUE,+ type = "updateCountText", |
| 201 | -! | +17x |
- handlerExpr = {
+ message = list( |
| 202 | -! | +17x |
- logger::log_trace(paste(+ id = session$ns(inputId), |
| 203 | -! | +17x |
- "SEFilterStates$srv_add@1 updating available row data choices,",+ label = label |
| 204 | -! | +
- "dataname: { private$dataname }"
+ ) |
|
| 205 |
- ))+ ) |
||
| 206 | -! | +
- if (is.null(avail_row_data_choices())) {
+ } |
|
| 207 | -! | +
- shinyjs::hide("row_to_add")
+
|
|
| 208 |
- } else {
+ #' Build count text |
||
| 209 | -! | +
- shinyjs::show("row_to_add")
+ #' |
|
| 210 |
- }+ #' Returns a text label describing filtered counts. The text is composed in the following way: |
||
| 211 | -! | +
- teal.widgets::updateOptionalSelectInput(+ #' - when `countnow` is not `NULL`: `<label> (<countnow>/<countmax>)` |
|
| 212 | -! | +
- session,+ #' - when `countnow` is `NULL`: `<label> (<countmax>)` |
|
| 213 | -! | +
- "row_to_add",+ #' |
|
| 214 | -! | +
- choices = avail_row_data_choices()+ #' @param label (`character(1)`) Text displayed before counts. |
|
| 215 |
- )+ #' @param countnow (`numeric(1)`) Number of filtered counts. |
||
| 216 | -! | +
- logger::log_trace(paste(+ #' @param countmax (`numeric(1)`) Number of unfiltered counts. |
|
| 217 | -! | +
- "SEFilterStates$srv_add@1 updated available row data choices,",+ #' |
|
| 218 | -! | +
- "dataname: { private$dataname }"
+ #' @return A character string. |
|
| 219 |
- ))+ #' |
||
| 220 |
- }+ #' @keywords internal |
||
| 221 |
- )+ #' |
||
| 222 |
-
+ make_count_text <- function(label, countmax, countnow = NULL) {
|
||
| 223 | -! | +96x |
- observeEvent(+ checkmate::assert_string(label) |
| 224 | -! | +94x |
- avail_col_data_choices(),+ checkmate::assert_number(countmax) |
| 225 | -! | +92x |
- ignoreNULL = TRUE,+ checkmate::assert_number(countnow, null.ok = TRUE) |
| 226 | -! | +90x |
- handlerExpr = {
+ sprintf( |
| 227 | -! | +90x |
- logger::log_trace(paste(+ "%s (%s%s)", |
| 228 | -! | +90x |
- "SEFilterStates$srv_add@2 updating available col data choices,",+ label, |
| 229 | -! | +90x |
- "dataname: { private$dataname }"
+ if (is.null(countnow)) "" else sprintf("%s/", countnow),
|
| 230 | -+ | 90x |
- ))+ countmax |
| 231 | -! | +
- if (is.null(avail_col_data_choices())) {
+ ) |
|
| 232 | -! | +
- shinyjs::hide("col_to_add")
- |
- |
| 233 | -- |
- } else {
- |
- |
| 234 | -! | -
- shinyjs::show("col_to_add")
- |
- |
| 235 | -- |
- }- |
- |
| 236 | -! | -
- teal.widgets::updateOptionalSelectInput(- |
- |
| 237 | -! | -
- session,- |
- |
| 238 | -! | -
- "col_to_add",- |
- |
| 239 | -! | -
- choices = avail_col_data_choices()- |
- |
| 240 | -- |
- )- |
- |
| 241 | -! | -
- logger::log_trace(paste(- |
- |
| 242 | -! | -
- "SEFilterStates$srv_add@2 updated available col data choices,",- |
- |
| 243 | -! | -
- "dataname: { private$dataname }"
- |
- |
| 244 | -- |
- ))- |
- |
| 245 | -- |
- }- |
- |
| 246 | -- |
- )- |
- |
| 247 | -- | - - | -|
| 248 | -! | -
- observeEvent(- |
- |
| 249 | -! | -
- eventExpr = input$col_to_add,- |
- |
| 250 | -! | -
- handlerExpr = {
- |
- |
| 251 | -! | -
- logger::log_trace(- |
- |
| 252 | -! | -
- sprintf(- |
- |
| 253 | -! | -
- "SEFilterStates$srv_add@3 adding FilterState of column %s to col data, dataname: %s",- |
- |
| 254 | -! | -
- deparse1(input$col_to_add),- |
- |
| 255 | -! | -
- private$dataname- |
- |
| 256 | -- |
- )- |
- |
| 257 | -- |
- )- |
- |
| 258 | -! | -
- varname <- input$col_to_add- |
- |
| 259 | -! | -
- self$set_filter_state(teal_slices(- |
- |
| 260 | -! | -
- teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select")- |
- |
| 261 | -- |
- ))- |
- |
| 262 | -- | - - | -|
| 263 | -! | -
- logger::log_trace(- |
- |
| 264 | -! | -
- sprintf(- |
- |
| 265 | -! | -
- "SEFilterStates$srv_add@3 added FilterState of column %s to col data, dataname: %s",- |
- |
| 266 | -! | -
- deparse1(varname),- |
- |
| 267 | -! | -
- private$dataname- |
- |
| 268 | -- |
- )- |
- |
| 269 | -- |
- )- |
- |
| 270 | -- |
- }- |
- |
| 271 | -- |
- )- |
- |
| 272 | -- | - - | -|
| 273 | -- | - - | -|
| 274 | -! | -
- observeEvent(- |
- |
| 275 | -! | -
- eventExpr = input$row_to_add,- |
- |
| 276 | -! | -
- handlerExpr = {
- |
- |
| 277 | -! | -
- logger::log_trace(- |
- |
| 278 | -! | -
- sprintf(- |
- |
| 279 | -! | -
- "SEFilterStates$srv_add@4 adding FilterState of variable %s to row data, dataname: %s",- |
- |
| 280 | -! | -
- deparse1(input$row_to_add),- |
- |
| 281 | -! | -
- private$dataname- |
- |
| 282 | -- |
- )- |
- |
| 283 | -- |
- )- |
- |
| 284 | -! | -
- varname <- input$row_to_add- |
- |
| 285 | -! | -
- self$set_filter_state(teal_slices(- |
- |
| 286 | -! | -
- teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset")- |
- |
| 287 | -- |
- ))- |
- |
| 288 | -- | - - | -|
| 289 | -! | -
- logger::log_trace(- |
- |
| 290 | -! | -
- sprintf(- |
- |
| 291 | -! | -
- "SEFilterStates$srv_add@4 added FilterState of variable %s to row data, dataname: %s",- |
- |
| 292 | -! | -
- deparse1(varname),- |
- |
| 293 | -! | -
- private$dataname- |
- |
| 294 | -- |
- )- |
- |
| 295 | -- |
- )- |
- |
| 296 | -- |
- }- |
- |
| 297 | -- |
- )- |
- |
| 298 | -- | - - | -|
| 299 | -! | -
- logger::log_trace("SEFilterState$srv_add initialized, dataname: { private$dataname }")
- |
- |
| 300 | -! | -
- NULL- |
- |
| 301 | -- |
- }- |
- |
| 302 | -- |
- )- |
- |
| 303 | -- |
- }- |
- |
| 304 | -- |
- )- |
- |
| 305 | -- |
- )+ } |
| 1 |
- #' Set "`<choice>:<label>`" type of names+ # ChoicesFilterState ------ |
||
| 2 |
- #'+ |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' @name ChoicesFilterState |
||
| 4 |
- #'+ #' @docType class |
||
| 5 |
- #' This is often useful for as it marks up the drop-down boxes for [shiny::selectInput()].+ #' |
||
| 6 |
- #'+ #' @title `FilterState` object for categorical data |
||
| 7 |
- #' @details+ #' |
||
| 8 |
- #' If either `choices` or `labels` are factors, they are coerced to character.+ #' @description Manages choosing elements from a set. |
||
| 9 |
- #' Duplicated elements from `choices` get removed.+ #' |
||
| 10 |
- #'+ #' @examples |
||
| 11 |
- #' @param choices (`character` or `numeric` or `logical`) vector+ #' # use non-exported function from teal.slice |
||
| 12 |
- #' @param labels (`character`) vector containing labels to be applied to `choices`. If `NA` then+ #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
||
| 13 |
- #' "Label Missing" will be used.+ #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
||
| 14 |
- #' @param subset a vector that is a subset of `choices`. This is useful if+ #' ChoicesFilterState <- getFromNamespace("ChoicesFilterState", "teal.slice")
|
||
| 15 |
- #' only a few variables need to be named. If this argument is used, the returned vector will+ #' |
||
| 16 |
- #' match its order.+ #' library(shiny) |
||
| 17 |
- #' @param types vector containing the types of the columns.+ #' |
||
| 18 |
- #'+ #' filter_state <- ChoicesFilterState$new( |
||
| 19 |
- #' @return A named character vector.+ #' x = c(LETTERS, NA), |
||
| 20 |
- #'+ #' slice = teal_slice(varname = "var", dataname = "data") |
||
| 21 |
- #' @keywords internal+ #' ) |
||
| 22 |
- #'+ #' isolate(filter_state$get_call()) |
||
| 23 |
- choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
+ #' filter_state$set_state( |
||
| 24 | -9x | +
- if (is.factor(choices)) {
+ #' teal_slice( |
|
| 25 | -! | +
- choices <- as.character(choices)+ #' dataname = "data", |
|
| 26 |
- }+ #' varname = "var", |
||
| 27 |
-
+ #' selected = "A", |
||
| 28 | -9x | +
- stopifnot(+ #' keep_na = TRUE |
|
| 29 | -9x | +
- is.character(choices) ||+ #' ) |
|
| 30 | -9x | +
- is.numeric(choices) ||+ #' ) |
|
| 31 | -9x | +
- is.logical(choices) ||+ #' isolate(filter_state$get_call()) |
|
| 32 | -9x | +
- (length(choices) == 1 && is.na(choices))+ #' |
|
| 33 |
- )+ #' # working filter in an app |
||
| 34 |
-
+ #' library(shinyjs) |
||
| 35 | -9x | +
- if (is.factor(labels)) {
+ #' |
|
| 36 | -! | +
- labels <- as.character(labels)+ #' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA) |
|
| 37 |
- }+ #' attr(data_choices, "label") <- "lowercase letters" |
||
| 38 |
-
+ #' fs <- ChoicesFilterState$new( |
||
| 39 | -9x | +
- checkmate::assert_character(labels[!is.na(labels)], any.missing = FALSE)+ #' x = data_choices, |
|
| 40 | -9x | +
- if (length(choices) != length(labels)) {
+ #' slice = teal_slice( |
|
| 41 | -! | +
- stop("length of choices must be the same as labels")
+ #' dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE
|
|
| 42 |
- }+ #' ) |
||
| 43 | -9x | +
- stopifnot(is.null(subset) || is.vector(subset))+ #' ) |
|
| 44 | -9x | +
- stopifnot(is.null(types) || is.vector(types))+ #' |
|
| 45 |
-
+ #' ui <- fluidPage( |
||
| 46 | -9x | +
- if (is.vector(types)) {
+ #' useShinyjs(), |
|
| 47 | -9x | +
- stopifnot(length(choices) == length(types))+ #' include_css_files(pattern = "filter-panel"), |
|
| 48 |
- }+ #' include_js_files(pattern = "count-bar-labels"), |
||
| 49 |
-
+ #' column(4, tags$div( |
||
| 50 | -9x | +
- if (!is.null(subset)) {
+ #' tags$h4("ChoicesFilterState"),
|
|
| 51 | -! | +
- if (!all(subset %in% choices)) {
+ #' fs$ui("fs")
|
|
| 52 | -! | +
- stop("all of subset variables must be in choices")
+ #' )), |
|
| 53 |
- }+ #' column(4, tags$div( |
||
| 54 | -! | +
- labels <- labels[choices %in% subset]+ #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|
| 55 | -! | +
- types <- types[choices %in% subset]+ #' textOutput("condition_choices"), tags$br(),
|
|
| 56 | -! | +
- choices <- choices[choices %in% subset]+ #' tags$h4("Unformatted state"), # display raw filter state
|
|
| 57 |
- }+ #' textOutput("unformatted_choices"), tags$br(),
|
||
| 58 |
-
+ #' tags$h4("Formatted state"), # display human readable filter state
|
||
| 59 | -9x | +
- is_dupl <- duplicated(choices)+ #' textOutput("formatted_choices"), tags$br()
|
|
| 60 | -9x | +
- choices <- choices[!is_dupl]+ #' )), |
|
| 61 | -9x | +
- labels <- labels[!is_dupl]+ #' column(4, tags$div( |
|
| 62 | -9x | +
- types <- types[!is_dupl]+ #' tags$h4("Programmatic filter control"),
|
|
| 63 | -9x | +
- labels[is.na(labels)] <- "Label Missing"+ #' actionButton("button1_choices", "set drop NA", width = "100%"), tags$br(),
|
|
| 64 | -9x | +
- raw_labels <- labels+ #' actionButton("button2_choices", "set keep NA", width = "100%"), tags$br(),
|
|
| 65 | -9x | +
- combined_labels <- if (length(choices) > 0) {
+ #' actionButton("button3_choices", "set selection: a, b", width = "100%"), tags$br(),
|
|
| 66 | -9x | +
- paste0(choices, ": ", labels)+ #' actionButton("button4_choices", "deselect all", width = "100%"), tags$br(),
|
|
| 67 |
- } else {
+ #' actionButton("button0_choices", "set initial state", width = "100%"), tags$br()
|
||
| 68 | -! | +
- character(0)+ #' )) |
|
| 69 |
- }+ #' ) |
||
| 70 |
-
+ #' |
||
| 71 | -9x | +
- if (!is.null(subset)) {
+ #' server <- function(input, output, session) {
|
|
| 72 | -! | +
- ord <- match(subset, choices)+ #' fs$server("fs")
|
|
| 73 | -! | +
- choices <- choices[ord]+ #' output$condition_choices <- renderPrint(fs$get_call()) |
|
| 74 | -! | +
- raw_labels <- raw_labels[ord]+ #' output$formatted_choices <- renderText(fs$format()) |
|
| 75 | -! | +
- combined_labels <- combined_labels[ord]+ #' output$unformatted_choices <- renderPrint(fs$get_state()) |
|
| 76 | -! | +
- types <- types[ord]+ #' # modify filter state programmatically |
|
| 77 |
- }+ #' observeEvent( |
||
| 78 | -9x | +
- choices <- structure(+ #' input$button1_choices, |
|
| 79 | -9x | +
- choices,+ #' fs$set_state( |
|
| 80 | -9x | +
- names = combined_labels,+ #' teal_slice(dataname = "data", varname = "variable", keep_na = FALSE) |
|
| 81 | -9x | +
- raw_labels = raw_labels,+ #' ) |
|
| 82 | -9x | +
- combined_labels = combined_labels,+ #' ) |
|
| 83 | -9x | +
- class = c("choices_labeled", "character"),
+ #' observeEvent( |
|
| 84 | -9x | +
- types = types+ #' input$button2_choices, |
|
| 85 |
- )+ #' fs$set_state( |
||
| 86 |
-
+ #' teal_slice(dataname = "data", varname = "variable", keep_na = TRUE) |
||
| 87 | -9x | +
- choices+ #' ) |
|
| 88 |
- }+ #' ) |
| 1 | +89 |
- # MAEFilteredDataset ------+ #' observeEvent( |
||
| 2 | +90 |
-
+ #' input$button3_choices, |
||
| 3 | +91 |
- #' @name MAEFilteredDataset+ #' fs$set_state( |
||
| 4 | +92 |
- #' @docType class+ #' teal_slice(dataname = "data", varname = "variable", selected = c("a", "b"))
|
||
| 5 | +93 |
- #' @title `MAEFilteredDataset` `R6` class+ #' ) |
||
| 6 | +94 |
- #'+ #' ) |
||
| 7 | +95 |
- #' @examplesIf requireNamespace("MultiAssayExperiment")
+ #' observeEvent( |
||
| 8 | +96 |
- #' # use non-exported function from teal.slice+ #' input$button4_choices, |
||
| 9 | +97 |
- #' MAEFilteredDataset <- getFromNamespace("MAEFilteredDataset", "teal.slice")
+ #' fs$set_state( |
||
| 10 | +98 |
- #'+ #' teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE) |
||
| 11 | +99 |
- #' data(miniACC, package = "MultiAssayExperiment")+ #' ) |
||
| 12 | +100 |
- #' dataset <- MAEFilteredDataset$new(miniACC, "MAE")+ #' ) |
||
| 13 | +101 |
- #' fs <- teal_slices(+ #' observeEvent( |
||
| 14 | +102 |
- #' teal_slice(+ #' input$button0_choices, |
||
| 15 | +103 |
- #' dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE+ #' fs$set_state( |
||
| 16 | +104 |
- #' ),+ #' teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE)
|
||
| 17 | +105 |
- #' teal_slice(+ #' ) |
||
| 18 | +106 |
- #' dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE+ #' ) |
||
| 19 | +107 |
- #' ),+ #' } |
||
| 20 | +108 |
- #' teal_slice(+ #' |
||
| 21 | +109 |
- #' dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE+ #' if (interactive()) {
|
||
| 22 | +110 |
- #' ),+ #' shinyApp(ui, server) |
||
| 23 | +111 |
- #' teal_slice(+ #' } |
||
| 24 | +112 |
- #' dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE+ #' |
||
| 25 | +113 |
- #' )+ #' @keywords internal |
||
| 26 | +114 |
- #' )+ #' |
||
| 27 | +115 |
- #' dataset$set_filter_state(state = fs)+ ChoicesFilterState <- R6::R6Class( # nolint |
||
| 28 | +116 |
- #'+ "ChoicesFilterState", |
||
| 29 | +117 |
- #' library(shiny)+ inherit = FilterState, |
||
| 30 | +118 |
- #' isolate(dataset$get_filter_state())+ |
||
| 31 | +119 |
- #'+ # public methods ---- |
||
| 32 | +120 |
- #' @keywords internal+ |
||
| 33 | +121 |
- #'+ public = list( |
||
| 34 | +122 |
- MAEFilteredDataset <- R6::R6Class( # nolint+ |
||
| 35 | +123 |
- classname = "MAEFilteredDataset",+ #' @description |
||
| 36 | +124 |
- inherit = FilteredDataset,+ #' Initialize a `FilterState` object. |
||
| 37 | +125 |
-
+ #' |
||
| 38 | +126 |
- # public methods ----+ #' @param x (`character`) |
||
| 39 | +127 |
- public = list(+ #' variable to be filtered. |
||
| 40 | +128 |
- #' @description+ #' @param x_reactive (`reactive`) |
||
| 41 | +129 |
- #' Initialize `MAEFilteredDataset` object.+ #' returning vector of the same type as `x`. Is used to update |
||
| 42 | +130 |
- #'+ #' counts following the change in values of the filtered dataset. |
||
| 43 | +131 |
- #' @param dataset (`MulitiAssayExperiment`)+ #' If it is set to `reactive(NULL)` then counts based on filtered |
||
| 44 | +132 |
- #' single `MulitiAssayExperiment` for which filters are rendered.+ #' dataset are not shown. |
||
| 45 | +133 |
- #' @param dataname (`character(1)`)+ #' @param slice (`teal_slice`) |
||
| 46 | +134 |
- #' syntactically valid name given to the dataset.+ #' specification of this filter state. |
||
| 47 | +135 |
- #' @param keys (`character`) optional+ #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
||
| 48 | +136 |
- #' vector of primary key column names.+ #' `get_state` returns `teal_slice` object which can be reused in other places. |
||
| 49 | +137 |
- #' @param label (`character(1)`)+ #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
||
| 50 | +138 |
- #' label to describe the dataset.+ #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
||
| 51 | +139 |
- #'+ #' @param extract_type (`character`) |
||
| 52 | +140 |
- #' @return Object of class `MAEFilteredDataset`, invisibly.+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
||
| 53 | +141 |
- #'+ #' - `character(0)` (default) `varname` in the condition call will not be prefixed |
||
| 54 | +142 |
- initialize = function(dataset, dataname, keys = character(0), label = character(0)) {
+ #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
||
| 55 | -23x | +|||
| 143 | +
- if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|||
| 56 | -! | +|||
| 144 | +
- stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ #' |
|||
| 57 | +145 |
- }+ #' @return Object of class `ChoicesFilterState`, invisibly. |
||
| 58 | -23x | +|||
| 146 | +
- checkmate::assert_class(dataset, "MultiAssayExperiment")+ #' |
|||
| 59 | -21x | +|||
| 147 | +
- super$initialize(dataset, dataname, keys, label)+ initialize = function(x, |
|||
| 60 | -21x | +|||
| 148 | +
- experiment_names <- names(dataset)+ x_reactive = reactive(NULL), |
|||
| 61 | +149 |
-
+ slice, |
||
| 62 | +150 |
- # subsetting by subjects means subsetting by colData(MAE)+ extract_type = character(0)) {
|
||
| 63 | -21x | +151 | +160x |
- private$add_filter_states(+ isolate({
|
| 64 | -21x | +152 | +160x |
- filter_states = init_filter_states(+ checkmate::assert( |
| 65 | -21x | +153 | +160x |
- data = dataset,+ is.character(x), |
| 66 | -21x | +154 | +160x |
- data_reactive = private$data_filtered_fun,+ is.factor(x), |
| 67 | -21x | +155 | +160x |
- dataname = dataname,+ length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
|
| 68 | -21x | +156 | +160x |
- datalabel = "subjects",+ combine = "or" |
| 69 | -21x | +|||
| 157 | +
- keys = self$get_keys()+ ) |
|||
| 70 | -+ | |||
| 158 | +160x |
- ),+ super$initialize( |
||
| 71 | -21x | +159 | +160x |
- id = "subjects"+ x = x, |
| 72 | -+ | |||
| 160 | +160x |
- )+ x_reactive = x_reactive, |
||
| 73 | -+ | |||
| 161 | +160x |
- # elements of the list (experiments) are unknown+ slice = slice, |
||
| 74 | -+ | |||
| 162 | +160x |
- # dispatch needed because we can't hardcode methods otherwise:+ extract_type = extract_type |
||
| 75 | +163 |
- # if (matrix) else if (SummarizedExperiment) else if ...+ ) |
||
| 76 | -21x | +164 | +160x |
- lapply(+ private$set_choices(slice$choices) |
| 77 | -21x | +165 | +160x |
- experiment_names,+ if (is.null(slice$selected) && slice$multiple) {
|
| 78 | -21x | +166 | +42x |
- function(experiment_name) {
+ slice$selected <- private$get_choices() |
| 79 | -105x | +167 | +118x |
- data_reactive <- function(sid = "") private$data_filtered_fun(sid)[[experiment_name]]+ } else if (is.null(slice$selected)) {
|
| 80 | -105x | +168 | +1x |
- private$add_filter_states(+ slice$selected <- private$get_choices()[1] |
| 81 | -105x | +169 | +117x |
- filter_states = init_filter_states(+ } else if (length(slice$selected) > 1 && !slice$multiple) {
|
| 82 | -105x | +170 | +1x |
- data = dataset[[experiment_name]],+ warning( |
| 83 | -105x | +171 | +1x |
- data_reactive = data_reactive,+ "ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ", |
| 84 | -105x | +172 | +1x |
- dataname = dataname,+ "Only the first value will be used."+ |
+
| 173 | ++ |
+ ) |
||
| 85 | -105x | +174 | +1x |
- datalabel = experiment_name+ slice$selected <- slice$selected[1] |
| 86 | +175 |
- ),+ } |
||
| 87 | -105x | +176 | +160x |
- id = experiment_name+ private$set_selected(slice$selected)+ |
+
| 177 | +160x | +
+ if (inherits(x, "POSIXt")) {
+ |
+ ||
| 178 | +9x | +
+ private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone")) |
||
| 88 | +179 |
- )+ } |
||
| 89 | +180 |
- }+ + |
+ ||
| 181 | +160x | +
+ private$set_choices_counts(unname(table(x))) |
||
| 90 | +182 |
- )+ })+ |
+ ||
| 183 | +160x | +
+ invisible(self) |
||
| 91 | +184 |
}, |
||
| 92 | +185 | |||
| 93 | +186 |
#' @description |
||
| 94 | +187 |
- #' Set filter state.+ #' Returns reproducible condition call for current selection. |
||
| 95 | +188 |
- #'+ #' For this class returned call looks like |
||
| 96 | +189 |
- #' @param state (`teal_slices`)+ #' `<varname> %in% c(<values selected>)` with optional `is.na(<varname>)`. |
||
| 97 | +190 |
- #' @return `NULL`, invisibly.+ #' @param dataname (`character(1)`) name of data set; defaults to `private$get_dataname()` |
||
| 98 | +191 |
- #'+ #' @return `call` or `NULL` |
||
| 99 | +192 |
- set_filter_state = function(state) {
+ #' |
||
| 100 | -15x | +|||
| 193 | +
- isolate({
+ get_call = function(dataname) {
|
|||
| 101 | -15x | +194 | +61x |
- logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
+ if (isFALSE(private$is_any_filtered())) {
|
| 102 | -15x | +195 | +7x |
- checkmate::assert_class(state, "teal_slices")+ return(NULL) |
| 103 | -14x | +|||
| 196 | +
- lapply(state, function(x) {
+ } |
|||
| 104 | -52x | +197 | +30x |
- checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname")+ if (missing(dataname)) dataname <- private$get_dataname() |
| 105 | -+ | |||
| 198 | +54x |
- })+ varname <- private$get_varname_prefixed(dataname) |
||
| 106 | -+ | |||
| 199 | +54x |
-
+ choices <- private$get_choices() |
||
| 107 | -+ | |||
| 200 | +54x |
- # set state on subjects+ selected <- private$get_selected() |
||
| 108 | -14x | +201 | +54x |
- subject_state <- Filter(function(x) is.null(x$experiment), state)+ fun_compare <- if (length(selected) == 1L) "==" else "%in%" |
| 109 | -14x | +202 | +54x |
- private$get_filter_states()[["subjects"]]$set_filter_state(subject_state)+ filter_call <- if (length(selected) == 0) {
|
| 110 | -+ | |||
| 203 | +6x |
-
+ call("!", call(fun_compare, varname, make_c_call(as.character(choices))))
|
||
| 111 | +204 |
- # set state on experiments+ } else {
|
||
| 112 | -+ | |||
| 205 | +48x |
- # determine target experiments (defined in teal_slices)+ if (setequal(selected, choices) && !private$is_choice_limited) {
|
||
| 113 | -14x | +206 | +2x |
- experiments <- unique(unlist(lapply(state, "[[", "experiment")))+ NULL |
| 114 | -14x | +207 | +46x |
- available_experiments <- setdiff(names(private$get_filter_states()), "subjects")+ } else if (inherits(private$x, "Date")) {
|
| 115 | -14x | +208 | +1x |
- excluded_filters <- setdiff(experiments, available_experiments)+ call(fun_compare, varname, call("as.Date", make_c_call(as.character(selected))))
|
| 116 | -14x | +209 | +45x |
- if (length(excluded_filters)) {
+ } else if (inherits(private$x, c("POSIXct", "POSIXlt"))) {
|
| 117 | -! | +|||
| 210 | +2x |
- stop(sprintf(+ class <- class(private$x)[1L] |
||
| 118 | -! | +|||
| 211 | +2x |
- "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",+ date_fun <- as.name( |
||
| 119 | -! | +|||
| 212 | +2x |
- private$dataname,+ switch(class, |
||
| 120 | -! | +|||
| 213 | +2x |
- toString(excluded_filters),+ "POSIXct" = "as.POSIXct", |
||
| 121 | -! | +|||
| 214 | +2x |
- toString(available_experiments)+ "POSIXlt" = "as.POSIXlt" |
||
| 122 | +215 |
- ))+ ) |
||
| 123 | +216 |
- }+ ) |
||
| 124 | -+ | |||
| 217 | +2x |
-
+ call( |
||
| 125 | -+ | |||
| 218 | +2x |
- # set states on state_lists with corresponding experiments+ fun_compare, |
||
| 126 | -14x | +219 | +2x |
- lapply(available_experiments, function(experiment) {
+ varname, |
| 127 | -70x | +220 | +2x |
- slices <- Filter(function(x) identical(x$experiment, experiment), state)+ as.call(list(date_fun, make_c_call(as.character(selected)), tz = private$tzone)) |
| 128 | -70x | +|||
| 221 | +
- private$get_filter_states()[[experiment]]$set_filter_state(slices)+ )+ |
+ |||
| 222 | +43x | +
+ } else if (is.numeric(private$x)) {
+ |
+ ||
| 223 | +7x | +
+ call(fun_compare, varname, make_c_call(as.numeric(selected))) |
||
| 129 | +224 |
- })+ } else {
|
||
| 130 | +225 |
-
+ # This handles numerics, characters, and factors. |
||
| 131 | -14x | +226 | +36x |
- logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
+ call(fun_compare, varname, make_c_call(selected)) |
| 132 | +227 |
-
+ }+ |
+ ||
| 228 | ++ |
+ } |
||
| 133 | -14x | +229 | +54x |
- invisible(NULL)+ private$add_keep_na_call(filter_call, varname) |
| 134 | +230 |
- })+ } |
||
| 135 | +231 |
- },+ ), |
||
| 136 | +232 | |||
| 137 | +233 |
- #' @description+ # private members ---- |
||
| 138 | +234 |
- #' Remove one or more `FilterState` of a `MAEFilteredDataset`.+ private = list( |
||
| 139 | +235 |
- #'+ x = NULL, |
||
| 140 | +236 |
- #' @param state (`teal_slices`)+ choices_counts = integer(0), |
||
| 141 | +237 |
- #' specifying `FilterState` objects to remove;+ tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call |
||
| 142 | +238 |
- #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored.+ |
||
| 143 | +239 |
- #'+ # private methods ---- |
||
| 144 | +240 |
- #' @return `NULL`, invisibly.+ |
||
| 145 | +241 |
- #'+ # @description |
||
| 146 | +242 |
- remove_filter_state = function(state) {
+ # Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices |
||
| 147 | -1x | +|||
| 243 | +
- checkmate::assert_class(state, "teal_slices")+ # are limited by default from the start. |
|||
| 148 | +244 |
-
+ set_choices = function(choices) {
|
||
| 149 | -1x | +245 | +160x |
- isolate({
+ if (is.null(choices)) {
|
| 150 | -1x | +246 | +145x |
- logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")
+ choices <- unique(as.character(na.omit(private$x))) |
| 151 | +247 |
- # remove state on subjects+ } else {
|
||
| 152 | -1x | +248 | +15x |
- subject_state <- Filter(function(x) is.null(x$experiment), state)+ choices <- as.character(choices) |
| 153 | -1x | +249 | +15x |
- private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state)+ choices_adjusted <- choices[choices %in% unique(private$x)]+ |
+
| 250 | +15x | +
+ if (length(setdiff(choices, choices_adjusted)) > 0L) {
+ |
+ ||
| 251 | +2x | +
+ warning(+ |
+ ||
| 252 | +2x | +
+ sprintf(+ |
+ ||
| 253 | +2x | +
+ "Some choices not found in data. Adjusting. Filter id: %s.",+ |
+ ||
| 254 | +2x | +
+ private$get_id() |
||
| 154 | +255 |
-
+ ) |
||
| 155 | +256 |
- # remove state on experiments+ )+ |
+ ||
| 257 | +2x | +
+ choices <- choices_adjusted |
||
| 156 | +258 |
- # determine target experiments (defined in teal_slices)+ } |
||
| 157 | -1x | +259 | +15x |
- experiments <- unique(unlist(lapply(state, "[[", "experiment")))+ if (length(choices) == 0) {
|
| 158 | +260 | 1x |
- available_experiments <- setdiff(names(private$get_filter_states()), "subjects")+ warning( |
|
| 159 | +261 | 1x |
- excluded_filters <- setdiff(experiments, available_experiments)+ sprintf( |
|
| 160 | +262 | 1x |
- if (length(excluded_filters)) {
+ "None of the choices were found in data. Setting defaults. Filter id: %s.", |
|
| 161 | -! | +|||
| 263 | +1x |
- stop(sprintf(+ private$get_id() |
||
| 162 | -! | +|||
| 264 | +
- "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",+ ) |
|||
| 163 | -! | +|||
| 265 | +
- private$dataname,+ ) |
|||
| 164 | -! | +|||
| 266 | +1x |
- toString(excluded_filters),+ choices <- levels(private$x) |
||
| 165 | -! | +|||
| 267 | +
- toString(available_experiments)+ } |
|||
| 166 | +268 |
- ))+ } |
||
| 167 | -+ | |||
| 269 | +160x |
- }+ private$set_is_choice_limited(private$x, choices) |
||
| 168 | -+ | |||
| 270 | +160x |
- # remove states on state_lists with corresponding experiments+ private$teal_slice$choices <- choices |
||
| 169 | -1x | +271 | +160x |
- lapply(experiments, function(experiment) {
+ private$x <- private$x[(private$x %in% private$get_choices()) | is.na(private$x)] |
| 170 | -! | +|||
| 272 | +36x |
- slices <- Filter(function(x) identical(x$experiment, experiment), state)+ if (is.factor(private$x)) private$x <- droplevels(private$x) |
||
| 171 | -! | +|||
| 273 | +160x |
- private$get_filter_states()[[experiment]]$remove_filter_state(slices)+ invisible(NULL) |
||
| 172 | +274 |
- })+ }, |
||
| 173 | +275 |
-
+ # @description |
||
| 174 | +276 |
-
+ # Check whether the initial choices filter out some values of x and set the flag in case. |
||
| 175 | -1x | +|||
| 277 | +
- logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
+ set_is_choice_limited = function(x, choices) {
|
|||
| 176 | -+ | |||
| 278 | +160x |
- })+ xl <- x[!is.na(x)] |
||
| 177 | -+ | |||
| 279 | +160x |
-
+ private$is_choice_limited <- length(setdiff(xl, choices)) > 0L |
||
| 178 | -1x | +280 | +160x |
invisible(NULL) |
| 179 | +281 |
}, |
||
| 180 | +282 |
-
+ # @description |
||
| 181 | +283 |
- #' @description+ # Sets choices_counts private field. |
||
| 182 | +284 |
- #' UI module to add filter variable for this dataset.+ set_choices_counts = function(choices_counts) {
|
||
| 183 | -+ | |||
| 285 | +160x |
- #' @param id (`character(1)`)+ private$choices_counts <- choices_counts |
||
| 184 | -+ | |||
| 286 | +160x |
- #' `shiny` module instance id.+ invisible(NULL) |
||
| 185 | +287 |
- #'+ }, |
||
| 186 | +288 |
- #' @return `shiny.tag`+ # @description |
||
| 187 | +289 |
- #'+ # Checks how many counts of each choice is present in the data. |
||
| 188 | +290 |
- ui_add = function(id) {
- |
- ||
| 189 | -! | -
- ns <- NS(id)+ get_choices_counts = function() {
|
||
| 190 | +291 | ! |
- data <- self$get_dataset()+ if (!is.null(private$x_reactive)) {
|
|
| 191 | +292 | ! |
- experiment_names <- names(data)+ table(factor(private$x_reactive(), levels = private$get_choices())) |
|
| 192 | +293 |
-
+ } else {
|
||
| 193 | +294 | ! |
- tags$div(+ NULL |
|
| 194 | -! | +|||
| 295 | +
- tags$label("Add", tags$code(self$get_dataname()), "filter"),
+ } |
|||
| 195 | -! | +|||
| 296 | +
- tags$br(),+ }, |
|||
| 196 | -! | +|||
| 297 | +
- HTML("►"),
+ # @description |
|||
| 197 | -! | +|||
| 298 | +
- tags$label("Add subjects filter"),
+ # Checks whether the input should be rendered as a checkboxgroup/radiobutton or a drop-down. |
|||
| 198 | -! | +|||
| 299 | +
- private$get_filter_states()[["subjects"]]$ui_add(id = ns("subjects")),
+ is_checkboxgroup = function() {
|
|||
| 199 | -! | +|||
| 300 | +23x |
- tagList(+ length(private$get_choices()) <= getOption("teal.threshold_slider_vs_checkboxgroup")
|
||
| 200 | -! | +|||
| 301 | +
- lapply(+ }, |
|||
| 201 | -! | +|||
| 302 | +
- experiment_names,+ cast_and_validate = function(values) {
|
|||
| 202 | -! | +|||
| 303 | +189x |
- function(experiment_name) {
+ tryCatch( |
||
| 203 | -! | +|||
| 304 | +189x |
- tagList(+ expr = {
|
||
| 204 | -! | +|||
| 305 | +189x |
- HTML("►"),
+ values <- as.character(values) |
||
| 205 | +306 | ! |
- tags$label("Add", tags$code(experiment_name), "filter"),
+ if (anyNA(values)) stop() |
|
| 206 | -! | +|||
| 307 | +
- private$get_filter_states()[[experiment_name]]$ui_add(id = ns(experiment_name))+ }, |
|||
| 207 | -+ | |||
| 308 | +189x |
- )+ error = function(e) stop("The vector of set values must contain values coercible to character.")
|
||
| 208 | +309 |
- }+ ) |
||
| 209 | -+ | |||
| 310 | +189x |
- )+ values |
||
| 210 | +311 |
- )+ }, |
||
| 211 | +312 |
- )+ # If multiple forbidden but selected, restores previous selection with warning. |
||
| 212 | +313 |
- },+ check_length = function(values) {
|
||
| 213 | -+ | |||
| 314 | +189x |
-
+ if (!private$is_multiple() && length(values) > 1) {
|
||
| 214 | -+ | |||
| 315 | +1x |
- #' @description+ warning(+ |
+ ||
| 316 | +1x | +
+ sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
+ |
+ ||
| 317 | +1x | +
+ "Maintaining previous selection." |
||
| 215 | +318 |
- #' Creates row for filter overview in the form of \cr+ )+ |
+ ||
| 319 | +1x | +
+ values <- isolate(private$get_selected()) |
||
| 216 | +320 |
- #' `dataname -- observations (remaining/total) -- subjects (remaining/total)` - MAE+ }+ |
+ ||
| 321 | +189x | +
+ values |
||
| 217 | +322 |
- #' @return A `data.frame`.+ }, |
||
| 218 | +323 |
- get_filter_overview = function() {
+ remove_out_of_bounds_values = function(values) {
|
||
| 219 | -2x | +324 | +189x |
- data <- self$get_dataset()+ in_choices_mask <- values %in% private$get_choices() |
| 220 | -2x | +325 | +189x |
- data_filtered <- self$get_dataset(TRUE)+ if (length(values[!in_choices_mask]) > 0) {
|
| 221 | -2x | +326 | +17x |
- experiment_names <- names(data)+ warning(paste( |
| 222 | -+ | |||
| 327 | +17x |
-
+ "Values:", toString(values[!in_choices_mask], width = 360), |
||
| 223 | -2x | +328 | +17x |
- mae_info <- data.frame(+ "are not in choices of column", private$get_varname(), "in dataset", private$get_dataname(), "." |
| 224 | -2x | +|||
| 329 | +
- dataname = private$dataname,+ )) |
|||
| 225 | -2x | +|||
| 330 | +
- subjects = nrow(SummarizedExperiment::colData(data)),+ } |
|||
| 226 | -2x | +331 | +189x |
- subjects_filtered = nrow(SummarizedExperiment::colData(data_filtered()))+ values[in_choices_mask] |
| 227 | +332 |
- )+ }, |
||
| 228 | +333 | |||
| 229 | -2x | +|||
| 334 | +
- experiment_obs_info <- do.call("rbind", lapply(
+ # shiny modules ---- |
|||
| 230 | -2x | +|||
| 335 | +
- experiment_names,+ |
|||
| 231 | -2x | +|||
| 336 | +
- function(experiment_name) {
+ # @description |
|||
| 232 | -10x | +|||
| 337 | +
- data.frame(+ # UI Module for `ChoicesFilterState`. |
|||
| 233 | -10x | +|||
| 338 | +
- dataname = sprintf("- %s", experiment_name),
+ # This UI element contains available choices selection and |
|||
| 234 | -10x | +|||
| 339 | +
- obs = nrow(data[[experiment_name]]),+ # checkbox whether to keep or not keep the `NA` values. |
|||
| 235 | -10x | +|||
| 340 | +
- obs_filtered = nrow(data_filtered()[[experiment_name]])+ # @param id (`character(1)`) `shiny` module instance id. |
|||
| 236 | +341 |
- )+ ui_inputs = function(id) {
|
||
| 237 | -+ | |||
| 342 | +7x |
- }+ ns <- NS(id) |
||
| 238 | +343 |
- ))+ |
||
| 239 | +344 |
-
+ # we need to isolate UI to not rettrigger renderUI |
||
| 240 | -2x | +345 | +7x |
- get_experiment_keys <- function(mae, experiment) {
+ isolate({
|
| 241 | -20x | +346 | +7x |
- sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment))+ countsmax <- private$choices_counts |
| 242 | -20x | +347 | +7x |
- length(unique(sample_subset$primary))+ countsnow <- if (!is.null(private$x_reactive())) {
+ |
+
| 348 | +! | +
+ unname(table(factor(private$x_reactive(), levels = private$get_choices()))) |
||
| 243 | +349 |
- }+ } |
||
| 244 | +350 | |||
| 245 | -2x | +351 | +7x |
- experiment_subjects_info <- do.call("rbind", lapply(
+ ui_input <- if (private$is_checkboxgroup()) {
|
| 246 | -2x | +352 | +7x |
- experiment_names,+ labels <- countBars( |
| 247 | -2x | +353 | +7x |
- function(experiment_name) {
+ inputId = ns("labels"),
|
| 248 | -10x | +354 | +7x |
- data.frame(+ choices = private$get_choices(), |
| 249 | -10x | +355 | +7x |
- subjects = get_experiment_keys(data, data[[experiment_name]]),+ countsnow = countsnow, |
| 250 | -10x | +356 | +7x |
- subjects_filtered = get_experiment_keys(data_filtered(), data_filtered()[[experiment_name]])+ countsmax = countsmax |
| 251 | +357 |
) |
||
| 252 | -+ | |||
| 358 | +7x |
- }+ tags$div( |
||
| 253 | -+ | |||
| 359 | +7x |
- ))+ class = "choices_state", |
||
| 254 | -+ | |||
| 360 | +7x |
-
+ if (private$is_multiple()) {
|
||
| 255 | -2x | +361 | +7x |
- experiment_info <- cbind(experiment_obs_info, experiment_subjects_info)+ checkboxGroupInput( |
| 256 | -2x | +362 | +7x |
- dplyr::bind_rows(mae_info, experiment_info)+ inputId = ns("selection"),
|
| 257 | -+ | |||
| 363 | +7x |
- }+ label = NULL, |
||
| 258 | -+ | |||
| 364 | +7x |
- )+ selected = private$get_selected(), |
||
| 259 | -+ | |||
| 365 | +7x |
- )+ choiceNames = labels, |
| 1 | -+ | |||
| 366 | +7x |
- # LogicalFilterState ------+ choiceValues = private$get_choices(), |
||
| 2 | -+ | |||
| 367 | +7x |
-
+ width = "100%" |
||
| 3 | +368 |
- #' @name LogicalFilterState+ ) |
||
| 4 | +369 |
- #' @docType class+ } else {
|
||
| 5 | -+ | |||
| 370 | +! |
- #'+ radioButtons( |
||
| 6 | -+ | |||
| 371 | +! |
- #' @title `FilterState` object for logical data+ inputId = ns("selection"),
|
||
| 7 | -+ | |||
| 372 | +! |
- #'+ label = NULL, |
||
| 8 | -+ | |||
| 373 | +! |
- #' @description Manages choosing a logical state.+ selected = private$get_selected(), |
||
| 9 | -+ | |||
| 374 | +! |
- #'+ choiceNames = labels, |
||
| 10 | -+ | |||
| 375 | +! |
- #' @examples+ choiceValues = private$get_choices(), |
||
| 11 | -+ | |||
| 376 | +! |
- #' # use non-exported function from teal.slice+ width = "100%" |
||
| 12 | +377 |
- #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
+ ) |
||
| 13 | +378 |
- #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
+ } |
||
| 14 | +379 |
- #' LogicalFilterState <- getFromNamespace("LogicalFilterState", "teal.slice")
+ ) |
||
| 15 | +380 |
- #'+ } else {
|
||
| 16 | -+ | |||
| 381 | +! |
- #' library(shiny)+ labels <- mapply( |
||
| 17 | -+ | |||
| 382 | +! |
- #'+ FUN = make_count_text, |
||
| 18 | -+ | |||
| 383 | +! |
- #' filter_state <- LogicalFilterState$new(+ label = private$get_choices(), |
||
| 19 | -+ | |||
| 384 | +! |
- #' x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE),+ countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow, |
||
| 20 | -+ | |||
| 385 | +! |
- #' slice = teal_slice(varname = "x", dataname = "data")+ countmax = countsmax |
||
| 21 | +386 |
- #' )+ ) |
||
| 22 | +387 |
- #' isolate(filter_state$get_call())+ |
||
| 23 | -+ | |||
| 388 | +! |
- #' filter_state$set_state(+ teal.widgets::optionalSelectInput( |
||
| 24 | -+ | |||
| 389 | +! |
- #' teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE)+ inputId = ns("selection"),
|
||
| 25 | -+ | |||
| 390 | +! |
- #' )+ choices = stats::setNames(private$get_choices(), labels), |
||
| 26 | -+ | |||
| 391 | +! |
- #' isolate(filter_state$get_call())+ selected = private$get_selected(), |
||
| 27 | -+ | |||
| 392 | +! |
- #'+ multiple = private$is_multiple(), |
||
| 28 | -+ | |||
| 393 | +! |
- #' # working filter in an app+ options = shinyWidgets::pickerOptions( |
||
| 29 | -+ | |||
| 394 | +! |
- #' library(shinyjs)+ actionsBox = TRUE, |
||
| 30 | -+ | |||
| 395 | +! |
- #'+ liveSearch = (length(private$get_choices()) > 10), |
||
| 31 | -+ | |||
| 396 | +! |
- #' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA)+ noneSelectedText = "Select a value" |
||
| 32 | +397 |
- #' fs <- LogicalFilterState$new(+ ) |
||
| 33 | +398 |
- #' x = data_logical,+ ) |
||
| 34 | +399 |
- #' slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)+ } |
||
| 35 | -+ | |||
| 400 | +7x |
- #' )+ tags$div( |
||
| 36 | -+ | |||
| 401 | +7x |
- #'+ uiOutput(ns("trigger_visible")),
|
||
| 37 | -+ | |||
| 402 | +7x |
- #' ui <- fluidPage(+ ui_input, |
||
| 38 | -+ | |||
| 403 | +7x |
- #' useShinyjs(),+ private$keep_na_ui(ns("keep_na"))
|
||
| 39 | +404 |
- #' include_css_files(pattern = "filter-panel"),+ ) |
||
| 40 | +405 |
- #' include_js_files(pattern = "count-bar-labels"),+ }) |
||
| 41 | +406 |
- #' column(4, tags$div(+ }, |
||
| 42 | +407 |
- #' tags$h4("LogicalFilterState"),
+
|
||
| 43 | +408 |
- #' fs$ui("fs")
+ # @description |
||
| 44 | +409 |
- #' )),+ # Server module |
||
| 45 | +410 |
- #' column(4, tags$div(+ # @param id (`character(1)`) `shiny` module instance id. |
||
| 46 | +411 |
- #' id = "outputs", # div id is needed for toggling the element+ # @return `NULL`. |
||
| 47 | +412 |
- #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
+ server_inputs = function(id) {
|
||
| 48 | -+ | |||
| 413 | +7x |
- #' textOutput("condition_logical"), tags$br(),
+ moduleServer( |
||
| 49 | -+ | |||
| 414 | +7x |
- #' tags$h4("Unformatted state"), # display raw filter state
+ id = id, |
||
| 50 | -+ | |||
| 415 | +7x |
- #' textOutput("unformatted_logical"), tags$br(),
+ function(input, output, session) {
|
||
| 51 | -+ | |||
| 416 | +7x |
- #' tags$h4("Formatted state"), # display human readable filter state
+ logger::log_trace("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }")
|
||
| 52 | +417 |
- #' textOutput("formatted_logical"), tags$br()
+
|
||
| 53 | +418 |
- #' )),+ # 1. renderUI is used here as an observer which triggers only if output is visible |
||
| 54 | +419 |
- #' column(4, tags$div(+ # and if the reactive changes - reactive triggers only if the output is visible. |
||
| 55 | +420 |
- #' tags$h4("Programmatic filter control"),
+ # 2. We want to trigger change of the labels only if reactive count changes (not underlying data) |
||
| 56 | -+ | |||
| 421 | +7x |
- #' actionButton("button1_logical", "set drop NA", width = "100%"), tags$br(),
+ non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive())) |
||
| 57 | -+ | |||
| 422 | +7x |
- #' actionButton("button2_logical", "set keep NA", width = "100%"), tags$br(),
+ output$trigger_visible <- renderUI({
|
||
| 58 | -+ | |||
| 423 | +7x |
- #' actionButton("button3_logical", "set a selection", width = "100%"), tags$br(),
+ logger::log_trace("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")
|
||
| 59 | +424 |
- #' actionButton("button0_logical", "set initial state", width = "100%"), tags$br()
+
|
||
| 60 | -+ | |||
| 425 | +7x |
- #' ))+ countsnow <- if (!is.null(private$x_reactive())) {
|
||
| 61 | -+ | |||
| 426 | +! |
- #' )+ unname(table(factor(non_missing_values(), levels = private$get_choices()))) |
||
| 62 | +427 |
- #'+ } |
||
| 63 | +428 |
- #' server <- function(input, output, session) {
+
|
||
| 64 | +429 |
- #' fs$server("fs")
+ # update should be based on a change of counts only |
||
| 65 | -+ | |||
| 430 | +7x |
- #' output$condition_logical <- renderPrint(fs$get_call())+ isolate({
|
||
| 66 | -+ | |||
| 431 | +7x |
- #' output$formatted_logical <- renderText(fs$format())+ if (private$is_checkboxgroup()) {
|
||
| 67 | -+ | |||
| 432 | +7x |
- #' output$unformatted_logical <- renderPrint(fs$get_state())+ updateCountBars( |
||
| 68 | -+ | |||
| 433 | +7x |
- #' # modify filter state programmatically+ inputId = "labels", |
||
| 69 | -+ | |||
| 434 | +7x |
- #' observeEvent(+ choices = private$get_choices(), |
||
| 70 | -+ | |||
| 435 | +7x |
- #' input$button1_logical,+ countsmax = private$choices_counts, |
||
| 71 | -+ | |||
| 436 | +7x |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))+ countsnow = countsnow |
||
| 72 | +437 |
- #' )+ ) |
||
| 73 | +438 |
- #' observeEvent(+ } else {
|
||
| 74 | -+ | |||
| 439 | +! |
- #' input$button2_logical,+ labels <- mapply( |
||
| 75 | -+ | |||
| 440 | +! |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ FUN = make_count_text, |
||
| 76 | -+ | |||
| 441 | +! |
- #' )+ label = private$get_choices(), |
||
| 77 | -+ | |||
| 442 | +! |
- #' observeEvent(+ countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow, |
||
| 78 | -+ | |||
| 443 | +! |
- #' input$button3_logical,+ countmax = private$choices_counts |
||
| 79 | +444 |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE))+ ) |
||
| 80 | -+ | |||
| 445 | +! |
- #' )+ teal.widgets::updateOptionalSelectInput( |
||
| 81 | -+ | |||
| 446 | +! |
- #' observeEvent(+ session = session, |
||
| 82 | -+ | |||
| 447 | +! |
- #' input$button0_logical,+ inputId = "selection", |
||
| 83 | -+ | |||
| 448 | +! |
- #' fs$set_state(+ choices = stats::setNames(private$get_choices(), labels), |
||
| 84 | -+ | |||
| 449 | +! |
- #' teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)+ selected = private$get_selected() |
||
| 85 | +450 |
- #' )+ ) |
||
| 86 | +451 |
- #' )+ } |
||
| 87 | -+ | |||
| 452 | +7x |
- #' }+ NULL |
||
| 88 | +453 |
- #'+ }) |
||
| 89 | +454 |
- #' if (interactive()) {
+ }) |
||
| 90 | +455 |
- #' shinyApp(ui, server)+ |
||
| 91 | -+ | |||
| 456 | +7x |
- #' }+ if (private$is_checkboxgroup()) {
|
||
| 92 | -+ | |||
| 457 | +7x |
- #'+ private$observers$selection <- observeEvent( |
||
| 93 | -+ | |||
| 458 | +7x |
- #' @keywords internal+ ignoreNULL = FALSE, |
||
| 94 | -+ | |||
| 459 | +7x |
- #'+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
||
| 95 | -+ | |||
| 460 | +7x |
- LogicalFilterState <- R6::R6Class( # nolint+ eventExpr = input$selection, |
||
| 96 | -+ | |||
| 461 | +7x |
- "LogicalFilterState",+ handlerExpr = {
|
||
| 97 | -+ | |||
| 462 | +! |
- inherit = FilterState,+ logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
|
||
| 98 | +463 | |||
| 99 | -+ | |||
| 464 | +! |
- # public methods ----+ selection <- if (is.null(input$selection) && private$is_multiple()) {
|
||
| 100 | -+ | |||
| 465 | +! |
- public = list(+ character(0) |
||
| 101 | +466 |
-
+ } else {
|
||
| 102 | -+ | |||
| 467 | +! |
- #' @description+ input$selection |
||
| 103 | +468 |
- #' Initialize a `FilterState` object.+ } |
||
| 104 | +469 |
- #'+ |
||
| 105 | -+ | |||
| 470 | +! |
- #' @param x (`logical`)+ private$set_selected(selection) |
||
| 106 | +471 |
- #' variable to be filtered.+ } |
||
| 107 | +472 |
- #' @param x_reactive (`reactive`)+ ) |
||
| 108 | +473 |
- #' returning vector of the same type as `x`. Is used to update+ } else {
|
||
| 109 | -+ | |||
| 474 | +! |
- #' counts following the change in values of the filtered dataset.- |
- ||
| 110 | -- |
- #' If it is set to `reactive(NULL)` then counts based on filtered- |
- ||
| 111 | -- |
- #' dataset are not shown.- |
- ||
| 112 | -- |
- #' @param slice (`teal_slice`)+ private$observers$selection <- observeEvent( |
||
| 113 | -+ | |||
| 475 | +! |
- #' specification of this filter state.+ ignoreNULL = FALSE, |
||
| 114 | -+ | |||
| 476 | +! |
- #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
||
| 115 | -+ | |||
| 477 | +! |
- #' `get_state` returns `teal_slice` object which can be reused in other places.+ eventExpr = input$selection_open, # observe click on a dropdown |
||
| 116 | -+ | |||
| 478 | +! |
- #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.+ handlerExpr = {
|
||
| 117 | -+ | |||
| 479 | +! |
- #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.+ if (!isTRUE(input$selection_open)) { # only when the dropdown got closed
|
||
| 118 | -+ | |||
| 480 | +! |
- #' @param extract_type (`character`)+ logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
|
||
| 119 | +481 |
- #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ |
||
| 120 | -+ | |||
| 482 | +! |
- #' - `character(0)` (default) `varname` in the condition call will not be prefixed+ selection <- if (is.null(input$selection) && private$is_multiple()) {
|
||
| 121 | -+ | |||
| 483 | +! |
- #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`+ character(0) |
||
| 122 | -+ | |||
| 484 | +! |
- #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`+ } else if (isTRUE(length(input$selection) != 1) && !private$is_multiple()) {
|
||
| 123 | +485 |
- #'+ # In optionalSelectInput user is able to select mutliple options. But if FilterState is not multiple |
||
| 124 | +486 |
- #' @return Object of class `LogicalFilterState`, invisibly.+ # we should prevent this selection to be processed further. |
||
| 125 | +487 |
- #'+ # This is why notification is thrown and dropdown is changed back to latest selected. |
||
| 126 | -+ | |||
| 488 | +! |
- initialize = function(x,+ showNotification(paste( |
||
| 127 | -+ | |||
| 489 | +! |
- x_reactive = reactive(NULL),+ "This filter exclusively supports single selection.", |
||
| 128 | -+ | |||
| 490 | +! |
- extract_type = character(0),+ "Any additional choices made will be disregarded." |
||
| 129 | +491 |
- slice) {
- |
- ||
| 130 | -16x | -
- isolate({
+ )) |
||
| 131 | -16x | +|||
| 492 | +! |
- checkmate::assert_logical(x)+ teal.widgets::updateOptionalSelectInput( |
||
| 132 | -15x | +|||
| 493 | +! |
- checkmate::assert_logical(slice$selected, null.ok = TRUE)+ session, "selection", |
||
| 133 | -14x | +|||
| 494 | +! |
- super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type)+ selected = private$get_selected() |
||
| 134 | +495 | - - | -||
| 135 | -14x | -
- private$set_choices(slice$choices)+ ) |
||
| 136 | +496 | ! |
- if (is.null(slice$multiple)) slice$multiple <- FALSE- |
- |
| 137 | -14x | -
- if (is.null(slice$selected) && slice$multiple) {
- |
- ||
| 138 | -7x | -
- slice$selected <- private$get_choices()- |
- ||
| 139 | -7x | -
- } else if (length(slice$selected) != 1 && !slice$multiple) {
- |
- ||
| 140 | -3x | -
- slice$selected <- TRUE+ return(NULL) |
||
| 141 | +497 |
- }- |
- ||
| 142 | -14x | -
- private$set_selected(slice$selected)+ } else {
|
||
| 143 | -14x | +|||
| 498 | +! |
- df <- factor(x, levels = c(TRUE, FALSE))+ input$selection |
||
| 144 | -14x | +|||
| 499 | +
- tbl <- table(df)+ } |
|||
| 145 | -14x | +|||
| 500 | +! |
- private$set_choices_counts(tbl)+ private$set_selected(selection) |
||
| 146 | +501 |
- })+ } |
||
| 147 | -14x | +|||
| 502 | +
- invisible(self)+ } |
|||
| 148 | +503 |
- },+ ) |
||
| 149 | +504 |
-
+ } |
||
| 150 | +505 |
- #' @description+ |
||
| 151 | +506 |
- #' Returns reproducible condition call for current selection.+ |
||
| 152 | -+ | |||
| 507 | +7x |
- #' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally `is.na(<varname>)`+ private$keep_na_srv("keep_na")
|
||
| 153 | +508 |
- #' @param dataname name of data set; defaults to `private$get_dataname()`+ |
||
| 154 | +509 |
- #' @return `call`+ # this observer is needed in the situation when teal_slice$selected has been |
||
| 155 | +510 |
- #'+ # changed directly by the api - then it's needed to rerender UI element |
||
| 156 | +511 |
- get_call = function(dataname) {
+ # to show relevant values |
||
| 157 | -6x | +512 | +7x |
- if (isFALSE(private$is_any_filtered())) {
+ private$observers$selection_api <- observeEvent(private$get_selected(), {
|
| 158 | -! | +|||
| 513 | +
- return(NULL)+ # it's important to not retrigger when the input$selection is the same as reactive values |
|||
| 159 | +514 |
- }+ # kept in the teal_slice$selected |
||
| 160 | -4x | +515 | +2x |
- if (missing(dataname)) dataname <- private$get_dataname()+ if (!setequal(input$selection, private$get_selected())) {
|
| 161 | -6x | +516 | +2x |
- varname <- private$get_varname_prefixed(dataname)+ logger::log_trace("ChoicesFilterState$server@1 state changed, id: { private$get_id() }")
|
| 162 | -6x | +517 | +2x |
- choices <- private$get_selected()+ if (private$is_checkboxgroup()) {
|
| 163 | -6x | +518 | +2x |
- n_choices <- length(choices)+ if (private$is_multiple()) {
|
| 164 | -+ | |||
| 519 | +2x |
-
+ updateCheckboxGroupInput( |
||
| 165 | -6x | +520 | +2x |
- filter_call <-+ inputId = "selection", |
| 166 | -6x | +521 | +2x |
- if (n_choices == 1 && choices) {
+ selected = private$get_selected() |
| 167 | -1x | +|||
| 522 | +
- varname+ ) |
|||
| 168 | -6x | +|||
| 523 | +
- } else if (n_choices == 1 && !choices) {
+ } else {
|
|||
| 169 | -4x | +|||
| 524 | +! |
- call("!", varname)
+ updateRadioButtons( |
||
| 170 | -+ | |||
| 525 | +! |
- } else {
+ inputId = "selection", |
||
| 171 | -1x | +|||
| 526 | +! |
- call("%in%", varname, make_c_call(choices))
+ selected = private$get_selected() |
||
| 172 | +527 |
- }+ ) |
||
| 173 | -6x | +|||
| 528 | +
- private$add_keep_na_call(filter_call, varname)+ } |
|||
| 174 | +529 |
- }+ } else {
|
||
| 175 | -+ | |||
| 530 | +! |
- ),+ teal.widgets::updateOptionalSelectInput( |
||
| 176 | -+ | |||
| 531 | +! |
-
+ session, "selection", |
||
| 177 | -+ | |||
| 532 | +! |
- # private members ----+ selected = private$get_selected() |
||
| 178 | +533 |
- private = list(+ ) |
||
| 179 | +534 |
- choices_counts = integer(0),+ } |
||
| 180 | +535 |
-
+ } |
||
| 181 | +536 |
- # private methods ----+ }) |
||
| 182 | +537 |
- set_choices = function(choices) {
+
|
||
| 183 | -14x | +538 | +7x |
- private$teal_slice$choices <- c(TRUE, FALSE)+ logger::log_trace("ChoicesFilterState$server_inputs initialized, id: { private$get_id() }")
|
| 184 | -14x | +539 | +7x |
- invisible(NULL)+ NULL |
| 185 | +540 |
- },+ } |
||
| 186 | +541 |
- # @description+ ) |
||
| 187 | +542 |
- # Sets choices_counts private field+ }, |
||
| 188 | +543 |
- set_choices_counts = function(choices_counts) {
+ server_inputs_fixed = function(id) {
|
||
| 189 | -14x | +|||
| 544 | +! |
- private$choices_counts <- choices_counts+ moduleServer( |
||
| 190 | -14x | +|||
| 545 | +! |
- invisible(NULL)+ id = id, |
||
| 191 | -+ | |||
| 546 | +! |
- },+ function(input, output, session) {
+ |
+ ||
| 547 | +! | +
+ logger::log_trace("ChoicesFilterState$server_inputs_fixed initializing, id: { private$get_id() }")
|
||
| 192 | +548 |
- cast_and_validate = function(values) {
+
|
||
| 193 | -21x | +|||
| 549 | +! |
- tryCatch(+ output$selection <- renderUI({
|
||
| 194 | -21x | +|||
| 550 | +! |
- expr = {
+ countsnow <- if (!is.null(private$x_reactive())) {
|
||
| 195 | -21x | +|||
| 551 | +! |
- values <- as.logical(values)+ unname(table(factor(private$x_reactive(), levels = private$get_choices()))) |
||
| 196 | -1x | +|||
| 552 | +
- if (anyNA(values)) stop()+ } |
|||
| 197 | -20x | +|||
| 553 | +! |
- values+ countsmax <- private$choices_counts |
||
| 198 | +554 |
- },+ |
||
| 199 | -21x | +|||
| 555 | +! |
- error = function(e) stop("Vector of set values must contain values coercible to logical.")
+ ind <- private$get_choices() %in% isolate(private$get_selected()) |
||
| 200 | -+ | |||
| 556 | +! |
- )+ countBars( |
||
| 201 | -+ | |||
| 557 | +! |
- },+ inputId = session$ns("labels"),
|
||
| 202 | -+ | |||
| 558 | +! |
- # If multiple forbidden but selected, restores previous selection with warning.+ choices = isolate(private$get_selected()),+ |
+ ||
| 559 | +! | +
+ countsnow = countsnow[ind],+ |
+ ||
| 560 | +! | +
+ countsmax = countsmax[ind] |
||
| 203 | +561 |
- check_length = function(values) {
+ ) |
||
| 204 | -20x | +|||
| 562 | +
- if (!private$is_multiple() && length(values) > 1) {
+ }) |
|||
| 205 | -1x | +|||
| 563 | +
- warning(+ |
|||
| 206 | -1x | +|||
| 564 | +! |
- sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
+ logger::log_trace("ChoicesFilterState$server_inputs_fixed initialized, id: { private$get_id() }")
|
||
| 207 | -1x | +|||
| 565 | +! |
- "Maintaining previous selection."+ NULL |
||
| 208 | +566 |
- )+ } |
||
| 209 | -1x | +|||
| 567 | +
- values <- isolate(private$get_selected())+ ) |
|||
| 210 | +568 |
- }+ }, |
||
| 211 | -20x | +|||
| 569 | +
- values+ |
|||
| 212 | +570 |
- },+ # @description |
||
| 213 | +571 |
-
+ # UI module to display filter summary |
||
| 214 | +572 |
- # Answers the question of whether the current settings and values selected actually filters out any values.+ # renders text describing number of selected levels |
||
| 215 | +573 |
- # @return logical scalar+ # and if NA are included also |
||
| 216 | +574 |
- is_any_filtered = function() {
+ content_summary = function(id) {
|
||
| 217 | -6x | +575 | +7x |
- if (private$is_choice_limited) {
+ selected <- private$get_selected()+ |
+
| 576 | +7x | +
+ selected_text <-+ |
+ ||
| 577 | +7x | +
+ if (length(selected) == 0L) {
|
||
| 218 | +578 | ! |
- TRUE+ "no selection"+ |
+ |
| 579 | ++ |
+ } else {
|
||
| 219 | -6x | +580 | +7x |
- } else if (all(private$choices_counts > 0)) {
+ if (sum(nchar(selected)) <= 40L) {
|
| 220 | -6x | +581 | +7x |
- TRUE+ paste(selected, collapse = ", ") |
| 221 | +582 |
- } else if (+ } else {
|
||
| 222 | +583 | ! |
- setequal(private$get_selected(), private$get_choices()) &&+ paste(length(selected), "levels selected") |
|
| 223 | -! | +|||
| 584 | +
- !anyNA(private$get_selected(), private$get_choices())+ } |
|||
| 224 | +585 |
- ) {
+ } |
||
| 225 | -! | +|||
| 586 | +7x |
- TRUE+ tagList( |
||
| 226 | -! | +|||
| 587 | +7x |
- } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ tags$span( |
||
| 227 | -! | +|||
| 588 | +7x |
- TRUE+ class = "filter-card-summary-value",+ |
+ ||
| 589 | +7x | +
+ selected_text |
||
| 228 | +590 |
- } else {
+ ),+ |
+ ||
| 591 | +7x | +
+ tags$span(+ |
+ ||
| 592 | +7x | +
+ class = "filter-card-summary-controls",+ |
+ ||
| 593 | +7x | +
+ if (private$na_count > 0) {
|
||
| 229 | +594 | ! |
- FALSE+ tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
|
|
| 230 | +595 |
- }+ } |
||
| 231 | +596 |
- },+ ) |
||
| 232 | +597 |
-
+ ) |
||
| 233 | +598 |
- # shiny modules ----+ } |
||
| 234 | +599 |
-
+ ) |
||
| 235 | +600 |
- # @description+ ) |
| 236 | +1 |
- # UI Module for `EmptyFilterState`.+ # MAEFilteredDataset ------ |
|
| 237 | +2 |
- # This UI element contains available choices selection and+ |
|
| 238 | +3 |
- # checkbox whether to keep or not keep the `NA` values.+ #' @name MAEFilteredDataset |
|
| 239 | +4 |
- # @param id (`character(1)`) `shiny` module instance id.+ #' @docType class |
|
| 240 | +5 |
- ui_inputs = function(id) {
+ #' @title `MAEFilteredDataset` `R6` class |
|
| 241 | -! | +||
| 6 | +
- ns <- NS(id)+ #' |
||
| 242 | -! | +||
| 7 | +
- isolate({
+ #' @examplesIf requireNamespace("MultiAssayExperiment")
|
||
| 243 | -! | +||
| 8 | +
- countsmax <- private$choices_counts+ #' # use non-exported function from teal.slice |
||
| 244 | -! | +||
| 9 | +
- countsnow <- if (!is.null(private$x_reactive())) {
+ #' MAEFilteredDataset <- getFromNamespace("MAEFilteredDataset", "teal.slice")
|
||
| 245 | -! | +||
| 10 | +
- unname(table(factor(private$x_reactive(), levels = private$get_choices())))+ #' |
||
| 246 | +11 |
- } else {
+ #' data(miniACC, package = "MultiAssayExperiment") |
|
| 247 | -! | +||
| 12 | +
- NULL+ #' dataset <- MAEFilteredDataset$new(miniACC, "MAE") |
||
| 248 | +13 |
- }+ #' fs <- teal_slices( |
|
| 249 | +14 |
-
+ #' teal_slice( |
|
| 250 | -! | +||
| 15 | +
- labels <- countBars(+ #' dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE |
||
| 251 | -! | +||
| 16 | +
- inputId = ns("labels"),
+ #' ), |
||
| 252 | -! | +||
| 17 | +
- choices = as.character(private$get_choices()),+ #' teal_slice( |
||
| 253 | -! | +||
| 18 | +
- countsnow = countsnow,+ #' dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE |
||
| 254 | -! | +||
| 19 | +
- countsmax = countsmax+ #' ), |
||
| 255 | +20 |
- )+ #' teal_slice( |
|
| 256 | -! | +||
| 21 | +
- ui_input <- if (private$is_multiple()) {
+ #' dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE |
||
| 257 | -! | +||
| 22 | +
- checkboxGroupInput(+ #' ), |
||
| 258 | -! | +||
| 23 | +
- inputId = ns("selection"),
+ #' teal_slice( |
||
| 259 | -! | +||
| 24 | +
- label = NULL,+ #' dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE |
||
| 260 | -! | +||
| 25 | +
- selected = isolate(as.character(private$get_selected())),+ #' ) |
||
| 261 | -! | +||
| 26 | +
- choiceNames = labels,- |
- ||
| 262 | -! | -
- choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
- |
- |
| 263 | -! | -
- width = "100%"+ #' ) |
|
| 264 | +27 |
- )+ #' dataset$set_filter_state(state = fs) |
|
| 265 | +28 |
- } else {
+ #' |
|
| 266 | -! | +||
| 29 | +
- radioButtons(+ #' library(shiny) |
||
| 267 | -! | +||
| 30 | +
- inputId = ns("selection"),
+ #' isolate(dataset$get_filter_state()) |
||
| 268 | -! | +||
| 31 | +
- label = NULL,+ #' |
||
| 269 | -! | +||
| 32 | +
- selected = isolate(as.character(private$get_selected())),+ #' @keywords internal |
||
| 270 | -! | +||
| 33 | +
- choiceNames = labels,+ #' |
||
| 271 | -! | +||
| 34 | +
- choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
+ MAEFilteredDataset <- R6::R6Class( # nolint |
||
| 272 | -! | +||
| 35 | +
- width = "100%"+ classname = "MAEFilteredDataset", |
||
| 273 | +36 |
- )+ inherit = FilteredDataset, |
|
| 274 | +37 |
- }+ |
|
| 275 | -! | +||
| 38 | +
- tags$div(+ # public methods ---- |
||
| 276 | -! | +||
| 39 | +
- tags$div(+ public = list( |
||
| 277 | -! | +||
| 40 | +
- class = "choices_state",+ #' @description |
||
| 278 | -! | +||
| 41 | +
- uiOutput(ns("trigger_visible"), inline = TRUE),
+ #' Initialize `MAEFilteredDataset` object. |
||
| 279 | -! | +||
| 42 | +
- ui_input+ #' |
||
| 280 | +43 |
- ),+ #' @param dataset (`MulitiAssayExperiment`) |
|
| 281 | -! | +||
| 44 | +
- private$keep_na_ui(ns("keep_na"))
+ #' single `MulitiAssayExperiment` for which filters are rendered. |
||
| 282 | +45 |
- )+ #' @param dataname (`character(1)`) |
|
| 283 | +46 |
- })+ #' syntactically valid name given to the dataset. |
|
| 284 | +47 |
- },+ #' @param keys (`character`) optional |
|
| 285 | +48 |
-
+ #' vector of primary key column names. |
|
| 286 | +49 |
- # @description+ #' @param label (`character(1)`) |
|
| 287 | +50 |
- # Server module+ #' label to describe the dataset. |
|
| 288 | +51 |
- # @param id (`character(1)`) `shiny` module instance id.+ #' |
|
| 289 | +52 |
- # @return `NULL`.+ #' @return Object of class `MAEFilteredDataset`, invisibly. |
|
| 290 | +53 |
- server_inputs = function(id) {
+ #' |
|
| 291 | -! | +||
| 54 | +
- moduleServer(+ initialize = function(dataset, dataname, keys = character(0), label = character(0)) {
|
||
| 292 | -! | +||
| 55 | +23x |
- id = id,+ if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
|
| 293 | +56 | ! |
- function(input, output, session) {
- |
-
| 294 | -- |
- # this observer is needed in the situation when teal_slice$selected has been- |
- |
| 295 | -- |
- # changed directly by the api - then it's needed to rerender UI element+ stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
|
|
| 296 | +57 |
- # to show relevant values+ } |
|
| 297 | -! | +||
| 58 | +23x |
- non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))+ checkmate::assert_class(dataset, "MultiAssayExperiment") |
|
| 298 | -! | +||
| 59 | +21x |
- output$trigger_visible <- renderUI({
+ super$initialize(dataset, dataname, keys, label) |
|
| 299 | -! | +||
| 60 | +21x |
- logger::log_trace("LogicalFilterState$server@1 updating count labels, id: { private$get_id() }")
+ experiment_names <- names(dataset) |
|
| 300 | +61 | ||
| 301 | -! | +||
| 62 | +
- countsnow <- if (!is.null(private$x_reactive())) {
+ # subsetting by subjects means subsetting by colData(MAE) |
||
| 302 | -! | +||
| 63 | +21x |
- unname(table(factor(non_missing_values(), levels = private$get_choices())))+ private$add_filter_states( |
|
| 303 | -+ | ||
| 64 | +21x |
- } else {
+ filter_states = init_filter_states( |
|
| 304 | -! | +||
| 65 | +21x |
- NULL+ data = dataset, |
|
| 305 | -+ | ||
| 66 | +21x |
- }+ data_reactive = private$data_filtered_fun, |
|
| 306 | -+ | ||
| 67 | +21x |
-
+ dataname = dataname, |
|
| 307 | -! | +||
| 68 | +21x |
- updateCountBars(+ datalabel = "subjects", |
|
| 308 | -! | +||
| 69 | +21x |
- inputId = "labels",+ keys = self$get_keys() |
|
| 309 | -! | +||
| 70 | +
- choices = as.character(private$get_choices()),+ ), |
||
| 310 | -! | +||
| 71 | +21x |
- countsmax = private$choices_counts,+ id = "subjects" |
|
| 311 | -! | +||
| 72 | +
- countsnow = countsnow+ ) |
||
| 312 | +73 |
- )+ # elements of the list (experiments) are unknown |
|
| 313 | -! | +||
| 74 | +
- NULL+ # dispatch needed because we can't hardcode methods otherwise: |
||
| 314 | +75 |
- })+ # if (matrix) else if (SummarizedExperiment) else if ... |
|
| 315 | -+ | ||
| 76 | +21x |
-
+ lapply( |
|
| 316 | -! | +||
| 77 | +21x |
- private$observers$seleted_api <- observeEvent(+ experiment_names, |
|
| 317 | -! | +||
| 78 | +21x |
- ignoreNULL = !private$is_multiple(),+ function(experiment_name) {
|
|
| 318 | -! | +||
| 79 | +105x |
- ignoreInit = TRUE,+ data_reactive <- function(sid = "") private$data_filtered_fun(sid)[[experiment_name]] |
|
| 319 | -! | +||
| 80 | +105x |
- eventExpr = private$get_selected(),+ private$add_filter_states( |
|
| 320 | -! | +||
| 81 | +105x |
- handlerExpr = {
+ filter_states = init_filter_states( |
|
| 321 | -! | +||
| 82 | +105x |
- if (!setequal(private$get_selected(), input$selection)) {
+ data = dataset[[experiment_name]], |
|
| 322 | -! | +||
| 83 | +105x |
- logger::log_trace("LogicalFilterState$server@1 state changed, id: { private$get_id() }")
+ data_reactive = data_reactive, |
|
| 323 | -! | +||
| 84 | +105x |
- if (private$is_multiple()) {
+ dataname = dataname, |
|
| 324 | -! | +||
| 85 | +105x |
- updateCheckboxGroupInput(+ datalabel = experiment_name |
|
| 325 | -! | +||
| 86 | +
- inputId = "selection",+ ), |
||
| 326 | -! | +||
| 87 | +105x |
- selected = private$get_selected()+ id = experiment_name |
|
| 327 | +88 |
- )+ ) |
|
| 328 | +89 |
- } else {
+ } |
|
| 329 | -! | +||
| 90 | +
- updateRadioButtons(+ ) |
||
| 330 | -! | +||
| 91 | +
- inputId = "selection",+ }, |
||
| 331 | -! | +||
| 92 | +
- selected = private$get_selected()+ |
||
| 332 | +93 |
- )+ #' @description |
|
| 333 | +94 |
- }+ #' Set filter state. |
|
| 334 | +95 |
- }+ #' |
|
| 335 | +96 |
- }+ #' @param state (`teal_slices`) |
|
| 336 | +97 |
- )+ #' @return `NULL`, invisibly. |
|
| 337 | +98 |
-
+ #' |
|
| 338 | -! | +||
| 99 | +
- private$observers$selection <- observeEvent(+ set_filter_state = function(state) {
|
||
| 339 | -! | +||
| 100 | +15x |
- ignoreNULL = FALSE,+ isolate({
|
|
| 340 | -! | +||
| 101 | +15x |
- ignoreInit = TRUE,+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
|
|
| 341 | -! | +||
| 102 | +15x |
- eventExpr = input$selection,+ checkmate::assert_class(state, "teal_slices") |
|
| 342 | -! | +||
| 103 | +14x |
- handlerExpr = {
+ lapply(state, function(x) {
|
|
| 343 | -! | +||
| 104 | +52x |
- logger::log_trace("LogicalFilterState$server@2 selection changed, id: { private$get_id() }")
+ checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname") |
|
| 344 | +105 |
- # for private$is_multiple() == TRUE input$selection will always have value- |
- |
| 345 | -! | -
- if (is.null(input$selection) && isFALSE(private$is_multiple())) {
+ }) |
|
| 346 | -! | +||
| 106 | +
- selection_state <- private$get_selected()+ |
||
| 347 | +107 |
- } else {
+ # set state on subjects |
|
| 348 | -! | +||
| 108 | +14x |
- selection_state <- as.logical(input$selection)+ subject_state <- Filter(function(x) is.null(x$experiment), state) |
|
| 349 | -+ | ||
| 109 | +14x |
- }+ private$get_filter_states()[["subjects"]]$set_filter_state(subject_state) |
|
| 350 | +110 | ||
| 351 | -! | +||
| 111 | +
- if (is.null(selection_state)) {
+ # set state on experiments |
||
| 352 | -! | +||
| 112 | +
- selection_state <- logical(0)+ # determine target experiments (defined in teal_slices) |
||
| 353 | -+ | ||
| 113 | +14x |
- }+ experiments <- unique(unlist(lapply(state, "[[", "experiment"))) |
|
| 354 | -! | +||
| 114 | +14x |
- private$set_selected(selection_state)+ available_experiments <- setdiff(names(private$get_filter_states()), "subjects") |
|
| 355 | -+ | ||
| 115 | +14x |
- }+ excluded_filters <- setdiff(experiments, available_experiments) |
|
| 356 | -+ | ||
| 116 | +14x |
- )+ if (length(excluded_filters)) {
|
|
| 357 | -+ | ||
| 117 | +! |
-
+ stop(sprintf( |
|
| 358 | +118 | ! |
- private$keep_na_srv("keep_na")
+ "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s", |
| 359 | -+ | ||
| 119 | +! |
-
+ private$dataname, |
|
| 360 | +120 | ! |
- logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
+ toString(excluded_filters), |
| 361 | +121 | ! |
- NULL+ toString(available_experiments) |
| 362 | +122 |
- }+ )) |
|
| 363 | +123 |
- )+ } |
|
| 364 | +124 |
- },+ |
|
| 365 | +125 |
- server_inputs_fixed = function(id) {
+ # set states on state_lists with corresponding experiments |
|
| 366 | -! | +||
| 126 | +14x |
- moduleServer(+ lapply(available_experiments, function(experiment) {
|
|
| 367 | -! | +||
| 127 | +70x |
- id = id,+ slices <- Filter(function(x) identical(x$experiment, experiment), state) |
|
| 368 | -! | +||
| 128 | +70x |
- function(input, output, session) {
+ private$get_filter_states()[[experiment]]$set_filter_state(slices) |
|
| 369 | -! | +||
| 129 | +
- logger::log_trace("LogicalFilterState$server initializing, id: { private$get_id() }")
+ }) |
||
| 370 | +130 | ||
| 371 | -! | -
- output$selection <- renderUI({
- |
- |
| 372 | -! | -
- countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices())))- |
- |
| 373 | -! | +||
| 131 | +14x |
- countsmax <- private$choices_counts+ logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
|
|
| 374 | +132 | ||
| 375 | -! | +||
| 133 | +14x |
- ind <- private$get_choices() %in% private$get_selected()+ invisible(NULL) |
|
| 376 | -! | +||
| 134 | +
- countBars(+ }) |
||
| 377 | -! | +||
| 135 | +
- inputId = session$ns("labels"),
+ }, |
||
| 378 | -! | +||
| 136 | +
- choices = private$get_selected(),+ |
||
| 379 | -! | +||
| 137 | +
- countsnow = countsnow[ind],+ #' @description |
||
| 380 | -! | +||
| 138 | +
- countsmax = countsmax[ind]+ #' Remove one or more `FilterState` of a `MAEFilteredDataset`. |
||
| 381 | +139 |
- )+ #' |
|
| 382 | +140 |
- })+ #' @param state (`teal_slices`) |
|
| 383 | +141 |
-
+ #' specifying `FilterState` objects to remove; |
|
| 384 | -! | +||
| 142 | +
- logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored. |
||
| 385 | -! | +||
| 143 | +
- NULL+ #' |
||
| 386 | +144 |
- }+ #' @return `NULL`, invisibly. |
|
| 387 | +145 |
- )+ #' |
|
| 388 | +146 |
- },+ remove_filter_state = function(state) {
+ |
+ |
| 147 | +1x | +
+ checkmate::assert_class(state, "teal_slices") |
|
| 389 | +148 | ||
| 390 | -+ | ||
| 149 | +1x |
- # @description+ isolate({
+ |
+ |
| 150 | +1x | +
+ logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")
|
|
| 391 | +151 |
- # Server module to display filter summary+ # remove state on subjects+ |
+ |
| 152 | +1x | +
+ subject_state <- Filter(function(x) is.null(x$experiment), state)+ |
+ |
| 153 | +1x | +
+ private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state) |
|
| 392 | +154 |
- # renders text describing whether TRUE or FALSE is selected+ |
|
| 393 | +155 |
- # and if NA are included also+ # remove state on experiments |
|
| 394 | +156 |
- content_summary = function(id) {
+ # determine target experiments (defined in teal_slices) |
|
| 395 | -! | +||
| 157 | +1x |
- tagList(+ experiments <- unique(unlist(lapply(state, "[[", "experiment"))) |
|
| 396 | -! | +||
| 158 | +1x |
- tags$span(+ available_experiments <- setdiff(names(private$get_filter_states()), "subjects") |
|
| 397 | -! | +||
| 159 | +1x |
- class = "filter-card-summary-value",+ excluded_filters <- setdiff(experiments, available_experiments) |
|
| 398 | -! | +||
| 160 | +1x |
- toString(private$get_selected())+ if (length(excluded_filters)) {
|
|
| 399 | -+ | ||
| 161 | +! |
- ),+ stop(sprintf( |
|
| 400 | +162 | ! |
- tags$span(+ "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s", |
| 401 | +163 | ! |
- class = "filter-card-summary-controls",+ private$dataname, |
| 402 | +164 | ! |
- if (private$na_count > 0) {
+ toString(excluded_filters), |
| 403 | +165 | ! |
- tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
+ toString(available_experiments) |
| 404 | +166 |
- }+ )) |
|
| 405 | +167 |
- )+ } |
|
| 406 | +168 |
- )+ # remove states on state_lists with corresponding experiments |
|
| 407 | -+ | ||
| 169 | +1x |
- }+ lapply(experiments, function(experiment) {
|
|
| 408 | -+ | ||
| 170 | +! |
- )+ slices <- Filter(function(x) identical(x$experiment, experiment), state) |
|
| 409 | -+ | ||
| 171 | +! |
- )+ private$get_filter_states()[[experiment]]$remove_filter_state(slices) |
| 1 | +172 |
- # DataframeFilteredDataset ------+ }) |
||
| 2 | +173 | |||
| 3 | +174 |
- #' @name DataframeFilteredDataset+ |
||
| 4 | -+ | |||
| 175 | +1x |
- #' @docType class+ logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
|
||
| 5 | +176 |
- #' @title The `DataframeFilteredDataset` `R6` class+ }) |
||
| 6 | +177 |
- #'+ |
||
| 7 | -+ | |||
| 178 | +1x |
- #' @examples+ invisible(NULL) |
||
| 8 | +179 |
- #' # use non-exported function from teal.slice+ }, |
||
| 9 | +180 |
- #' DataframeFilteredDataset <- getFromNamespace("DataframeFilteredDataset", "teal.slice")
+
|
||
| 10 | +181 |
- #'+ #' @description |
||
| 11 | +182 |
- #' library(shiny)+ #' UI module to add filter variable for this dataset. |
||
| 12 | +183 |
- #'+ #' @param id (`character(1)`) |
||
| 13 | -- |
- #' ds <- DataframeFilteredDataset$new(iris, "iris")- |
- ||
| 14 | +184 |
- #' ds$set_filter_state(+ #' `shiny` module instance id. |
||
| 15 | +185 |
- #' teal_slices(+ #' |
||
| 16 | +186 |
- #' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),+ #' @return `shiny.tag` |
||
| 17 | +187 |
- #' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))+ #' |
||
| 18 | +188 |
- #' )+ ui_add = function(id) {
|
||
| 19 | -+ | |||
| 189 | +! |
- #' )+ ns <- NS(id) |
||
| 20 | -+ | |||
| 190 | +! |
- #' isolate(ds$get_filter_state())+ data <- self$get_dataset() |
||
| 21 | -+ | |||
| 191 | +! |
- #' isolate(ds$get_call())+ experiment_names <- names(data) |
||
| 22 | +192 |
- #'+ |
||
| 23 | -+ | |||
| 193 | +! |
- #' ## set_filter_state+ tags$div( |
||
| 24 | -+ | |||
| 194 | +! |
- #' dataset <- DataframeFilteredDataset$new(iris, "iris")+ tags$label("Add", tags$code(self$get_dataname()), "filter"),
|
||
| 25 | -+ | |||
| 195 | +! |
- #' fs <- teal_slices(+ tags$br(), |
||
| 26 | -+ | |||
| 196 | +! |
- #' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),+ HTML("►"),
|
||
| 27 | -+ | |||
| 197 | +! |
- #' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))+ tags$label("Add subjects filter"),
|
||
| 28 | -+ | |||
| 198 | +! |
- #' )+ private$get_filter_states()[["subjects"]]$ui_add(id = ns("subjects")),
|
||
| 29 | -+ | |||
| 199 | +! |
- #' dataset$set_filter_state(state = fs)+ tagList( |
||
| 30 | -+ | |||
| 200 | +! |
- #' isolate(dataset$get_filter_state())+ lapply( |
||
| 31 | -+ | |||
| 201 | +! |
- #'+ experiment_names, |
||
| 32 | -+ | |||
| 202 | +! |
- #' @keywords internal+ function(experiment_name) {
|
||
| 33 | -+ | |||
| 203 | +! |
- #'+ tagList( |
||
| 34 | -+ | |||
| 204 | +! |
- DataframeFilteredDataset <- R6::R6Class( # nolint+ HTML("►"),
|
||
| 35 | -+ | |||
| 205 | +! |
- classname = "DataframeFilteredDataset",+ tags$label("Add", tags$code(experiment_name), "filter"),
|
||
| 36 | -+ | |||
| 206 | +! |
- inherit = FilteredDataset,+ private$get_filter_states()[[experiment_name]]$ui_add(id = ns(experiment_name)) |
||
| 37 | +207 |
-
+ ) |
||
| 38 | +208 |
- # public fields ----+ } |
||
| 39 | +209 |
- public = list(+ ) |
||
| 40 | +210 |
-
+ ) |
||
| 41 | +211 |
- #' @description+ ) |
||
| 42 | +212 |
- #' Initializes this `DataframeFilteredDataset` object.+ }, |
||
| 43 | +213 |
- #'+ |
||
| 44 | +214 |
- #' @param dataset (`data.frame`)+ #' @description |
||
| 45 | +215 |
- #' single `data.frame` for which filters are rendered.+ #' Creates row for filter overview in the form of \cr |
||
| 46 | +216 |
- #' @param dataname (`character(1)`)+ #' `dataname -- observations (remaining/total) -- subjects (remaining/total)` - MAE |
||
| 47 | +217 |
- #' syntactically valid name given to the dataset.+ #' @return A `data.frame`. |
||
| 48 | +218 |
- #' @param keys (`character`) optional+ get_filter_overview = function() {
|
||
| 49 | -+ | |||
| 219 | +2x |
- #' vector of primary key column names.+ data <- self$get_dataset() |
||
| 50 | -+ | |||
| 220 | +2x |
- #' @param parent_name (`character(1)`)+ data_filtered <- self$get_dataset(TRUE) |
||
| 51 | -+ | |||
| 221 | +2x |
- #' name of the parent dataset.+ experiment_names <- names(data) |
||
| 52 | +222 |
- #' @param parent (`reactive`)+ |
||
| 53 | -+ | |||
| 223 | +2x |
- #' that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`.+ mae_info <- data.frame( |
||
| 54 | -+ | |||
| 224 | +2x |
- #' Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset`+ dataname = private$dataname, |
||
| 55 | -+ | |||
| 225 | +2x |
- #' based on the changes in `parent`.+ subjects = nrow(SummarizedExperiment::colData(data)), |
||
| 56 | -+ | |||
| 226 | +2x |
- #' @param join_keys (`character`)+ subjects_filtered = nrow(SummarizedExperiment::colData(data_filtered())) |
||
| 57 | +227 |
- #' vector of names of columns in this dataset to join with `parent` dataset.+ ) |
||
| 58 | +228 |
- #' If column names in the parent do not match these, they should be given as the names of this vector.+ |
||
| 59 | -+ | |||
| 229 | +2x |
- #' @param label (`character(1)`)+ experiment_obs_info <- do.call("rbind", lapply(
|
||
| 60 | -+ | |||
| 230 | +2x |
- #' label to describe the dataset.+ experiment_names, |
||
| 61 | -+ | |||
| 231 | +2x |
- #'+ function(experiment_name) {
|
||
| 62 | -+ | |||
| 232 | +10x |
- #' @return Object of class `DataframeFilteredDataset`, invisibly.+ data.frame( |
||
| 63 | -+ | |||
| 233 | +10x |
- #'+ dataname = sprintf("- %s", experiment_name),
|
||
| 64 | -+ | |||
| 234 | +10x |
- initialize = function(dataset,+ obs = nrow(data[[experiment_name]]), |
||
| 65 | -+ | |||
| 235 | +10x |
- dataname,+ obs_filtered = nrow(data_filtered()[[experiment_name]]) |
||
| 66 | +236 |
- keys = character(0),+ ) |
||
| 67 | +237 |
- parent_name = character(0),+ } |
||
| 68 | +238 |
- parent = NULL,+ )) |
||
| 69 | +239 |
- join_keys = character(0),+ |
||
| 70 | -+ | |||
| 240 | +2x |
- label = character(0)) {
+ get_experiment_keys <- function(mae, experiment) {
|
||
| 71 | -103x | +241 | +20x |
- checkmate::assert_data_frame(dataset)+ sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment)) |
| 72 | -101x | +242 | +20x |
- super$initialize(dataset, dataname, keys, label)+ length(unique(sample_subset$primary)) |
| 73 | +243 |
-
+ } |
||
| 74 | +244 |
- # overwrite filtered_data if there is relationship with parent dataset+ |
||
| 75 | -99x | +245 | +2x |
- if (!is.null(parent)) {
+ experiment_subjects_info <- do.call("rbind", lapply(
|
| 76 | -10x | +246 | +2x |
- checkmate::assert_character(parent_name, len = 1)+ experiment_names, |
| 77 | -10x | +247 | +2x |
- checkmate::assert_character(join_keys, min.len = 1)+ function(experiment_name) {
|
| 78 | -+ | |||
| 248 | +10x |
-
+ data.frame( |
||
| 79 | +249 | 10x |
- private$parent_name <- parent_name+ subjects = get_experiment_keys(data, data[[experiment_name]]), |
|
| 80 | +250 | 10x |
- private$join_keys <- join_keys+ subjects_filtered = get_experiment_keys(data_filtered(), data_filtered()[[experiment_name]]) |
|
| 81 | +251 |
-
+ ) |
||
| 82 | -10x | +|||
| 252 | +
- private$data_filtered_fun <- function(sid = "") {
+ } |
|||
| 83 | -8x | +|||
| 253 | +
- checkmate::assert_character(sid)+ ))+ |
+ |||
| 254 | ++ | + | ||
| 84 | -8x | +255 | +2x |
- if (length(sid)) {
+ experiment_info <- cbind(experiment_obs_info, experiment_subjects_info) |
| 85 | -8x | +256 | +2x |
- logger::log_trace("filtering data dataname: { dataname }, sid: { sid }")
+ dplyr::bind_rows(mae_info, experiment_info) |
| 86 | +257 |
- } else {
+ } |
||
| 87 | -! | +|||
| 258 | +
- logger::log_trace("filtering data dataname: { private$dataname }")
+ ) |
|||
| 88 | +259 |
- }+ ) |
||
| 89 | -8x | +
| 1 | +
- env <- new.env(parent = parent.env(globalenv()))+ #' Complete filter specification |
|||
| 90 | -8x | +|||
| 2 | +
- env[[dataname]] <- private$dataset+ #' |
|||
| 91 | -8x | +|||
| 3 | +
- env[[parent_name]] <- parent()+ #' Create `teal_slices` object to package multiple filters and additional settings. |
|||
| 92 | -8x | +|||
| 4 | +
- filter_call <- self$get_call(sid)+ #' Check out [`teal_slices-utilities`] functions for working with `teal_slices` object. |
|||
| 93 | -8x | +|||
| 5 | +
- eval_expr_with_msg(filter_call, env)+ #' |
|||
| 94 | -8x | +|||
| 6 | +
- get(x = dataname, envir = env)+ #' `teal_slices()` collates multiple `teal_slice` objects into a `teal_slices` object, |
|||
| 95 | +7 |
- }+ #' a complete filter specification. This is used by all classes above `FilterState` |
||
| 96 | +8 |
- }+ #' as well as `filter_panel_api` wrapper functions. |
||
| 97 | +9 |
-
+ #' `teal_slices` has attributes that modify the behavior of the filter panel, which are resolved by different classes. |
||
| 98 | -99x | +|||
| 10 | +
- private$add_filter_states(+ #' |
|||
| 99 | -99x | +|||
| 11 | +
- filter_states = init_filter_states(+ #' `include_varnames` and `exclude_varnames` determine which variables can have filters assigned. |
|||
| 100 | -99x | +|||
| 12 | +
- data = dataset,+ #' The former enumerates allowed variables, the latter enumerates forbidden values. |
|||
| 101 | -99x | +|||
| 13 | +
- data_reactive = private$data_filtered_fun,+ #' Since these could be mutually exclusive, it is impossible to set both allowed and forbidden |
|||
| 102 | -99x | +|||
| 14 | +
- dataname = dataname,+ #' variables for one data set in one `teal_slices`. |
|||
| 103 | -99x | +|||
| 15 | +
- keys = self$get_keys()+ #' |
|||
| 104 | +16 |
- ),+ #' @param ... any number of `teal_slice` objects. |
||
| 105 | -99x | +|||
| 17 | +
- id = "filter"+ #' @param include_varnames,exclude_varnames (`named list`s of `character`) where list names |
|||
| 106 | +18 |
- )+ #' match names of data sets and vector elements match variable names in respective data sets; |
||
| 107 | +19 |
-
+ #' specify which variables are allowed to be filtered; see `Details`. |
||
| 108 | +20 |
- # todo: Should we make these defaults? It could be handled by the app developer+ #' @param count_type `r lifecycle::badge("experimental")`
|
||
| 109 | -99x | +|||
| 21 | +
- if (!is.null(parent)) {
+ #' _This is a new feature. Do kindly share your opinions on |
|||
| 110 | -10x | +|||
| 22 | +
- fs <- teal_slices(+ #' [`teal.slice`'s GitHub repository](https://github.com/insightsengineering/teal.slice/)._ |
|||
| 111 | -10x | +|||
| 23 | +
- exclude_varnames = structure(+ #' |
|||
| 112 | -10x | +|||
| 24 | +
- list(intersect(colnames(dataset), colnames(isolate(parent())))),+ #' (`character(1)`) string specifying how observations are tallied by these filter states. |
|||
| 113 | -10x | +|||
| 25 | +
- names = private$dataname+ #' Possible options: |
|||
| 114 | +26 |
- )+ #' - `"none"` (default) to have counts of single `FilterState` to show unfiltered number only. |
||
| 115 | +27 |
- )+ #' - `"all"` to have counts of single `FilterState` to show number of observation in filtered |
||
| 116 | -10x | +|||
| 28 | +
- self$set_filter_state(fs)+ #' and unfiltered dataset. Note, that issues were reported when using this option with `MultiAssayExperiment`. |
|||
| 117 | +29 |
- }+ #' Please make sure that adding new filters doesn't fail on target platform before deploying for production. |
||
| 118 | +30 |
-
+ #' @param allow_add (`logical(1)`) logical flag specifying whether the user will be able to add new filters |
||
| 119 | -99x | +|||
| 31 | +
- invisible(self)+ #' |
|||
| 120 | +32 |
- },+ #' @return |
||
| 121 | +33 |
-
+ #' `teal_slices`, which is an unnamed list of `teal_slice` objects. |
||
| 122 | +34 |
- #' @description+ #' |
||
| 123 | +35 |
- #' Gets the subset expression.+ #' @examples |
||
| 124 | +36 |
- #'+ #' filter_1 <- teal_slice( |
||
| 125 | +37 |
- #' This function returns subset expressions equivalent to selected items+ #' dataname = "dataname1", |
||
| 126 | +38 |
- #' within each of `filter_states`. Configuration of the expressions is constant and+ #' varname = "varname1", |
||
| 127 | +39 |
- #' depends on `filter_states` type and order which are set during initialization.+ #' choices = letters, |
||
| 128 | +40 |
- #' This class contains single `FilterStates` which contains single `state_list`+ #' selected = "b", |
||
| 129 | +41 |
- #' and all `FilterState` objects apply to one argument (`...`) in a `dplyr::filter` call.+ #' keep_na = TRUE, |
||
| 130 | +42 |
- #'+ #' fixed = FALSE, |
||
| 131 | +43 |
- #' @param sid (`character`)+ #' extra1 = "extraone" |
||
| 132 | +44 |
- #' when specified, the method returns code containing conditions calls of+ #' ) |
||
| 133 | +45 |
- #' `FilterState` objects with `sid` different to that of this `sid` argument.+ #' filter_2 <- teal_slice( |
||
| 134 | +46 |
- #'+ #' dataname = "dataname1", |
||
| 135 | +47 |
- #' @return Either a `list` of length 1 containing a filter `call`, or `NULL`.+ #' varname = "varname2", |
||
| 136 | +48 |
- get_call = function(sid = "") {
+ #' choices = 1:10, |
||
| 137 | -42x | +|||
| 49 | +
- logger::log_trace("DataframeFilteredDataset$get_call initializing for dataname: { private$dataname }")
+ #' keep_na = TRUE, |
|||
| 138 | -42x | +|||
| 50 | +
- filter_call <- super$get_call(sid)+ #' selected = 2, |
|||
| 139 | -42x | +|||
| 51 | +
- dataname <- private$dataname+ #' fixed = TRUE, |
|||
| 140 | -42x | +|||
| 52 | +
- parent_dataname <- private$parent_name+ #' anchored = FALSE, |
|||
| 141 | +53 |
-
+ #' extra2 = "extratwo" |
||
| 142 | -42x | +|||
| 54 | +
- if (!identical(parent_dataname, character(0))) {
+ #' ) |
|||
| 143 | -9x | +|||
| 55 | +
- join_keys <- private$join_keys+ #' filter_3 <- teal_slice( |
|||
| 144 | -9x | +|||
| 56 | +
- parent_keys <- unname(join_keys)+ #' dataname = "dataname2", |
|||
| 145 | -9x | +|||
| 57 | +
- dataset_keys <- names(join_keys)+ #' varname = "varname3", |
|||
| 146 | +58 |
-
+ #' choices = 1:10 / 10, |
||
| 147 | -9x | +|||
| 59 | +
- y_arg <- if (length(parent_keys) == 0L) {
+ #' keep_na = TRUE, |
|||
| 148 | -! | +|||
| 60 | +
- parent_dataname+ #' selected = 0.2, |
|||
| 149 | +61 |
- } else {
+ #' fixed = TRUE, |
||
| 150 | -9x | +|||
| 62 | +
- sprintf(+ #' anchored = FALSE, |
|||
| 151 | -9x | +|||
| 63 | +
- "%s[, c(%s), drop = FALSE]",+ #' extra1 = "extraone", |
|||
| 152 | -9x | +|||
| 64 | +
- parent_dataname,+ #' extra2 = "extratwo" |
|||
| 153 | -9x | +|||
| 65 | +
- toString(dQuote(parent_keys, q = FALSE))+ #' ) |
|||
| 154 | +66 |
- )+ #' |
||
| 155 | +67 |
- }+ #' all_filters <- teal_slices( |
||
| 156 | +68 |
-
+ #' filter_1, |
||
| 157 | -9x | +|||
| 69 | +
- more_args <- if (length(parent_keys) == 0 || length(dataset_keys) == 0) {
+ #' filter_2, |
|||
| 158 | -! | +|||
| 70 | +
- list()+ #' filter_3, |
|||
| 159 | -9x | +|||
| 71 | +
- } else if (identical(parent_keys, dataset_keys)) {
+ #' exclude_varnames = list( |
|||
| 160 | -7x | +|||
| 72 | +
- list(by = parent_keys)+ #' "dataname1" = "varname2" |
|||
| 161 | +73 |
- } else {
+ #' ) |
||
| 162 | -2x | +|||
| 74 | +
- list(by = stats::setNames(parent_keys, dataset_keys))+ #' ) |
|||
| 163 | +75 |
- }+ #' |
||
| 164 | +76 |
-
+ #' is.teal_slices(all_filters) |
||
| 165 | -9x | +|||
| 77 | +
- merge_call <- call(+ #' all_filters[1:2] |
|||
| 166 | +78 |
- "<-",+ #' c(all_filters[1], all_filters[2]) |
||
| 167 | -9x | +|||
| 79 | +
- as.name(dataname),+ #' print(all_filters) |
|||
| 168 | -9x | +|||
| 80 | +
- as.call(+ #' print(all_filters, trim_lines = FALSE) |
|||
| 169 | -9x | +|||
| 81 | +
- c(+ #' |
|||
| 170 | -9x | +|||
| 82 | +
- str2lang("dplyr::inner_join"),
+ #' @seealso |
|||
| 171 | -9x | +|||
| 83 | +
- x = as.name(dataname),+ #' - [`teal_slice`] for creating constituent elements of `teal_slices` |
|||
| 172 | -9x | +|||
| 84 | +
- y = str2lang(y_arg),+ #' - [`teal::slices_store`] for robust utilities for saving and loading `teal_slices` in `JSON` format |
|||
| 173 | -9x | +|||
| 85 | +
- more_args+ #' - [`is.teal_slices`], [`as.teal_slices`], [`as.list.teal_slices`], [`[.teal_slices`], [`c.teal_slices`] |
|||
| 174 | +86 |
- )+ #' [`print.teal_slices`], [`format.teal_slices`] |
||
| 175 | +87 |
- )+ #' |
||
| 176 | +88 |
- )+ #' @export |
||
| 177 | +89 |
-
+ #' |
||
| 178 | -9x | +|||
| 90 | +
- filter_call <- c(filter_call, merge_call)+ teal_slices <- function(..., |
|||
| 179 | +91 |
- }+ exclude_varnames = NULL, |
||
| 180 | -42x | +|||
| 92 | +
- logger::log_trace("DataframeFilteredDataset$get_call initializing for dataname: { private$dataname }")
+ include_varnames = NULL, |
|||
| 181 | -42x | +|||
| 93 | +
- filter_call+ count_type = NULL, |
|||
| 182 | +94 |
- },+ allow_add = TRUE) {
|
||
| 183 | -+ | |||
| 95 | +764x |
-
+ slices <- list(...) |
||
| 184 | -+ | |||
| 96 | +764x |
- #' @description+ checkmate::assert_list(slices, types = "teal_slice", any.missing = FALSE) |
||
| 185 | -+ | |||
| 97 | +763x |
- #' Set filter state.+ slices_id <- isolate(vapply(slices, `[[`, character(1L), "id")) |
||
| 186 | -+ | |||
| 98 | +763x |
- #'+ if (any(duplicated(slices_id))) {
|
||
| 187 | -+ | |||
| 99 | +1x |
- #' @param state (`teal_slices`)+ stop( |
||
| 188 | -+ | |||
| 100 | +1x |
- #' @return `NULL`, invisibly.+ "Some teal_slice objects have the same id:\n",+ |
+ ||
| 101 | +1x | +
+ toString(unique(slices_id[duplicated(slices_id)])) |
||
| 189 | +102 |
- #'+ ) |
||
| 190 | +103 |
- set_filter_state = function(state) {
+ } |
||
| 191 | -81x | +104 | +762x |
- isolate({
+ checkmate::assert_list(exclude_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1) |
| 192 | -81x | +105 | +761x |
- logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
+ checkmate::assert_list(include_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1) |
| 193 | -81x | +106 | +760x |
- checkmate::assert_class(state, "teal_slices")+ checkmate::assert_character(count_type, len = 1, null.ok = TRUE) |
| 194 | -80x | +107 | +758x |
- lapply(state, function(slice) {
+ checkmate::assert_subset(count_type, choices = c("all", "none"), empty.ok = TRUE)
|
| 195 | -97x | +108 | +757x |
- checkmate::assert_true(slice$dataname == private$dataname)+ checkmate::assert_logical(allow_add) |
| 196 | +109 |
- })+ |
||
| 197 | -80x | +110 | +756x |
- private$get_filter_states()[[1L]]$set_filter_state(state = state)+ duplicated_datasets <- intersect(names(include_varnames), names(exclude_varnames)) |
| 198 | -80x | +111 | +756x |
- invisible(NULL)+ if (length(duplicated_datasets)) {
+ |
+
| 112 | +1x | +
+ stop(+ |
+ ||
| 113 | +1x | +
+ "Some datasets are specified in both, include_varnames and exclude_varnames:\n",+ |
+ ||
| 114 | +1x | +
+ toString(duplicated_datasets) |
||
| 199 | +115 |
- })+ ) |
||
| 200 | +116 |
- },+ } |
||
| 201 | +117 | |||
| 202 | -+ | |||
| 118 | +755x |
- #' @description+ structure( |
||
| 203 | -+ | |||
| 119 | +755x |
- #' Remove one or more `FilterState` form a `FilteredDataset`.+ slices, |
||
| 204 | -+ | |||
| 120 | +755x |
- #'+ exclude_varnames = exclude_varnames, |
||
| 205 | -+ | |||
| 121 | +755x |
- #' @param state (`teal_slices`)+ include_varnames = include_varnames, |
||
| 206 | -+ | |||
| 122 | +755x |
- #' specifying `FilterState` objects to remove;+ count_type = count_type, |
||
| 207 | -+ | |||
| 123 | +755x |
- #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored+ allow_add = allow_add, |
||
| 208 | -+ | |||
| 124 | +755x |
- #'+ class = c("teal_slices", class(slices))
|
||
| 209 | +125 |
- #' @return `NULL`, invisibly.+ ) |
||
| 210 | +126 |
- #'+ } |
||
| 211 | +127 |
- remove_filter_state = function(state) {
+
|
||
| 212 | -11x | +|||
| 128 | +
- checkmate::assert_class(state, "teal_slices")+ #' `teal_slices` utility functions |
|||
| 213 | +129 |
-
+ #' |
||
| 214 | -11x | +|||
| 130 | +
- isolate({
+ #' Helper functions for working with [`teal_slices`] object. |
|||
| 215 | -11x | +|||
| 131 | +
- logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")
+ #' @param x object to test for `teal_slices`, object to convert to `teal_slices` or a `teal_slices` object |
|||
| 216 | +132 |
-
+ #' @param i (`character` or `numeric` or `logical`) indicating which elements to extract |
||
| 217 | -11x | +|||
| 133 | +
- varnames <- unique(unlist(lapply(state, "[[", "varname")))+ #' @param recursive (`logical(1)`) flag specifying whether to also convert to list the elements of this `teal_slices` |
|||
| 218 | -11x | +|||
| 134 | +
- private$get_filter_states()[[1]]$remove_filter_state(state)+ #' @param ... additional arguments passed to other functions. |
|||
| 219 | +135 |
-
+ #' @name teal_slices-utilities |
||
| 220 | -11x | +|||
| 136 | +
- logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
+ #' @inherit teal_slices examples |
|||
| 221 | +137 |
- })+ #' @keywords internal |
||
| 222 | +138 | |||
| 223 | -11x | +|||
| 139 | +
- invisible(NULL)+ #' @rdname teal_slices-utilities |
|||
| 224 | +140 |
- },+ #' @export |
||
| 225 | +141 |
-
+ #' |
||
| 226 | +142 |
- #' @description+ is.teal_slices <- function(x) { # nolint
|
||
| 227 | -+ | |||
| 143 | +465x |
- #' UI module to add filter variable for this dataset.+ inherits(x, "teal_slices") |
||
| 228 | +144 |
- #'+ } |
||
| 229 | +145 |
- #' @param id (`character(1)`)+ |
||
| 230 | +146 |
- #' `shiny` module instance id.+ #' @rdname teal_slices-utilities |
||
| 231 | +147 |
- #'+ #' @export |
||
| 232 | +148 |
- #' @return `shiny.tag`+ #' |
||
| 233 | +149 |
- ui_add = function(id) {
+ as.teal_slices <- function(x) { # nolint
|
||
| 234 | +150 | ! |
- ns <- NS(id)+ checkmate::assert_list(x) |
|
| 235 | +151 | ! |
- tagList(+ lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")+ |
+ |
| 152 | ++ | + | ||
| 236 | +153 | ! |
- tags$label("Add", tags$code(self$get_dataname()), "filter"),
+ attrs <- attributes(unclass(x)) |
|
| 237 | +154 | ! |
- private$get_filter_states()[["filter"]]$ui_add(id = ns("filter"))
+ ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x)) |
|
| 238 | -+ | |||
| 155 | +! |
- )+ do.call(teal_slices, c(ans, attrs)) |
||
| 239 | +156 |
- },+ } |
||
| 240 | +157 | |||
| 241 | +158 |
- #' @description+ |
||
| 242 | +159 |
- #' Creates row for filter overview in the form of \cr+ #' @rdname teal_slices-utilities |
||
| 243 | +160 |
- #' `dataname -- observations (remaining/total)` - data.frame+ #' @export |
||
| 244 | +161 |
- #' @return A `data.frame`.+ #' |
||
| 245 | +162 |
- get_filter_overview = function() {
+ as.list.teal_slices <- function(x, recursive = FALSE, ...) { # nolint
|
||
| 246 | -12x | +163 | +1077x |
- logger::log_trace("FilteredDataset$srv_filter_overview initialized")
+ ans <- unclass(x)+ |
+
| 164 | +45x | +
+ if (recursive) ans[] <- lapply(ans, as.list)+ |
+ ||
| 165 | +1077x | +
+ ans |
||
| 247 | +166 |
- # Gets filter overview subjects number and returns a list+ } |
||
| 248 | +167 |
- # of the number of subjects of filtered/non-filtered datasets+ |
||
| 249 | -12x | +|||
| 168 | +
- subject_keys <- if (length(private$parent_name) > 0) {
+
|
|||
| 250 | -1x | +|||
| 169 | +
- names(private$join_keys)+ #' @rdname teal_slices-utilities |
|||
| 251 | +170 |
- } else {
+ #' @export |
||
| 252 | -11x | +|||
| 171 | +
- self$get_keys()+ #' |
|||
| 253 | +172 |
- }+ `[.teal_slices` <- function(x, i) {
|
||
| 254 | -12x | +173 | +3x |
- dataset <- self$get_dataset()+ if (missing(i)) i <- seq_along(x) |
| 255 | -12x | +174 | +506x |
- data_filtered <- self$get_dataset(TRUE)+ if (length(i) == 0L) {
|
| 256 | -12x | +175 | +178x |
- if (length(subject_keys) == 0) {
+ return(x[0]) |
| 257 | -10x | +|||
| 176 | +
- data.frame(+ } |
|||
| 258 | -10x | +177 | +1x |
- dataname = private$dataname,+ if (is.logical(i) && length(i) > length(x)) stop("subscript out of bounds")
|
| 259 | -10x | +178 | +1x |
- obs = nrow(dataset),+ if (is.numeric(i) && max(i) > length(x)) stop("subscript out of bounds")
|
| 260 | -10x | -
- obs_filtered = nrow(data_filtered())- |
- ||
| 261 | -+ | 179 | +326x |
- )+ if (is.character(i)) {
|
| 262 | -+ | |||
| 180 | +1x |
- } else {
+ if (!all(is.element(i, names(x)))) stop("subscript out of bounds")
|
||
| 263 | +181 | 2x |
- data.frame(+ i <- which(is.element(i, names(x))) |
|
| 264 | -2x | +|||
| 182 | +
- dataname = private$dataname,+ } |
|||
| 265 | -2x | +|||
| 183 | +
- obs = nrow(dataset),+ |
|||
| 266 | -2x | +184 | +325x |
- obs_filtered = nrow(data_filtered()),+ y <- NextMethod("[")
|
| 267 | -2x | +185 | +325x |
- subjects = nrow(unique(dataset[subject_keys])),+ attrs <- attributes(x) |
| 268 | -2x | +186 | +325x |
- subjects_filtered = nrow(unique(data_filtered()[subject_keys]))+ attrs$names <- attrs$names[i] |
| 269 | -+ | |||
| 187 | +325x |
- )+ attributes(y) <- attrs |
||
| 270 | -+ | |||
| 188 | +325x |
- }+ y |
||
| 271 | +189 |
- }+ } |
||
| 272 | +190 |
- ),+ |
||
| 273 | +191 | |||
| 274 | +192 |
- # private fields ----+ #' @rdname teal_slices-utilities |
||
| 275 | +193 |
- private = list(+ #' @export |
||
| 276 | +194 |
- parent_name = character(0),+ #' |
||
| 277 | +195 |
- join_keys = character(0)+ c.teal_slices <- function(...) {
|
||
| 278 | -+ | |||
| 196 | +252x |
- )+ x <- list(...) |
||
| 279 | -+ | |||
| 197 | +252x |
- )+ checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices") |
| 1 | +198 |
- #' Complete filter specification+ |
|
| 2 | -+ | ||
| 199 | +251x |
- #'+ all_attributes <- lapply(x, attributes) |
|
| 3 | -+ | ||
| 200 | +251x |
- #' Create `teal_slices` object to package multiple filters and additional settings.+ all_attributes <- coalesce_r(all_attributes) |
|
| 4 | -+ | ||
| 201 | +251x |
- #' Check out [`teal_slices-utilities`] functions for working with `teal_slices` object.+ all_attributes <- all_attributes[names(all_attributes) != "class"] |
|
| 5 | +202 |
- #'+ |
|
| 6 | -+ | ||
| 203 | +251x |
- #' `teal_slices()` collates multiple `teal_slice` objects into a `teal_slices` object,+ do.call( |
|
| 7 | -+ | ||
| 204 | +251x |
- #' a complete filter specification. This is used by all classes above `FilterState`+ teal_slices, |
|
| 8 | -+ | ||
| 205 | +251x |
- #' as well as `filter_panel_api` wrapper functions.+ c( |
|
| 9 | -+ | ||
| 206 | +251x |
- #' `teal_slices` has attributes that modify the behavior of the filter panel, which are resolved by different classes.+ unique(unlist(x, recursive = FALSE)), |
|
| 10 | -+ | ||
| 207 | +251x |
- #'+ all_attributes |
|
| 11 | +208 |
- #' `include_varnames` and `exclude_varnames` determine which variables can have filters assigned.+ ) |
|
| 12 | +209 |
- #' The former enumerates allowed variables, the latter enumerates forbidden values.+ ) |
|
| 13 | +210 |
- #' Since these could be mutually exclusive, it is impossible to set both allowed and forbidden+ } |
|
| 14 | +211 |
- #' variables for one data set in one `teal_slices`.+ |
|
| 15 | +212 |
- #'+ |
|
| 16 | +213 |
- #' @param ... any number of `teal_slice` objects.+ #' @rdname teal_slices-utilities |
|
| 17 | +214 |
- #' @param include_varnames,exclude_varnames (`named list`s of `character`) where list names+ #' @param show_all (`logical(1)`) whether to display non-null elements of constituent `teal_slice` objects |
|
| 18 | +215 |
- #' match names of data sets and vector elements match variable names in respective data sets;+ #' @param trim_lines (`logical(1)`) whether to trim lines |
|
| 19 | +216 |
- #' specify which variables are allowed to be filtered; see `Details`.+ #' @export |
|
| 20 | +217 |
- #' @param count_type `r lifecycle::badge("experimental")`
+ #' |
|
| 21 | +218 |
- #' _This is a new feature. Do kindly share your opinions on+ format.teal_slices <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
|
|
| 22 | -+ | ||
| 219 | +45x |
- #' [`teal.slice`'s GitHub repository](https://github.com/insightsengineering/teal.slice/)._+ checkmate::assert_flag(show_all) |
|
| 23 | -+ | ||
| 220 | +45x |
- #'+ checkmate::assert_flag(trim_lines) |
|
| 24 | +221 |
- #' (`character(1)`) string specifying how observations are tallied by these filter states.+ |
|
| 25 | -+ | ||
| 222 | +45x |
- #' Possible options:+ x <- as.list(x, recursive = TRUE) |
|
| 26 | -+ | ||
| 223 | +45x |
- #' - `"none"` (default) to have counts of single `FilterState` to show unfiltered number only.+ attrs <- attributes(x) |
|
| 27 | -+ | ||
| 224 | +45x |
- #' - `"all"` to have counts of single `FilterState` to show number of observation in filtered+ attributes(x) <- NULL |
|
| 28 | -+ | ||
| 225 | +45x |
- #' and unfiltered dataset. Note, that issues were reported when using this option with `MultiAssayExperiment`.+ slices_list <- list(slices = x, attributes = attrs) |
|
| 29 | -+ | ||
| 226 | +45x |
- #' Please make sure that adding new filters doesn't fail on target platform before deploying for production.+ slices_list <- Filter(Negate(is.null), slices_list) # drop attributes if empty |
|
| 30 | +227 |
- #' @param allow_add (`logical(1)`) logical flag specifying whether the user will be able to add new filters+ |
|
| 31 | -+ | ||
| 228 | +20x |
- #'+ if (!show_all) slices_list$slices <- lapply(slices_list$slices, function(slice) Filter(Negate(is.null), slice)) |
|
| 32 | +229 |
- #' @return+ |
|
| 33 | -+ | ||
| 230 | +45x |
- #' `teal_slices`, which is an unnamed list of `teal_slice` objects.+ jsonify(slices_list, trim_lines) |
|
| 34 | +231 |
- #'+ } |
|
| 35 | +232 |
- #' @examples+ |
|
| 36 | +233 |
- #' filter_1 <- teal_slice(+ #' @rdname teal_slices-utilities |
|
| 37 | +234 |
- #' dataname = "dataname1",+ #' @export |
|
| 38 | +235 |
- #' varname = "varname1",+ #' |
|
| 39 | +236 |
- #' choices = letters,+ print.teal_slices <- function(x, ...) {
|
|
| 40 | -+ | ||
| 237 | +2x |
- #' selected = "b",+ cat(format(x, ...), "\n") |
|
| 41 | +238 |
- #' keep_na = TRUE,+ } |
|
| 42 | +239 |
- #' fixed = FALSE,+ |
|
| 43 | +240 |
- #' extra1 = "extraone"+ |
|
| 44 | +241 |
- #' )+ #' `setdiff` method for `teal_slices` |
|
| 45 | +242 |
- #' filter_2 <- teal_slice(+ #' |
|
| 46 | +243 |
- #' dataname = "dataname1",+ #' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`. |
|
| 47 | +244 |
- #' varname = "varname2",+ #' @param x,y (`teal_slices`) |
|
| 48 | +245 |
- #' choices = 1:10,+ #' @return `teal_slices` |
|
| 49 | +246 |
- #' keep_na = TRUE,+ #' @keywords internal |
|
| 50 | +247 |
- #' selected = 2,+ #' |
|
| 51 | +248 |
- #' fixed = TRUE,+ setdiff_teal_slices <- function(x, y) {
|
|
| 52 | -+ | ||
| 249 | +14x |
- #' anchored = FALSE,+ Filter( |
|
| 53 | -+ | ||
| 250 | +14x |
- #' extra2 = "extratwo"+ function(xx) {
|
|
| 54 | -+ | ||
| 251 | +12x |
- #' )+ !any(vapply(y, function(yy) identical(yy, xx), logical(1))) |
|
| 55 | +252 |
- #' filter_3 <- teal_slice(+ }, |
|
| 56 | -+ | ||
| 253 | +14x |
- #' dataname = "dataname2",+ x |
|
| 57 | +254 |
- #' varname = "varname3",+ ) |
|
| 58 | +255 |
- #' choices = 1:10 / 10,+ } |
|
| 59 | +256 |
- #' keep_na = TRUE,+ |
|
| 60 | +257 |
- #' selected = 0.2,+ #' Recursively coalesce list elements. |
|
| 61 | +258 |
- #' fixed = TRUE,+ #' |
|
| 62 | +259 |
- #' anchored = FALSE,+ #' Returns first element of list that it not `NULL`, recursively. |
|
| 63 | +260 |
- #' extra1 = "extraone",+ #' |
|
| 64 | +261 |
- #' extra2 = "extratwo"+ #' Given a list of atomic vectors, the first non-null element is returned. |
|
| 65 | +262 |
- #' )+ #' Given a list of lists, for all `names` found in all elements of the list |
|
| 66 | +263 |
- #'+ #' the first non-null element of a given name is returned. |
|
| 67 | +264 |
- #' all_filters <- teal_slices(+ #' |
|
| 68 | +265 |
- #' filter_1,+ #' This function is used internally in `c.teal_slices` to manage `teal_slices` attributes. |
|
| 69 | +266 |
- #' filter_2,+ #' |
|
| 70 | +267 |
- #' filter_3,+ #' @param x (`list`), either of atomic vectors or of named lists |
|
| 71 | +268 |
- #' exclude_varnames = list(+ #' @return |
|
| 72 | +269 |
- #' "dataname1" = "varname2"+ #' Either an atomic vector of length 1 or a (potentially nested) list. |
|
| 73 | +270 |
- #' )+ #' |
|
| 74 | +271 |
- #' )+ #' @keywords internal |
|
| 75 | +272 |
#' |
|
| 76 | +273 |
- #' is.teal_slices(all_filters)+ coalesce_r <- function(x) {
|
|
| 77 | -+ | ||
| 274 | +1569x |
- #' all_filters[1:2]+ checkmate::assert_list(x) |
|
| 78 | -+ | ||
| 275 | +1568x |
- #' c(all_filters[1], all_filters[2])+ xnn <- Filter(Negate(is.null), x) |
|
| 79 | -+ | ||
| 276 | +1568x |
- #' print(all_filters)+ if (all(vapply(xnn, is.atomic, logical(1L)))) {
|
|
| 80 | -+ | ||
| 277 | +1059x |
- #' print(all_filters, trim_lines = FALSE)+ return(xnn[[1L]]) |
|
| 81 | +278 |
- #'+ } |
|
| 82 | -+ | ||
| 279 | +509x |
- #' @seealso+ lapply(x, checkmate::assert_list, names = "named", null.ok = TRUE, .var.name = "list element")+ |
+ |
| 280 | +508x | +
+ all_names <- unique(unlist(lapply(x, names)))+ |
+ |
| 281 | +508x | +
+ sapply(all_names, function(nm) coalesce_r(lapply(x, `[[`, nm)), simplify = FALSE) |
|
| 83 | +282 |
- #' - [`teal_slice`] for creating constituent elements of `teal_slices`+ } |
| 84 | +1 |
- #' - [`teal::slices_store`] for robust utilities for saving and loading `teal_slices` in `JSON` format+ # SEFilterStates ------ |
||
| 85 | +2 |
- #' - [`is.teal_slices`], [`as.teal_slices`], [`as.list.teal_slices`], [`[.teal_slices`], [`c.teal_slices`]+ |
||
| 86 | +3 |
- #' [`print.teal_slices`], [`format.teal_slices`]+ #' @name SEFilterStates |
||
| 87 | +4 |
- #'+ #' @docType class |
||
| 88 | +5 |
- #' @export+ #' @title `FilterStates` subclass for `SummarizedExperiment`s |
||
| 89 | +6 |
- #'+ #' @description Handles filter states in a `SummaryExperiment`. |
||
| 90 | +7 |
- teal_slices <- function(...,+ #' @keywords internal |
||
| 91 | +8 |
- exclude_varnames = NULL,+ #' |
||
| 92 | +9 |
- include_varnames = NULL,+ SEFilterStates <- R6::R6Class( # nolint |
||
| 93 | +10 |
- count_type = NULL,+ classname = "SEFilterStates", |
||
| 94 | +11 |
- allow_add = TRUE) {
+ inherit = FilterStates, |
||
| 95 | -764x | +|||
| 12 | +
- slices <- list(...)+ |
|||
| 96 | -764x | +|||
| 13 | +
- checkmate::assert_list(slices, types = "teal_slice", any.missing = FALSE)+ # public methods ---- |
|||
| 97 | -763x | +|||
| 14 | +
- slices_id <- isolate(vapply(slices, `[[`, character(1L), "id"))+ public = list( |
|||
| 98 | -763x | +|||
| 15 | +
- if (any(duplicated(slices_id))) {
+ #' @description |
|||
| 99 | -1x | +|||
| 16 | +
- stop(+ #' Initialize `SEFilterStates` object. |
|||
| 100 | -1x | +|||
| 17 | +
- "Some teal_slice objects have the same id:\n",+ #' |
|||
| 101 | -1x | +|||
| 18 | +
- toString(unique(slices_id[duplicated(slices_id)]))+ #' @param data (`SummarizedExperiment`) |
|||
| 102 | +19 |
- )+ #' the `R` object which `subset` function is applied on. |
||
| 103 | +20 |
- }+ #' @param data_reactive (`function(sid)`) |
||
| 104 | -762x | +|||
| 21 | +
- checkmate::assert_list(exclude_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)+ #' should return a `SummarizedExperiment` object or `NULL`. |
|||
| 105 | -761x | +|||
| 22 | +
- checkmate::assert_list(include_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)+ #' This object is needed for the `FilterState` counts being updated on a change in filters. |
|||
| 106 | -760x | +|||
| 23 | +
- checkmate::assert_character(count_type, len = 1, null.ok = TRUE)+ #' If function returns `NULL` then filtered counts are not shown. |
|||
| 107 | -758x | +|||
| 24 | +
- checkmate::assert_subset(count_type, choices = c("all", "none"), empty.ok = TRUE)
+ #' Function has to have `sid` argument being a character. |
|||
| 108 | -757x | +|||
| 25 | +
- checkmate::assert_logical(allow_add)+ #' @param dataname (`character(1)`) |
|||
| 109 | +26 |
-
+ #' name of the data used in the expression |
||
| 110 | -756x | +|||
| 27 | +
- duplicated_datasets <- intersect(names(include_varnames), names(exclude_varnames))+ #' specified to the function argument attached to this `FilterStates`. |
|||
| 111 | -756x | +|||
| 28 | +
- if (length(duplicated_datasets)) {
+ #' @param datalabel (`character(1)`) optional |
|||
| 112 | -1x | +|||
| 29 | +
- stop(+ #' text label. Should be the name of experiment. |
|||
| 113 | -1x | +|||
| 30 | +
- "Some datasets are specified in both, include_varnames and exclude_varnames:\n",+ #' |
|||
| 114 | -1x | +|||
| 31 | +
- toString(duplicated_datasets)+ initialize = function(data, |
|||
| 115 | +32 |
- )+ data_reactive = function(sid = "") NULL, |
||
| 116 | +33 |
- }+ dataname, |
||
| 117 | +34 |
-
+ datalabel = NULL) {
|
||
| 118 | -755x | +35 | +92x |
- structure(+ if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
|
| 119 | -755x | +|||
| 36 | +! |
- slices,+ stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
+ |
+ ||
| 37 | ++ |
+ } |
||
| 120 | -755x | +38 | +92x |
- exclude_varnames = exclude_varnames,+ checkmate::assert_function(data_reactive, args = "sid") |
| 121 | -755x | +39 | +92x |
- include_varnames = include_varnames,+ checkmate::assert_class(data, "SummarizedExperiment") |
| 122 | -755x | +40 | +91x |
- count_type = count_type,+ super$initialize(data, data_reactive, dataname, datalabel) |
| 123 | -755x | +41 | +91x |
- allow_add = allow_add,+ if (!is.null(datalabel)) {
|
| 124 | -755x | +42 | +84x |
- class = c("teal_slices", class(slices))
+ private$dataname_prefixed <- sprintf("%s[['%s']]", dataname, datalabel)
|
| 125 | +43 |
- )+ } |
||
| 126 | +44 |
- }+ }, |
||
| 127 | +45 | |||
| 128 | +46 |
- #' `teal_slices` utility functions+ #' @description |
||
| 129 | +47 |
- #'+ #' Set filter state. |
||
| 130 | +48 |
- #' Helper functions for working with [`teal_slices`] object.+ #' |
||
| 131 | +49 |
- #' @param x object to test for `teal_slices`, object to convert to `teal_slices` or a `teal_slices` object+ #' @param state (`teal_slices`) |
||
| 132 | +50 |
- #' @param i (`character` or `numeric` or `logical`) indicating which elements to extract+ #' `teal_slice` objects should contain the field `arg %in% c("subset", "select")`
|
||
| 133 | +51 |
- #' @param recursive (`logical(1)`) flag specifying whether to also convert to list the elements of this `teal_slices`+ #' |
||
| 134 | +52 |
- #' @param ... additional arguments passed to other functions.+ #' @return `NULL`, invisibly. |
||
| 135 | +53 |
- #' @name teal_slices-utilities+ #' |
||
| 136 | +54 |
- #' @inherit teal_slices examples+ set_filter_state = function(state) {
|
||
| 137 | -+ | |||
| 55 | +61x |
- #' @keywords internal+ isolate({
|
||
| 138 | -+ | |||
| 56 | +61x |
-
+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
|
||
| 139 | -+ | |||
| 57 | +61x |
- #' @rdname teal_slices-utilities+ checkmate::assert_class(state, "teal_slices") |
||
| 140 | -+ | |||
| 58 | +59x |
- #' @export+ lapply(state, function(x) {
|
||
| 141 | -+ | |||
| 59 | +17x |
- #'+ checkmate::assert_choice(x$arg, choices = c("subset", "select"), null.ok = TRUE, .var.name = "teal_slice$arg")
|
||
| 142 | +60 |
- is.teal_slices <- function(x) { # nolint
+ }) |
||
| 143 | -465x | +61 | +59x |
- inherits(x, "teal_slices")+ count_type <- attr(state, "count_type") |
| 144 | -+ | |||
| 62 | +59x |
- }+ if (length(count_type)) {
|
||
| 145 | -+ | |||
| 63 | +8x |
-
+ private$count_type <- count_type |
||
| 146 | +64 |
- #' @rdname teal_slices-utilities+ } |
||
| 147 | +65 |
- #' @export+ |
||
| 148 | -+ | |||
| 66 | +59x |
- #'+ subset_states <- Filter(function(x) x$arg == "subset", state) |
||
| 149 | -+ | |||
| 67 | +59x |
- as.teal_slices <- function(x) { # nolint
+ private$set_filter_state_impl( |
||
| 150 | -! | +|||
| 68 | +59x |
- checkmate::assert_list(x)+ state = subset_states, |
||
| 151 | -! | +|||
| 69 | +59x |
- lapply(x, checkmate::assert_list, names = "named", .var.name = "list element")+ data = SummarizedExperiment::rowData(private$data), |
||
| 152 | -+ | |||
| 70 | +59x |
-
+ data_reactive = function(sid = "") {
|
||
| 153 | +71 | ! |
- attrs <- attributes(unclass(x))+ data <- private$data_reactive() |
|
| 154 | +72 | ! |
- ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x))+ if (!is.null(data)) {
|
|
| 155 | +73 | ! |
- do.call(teal_slices, c(ans, attrs))+ SummarizedExperiment::rowData(data) |
|
| 156 | +74 |
- }+ } |
||
| 157 | +75 |
-
+ } |
||
| 158 | +76 |
-
+ ) |
||
| 159 | +77 |
- #' @rdname teal_slices-utilities+ |
||
| 160 | -- |
- #' @export- |
- ||
| 161 | -+ | |||
| 78 | +59x |
- #'+ select_states <- Filter(function(x) x$arg == "select", state) |
||
| 162 | -+ | |||
| 79 | +59x |
- as.list.teal_slices <- function(x, recursive = FALSE, ...) { # nolint
+ private$set_filter_state_impl( |
||
| 163 | -1077x | +80 | +59x |
- ans <- unclass(x)+ state = select_states, |
| 164 | -45x | +81 | +59x |
- if (recursive) ans[] <- lapply(ans, as.list)+ data = SummarizedExperiment::colData(private$data), |
| 165 | -1077x | +82 | +59x |
- ans+ data_reactive = function(sid = "") {
|
| 166 | -+ | |||
| 83 | +! |
- }+ data <- private$data_reactive() |
||
| 167 | -+ | |||
| 84 | +! |
-
+ if (!is.null(data)) {
|
||
| 168 | -+ | |||
| 85 | +! |
-
+ SummarizedExperiment::colData(data) |
||
| 169 | +86 |
- #' @rdname teal_slices-utilities+ } |
||
| 170 | +87 |
- #' @export+ } |
||
| 171 | +88 |
- #'+ ) |
||
| 172 | +89 |
- `[.teal_slices` <- function(x, i) {
- |
- ||
| 173 | -3x | -
- if (missing(i)) i <- seq_along(x)+ |
||
| 174 | -506x | +90 | +59x |
- if (length(i) == 0L) {
+ logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
|
| 175 | -178x | +91 | +59x |
- return(x[0])+ invisible(NULL) |
| 176 | +92 |
- }- |
- ||
| 177 | -1x | -
- if (is.logical(i) && length(i) > length(x)) stop("subscript out of bounds")
- |
- ||
| 178 | -1x | -
- if (is.numeric(i) && max(i) > length(x)) stop("subscript out of bounds")
- |
- ||
| 179 | -326x | -
- if (is.character(i)) {
- |
- ||
| 180 | -1x | -
- if (!all(is.element(i, names(x)))) stop("subscript out of bounds")
- |
- ||
| 181 | -2x | -
- i <- which(is.element(i, names(x)))+ }) |
||
| 182 | +93 |
- }+ }, |
||
| 183 | +94 | |||
| 184 | -325x | -
- y <- NextMethod("[")
- |
- ||
| 185 | -325x | -
- attrs <- attributes(x)- |
- ||
| 186 | -325x | -
- attrs$names <- attrs$names[i]- |
- ||
| 187 | -325x | -
- attributes(y) <- attrs- |
- ||
| 188 | -325x | -
- y- |
- ||
| 189 | +95 |
- }+ #' @description |
||
| 190 | +96 |
-
+ #' `shiny` UI module to add filter variable. |
||
| 191 | +97 |
-
+ #' @param id (`character(1)`) |
||
| 192 | +98 |
- #' @rdname teal_slices-utilities+ #' `shiny` module instance id. |
||
| 193 | +99 |
- #' @export+ #' @return `shiny.tag` |
||
| 194 | +100 |
- #'+ ui_add = function(id) {
|
||
| 195 | -+ | |||
| 101 | +2x |
- c.teal_slices <- function(...) {
+ data <- private$data |
||
| 196 | -252x | +102 | +2x |
- x <- list(...)+ checkmate::assert_string(id) |
| 197 | -252x | +103 | +2x |
- checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ ns <- NS(id) |
| 198 | -+ | |||
| 104 | +2x |
-
+ row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
|
||
| 199 | -251x | +105 | +1x |
- all_attributes <- lapply(x, attributes)+ tags$div("no sample variables available")
|
| 200 | -251x | +106 | +2x |
- all_attributes <- coalesce_r(all_attributes)+ } else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
|
| 201 | -251x | +107 | +1x |
- all_attributes <- all_attributes[names(all_attributes) != "class"]+ tags$div("no samples available")
|
| 202 | +108 |
-
+ } else {
|
||
| 203 | -251x | +|||
| 109 | +! |
- do.call(+ teal.widgets::optionalSelectInput( |
||
| 204 | -251x | +|||
| 110 | +! |
- teal_slices,+ ns("row_to_add"),
|
||
| 205 | -251x | +|||
| 111 | +! |
- c(+ choices = NULL, |
||
| 206 | -251x | +|||
| 112 | +! |
- unique(unlist(x, recursive = FALSE)),+ options = shinyWidgets::pickerOptions( |
||
| 207 | -251x | +|||
| 113 | +! |
- all_attributes+ liveSearch = TRUE, |
||
| 208 | -+ | |||
| 114 | +! |
- )+ noneSelectedText = "Select gene variable" |
||
| 209 | +115 |
- )+ ) |
||
| 210 | +116 |
- }+ ) |
||
| 211 | +117 |
-
+ } |
||
| 212 | +118 | |||
| 213 | -+ | |||
| 119 | +2x |
- #' @rdname teal_slices-utilities+ col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
|
||
| 214 | -+ | |||
| 120 | +1x |
- #' @param show_all (`logical(1)`) whether to display non-null elements of constituent `teal_slice` objects+ tags$div("no sample variables available")
|
||
| 215 | -+ | |||
| 121 | +2x |
- #' @param trim_lines (`logical(1)`) whether to trim lines+ } else if (nrow(SummarizedExperiment::colData(data)) == 0) {
|
||
| 216 | -+ | |||
| 122 | +1x |
- #' @export+ tags$div("no samples available")
|
||
| 217 | +123 |
- #'+ } else {
|
||
| 218 | -+ | |||
| 124 | +! |
- format.teal_slices <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
+ teal.widgets::optionalSelectInput( |
||
| 219 | -45x | +|||
| 125 | +! |
- checkmate::assert_flag(show_all)+ ns("col_to_add"),
|
||
| 220 | -45x | +|||
| 126 | +! |
- checkmate::assert_flag(trim_lines)+ choices = NULL, |
||
| 221 | -+ | |||
| 127 | +! |
-
+ options = shinyWidgets::pickerOptions( |
||
| 222 | -45x | +|||
| 128 | +! |
- x <- as.list(x, recursive = TRUE)+ liveSearch = TRUE, |
||
| 223 | -45x | +|||
| 129 | +! |
- attrs <- attributes(x)+ noneSelectedText = "Select sample variable" |
||
| 224 | -45x | +|||
| 130 | +
- attributes(x) <- NULL+ ) |
|||
| 225 | -45x | +|||
| 131 | +
- slices_list <- list(slices = x, attributes = attrs)+ ) |
|||
| 226 | -45x | +|||
| 132 | +
- slices_list <- Filter(Negate(is.null), slices_list) # drop attributes if empty+ } |
|||
| 227 | +133 | |||
| 228 | -20x | +134 | +2x |
- if (!show_all) slices_list$slices <- lapply(slices_list$slices, function(slice) Filter(Negate(is.null), slice))+ tags$div( |
| 229 | -+ | |||
| 135 | +2x |
-
+ row_input, |
||
| 230 | -45x | +136 | +2x |
- jsonify(slices_list, trim_lines)+ col_input |
| 231 | +137 |
- }+ ) |
||
| 232 | +138 |
-
+ }, |
||
| 233 | +139 |
- #' @rdname teal_slices-utilities+ |
||
| 234 | +140 |
- #' @export+ #' @description |
||
| 235 | +141 |
- #'+ #' `shiny` server module to add filter variable. |
||
| 236 | +142 |
- print.teal_slices <- function(x, ...) {
+ #' |
||
| 237 | -2x | +|||
| 143 | +
- cat(format(x, ...), "\n")+ #' Module controls available choices to select as a filter variable. |
|||
| 238 | +144 |
- }+ #' Selected filter variable is being removed from available choices. |
||
| 239 | +145 |
-
+ #' Removed filter variable gets back to available choices. |
||
| 240 | +146 |
-
+ #' This module unlike other `FilterStates` classes manages two |
||
| 241 | +147 |
- #' `setdiff` method for `teal_slices`+ #' sets of filter variables - one for `colData` and another for |
||
| 242 | +148 |
- #'+ #' `rowData`. |
||
| 243 | +149 |
- #' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`.+ #' |
||
| 244 | +150 |
- #' @param x,y (`teal_slices`)+ #' @param id (`character(1)`) |
||
| 245 | +151 |
- #' @return `teal_slices`+ #' `shiny` module instance id. |
||
| 246 | +152 |
- #' @keywords internal+ #' @return `NULL` |
||
| 247 | +153 |
- #'+ srv_add = function(id) {
|
||
| 248 | -+ | |||
| 154 | +! |
- setdiff_teal_slices <- function(x, y) {
+ data <- private$data |
||
| 249 | -14x | +|||
| 155 | +! |
- Filter(+ data_reactive <- private$data_reactive |
||
| 250 | -14x | +|||
| 156 | +! |
- function(xx) {
+ moduleServer( |
||
| 251 | -12x | +|||
| 157 | +! |
- !any(vapply(y, function(yy) identical(yy, xx), logical(1)))+ id = id, |
||
| 252 | -+ | |||
| 158 | +! |
- },+ function(input, output, session) {
|
||
| 253 | -14x | +|||
| 159 | +! |
- x+ logger::log_trace("SEFilterState$srv_add initializing, dataname: { private$dataname }")
|
||
| 254 | +160 |
- )+ |
||
| 255 | -+ | |||
| 161 | +! |
- }+ row_data <- SummarizedExperiment::rowData(data) |
||
| 256 | -+ | |||
| 162 | +! |
-
+ col_data <- SummarizedExperiment::colData(data) |
||
| 257 | +163 |
- #' Recursively coalesce list elements.+ |
||
| 258 | -+ | |||
| 164 | +! |
- #'+ avail_row_data_choices <- reactive({
|
||
| 259 | -+ | |||
| 165 | +! |
- #' Returns first element of list that it not `NULL`, recursively.+ slices_for_subset <- Filter(function(x) x$arg == "subset", self$get_filter_state()) |
||
| 260 | -+ | |||
| 166 | +! |
- #'+ active_filter_row_vars <- unique(unlist(lapply(slices_for_subset, "[[", "varname"))) |
||
| 261 | +167 |
- #' Given a list of atomic vectors, the first non-null element is returned.+ |
||
| 262 | -+ | |||
| 168 | +! |
- #' Given a list of lists, for all `names` found in all elements of the list+ choices <- setdiff( |
||
| 263 | -+ | |||
| 169 | +! |
- #' the first non-null element of a given name is returned.+ get_supported_filter_varnames(data = row_data), |
||
| 264 | -+ | |||
| 170 | +! |
- #'+ active_filter_row_vars |
||
| 265 | +171 |
- #' This function is used internally in `c.teal_slices` to manage `teal_slices` attributes.+ ) |
||
| 266 | +172 |
- #'+ |
||
| 267 | -+ | |||
| 173 | +! |
- #' @param x (`list`), either of atomic vectors or of named lists+ data_choices_labeled( |
||
| 268 | -+ | |||
| 174 | +! |
- #' @return+ data = row_data, |
||
| 269 | -+ | |||
| 175 | +! |
- #' Either an atomic vector of length 1 or a (potentially nested) list.+ choices = choices, |
||
| 270 | -+ | |||
| 176 | +! |
- #'+ varlabels = character(0), |
||
| 271 | -+ | |||
| 177 | +! |
- #' @keywords internal+ keys = NULL |
||
| 272 | +178 |
- #'+ ) |
||
| 273 | +179 |
- coalesce_r <- function(x) {
+ }) |
||
| 274 | -1569x | +|||
| 180 | +
- checkmate::assert_list(x)+ |
|||
| 275 | -1568x | +|||
| 181 | +! |
- xnn <- Filter(Negate(is.null), x)+ avail_col_data_choices <- reactive({
|
||
| 276 | -1568x | +|||
| 182 | +! |
- if (all(vapply(xnn, is.atomic, logical(1L)))) {
+ slices_for_select <- Filter(function(x) x$arg == "select", self$get_filter_state()) |
||
| 277 | -1059x | +|||
| 183 | +! |
- return(xnn[[1L]])+ active_filter_col_vars <- unique(unlist(lapply(slices_for_select, "[[", "varname"))) |
||
| 278 | +184 |
- }+ |
||
| 279 | -509x | +|||
| 185 | +! |
- lapply(x, checkmate::assert_list, names = "named", null.ok = TRUE, .var.name = "list element")+ choices <- setdiff( |
||
| 280 | -508x | +|||
| 186 | +! |
- all_names <- unique(unlist(lapply(x, names)))+ get_supported_filter_varnames(data = col_data), |
||
| 281 | -508x | +|||
| 187 | +! |
- sapply(all_names, function(nm) coalesce_r(lapply(x, `[[`, nm)), simplify = FALSE)+ active_filter_col_vars |
||
| 282 | +188 |
- }+ ) |
| 1 | +189 |
- # FilterState ------+ |
|
| 2 | -+ | ||
| 190 | +! |
-
+ data_choices_labeled( |
|
| 3 | -+ | ||
| 191 | +! |
- #' @name FilterState+ data = col_data, |
|
| 4 | -+ | ||
| 192 | +! |
- #' @docType class+ choices = choices, |
|
| 5 | -+ | ||
| 193 | +! |
- #'+ varlabels = character(0), |
|
| 6 | -+ | ||
| 194 | +! |
- #' @title `FilterState` abstract class+ keys = NULL |
|
| 7 | +195 |
- #'+ ) |
|
| 8 | +196 |
- #' @description Abstract class to encapsulate single filter state.+ }) |
|
| 9 | +197 |
- #'+ |
|
| 10 | -+ | ||
| 198 | +! |
- #' @details+ observeEvent( |
|
| 11 | -+ | ||
| 199 | +! |
- #' This class is responsible for managing a single filter item within a `FilteredData` object+ avail_row_data_choices(), |
|
| 12 | -+ | ||
| 200 | +! |
- #' and outputs a condition call (logical predicate) for subsetting one variable.+ ignoreNULL = TRUE, |
|
| 13 | -+ | ||
| 201 | +! |
- #' Filter states depend on the variable type:+ handlerExpr = {
|
|
| 14 | -+ | ||
| 202 | +! |
- #' (`logical`, `integer`, `numeric`, `character`, `factor`, `Date`, `POSIXct`, `POSIXlt`)+ logger::log_trace(paste( |
|
| 15 | -+ | ||
| 203 | +! |
- #' and `FilterState` subclasses exist that correspond to those types.+ "SEFilterStates$srv_add@1 updating available row data choices,", |
|
| 16 | -+ | ||
| 204 | +! |
- #' - `logical`: `class = LogicalFilterState`+ "dataname: { private$dataname }"
|
|
| 17 | +205 |
- #' - `integer`: `class = RangeFilterState`+ )) |
|
| 18 | -+ | ||
| 206 | +! |
- #' - `numeric`: `class = RangeFilterState`+ if (is.null(avail_row_data_choices())) {
|
|
| 19 | -+ | ||
| 207 | +! |
- #' - `character`: `class = ChoicesFilterState`+ shinyjs::hide("row_to_add")
|
|
| 20 | +208 |
- #' - `factor`: `class = ChoicesFilterState`+ } else {
|
|
| 21 | -+ | ||
| 209 | +! |
- #' - `Date`: `class = DateFilterState`+ shinyjs::show("row_to_add")
|
|
| 22 | +210 |
- #' - `POSIXct`, `POSIXlt`: `class = DatetimeFilterState`+ } |
|
| 23 | -+ | ||
| 211 | +! |
- #' - all `NA` entries: `class: FilterState`, cannot be filtered+ teal.widgets::updateOptionalSelectInput( |
|
| 24 | -+ | ||
| 212 | +! |
- #' - default: `FilterState`, cannot be filtered+ session, |
|
| 25 | -+ | ||
| 213 | +! |
- #'+ "row_to_add", |
|
| 26 | -+ | ||
| 214 | +! |
- #' Each variable's filter state is an `R6` object keeps the variable that is filtered,+ choices = avail_row_data_choices() |
|
| 27 | +215 |
- #' a `teal_slice` object that describes the filter state, as well as a `shiny` module (UI and server)+ ) |
|
| 28 | -+ | ||
| 216 | +! |
- #' that allows the user to alter the filter state.+ logger::log_trace(paste( |
|
| 29 | -+ | ||
| 217 | +! |
- #' Changes to the filter state that cause some observations to be omitted+ "SEFilterStates$srv_add@1 updated available row data choices,", |
|
| 30 | -+ | ||
| 218 | +! |
- #' trigger the `get_call` method and every `R` function call up in the reactive chain.+ "dataname: { private$dataname }"
|
|
| 31 | +219 |
- #'+ )) |
|
| 32 | +220 |
- #' @section Modifying state:+ } |
|
| 33 | +221 |
- #' Modifying a `FilterState` object is possible in three scenarios:+ ) |
|
| 34 | +222 |
- #' - In an interactive session, by passing an appropriate `teal_slice` to the `set_state` method.+ |
|
| 35 | -+ | ||
| 223 | +! |
- #' - In a running application, by changing appropriate inputs.+ observeEvent( |
|
| 36 | -+ | ||
| 224 | +! |
- #' - In a running application, by using [filter_state_api] which directly uses+ avail_col_data_choices(), |
|
| 37 | -+ | ||
| 225 | +! |
- #' `set_state` method of the `FilterState` object.+ ignoreNULL = TRUE, |
|
| 38 | -+ | ||
| 226 | +! |
- #'+ handlerExpr = {
|
|
| 39 | -+ | ||
| 227 | +! |
- #' @keywords internal+ logger::log_trace(paste( |
|
| 40 | -+ | ||
| 228 | +! |
- #'+ "SEFilterStates$srv_add@2 updating available col data choices,", |
|
| 41 | -+ | ||
| 229 | +! |
- FilterState <- R6::R6Class( # nolint+ "dataname: { private$dataname }"
|
|
| 42 | +230 |
- "FilterState",+ )) |
|
| 43 | -+ | ||
| 231 | +! |
-
+ if (is.null(avail_col_data_choices())) {
|
|
| 44 | -+ | ||
| 232 | +! |
- # public methods ----+ shinyjs::hide("col_to_add")
|
|
| 45 | +233 |
- public = list(+ } else {
|
|
| 46 | -+ | ||
| 234 | +! |
-
+ shinyjs::show("col_to_add")
|
|
| 47 | +235 |
- #' @description+ } |
|
| 48 | -+ | ||
| 236 | +! |
- #' Initialize a `FilterState` object.+ teal.widgets::updateOptionalSelectInput( |
|
| 49 | -+ | ||
| 237 | +! |
- #'+ session, |
|
| 50 | -+ | ||
| 238 | +! |
- #' @param x (`vector`)+ "col_to_add", |
|
| 51 | -+ | ||
| 239 | +! |
- #' variable to be filtered.+ choices = avail_col_data_choices() |
|
| 52 | +240 |
- #' @param x_reactive (`reactive`)+ ) |
|
| 53 | -+ | ||
| 241 | +! |
- #' returning vector of the same type as `x`. Is used to update+ logger::log_trace(paste( |
|
| 54 | -+ | ||
| 242 | +! |
- #' counts following the change in values of the filtered dataset.+ "SEFilterStates$srv_add@2 updated available col data choices,", |
|
| 55 | -+ | ||
| 243 | +! |
- #' If it is set to `reactive(NULL)` then counts based on filtered+ "dataname: { private$dataname }"
|
|
| 56 | +244 |
- #' dataset are not shown.+ )) |
|
| 57 | +245 |
- #' @param slice (`teal_slice`)+ } |
|
| 58 | +246 |
- #' specification of this filter state.+ ) |
|
| 59 | +247 |
- #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.+ |
|
| 60 | -+ | ||
| 248 | +! |
- #' `get_state` returns `teal_slice` object which can be reused in other places.+ observeEvent( |
|
| 61 | -+ | ||
| 249 | +! |
- #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.+ eventExpr = input$col_to_add, |
|
| 62 | -+ | ||
| 250 | +! |
- #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.+ handlerExpr = {
|
|
| 63 | -+ | ||
| 251 | +! |
- #' @param extract_type (`character`)+ logger::log_trace( |
|
| 64 | -+ | ||
| 252 | +! |
- #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ sprintf( |
|
| 65 | -+ | ||
| 253 | +! |
- #' - `character(0)` (default) `varname` in the condition call will not be prefixed+ "SEFilterStates$srv_add@3 adding FilterState of column %s to col data, dataname: %s", |
|
| 66 | -+ | ||
| 254 | +! |
- #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`+ deparse1(input$col_to_add), |
|
| 67 | -+ | ||
| 255 | +! |
- #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`+ private$dataname |
|
| 68 | +256 |
- #'+ ) |
|
| 69 | +257 |
- #' @return Object of class `FilterState`, invisibly.+ ) |
|
| 70 | -+ | ||
| 258 | +! |
- #'+ varname <- input$col_to_add |
|
| 71 | -+ | ||
| 259 | +! |
- initialize = function(x,+ self$set_filter_state(teal_slices( |
|
| 72 | -+ | ||
| 260 | +! |
- x_reactive = reactive(NULL),+ teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select") |
|
| 73 | +261 |
- slice,+ )) |
|
| 74 | +262 |
- extract_type = character(0)) {
+
|
|
| 75 | -368x | +||
| 263 | +! |
- checkmate::assert_class(x_reactive, "reactive")+ logger::log_trace( |
|
| 76 | -367x | +||
| 264 | +! |
- checkmate::assert_class(slice, "teal_slice")+ sprintf( |
|
| 77 | -365x | +||
| 265 | +! |
- checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)+ "SEFilterStates$srv_add@3 added FilterState of column %s to col data, dataname: %s", |
|
| 78 | -365x | +||
| 266 | +! |
- if (length(extract_type) == 1) {
+ deparse1(varname), |
|
| 79 | -53x | +||
| 267 | +! |
- checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
+ private$dataname |
|
| 80 | +268 |
- }+ ) |
|
| 81 | +269 |
-
+ ) |
|
| 82 | +270 |
- # Set data properties.+ } |
|
| 83 | -364x | +||
| 271 | +
- private$x <- x+ ) |
||
| 84 | -364x | +||
| 272 | +
- private$x_reactive <- x_reactive+ |
||
| 85 | +273 |
- # Set derived data properties.+ |
|
| 86 | -364x | +||
| 274 | +! |
- private$na_count <- sum(is.na(x))+ observeEvent( |
|
| 87 | -364x | +||
| 275 | +! |
- private$filtered_na_count <- reactive(+ eventExpr = input$row_to_add, |
|
| 88 | -364x | +||
| 276 | +! |
- if (!is.null(private$x_reactive())) {
+ handlerExpr = {
|
|
| 89 | +277 | ! |
- sum(is.na(private$x_reactive()))+ logger::log_trace( |
| 90 | -+ | ||
| 278 | +! |
- }+ sprintf( |
|
| 91 | -+ | ||
| 279 | +! |
- )+ "SEFilterStates$srv_add@4 adding FilterState of variable %s to row data, dataname: %s", |
|
| 92 | -+ | ||
| 280 | +! |
- # Set extract type.+ deparse1(input$row_to_add), |
|
| 93 | -364x | +||
| 281 | +! |
- private$extract_type <- extract_type+ private$dataname |
|
| 94 | +282 |
-
+ ) |
|
| 95 | +283 |
- # Set state properties.+ ) |
|
| 96 | -18x | +||
| 284 | +! |
- if (is.null(isolate(slice$keep_na)) && anyNA(x)) slice$keep_na <- TRUE+ varname <- input$row_to_add |
|
| 97 | -364x | +||
| 285 | +! |
- private$teal_slice <- slice+ self$set_filter_state(teal_slices( |
|
| 98 | -+ | ||
| 286 | +! |
- # Obtain variable label.+ teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset") |
|
| 99 | -364x | +||
| 287 | +
- varlabel <- attr(x, "label", exact = TRUE)+ )) |
||
| 100 | +288 |
- # Display only when different from varname.+ |
|
| 101 | -364x | +||
| 289 | +! |
- private$varlabel <-+ logger::log_trace( |
|
| 102 | -364x | +||
| 290 | +! |
- if (is.null(varlabel) || identical(varlabel, private$get_varname())) {
+ sprintf( |
|
| 103 | -363x | +||
| 291 | +! |
- character(0)+ "SEFilterStates$srv_add@4 added FilterState of variable %s to row data, dataname: %s", |
|
| 104 | -+ | ||
| 292 | +! |
- } else {
+ deparse1(varname), |
|
| 105 | -1x | +||
| 293 | +! |
- varlabel+ private$dataname |
|
| 106 | +294 |
- }+ ) |
|
| 107 | +295 | - - | -|
| 108 | -364x | -
- private$state_history <- reactiveVal(list())+ ) |
|
| 109 | +296 |
-
+ } |
|
| 110 | -364x | +||
| 297 | +
- logger::log_trace("Instantiated FilterState object id: { private$get_id() }")
+ ) |
||
| 111 | +298 | ||
| 112 | -364x | +||
| 299 | +! |
- invisible(self)+ logger::log_trace("SEFilterState$srv_add initialized, dataname: { private$dataname }")
|
|
| 113 | -+ | ||
| 300 | +! |
- },+ NULL |
|
| 114 | +301 |
-
+ } |
|
| 115 | +302 |
- #' @description+ ) |
|
| 116 | +303 |
- #' Returns a formatted string representing this `FilterState` object.+ } |
|
| 117 | +304 |
- #'+ ) |
|
| 118 | +305 |
- #' @param show_all (`logical(1)`) passed to `format.teal_slice`+ ) |
| 119 | +1 |
- #' @param trim_lines (`logical(1)`) passed to `format.teal_slice`+ # FilterState ------ |
||
| 120 | +2 |
- #'+ |
||
| 121 | +3 |
- #' @return `character(1)` the formatted string+ #' @name FilterState |
||
| 122 | +4 |
- #'+ #' @docType class |
||
| 123 | +5 |
- format = function(show_all = FALSE, trim_lines = TRUE) {
- |
- ||
| 124 | -68x | -
- sprintf(- |
- ||
| 125 | -68x | -
- "%s:\n%s",- |
- ||
| 126 | -68x | -
- class(self)[1],- |
- ||
| 127 | -68x | -
- format(self$get_state(), show_all = show_all, trim_lines = trim_lines)+ #' |
||
| 128 | +6 |
- )+ #' @title `FilterState` abstract class |
||
| 129 | +7 |
- },+ #' |
||
| 130 | +8 |
-
+ #' @description Abstract class to encapsulate single filter state. |
||
| 131 | +9 |
- #' @description+ #' |
||
| 132 | +10 |
- #' Prints this `FilterState` object.+ #' @details |
||
| 133 | +11 |
- #'+ #' This class is responsible for managing a single filter item within a `FilteredData` object |
||
| 134 | +12 |
- #' @param ... additional arguments+ #' and outputs a condition call (logical predicate) for subsetting one variable. |
||
| 135 | +13 |
- #'+ #' Filter states depend on the variable type: |
||
| 136 | +14 |
- print = function(...) {
- |
- ||
| 137 | -14x | -
- cat(isolate(self$format(...)))+ #' (`logical`, `integer`, `numeric`, `character`, `factor`, `Date`, `POSIXct`, `POSIXlt`) |
||
| 138 | +15 |
- },+ #' and `FilterState` subclasses exist that correspond to those types. |
||
| 139 | +16 |
-
+ #' - `logical`: `class = LogicalFilterState` |
||
| 140 | +17 |
- #' @description+ #' - `integer`: `class = RangeFilterState` |
||
| 141 | +18 |
- #' Sets mutable parameters of the filter state.+ #' - `numeric`: `class = RangeFilterState` |
||
| 142 | +19 |
- #' - `fixed` state is prevented from changing state+ #' - `character`: `class = ChoicesFilterState` |
||
| 143 | +20 |
- #' - `anchored` state is prevented from removing state+ #' - `factor`: `class = ChoicesFilterState` |
||
| 144 | +21 |
- #'+ #' - `Date`: `class = DateFilterState` |
||
| 145 | +22 |
- #' @param state (`teal_slice`)+ #' - `POSIXct`, `POSIXlt`: `class = DatetimeFilterState` |
||
| 146 | +23 |
- #'+ #' - all `NA` entries: `class: FilterState`, cannot be filtered |
||
| 147 | +24 |
- #' @return `self` invisibly+ #' - default: `FilterState`, cannot be filtered |
||
| 148 | +25 |
- #'+ #' |
||
| 149 | +26 |
- set_state = function(state) {
- |
- ||
| 150 | -89x | -
- checkmate::assert_class(state, "teal_slice")- |
- ||
| 151 | -88x | -
- if (private$is_fixed()) {
- |
- ||
| 152 | -1x | -
- warning("attempt to set state on fixed filter aborted id: ", private$get_id())
+ #' Each variable's filter state is an `R6` object keeps the variable that is filtered, |
||
| 153 | +27 |
- } else {
- |
- ||
| 154 | -87x | -
- logger::log_trace("{ class(self)[1] }$set_state setting state of filter id: { private$get_id() }")
- |
- ||
| 155 | -87x | -
- isolate({
- |
- ||
| 156 | -87x | -
- if (!is.null(state$selected)) {
- |
- ||
| 157 | -78x | -
- private$set_selected(state$selected)+ #' a `teal_slice` object that describes the filter state, as well as a `shiny` module (UI and server) |
||
| 158 | +28 |
- }+ #' that allows the user to alter the filter state. |
||
| 159 | -75x | +|||
| 29 | +
- if (!is.null(state$keep_na)) {
+ #' Changes to the filter state that cause some observations to be omitted |
|||
| 160 | -16x | +|||
| 30 | +
- private$set_keep_na(state$keep_na)+ #' trigger the `get_call` method and every `R` function call up in the reactive chain. |
|||
| 161 | +31 |
- }+ #' |
||
| 162 | -75x | +|||
| 32 | +
- if (!is.null(state$keep_inf)) {
+ #' @section Modifying state: |
|||
| 163 | -9x | +|||
| 33 | +
- private$set_keep_inf(state$keep_inf)+ #' Modifying a `FilterState` object is possible in three scenarios: |
|||
| 164 | +34 |
- }+ #' - In an interactive session, by passing an appropriate `teal_slice` to the `set_state` method. |
||
| 165 | -75x | +|||
| 35 | +
- current_state <- sprintf(+ #' - In a running application, by changing appropriate inputs. |
|||
| 166 | -75x | +|||
| 36 | +
- "selected: %s; keep_na: %s; keep_inf: %s",+ #' - In a running application, by using [filter_state_api] which directly uses |
|||
| 167 | -75x | +|||
| 37 | +
- toString(private$get_selected()),+ #' `set_state` method of the `FilterState` object. |
|||
| 168 | -75x | +|||
| 38 | +
- private$get_keep_na(),+ #' |
|||
| 169 | -75x | +|||
| 39 | +
- private$get_keep_inf()+ #' @keywords internal |
|||
| 170 | +40 |
- )+ #' |
||
| 171 | +41 |
- })+ FilterState <- R6::R6Class( # nolint |
||
| 172 | +42 |
- }+ "FilterState", |
||
| 173 | +43 | |||
| 174 | -76x | -
- invisible(self)- |
- ||
| 175 | +44 |
- },+ # public methods ---- |
||
| 176 | +45 |
-
+ public = list( |
||
| 177 | +46 | |||
| 178 | +47 |
#' @description |
||
| 179 | +48 |
- #' Returns a complete description of the filter state.+ #' Initialize a `FilterState` object. |
||
| 180 | +49 |
#' |
||
| 181 | +50 |
- #' @return A `teal_slice` object.+ #' @param x (`vector`) |
||
| 182 | +51 |
- #'+ #' variable to be filtered. |
||
| 183 | +52 |
- get_state = function() {
+ #' @param x_reactive (`reactive`) |
||
| 184 | -747x | +|||
| 53 | +
- private$teal_slice+ #' returning vector of the same type as `x`. Is used to update |
|||
| 185 | +54 |
- },+ #' counts following the change in values of the filtered dataset. |
||
| 186 | +55 |
-
+ #' If it is set to `reactive(NULL)` then counts based on filtered |
||
| 187 | +56 |
- #' @description+ #' dataset are not shown. |
||
| 188 | +57 |
- #' Returns reproducible condition call for current selection relevant+ #' @param slice (`teal_slice`) |
||
| 189 | +58 |
- #' for selected variable type.+ #' specification of this filter state. |
||
| 190 | +59 |
- #' Method is using internal reactive values which makes it reactive+ #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
||
| 191 | +60 |
- #' and must be executed in reactive or isolated context.+ #' `get_state` returns `teal_slice` object which can be reused in other places. |
||
| 192 | +61 |
- #'+ #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
||
| 193 | +62 |
- get_call = function() {
+ #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
||
| 194 | -1x | +|||
| 63 | +
- stop("this is a virtual method")
+ #' @param extract_type (`character`) |
|||
| 195 | +64 |
- },+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
||
| 196 | +65 |
-
+ #' - `character(0)` (default) `varname` in the condition call will not be prefixed |
||
| 197 | +66 |
- #' @description+ #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
||
| 198 | +67 |
- #' `shiny` module server.+ #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
||
| 199 | +68 |
#' |
||
| 200 | +69 |
- #' @param id (`character(1)`)+ #' @return Object of class `FilterState`, invisibly. |
||
| 201 | +70 |
- #' `shiny` module instance id.+ #' |
||
| 202 | +71 |
- #'+ initialize = function(x, |
||
| 203 | +72 |
- #' @return Reactive expression signaling that remove button has been clicked.+ x_reactive = reactive(NULL), |
||
| 204 | +73 |
- #'+ slice, |
||
| 205 | +74 |
- server = function(id) {
+ extract_type = character(0)) {
|
||
| 206 | -12x | +75 | +369x |
- moduleServer(+ checkmate::assert_class(x_reactive, "reactive") |
| 207 | -12x | +76 | +368x |
- id = id,+ checkmate::assert_class(slice, "teal_slice") |
| 208 | -12x | +77 | +366x |
- function(input, output, session) {
+ checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE) |
| 209 | -12x | +78 | +366x |
- logger::log_trace("FilterState$server initializing module for slice: { private$get_id() } ")
+ if (length(extract_type) == 1) {
|
| 210 | -12x | +79 | +53x |
- private$server_summary("summary")
+ checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
|
| 211 | -12x | +|||
| 80 | +
- if (private$is_fixed()) {
+ } |
|||
| 212 | -! | +|||
| 81 | +
- private$server_inputs_fixed("inputs")
+
|
|||
| 213 | +82 |
- } else {
+ # Set data properties. |
||
| 214 | -12x | +83 | +365x |
- private$server_inputs("inputs")
+ private$x <- x |
| 215 | -+ | |||
| 84 | +365x |
- }+ private$x_reactive <- x_reactive |
||
| 216 | +85 |
-
+ # Set derived data properties. |
||
| 217 | -12x | +86 | +365x |
- private$observers$state <- observeEvent(+ private$na_count <- sum(is.na(x)) |
| 218 | -12x | +87 | +365x |
- eventExpr = list(private$get_selected(), private$get_keep_na(), private$get_keep_inf()),+ private$filtered_na_count <- reactive( |
| 219 | -12x | -
- handlerExpr = {
- |
- ||
| 220 | -4x | -
- current_state <- as.list(self$get_state())- |
- ||
| 221 | -4x | -
- history <- private$state_history()- |
- ||
| 222 | -4x | +88 | +365x |
- history_update <- c(history, list(current_state))+ if (!is.null(private$x_reactive())) {
|
| 223 | -4x | +|||
| 89 | +! |
- private$state_history(history_update)+ sum(is.na(private$x_reactive())) |
||
| 224 | +90 |
- }+ } |
||
| 225 | +91 |
- )+ ) |
||
| 226 | +92 | - - | -||
| 227 | -12x | -
- private$observers$back <- observeEvent(- |
- ||
| 228 | -12x | -
- eventExpr = input$back,+ # Set extract type. |
||
| 229 | -12x | -
- handlerExpr = {
- |
- ||
| 230 | -! | +93 | +365x |
- history <- rev(private$state_history())+ private$extract_type <- extract_type |
| 231 | -! | +|||
| 94 | +
- slice <- history[[2L]]+ |
|||
| 232 | -! | +|||
| 95 | +
- history_update <- rev(history[-(1:2)])+ # Set state properties. |
|||
| 233 | -! | +|||
| 96 | +18x |
- private$state_history(history_update)+ if (is.null(isolate(slice$keep_na)) && anyNA(x)) slice$keep_na <- TRUE |
||
| 234 | -! | +|||
| 97 | +365x |
- self$set_state(as.teal_slice(slice))+ private$teal_slice <- slice |
||
| 235 | +98 |
- }+ # Obtain variable label. |
||
| 236 | -+ | |||
| 99 | +365x |
- )+ varlabel <- attr(x, "label", exact = TRUE) |
||
| 237 | +100 |
-
+ # Display only when different from varname. |
||
| 238 | -12x | +101 | +365x |
- private$observers$reset <- observeEvent(+ private$varlabel <- |
| 239 | -12x | +102 | +365x |
- eventExpr = input$reset,+ if (is.null(varlabel) || identical(varlabel, private$get_varname())) {
|
| 240 | -12x | +103 | +364x |
- handlerExpr = {
+ character(0) |
| 241 | -! | +|||
| 104 | +
- slice <- private$state_history()[[1L]]+ } else {
|
|||
| 242 | -! | +|||
| 105 | +1x |
- self$set_state(as.teal_slice(slice))+ varlabel |
||
| 243 | +106 |
- }+ } |
||
| 244 | +107 |
- )+ + |
+ ||
| 108 | +365x | +
+ private$state_history <- reactiveVal(list()) |
||
| 245 | +109 | |||
| 246 | -+ | |||
| 110 | +365x |
- # Buttons for rewind/reset are disabled upon change in history to prevent double-clicking.+ logger::log_trace("Instantiated FilterState object id: { private$get_id() }")
|
||
| 247 | +111 |
- # Re-enabling occurs after 100 ms, after they are potentially hidden when no history is present.+ |
||
| 248 | -12x | +112 | +365x |
- private$observers$state_history <- observeEvent(+ invisible(self) |
| 249 | -12x | +|||
| 113 | +
- eventExpr = private$state_history(),+ }, |
|||
| 250 | -12x | +|||
| 114 | +
- handlerExpr = {
+
|
|||
| 251 | -4x | +|||
| 115 | +
- shinyjs::disable(id = "back")+ #' @description |
|||
| 252 | -4x | +|||
| 116 | +
- shinyjs::disable(id = "reset")+ #' Returns a formatted string representing this `FilterState` object. |
|||
| 253 | -4x | +|||
| 117 | +
- shinyjs::delay(+ #' |
|||
| 254 | -4x | +|||
| 118 | +
- ms = 100,+ #' @param show_all (`logical(1)`) passed to `format.teal_slice` |
|||
| 255 | -4x | +|||
| 119 | +
- expr = {
+ #' @param trim_lines (`logical(1)`) passed to `format.teal_slice` |
|||
| 256 | -! | +|||
| 120 | +
- shinyjs::toggleElement(id = "back", condition = length(private$state_history()) > 1L)+ #' |
|||
| 257 | -! | +|||
| 121 | +
- shinyjs::enable(id = "back")+ #' @return `character(1)` the formatted string |
|||
| 258 | +122 |
- }+ #' |
||
| 259 | +123 |
- )+ format = function(show_all = FALSE, trim_lines = TRUE) {
|
||
| 260 | -4x | +124 | +68x |
- shinyjs::delay(+ sprintf( |
| 261 | -4x | +125 | +68x |
- ms = 100,+ "%s:\n%s", |
| 262 | -4x | -
- expr = {
- |
- ||
| 263 | -! | +126 | +68x |
- shinyjs::toggleElement(id = "reset", condition = length(private$state_history()) > 1L)+ class(self)[1], |
| 264 | -! | +|||
| 127 | +68x |
- shinyjs::enable(id = "reset")+ format(self$get_state(), show_all = show_all, trim_lines = trim_lines) |
||
| 265 | +128 |
- }+ ) |
||
| 266 | +129 |
- )+ }, |
||
| 267 | +130 |
- }+ |
||
| 268 | +131 |
- )+ #' @description |
||
| 269 | +132 | - - | -||
| 270 | -12x | -
- private$destroy_shiny <- function() {
- |
- ||
| 271 | -8x | -
- logger::log_trace("Destroying FilterState inputs and observers; id: { private$get_id() }")
+ #' Prints this `FilterState` object. |
||
| 272 | +133 |
- # remove values from the input list+ #' |
||
| 273 | -8x | +|||
| 134 | +
- lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)+ #' @param ... additional arguments |
|||
| 274 | +135 |
-
+ #' |
||
| 275 | +136 |
- # remove observers+ print = function(...) {
|
||
| 276 | -8x | +137 | +14x |
- lapply(private$observers, function(x) x$destroy())+ cat(isolate(self$format(...))) |
| 277 | +138 |
- }+ }, |
||
| 278 | +139 | |||
| 279 | -12x | -
- reactive(input$remove)- |
- ||
| 280 | +140 |
- }+ #' @description |
||
| 281 | +141 |
- )+ #' Sets mutable parameters of the filter state. |
||
| 282 | +142 |
- },+ #' - `fixed` state is prevented from changing state |
||
| 283 | +143 |
-
+ #' - `anchored` state is prevented from removing state |
||
| 284 | +144 |
- #' @description+ #' |
||
| 285 | +145 |
- #' `shiny` UI module.+ #' @param state (`teal_slice`) |
||
| 286 | +146 |
- #' The UI for this class contains simple message stating that it is not supported.+ #' |
||
| 287 | +147 |
- #' @param id (`character(1)`)+ #' @return `self` invisibly |
||
| 288 | +148 |
- #' `shiny` module instance id.+ #' |
||
| 289 | +149 |
- #' @param parent_id (`character(1)`) id of the `FilterStates` card container+ set_state = function(state) {
|
||
| 290 | -+ | |||
| 150 | +89x |
- ui = function(id, parent_id = "cards") {
+ checkmate::assert_class(state, "teal_slice") |
||
| 291 | -12x | +151 | +88x |
- ns <- NS(id)+ if (private$is_fixed()) {
|
| 292 | -+ | |||
| 152 | +1x |
-
+ warning("attempt to set state on fixed filter aborted id: ", private$get_id())
|
||
| 293 | +153 |
- # Filter card consists of header and body, arranged in a single column.+ } else {
|
||
| 294 | -+ | |||
| 154 | +87x |
- # Body is hidden and is toggled by clicking on header.+ logger::log_trace("{ class(self)[1] }$set_state setting state of filter id: { private$get_id() }")
|
||
| 295 | -+ | |||
| 155 | +87x |
- ## Header consists of title and summary, arranged in a column.+ isolate({
|
||
| 296 | -+ | |||
| 156 | +87x |
- ### Title consists of conditional icon, varname, conditional varlabel, and controls, arranged in a row.+ if (!is.null(state$selected)) {
|
||
| 297 | -+ | |||
| 157 | +78x |
- ### Summary consists of value and controls, arranged in a row.+ private$set_selected(state$selected) |
||
| 298 | +158 |
-
+ } |
||
| 299 | -12x | +159 | +75x |
- tags$div(+ if (!is.null(state$keep_na)) {
|
| 300 | -12x | +160 | +16x |
- id = id,+ private$set_keep_na(state$keep_na) |
| 301 | -12x | +|||
| 161 | +
- class = "panel filter-card",+ } |
|||
| 302 | -12x | +162 | +75x |
- include_js_files("count-bar-labels.js"),
+ if (!is.null(state$keep_inf)) {
|
| 303 | -12x | +163 | +9x |
- tags$div(+ private$set_keep_inf(state$keep_inf) |
| 304 | -12x | -
- class = "filter-card-header",- |
- ||
| 305 | -12x | +|||
| 164 | +
- `data-toggle` = "collapse",+ } |
|||
| 306 | -12x | +165 | +75x |
- `data-bs-toggle` = "collapse",+ current_state <- sprintf( |
| 307 | -12x | +166 | +75x |
- href = paste0("#", ns("body")),
+ "selected: %s; keep_na: %s; keep_inf: %s", |
| 308 | -12x | +167 | +75x |
- tags$div(+ toString(private$get_selected()), |
| 309 | -12x | +168 | +75x |
- class = "filter-card-title",+ private$get_keep_na(), |
| 310 | -12x | +169 | +75x |
- if (private$is_anchored() && private$is_fixed()) {
+ private$get_keep_inf() |
| 311 | -! | +|||
| 170 | +
- icon("anchor-lock", class = "filter-card-icon")
+ ) |
|||
| 312 | -12x | +|||
| 171 | +
- } else if (private$is_anchored() && !private$is_fixed()) {
+ }) |
|||
| 313 | -! | +|||
| 172 | +
- icon("anchor", class = "filter-card-icon")
+ } |
|||
| 314 | -12x | +|||
| 173 | +
- } else if (!private$is_anchored() && private$is_fixed()) {
+
|
|||
| 315 | -! | +|||
| 174 | +76x |
- icon("lock", class = "filter-card-icon")
+ invisible(self) |
||
| 316 | +175 |
- },+ }, |
||
| 317 | -12x | +|||
| 176 | +
- tags$div(class = "filter-card-varname", tags$strong(private$get_varname())),+ |
|||
| 318 | -12x | +|||
| 177 | +
- tags$div(class = "filter-card-varlabel", private$get_varlabel()),+ |
|||
| 319 | -12x | +|||
| 178 | +
- tags$div(+ #' @description |
|||
| 320 | -12x | +|||
| 179 | +
- class = "filter-card-controls",+ #' Returns a complete description of the filter state. |
|||
| 321 | +180 |
- # Suppress toggling body when clicking on this div.+ #' |
||
| 322 | +181 |
- # This is for bootstrap 3 and 4. Causes page to scroll to top, prevented by setting href on buttons.+ #' @return A `teal_slice` object. |
||
| 323 | -12x | +|||
| 182 | +
- onclick = "event.stopPropagation();event.preventDefault();",+ #' |
|||
| 324 | +183 |
- # This is for bootstrap 5.+ get_state = function() {
|
||
| 325 | -12x | +184 | +747x |
- `data-bs-toggle` = "collapse",+ private$teal_slice |
| 326 | -12x | +|||
| 185 | +
- `data-bs-target` = NULL,+ }, |
|||
| 327 | -12x | +|||
| 186 | +
- if (isFALSE(private$is_fixed())) {
+
|
|||
| 328 | -12x | +|||
| 187 | +
- actionLink(+ #' @description |
|||
| 329 | -12x | +|||
| 188 | +
- inputId = ns("back"),
+ #' Returns reproducible condition call for current selection relevant |
|||
| 330 | -12x | +|||
| 189 | +
- label = NULL,+ #' for selected variable type. |
|||
| 331 | -12x | +|||
| 190 | +
- icon = icon("circle-arrow-left", lib = "font-awesome"),
+ #' Method is using internal reactive values which makes it reactive |
|||
| 332 | -12x | +|||
| 191 | +
- title = "Rewind state",+ #' and must be executed in reactive or isolated context. |
|||
| 333 | -12x | +|||
| 192 | +
- class = "filter-card-back",+ #' |
|||
| 334 | -12x | +|||
| 193 | +
- style = "display: none"+ get_call = function() {
|
|||
| 335 | -+ | |||
| 194 | +1x |
- )+ stop("this is a virtual method")
|
||
| 336 | +195 |
- },+ }, |
||
| 337 | -12x | +|||
| 196 | +
- if (isFALSE(private$is_fixed())) {
+
|
|||
| 338 | -12x | +|||
| 197 | +
- actionLink(+ #' @description |
|||
| 339 | -12x | +|||
| 198 | +
- inputId = ns("reset"),
+ #' `shiny` module server. |
|||
| 340 | -12x | +|||
| 199 | +
- label = NULL,+ #' |
|||
| 341 | -12x | +|||
| 200 | +
- icon = icon("circle-arrow-up", lib = "font-awesome"),
+ #' @param id (`character(1)`) |
|||
| 342 | -12x | +|||
| 201 | +
- title = "Restore original state",+ #' `shiny` module instance id. |
|||
| 343 | -12x | +|||
| 202 | +
- class = "filter-card-back",+ #' |
|||
| 344 | -12x | +|||
| 203 | +
- style = "display: none"+ #' @return Reactive expression signaling that remove button has been clicked. |
|||
| 345 | +204 |
- )+ #' |
||
| 346 | +205 |
- },+ server = function(id) {
|
||
| 347 | +206 | 12x |
- if (isFALSE(private$is_anchored())) {
+ moduleServer( |
|
| 348 | +207 | 12x |
- actionLink(+ id = id, |
|
| 349 | +208 | 12x |
- inputId = ns("remove"),
+ function(input, output, session) {
|
|
| 350 | +209 | 12x |
- label = icon("circle-xmark", lib = "font-awesome"),
+ logger::log_trace("FilterState$server initializing module for slice: { private$get_id() } ")
|
|
| 351 | +210 | 12x |
- title = "Remove filter",+ private$server_summary("summary")
|
|
| 352 | +211 | 12x |
- class = "filter-card-remove"+ if (private$is_fixed()) {
|
|
| 353 | -+ | |||
| 212 | +! |
- )+ private$server_inputs_fixed("inputs")
|
||
| 354 | +213 |
- }+ } else {
|
||
| 355 | -+ | |||
| 214 | +12x |
- )+ private$server_inputs("inputs")
|
||
| 356 | +215 |
- ),- |
- ||
| 357 | -12x | -
- tags$div(class = "filter-card-summary", private$ui_summary(ns("summary")))
+ } |
||
| 358 | +216 |
- ),+ |
||
| 359 | +217 | 12x |
- tags$div(+ private$observers$state <- observeEvent( |
|
| 360 | +218 | 12x |
- id = ns("body"),
+ eventExpr = list(private$get_selected(), private$get_keep_na(), private$get_keep_inf()), |
|
| 361 | +219 | 12x |
- class = "collapse out",+ handlerExpr = {
|
|
| 362 | -12x | +220 | +4x |
- `data-parent` = paste0("#", parent_id),
+ current_state <- as.list(self$get_state()) |
| 363 | -12x | +221 | +4x |
- `data-bs-parent` = paste0("#", parent_id),
+ history <- private$state_history() |
| 364 | -12x | +222 | +4x |
- tags$div(+ history_update <- c(history, list(current_state)) |
| 365 | -12x | +223 | +4x |
- class = "filter-card-body",+ private$state_history(history_update) |
| 366 | -12x | +|||
| 224 | +
- if (private$is_fixed()) {
+ } |
|||
| 367 | -! | +|||
| 225 | +
- private$ui_inputs_fixed(ns("inputs"))
+ ) |
|||
| 368 | +226 |
- } else {
+
|
||
| 369 | +227 | 12x |
- private$ui_inputs(ns("inputs"))
+ private$observers$back <- observeEvent( |
|
| 370 | -+ | |||
| 228 | +12x |
- }+ eventExpr = input$back, |
||
| 371 | -+ | |||
| 229 | +12x |
- )+ handlerExpr = {
|
||
| 372 | -+ | |||
| 230 | +! |
- )+ history <- rev(private$state_history()) |
||
| 373 | -+ | |||
| 231 | +! |
- )+ slice <- history[[2L]] |
||
| 374 | -+ | |||
| 232 | +! |
- },+ history_update <- rev(history[-(1:2)]) |
||
| 375 | -+ | |||
| 233 | +! |
-
+ private$state_history(history_update) |
||
| 376 | -+ | |||
| 234 | +! |
- #' @description+ self$set_state(as.teal_slice(slice)) |
||
| 377 | +235 |
- #' Destroy observers stored in `private$observers`.+ } |
||
| 378 | +236 |
- #'+ ) |
||
| 379 | +237 |
- #' @return `NULL`, invisibly.+ |
||
| 380 | -+ | |||
| 238 | +12x |
- #'+ private$observers$reset <- observeEvent( |
||
| 381 | -+ | |||
| 239 | +12x |
- destroy_observers = function() {
+ eventExpr = input$reset, |
||
| 382 | -47x | +240 | +12x |
- if (!is.null(private$destroy_shiny)) {
+ handlerExpr = {
|
| 383 | -8x | -
- private$destroy_shiny()+ | ||
| 241 | +! | +
+ slice <- private$state_history()[[1L]] |
||
| 384 | -+ | |||
| 242 | +! |
- }+ self$set_state(as.teal_slice(slice)) |
||
| 385 | +243 |
- }+ } |
||
| 386 | +244 |
- ),+ ) |
||
| 387 | +245 | |||
| 388 | +246 |
- # private members ----+ # Buttons for rewind/reset are disabled upon change in history to prevent double-clicking. |
||
| 389 | +247 |
- private = list(+ # Re-enabling occurs after 100 ms, after they are potentially hidden when no history is present. |
||
| 390 | -+ | |||
| 248 | +12x |
- # set by constructor+ private$observers$state_history <- observeEvent( |
||
| 391 | -+ | |||
| 249 | +12x |
- x = NULL, # the filtered variable+ eventExpr = private$state_history(), |
||
| 392 | -+ | |||
| 250 | +12x |
- x_reactive = NULL, # reactive containing the filtered variable, used for updating counts and histograms+ handlerExpr = {
|
||
| 393 | -+ | |||
| 251 | +4x |
- teal_slice = NULL, # stores all transferable properties of this filter state+ shinyjs::disable(id = "back") |
||
| 394 | -+ | |||
| 252 | +4x |
- extract_type = character(0), # used by private$get_varname_prefixed+ shinyjs::disable(id = "reset") |
||
| 395 | -+ | |||
| 253 | +4x |
- na_count = integer(0),+ shinyjs::delay( |
||
| 396 | -+ | |||
| 254 | +4x |
- filtered_na_count = NULL, # reactive containing the count of NA in the filtered dataset+ ms = 100, |
||
| 397 | -+ | |||
| 255 | +4x |
- varlabel = character(0), # taken from variable labels in data; displayed in filter cards+ expr = {
|
||
| 398 | -+ | |||
| 256 | +! |
- destroy_shiny = NULL, # function is set in server+ shinyjs::toggleElement(id = "back", condition = length(private$state_history()) > 1L) |
||
| 399 | -+ | |||
| 257 | +! |
- # other+ shinyjs::enable(id = "back") |
||
| 400 | +258 |
- is_choice_limited = FALSE, # flag whether number of possible choices was limited when specifying filter+ } |
||
| 401 | +259 |
- observers = list(), # stores observers+ ) |
||
| 402 | -+ | |||
| 260 | +4x |
- state_history = NULL, # reactiveVal holding a list storing states this FilterState has had since instantiation+ shinyjs::delay(+ |
+ ||
| 261 | +4x | +
+ ms = 100,+ |
+ ||
| 262 | +4x | +
+ expr = {
+ |
+ ||
| 263 | +! | +
+ shinyjs::toggleElement(id = "reset", condition = length(private$state_history()) > 1L)+ |
+ ||
| 264 | +! | +
+ shinyjs::enable(id = "reset") |
||
| 403 | +265 |
-
+ } |
||
| 404 | +266 |
- # private methods ----+ ) |
||
| 405 | +267 |
-
+ } |
||
| 406 | +268 |
- # setters for state features ----+ ) |
||
| 407 | +269 | |||
| 270 | +12x | +
+ private$destroy_shiny <- function() {
+ |
+ ||
| 271 | +8x | +
+ logger::log_trace("Destroying FilterState inputs and observers; id: { private$get_id() }")
+ |
+ ||
| 408 | +272 |
- # @description+ # remove values from the input list+ |
+ ||
| 273 | +8x | +
+ lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) |
||
| 409 | +274 |
- # Set values that can be selected from.+ |
||
| 410 | +275 |
- set_choices = function(choices) {
+ # remove observers |
||
| 411 | -! | +|||
| 276 | +8x |
- stop("this is a virtual method")
+ lapply(private$observers, function(x) x$destroy()) |
||
| 412 | +277 |
- },+ } |
||
| 413 | +278 | |||
| 279 | +12x | +
+ reactive(input$remove)+ |
+ ||
| 414 | +280 |
- # @description+ } |
||
| 415 | +281 |
- # Set selection.+ ) |
||
| 416 | +282 |
- #+ }, |
||
| 417 | +283 |
- # @param value (`vector`)+ |
||
| 418 | +284 |
- # value(s) that come from filter selection; values are set in the+ #' @description |
||
| 419 | +285 |
- # module server after a selection is made in the app interface;+ #' `shiny` UI module. |
||
| 420 | +286 |
- # values are stored in `teal_slice$selected` which is reactive;+ #' The UI for this class contains simple message stating that it is not supported. |
||
| 421 | +287 |
- # value types have to be the same as `private$get_choices()`+ #' @param id (`character(1)`) |
||
| 422 | +288 |
- #+ #' `shiny` module instance id. |
||
| 423 | +289 |
- # @return `NULL`, invisibly.+ #' @param parent_id (`character(1)`) id of the `FilterStates` card container |
||
| 424 | +290 |
- set_selected = function(value) {
+ ui = function(id, parent_id = "cards") {
|
||
| 425 | -420x | +291 | +12x |
- logger::log_trace(+ ns <- NS(id) |
| 426 | -420x | +|||
| 292 | +
- sprintf(+ |
|||
| 427 | -420x | +|||
| 293 | +
- "%s$set_selected setting selection of id: %s",+ # Filter card consists of header and body, arranged in a single column. |
|||
| 428 | -420x | +|||
| 294 | +
- class(self)[1],+ # Body is hidden and is toggled by clicking on header. |
|||
| 429 | -420x | +|||
| 295 | +
- private$get_id()+ ## Header consists of title and summary, arranged in a column. |
|||
| 430 | +296 |
- )+ ### Title consists of conditional icon, varname, conditional varlabel, and controls, arranged in a row. |
||
| 431 | +297 |
- )+ ### Summary consists of value and controls, arranged in a row. |
||
| 432 | -420x | +|||
| 298 | +
- isolate({
+
|
|||
| 433 | -420x | +299 | +12x |
- value <- private$cast_and_validate(value)+ tags$div( |
| 434 | -409x | +300 | +12x |
- value <- private$check_length(value)+ id = id, |
| 435 | -403x | +301 | +12x |
- value <- private$remove_out_of_bounds_values(value)+ class = "panel filter-card", |
| 436 | -403x | +302 | +12x |
- private$teal_slice$selected <- value+ include_js_files("count-bar-labels.js"),
|
| 437 | -+ | |||
| 303 | +12x |
- })+ tags$div( |
||
| 438 | -403x | +304 | +12x |
- logger::log_trace(+ class = "filter-card-header", |
| 439 | -403x | +305 | +12x |
- sprintf(+ `data-toggle` = "collapse", |
| 440 | -403x | +306 | +12x |
- "%s$set_selected selection of id: %s",+ `data-bs-toggle` = "collapse", |
| 441 | -403x | +307 | +12x |
- class(self)[1],+ href = paste0("#", ns("body")),
|
| 442 | -403x | +308 | +12x |
- private$get_id()+ tags$div( |
| 443 | -+ | |||
| 309 | +12x |
- )+ class = "filter-card-title", |
||
| 444 | -+ | |||
| 310 | +12x |
- )+ if (private$is_anchored() && private$is_fixed()) {
|
||
| 445 | -+ | |||
| 311 | +! |
-
+ icon("anchor-lock", class = "filter-card-icon")
|
||
| 446 | -403x | +312 | +12x |
- invisible(NULL)+ } else if (private$is_anchored() && !private$is_fixed()) {
|
| 447 | -+ | |||
| 313 | +! |
- },+ icon("anchor", class = "filter-card-icon")
|
||
| 448 | -+ | |||
| 314 | +12x |
-
+ } else if (!private$is_anchored() && private$is_fixed()) {
|
||
| 449 | -+ | |||
| 315 | +! |
- # @description+ icon("lock", class = "filter-card-icon")
|
||
| 450 | +316 |
- # Sets `value` in `private$teal_slice$keep_na`.+ }, |
||
| 451 | -+ | |||
| 317 | +12x |
- #+ tags$div(class = "filter-card-varname", tags$strong(private$get_varname())), |
||
| 452 | -+ | |||
| 318 | +12x |
- # @param value (`logical(1)`)+ tags$div(class = "filter-card-varlabel", private$get_varlabel()), |
||
| 453 | -+ | |||
| 319 | +12x |
- # corresponding to the state of a checkbox input in the `shiny` interface.+ tags$div( |
||
| 454 | -+ | |||
| 320 | +12x |
- #+ class = "filter-card-controls", |
||
| 455 | +321 |
- # @return `NULL`, invisibly.+ # Suppress toggling body when clicking on this div. |
||
| 456 | +322 |
- #+ # This is for bootstrap 3 and 4. Causes page to scroll to top, prevented by setting href on buttons.+ |
+ ||
| 323 | +12x | +
+ onclick = "event.stopPropagation();event.preventDefault();", |
||
| 457 | +324 |
- set_keep_na = function(value) {
+ # This is for bootstrap 5. |
||
| 458 | -16x | +325 | +12x |
- checkmate::assert_flag(value)+ `data-bs-toggle` = "collapse", |
| 459 | -16x | +326 | +12x |
- private$teal_slice$keep_na <- value+ `data-bs-target` = NULL, |
| 460 | -16x | +327 | +12x |
- logger::log_trace(+ if (isFALSE(private$is_fixed())) {
|
| 461 | -16x | +328 | +12x |
- sprintf(+ actionLink( |
| 462 | -16x | +329 | +12x |
- "%s$set_keep_na set for filter %s to %s.",+ inputId = ns("back"),
|
| 463 | -16x | +330 | +12x |
- class(self)[1],+ label = NULL, |
| 464 | -16x | +331 | +12x |
- private$get_id(),+ icon = icon("circle-arrow-left", lib = "font-awesome"),
|
| 465 | -16x | -
- value- |
- ||
| 466 | -+ | 332 | +12x |
- )+ title = "Rewind state", |
| 467 | -+ | |||
| 333 | +12x |
- )+ class = "filter-card-back", |
||
| 468 | -16x | +334 | +12x |
- invisible(NULL)+ style = "display: none" |
| 469 | +335 |
- },+ ) |
||
| 470 | +336 |
-
+ }, |
||
| 471 | -+ | |||
| 337 | +12x |
- # @description+ if (isFALSE(private$is_fixed())) {
|
||
| 472 | -+ | |||
| 338 | +12x |
- # Sets `value` in `private$teal_slice$keep_inf`.+ actionLink( |
||
| 473 | -+ | |||
| 339 | +12x |
- #+ inputId = ns("reset"),
|
||
| 474 | -+ | |||
| 340 | +12x |
- # @param value (`logical(1)`)+ label = NULL, |
||
| 475 | -+ | |||
| 341 | +12x |
- # corresponding to the state of a checkbox input in the `shiny` interface.+ icon = icon("circle-arrow-up", lib = "font-awesome"),
|
||
| 476 | -+ | |||
| 342 | +12x |
- #+ title = "Restore original state", |
||
| 477 | -+ | |||
| 343 | +12x |
- # @return `NULL`, invisibly.+ class = "filter-card-back", |
||
| 478 | -+ | |||
| 344 | +12x |
- #+ style = "display: none" |
||
| 479 | +345 |
- set_keep_inf = function(value) {
+ ) |
||
| 480 | -9x | +|||
| 346 | +
- checkmate::assert_flag(value)+ }, |
|||
| 481 | -9x | +347 | +12x |
- private$teal_slice$keep_inf <- value+ if (isFALSE(private$is_anchored())) {
|
| 482 | -9x | +348 | +12x |
- logger::log_trace(+ actionLink( |
| 483 | -9x | +349 | +12x |
- sprintf(+ inputId = ns("remove"),
|
| 484 | -9x | +350 | +12x |
- "%s$set_keep_inf of filter %s set to %s",+ label = icon("circle-xmark", lib = "font-awesome"),
|
| 485 | -9x | +351 | +12x |
- class(self)[1],+ title = "Remove filter", |
| 486 | -9x | +352 | +12x |
- private$get_id(),+ class = "filter-card-remove" |
| 487 | -9x | +|||
| 353 | +
- value+ ) |
|||
| 488 | +354 |
- )+ } |
||
| 489 | +355 |
- )+ ) |
||
| 490 | +356 |
-
+ ), |
||
| 491 | -9x | +357 | +12x |
- invisible(NULL)+ tags$div(class = "filter-card-summary", private$ui_summary(ns("summary")))
|
| 492 | +358 |
- },+ ), |
||
| 493 | -+ | |||
| 359 | +12x |
-
+ tags$div( |
||
| 494 | -+ | |||
| 360 | +12x |
- # getters for state features ----+ id = ns("body"),
|
||
| 495 | -+ | |||
| 361 | +12x |
-
+ class = "collapse out", |
||
| 496 | -+ | |||
| 362 | +12x |
- # @description+ `data-parent` = paste0("#", parent_id),
|
||
| 497 | -+ | |||
| 363 | +12x |
- # Returns dataname.+ `data-bs-parent` = paste0("#", parent_id),
|
||
| 498 | -+ | |||
| 364 | +12x |
- # @return `character(1)`+ tags$div( |
||
| 499 | -+ | |||
| 365 | +12x |
- get_dataname = function() {
+ class = "filter-card-body", |
||
| 500 | -87x | +366 | +12x |
- isolate(private$teal_slice$dataname)+ if (private$is_fixed()) {
|
| 501 | -+ | |||
| 367 | +! |
- },+ private$ui_inputs_fixed(ns("inputs"))
|
||
| 502 | +368 |
-
+ } else {
|
||
| 503 | -+ | |||
| 369 | +12x |
- # @description+ private$ui_inputs(ns("inputs"))
|
||
| 504 | +370 |
- # Get variable name.+ } |
||
| 505 | +371 |
- # @return `character(1)`+ ) |
||
| 506 | +372 |
- get_varname = function() {
+ ) |
||
| 507 | -165x | +|||
| 373 | +
- isolate(private$teal_slice$varname)+ ) |
|||
| 508 | +374 |
}, |
||
| 509 | +375 | |||
| 510 | +376 |
- # @description+ #' @description |
||
| 511 | +377 |
- # Get id of the teal_slice.+ #' Destroy observers stored in `private$observers`. |
||
| 512 | +378 |
- # @return `character(1)`+ #' |
||
| 513 | +379 |
- get_id = function() {
+ #' @return `NULL`, invisibly. |
||
| 514 | -4x | +|||
| 380 | +
- isolate(private$teal_slice$id)+ #' |
|||
| 515 | +381 |
- },+ destroy_observers = function() {
|
||
| 516 | -+ | |||
| 382 | +47x |
-
+ if (!is.null(private$destroy_shiny)) {
+ |
+ ||
| 383 | +8x | +
+ private$destroy_shiny() |
||
| 517 | +384 |
- # @description+ } |
||
| 518 | +385 |
- # Get allowed values from `FilterState`.+ } |
||
| 519 | +386 |
- # @return+ ), |
||
| 520 | +387 |
- # Vector describing the available choices. Return type depends on the `FilterState` subclass.+ |
||
| 521 | +388 |
- get_choices = function() {
+ # private members ---- |
||
| 522 | -882x | +|||
| 389 | +
- isolate(private$teal_slice$choices)+ private = list( |
|||
| 523 | +390 |
- },+ # set by constructor |
||
| 524 | +391 |
-
+ x = NULL, # the filtered variable |
||
| 525 | +392 |
- # @description+ x_reactive = NULL, # reactive containing the filtered variable, used for updating counts and histograms |
||
| 526 | +393 |
- # Get selected values from `FilterState`.+ teal_slice = NULL, # stores all transferable properties of this filter state |
||
| 527 | +394 |
- # @return+ extract_type = character(0), # used by private$get_varname_prefixed |
||
| 528 | +395 |
- # Vector describing the current selection. Return type depends on the `FilterState` subclass.+ na_count = integer(0), |
||
| 529 | +396 |
- get_selected = function() {
+ filtered_na_count = NULL, # reactive containing the count of NA in the filtered dataset |
||
| 530 | -363x | +|||
| 397 | +
- private$teal_slice$selected+ varlabel = character(0), # taken from variable labels in data; displayed in filter cards |
|||
| 531 | +398 |
- },+ destroy_shiny = NULL, # function is set in server |
||
| 532 | +399 |
-
+ # other |
||
| 533 | +400 |
- # @description+ is_choice_limited = FALSE, # flag whether number of possible choices was limited when specifying filter |
||
| 534 | +401 |
- # Returns current `keep_na` selection.+ observers = list(), # stores observers |
||
| 535 | +402 |
- # @return `logical(1)`+ state_history = NULL, # reactiveVal holding a list storing states this FilterState has had since instantiation |
||
| 536 | +403 |
- get_keep_na = function() {
+
|
||
| 537 | -129x | +|||
| 404 | +
- private$teal_slice$keep_na+ # private methods ---- |
|||
| 538 | +405 |
- },+ |
||
| 539 | +406 |
-
+ # setters for state features ---- |
||
| 540 | +407 |
- # @description+ |
||
| 541 | +408 |
- # Returns current `keep_inf` selection.+ # @description |
||
| 542 | +409 |
- # @return (`logical(1)`)+ # Set values that can be selected from. |
||
| 543 | +410 |
- get_keep_inf = function() {
+ set_choices = function(choices) {
|
||
| 544 | -117x | +|||
| 411 | +! |
- private$teal_slice$keep_inf+ stop("this is a virtual method")
|
||
| 545 | +412 |
}, |
||
| 546 | +413 | |||
| 547 | +414 |
- # Check whether this filter is fixed (cannot be changed).+ # @description |
||
| 548 | +415 |
- # @return `logical(1)`+ # Set selection. |
||
| 549 | +416 |
- is_fixed = function() {
+ # |
||
| 550 | -148x | +|||
| 417 | +
- isolate(isTRUE(private$teal_slice$fixed))+ # @param value (`vector`) |
|||
| 551 | +418 |
- },+ # value(s) that come from filter selection; values are set in the |
||
| 552 | +419 |
-
+ # module server after a selection is made in the app interface; |
||
| 553 | +420 |
- # Check whether this filter is anchored (cannot be removed).+ # values are stored in `teal_slice$selected` which is reactive; |
||
| 554 | +421 |
- # @return `logical(1)`+ # value types have to be the same as `private$get_choices()` |
||
| 555 | +422 |
- is_anchored = function() {
+ # |
||
| 556 | -48x | +|||
| 423 | +
- isolate(isTRUE(private$teal_slice$anchored))+ # @return `NULL`, invisibly. |
|||
| 557 | +424 |
- },+ set_selected = function(value) {
|
||
| 558 | -+ | |||
| 425 | +421x |
-
+ logger::log_trace( |
||
| 559 | -+ | |||
| 426 | +421x |
- # Check whether this filter is capable of selecting multiple values.+ sprintf(+ |
+ ||
| 427 | +421x | +
+ "%s$set_selected setting selection of id: %s",+ |
+ ||
| 428 | +421x | +
+ class(self)[1],+ |
+ ||
| 429 | +421x | +
+ private$get_id() |
||
| 560 | +430 |
- # @return `logical(1)`+ ) |
||
| 561 | +431 |
- is_multiple = function() {
+ ) |
||
| 562 | -217x | +432 | +421x |
- isolate(isTRUE(private$teal_slice$multiple))+ isolate({
+ |
+
| 433 | +421x | +
+ value <- private$cast_and_validate(value)+ |
+ ||
| 434 | +410x | +
+ value <- private$check_length(value)+ |
+ ||
| 435 | +404x | +
+ value <- private$remove_out_of_bounds_values(value)+ |
+ ||
| 436 | +404x | +
+ private$teal_slice$selected <- value |
||
| 563 | +437 |
- },+ })+ |
+ ||
| 438 | +404x | +
+ logger::log_trace(+ |
+ ||
| 439 | +404x | +
+ sprintf(+ |
+ ||
| 440 | +404x | +
+ "%s$set_selected selection of id: %s",+ |
+ ||
| 441 | +404x | +
+ class(self)[1],+ |
+ ||
| 442 | +404x | +
+ private$get_id() |
||
| 564 | +443 |
-
+ ) |
||
| 565 | +444 |
- # other ----+ ) |
||
| 566 | +445 | |||
| 446 | +404x | +
+ invisible(NULL)+ |
+ ||
| 567 | +447 |
- # @description+ }, |
||
| 568 | +448 |
- # Returns variable label.+ |
||
| 569 | +449 |
- # @return `character(1)`+ # @description |
||
| 570 | +450 |
- get_varlabel = function() {
+ # Sets `value` in `private$teal_slice$keep_na`. |
||
| 571 | -12x | +|||
| 451 | +
- private$varlabel+ # |
|||
| 572 | +452 |
- },+ # @param value (`logical(1)`) |
||
| 573 | +453 |
-
+ # corresponding to the state of a checkbox input in the `shiny` interface. |
||
| 574 | +454 |
- # @description+ # |
||
| 575 | +455 |
- # Return variable name prefixed by `dataname` to be evaluated as extracted object, for example `data$var`+ # @return `NULL`, invisibly. |
||
| 576 | +456 |
- # @return Call that extracts the variable from the dataset.+ # |
||
| 577 | +457 |
- get_varname_prefixed = function(dataname) {
+ set_keep_na = function(value) {
|
||
| 578 | -108x | +458 | +16x |
- varname <- private$get_varname()+ checkmate::assert_flag(value) |
| 579 | -108x | +459 | +16x |
- varname_backticked <- sprintf("`%s`", varname)
+ private$teal_slice$keep_na <- value |
| 580 | -108x | +460 | +16x |
- ans <-+ logger::log_trace( |
| 581 | -108x | +461 | +16x |
- if (isTRUE(private$extract_type == "list")) {
+ sprintf( |
| 582 | +462 | 16x |
- sprintf("%s$%s", dataname, varname_backticked)
+ "%s$set_keep_na set for filter %s to %s.", |
|
| 583 | -108x | +463 | +16x |
- } else if (isTRUE(private$extract_type == "matrix")) {
+ class(self)[1], |
| 584 | -7x | +464 | +16x |
- sprintf("%s[, \"%s\"]", dataname, varname)
+ private$get_id(), |
| 585 | -+ | |||
| 465 | +16x |
- } else {
+ value |
||
| 586 | -85x | +|||
| 466 | +
- varname_backticked+ ) |
|||
| 587 | +467 |
- }+ ) |
||
| 588 | -108x | +468 | +16x |
- str2lang(ans)+ invisible(NULL) |
| 589 | +469 |
}, |
||
| 590 | +470 | |||
| 591 | +471 |
# @description |
||
| 592 | +472 |
- # Adds `is.na(varname)` moiety to the existing condition call, according to `keep_na` status.+ # Sets `value` in `private$teal_slice$keep_inf`. |
||
| 593 | +473 |
- # @param filter_call `call` raw filter call, as defined by selection+ # |
||
| 594 | +474 |
- # @param varname `character(1)` name of a variable+ # @param value (`logical(1)`) |
||
| 595 | +475 |
- # @return `call`+ # corresponding to the state of a checkbox input in the `shiny` interface. |
||
| 596 | +476 |
- add_keep_na_call = function(filter_call, varname) {
+ # |
||
| 597 | +477 |
- # No need to deal with NAs.+ # @return `NULL`, invisibly. |
||
| 598 | -107x | +|||
| 478 | +
- if (private$na_count == 0L) {
+ # |
|||
| 599 | -86x | +|||
| 479 | +
- return(filter_call)+ set_keep_inf = function(value) {
|
|||
| 600 | -+ | |||
| 480 | +9x |
- }+ checkmate::assert_flag(value) |
||
| 601 | -+ | |||
| 481 | +9x |
-
+ private$teal_slice$keep_inf <- value |
||
| 602 | -21x | +482 | +9x |
- if (is.null(filter_call) && isFALSE(private$get_keep_na())) {
+ logger::log_trace( |
| 603 | -2x | +483 | +9x |
- call("!", call("is.na", varname))
+ sprintf( |
| 604 | -19x | +484 | +9x |
- } else if (!is.null(filter_call) && isTRUE(private$get_keep_na())) {
+ "%s$set_keep_inf of filter %s set to %s", |
| 605 | -12x | +485 | +9x |
- call("|", call("is.na", varname), filter_call)
+ class(self)[1], |
| 606 | -7x | +486 | +9x |
- } else if (!is.null(filter_call) && isFALSE(private$get_keep_na())) {
+ private$get_id(), |
| 607 | -7x | +487 | +9x |
- call("&", call("!", call("is.na", varname)), filter_call)
+ value |
| 608 | +488 |
- }+ ) |
||
| 609 | +489 |
- },+ ) |
||
| 610 | +490 | |||
| 491 | +9x | +
+ invisible(NULL)+ |
+ ||
| 611 | +492 |
- # Converts values to the type fitting this `FilterState` and validates the conversion.+ }, |
||
| 612 | +493 |
- # Raises error if casting does not execute successfully.+ |
||
| 613 | +494 |
- #+ # getters for state features ---- |
||
| 614 | +495 |
- # @param values vector of values+ |
||
| 615 | +496 |
- #+ # @description |
||
| 616 | +497 |
- # @return vector converted to appropriate class+ # Returns dataname. |
||
| 617 | +498 |
- cast_and_validate = function(values) {
+ # @return `character(1)`+ |
+ ||
| 499 | ++ |
+ get_dataname = function() {
|
||
| 618 | -11x | +500 | +88x |
- values+ isolate(private$teal_slice$dataname) |
| 619 | +501 |
}, |
||
| 620 | +502 | |||
| 621 | +503 |
- # Checks length of selection.+ # @description |
||
| 622 | +504 |
- check_length = function(values) {
+ # Get variable name. |
||
| 623 | -11x | +|||
| 505 | +
- values+ # @return `character(1)` |
|||
| 624 | +506 |
- },+ get_varname = function() {
|
||
| 625 | -+ | |||
| 507 | +166x |
-
+ isolate(private$teal_slice$varname) |
||
| 626 | +508 |
- # Filters out erroneous values from vector.+ }, |
||
| 627 | +509 |
- #+ |
||
| 628 | +510 |
- # @param values vector of values+ # @description |
||
| 629 | +511 |
- #+ # Get id of the teal_slice. |
||
| 630 | +512 |
- # @return vector in which values that cannot be set in this FilterState have been dropped+ # @return `character(1)` |
||
| 631 | +513 |
- remove_out_of_bounds_values = function(values) {
+ get_id = function() {
|
||
| 632 | -31x | +514 | +4x |
- values+ isolate(private$teal_slice$id) |
| 633 | +515 |
}, |
||
| 634 | +516 | |||
| 635 | +517 |
- # Checks if the selection is valid in terms of class and length.+ # @description |
||
| 636 | +518 |
- # It should not return anything but raise an error if selection+ # Get allowed values from `FilterState`. |
||
| 637 | +519 |
- # has a wrong class or is outside of possible choices+ # @return |
||
| 638 | +520 |
- validate_selection = function(value) {
+ # Vector describing the available choices. Return type depends on the `FilterState` subclass. |
||
| 639 | -! | +|||
| 521 | +
- invisible(NULL)+ get_choices = function() {
+ |
+ |||
| 522 | +930x | +
+ isolate(private$teal_slice$choices) |
||
| 640 | +523 |
}, |
||
| 641 | +524 | |||
| 642 | +525 |
# @description |
||
| 643 | +526 |
- # Checks whether the current settings actually cause any values to be omitted.+ # Get selected values from `FilterState`. |
||
| 644 | +527 |
- # @return logical scalar+ # @return |
||
| 645 | +528 |
- is_any_filtered = function() {
+ # Vector describing the current selection. Return type depends on the `FilterState` subclass. |
||
| 646 | -74x | +|||
| 529 | +
- if (private$is_choice_limited) {
+ get_selected = function() {
|
|||
| 647 | -3x | +530 | +362x |
- TRUE+ private$teal_slice$selected |
| 648 | -71x | +|||
| 531 | +
- } else if (!setequal(private$get_selected(), private$get_choices())) {
+ }, |
|||
| 649 | -58x | +|||
| 532 | +
- TRUE+ |
|||
| 650 | -13x | +|||
| 533 | +
- } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ # @description |
|||
| 651 | -4x | +|||
| 534 | +
- TRUE+ # Returns current `keep_na` selection. |
|||
| 652 | +535 |
- } else {
+ # @return `logical(1)` |
||
| 653 | -9x | +|||
| 536 | +
- FALSE+ get_keep_na = function() {
|
|||
| 654 | -+ | |||
| 537 | +129x |
- }+ private$teal_slice$keep_na |
||
| 655 | +538 |
}, |
||
| 656 | +539 | |||
| 657 | +540 |
- # shiny modules -----+ # @description |
||
| 658 | +541 |
-
+ # Returns current `keep_inf` selection. |
||
| 659 | +542 |
- # @description+ # @return (`logical(1)`) |
||
| 660 | +543 |
- # Server module to display filter summary+ get_keep_inf = function() {
|
||
| 661 | -+ | |||
| 544 | +117x |
- # @param id (`character(1)`) `shiny` module instance id.+ private$teal_slice$keep_inf |
||
| 662 | +545 |
- ui_summary = function(id) {
+ }, |
||
| 663 | -12x | +|||
| 546 | +
- ns <- NS(id)+ |
|||
| 664 | -12x | +|||
| 547 | +
- uiOutput(ns("summary"), class = "filter-card-summary")
+ # Check whether this filter is fixed (cannot be changed). |
|||
| 665 | +548 |
- },+ # @return `logical(1)` |
||
| 666 | +549 |
-
+ is_fixed = function() {
+ |
+ ||
| 550 | +148x | +
+ isolate(isTRUE(private$teal_slice$fixed)) |
||
| 667 | +551 |
- # @description+ }, |
||
| 668 | +552 |
- # UI module to display filter summary+ |
||
| 669 | +553 |
- # @param id (`character(1)`) `shiny` module instance id.+ # Check whether this filter is anchored (cannot be removed). |
||
| 670 | +554 |
- # @return Nothing. Renders the UI.+ # @return `logical(1)` |
||
| 671 | +555 |
- server_summary = function(id) {
+ is_anchored = function() {
|
||
| 672 | -12x | +556 | +48x |
- moduleServer(+ isolate(isTRUE(private$teal_slice$anchored)) |
| 673 | -12x | +|||
| 557 | +
- id = id,+ }, |
|||
| 674 | -12x | +|||
| 558 | +
- function(input, output, session) {
+
|
|||
| 675 | -12x | +|||
| 559 | +
- output$summary <- renderUI(private$content_summary())+ # Check whether this filter is capable of selecting multiple values. |
|||
| 676 | +560 |
- }+ # @return `logical(1)` |
||
| 677 | +561 |
- )+ is_multiple = function() {
+ |
+ ||
| 562 | +218x | +
+ isolate(isTRUE(private$teal_slice$multiple)) |
||
| 678 | +563 |
}, |
||
| 679 | +564 | |||
| 680 | +565 |
- # module with inputs+ # other ---- |
||
| 681 | +566 |
- ui_inputs = function(id) {
+
|
||
| 682 | -! | +|||
| 567 | +
- stop("abstract class")
+ # @description |
|||
| 683 | +568 |
- },+ # Returns variable label. |
||
| 684 | +569 |
- # module with inputs+ # @return `character(1)` |
||
| 685 | +570 |
- server_inputs = function(id) {
+ get_varlabel = function() {
|
||
| 686 | -! | +|||
| 571 | +12x |
- stop("abstract class")
+ private$varlabel |
||
| 687 | +572 |
}, |
||
| 688 | +573 | |||
| 689 | +574 |
# @description |
||
| 690 | +575 |
- # Module displaying inputs in a fixed filter state.+ # Return variable name prefixed by `dataname` to be evaluated as extracted object, for example `data$var` |
||
| 691 | +576 |
- # There are no input widgets, only selection visualizations.+ # @return Call that extracts the variable from the dataset. |
||
| 692 | +577 |
- # @param id (`character(1)`) `shiny` module instance id.+ get_varname_prefixed = function(dataname) {
|
||
| 693 | -+ | |||
| 578 | +109x |
- ui_inputs_fixed = function(id) {
+ varname <- private$get_varname() |
||
| 694 | -! | +|||
| 579 | +109x |
- ns <- NS(id)+ varname_backticked <- sprintf("`%s`", varname)
|
||
| 695 | -! | +|||
| 580 | +109x |
- tags$div(+ ans <- |
||
| 696 | -! | +|||
| 581 | +109x |
- class = "choices_state",+ if (isTRUE(private$extract_type == "list")) {
|
||
| 697 | -! | +|||
| 582 | +16x |
- uiOutput(ns("selection"))
+ sprintf("%s$%s", dataname, varname_backticked)
|
||
| 698 | -+ | |||
| 583 | +109x |
- )+ } else if (isTRUE(private$extract_type == "matrix")) {
|
||
| 699 | -+ | |||
| 584 | +7x |
- },+ sprintf("%s[, \"%s\"]", dataname, varname)
|
||
| 700 | +585 |
-
+ } else {
|
||
| 701 | -+ | |||
| 586 | +86x |
- # @description+ varname_backticked |
||
| 702 | +587 |
- # Module creating the display of a fixed filter state.+ } |
||
| 703 | -+ | |||
| 588 | +109x |
- # @param id (`character(1)`) `shiny` module instance id.+ str2lang(ans) |
||
| 704 | +589 |
- server_inputs_fixed = function(id) {
+ }, |
||
| 705 | -! | +|||
| 590 | +
- stop("abstract class")
+
|
|||
| 706 | +591 |
- },+ # @description |
||
| 707 | +592 |
-
+ # Adds `is.na(varname)` moiety to the existing condition call, according to `keep_na` status. |
||
| 708 | +593 |
- # @description+ # @param filter_call `call` raw filter call, as defined by selection |
||
| 709 | +594 |
- # Module UI function displaying input to keep or remove NA in the `FilterState` call.+ # @param varname `character(1)` name of a variable |
||
| 710 | +595 |
- # Renders a checkbox input only when variable with which `FilterState` has been created contains NAs.+ # @return `call` |
||
| 711 | +596 |
- # @param id (`character(1)`) `shiny` module instance id.+ add_keep_na_call = function(filter_call, varname) {
|
||
| 712 | +597 |
- keep_na_ui = function(id) {
+ # No need to deal with NAs. |
||
| 713 | -12x | +598 | +108x |
- ns <- NS(id)+ if (private$na_count == 0L) {
|
| 714 | -12x | -
- if (private$na_count > 0) {
- |
- ||
| 715 | -! | -
- isolate({
- |
- ||
| 716 | -! | -
- countmax <- private$na_count- |
- ||
| 717 | -! | +599 | +87x |
- countnow <- private$filtered_na_count()+ return(filter_call) |
| 718 | -! | +|||
| 600 | +
- ui_input <- checkboxInput(+ } |
|||
| 719 | -! | +|||
| 601 | +
- inputId = ns("value"),
+
|
|||
| 720 | -! | +|||
| 602 | +21x |
- label = tags$span(+ if (is.null(filter_call) && isFALSE(private$get_keep_na())) {
|
||
| 721 | -! | +|||
| 603 | +2x |
- id = ns("count_label"),
+ call("!", call("is.na", varname))
|
||
| 722 | -! | +|||
| 604 | +19x |
- make_count_text(+ } else if (!is.null(filter_call) && isTRUE(private$get_keep_na())) {
|
||
| 723 | -! | +|||
| 605 | +12x |
- label = "Keep NA",+ call("|", call("is.na", varname), filter_call)
|
||
| 724 | -! | +|||
| 606 | +7x |
- countmax = countmax,+ } else if (!is.null(filter_call) && isFALSE(private$get_keep_na())) {
|
||
| 725 | -! | +|||
| 607 | +7x |
- countnow = countnow+ call("&", call("!", call("is.na", varname)), filter_call)
|
||
| 726 | +608 |
- )+ } |
||
| 727 | +609 |
- ),+ }, |
||
| 728 | -! | +|||
| 610 | +
- value = private$get_keep_na()+ |
|||
| 729 | +611 |
- )+ # Converts values to the type fitting this `FilterState` and validates the conversion. |
||
| 730 | -! | +|||
| 612 | +
- tags$div(+ # Raises error if casting does not execute successfully. |
|||
| 731 | -! | +|||
| 613 | +
- uiOutput(ns("trigger_visible"), inline = TRUE),
+ # |
|||
| 732 | -! | +|||
| 614 | +
- ui_input+ # @param values vector of values |
|||
| 733 | +615 |
- )+ # |
||
| 734 | +616 |
- })+ # @return vector converted to appropriate class |
||
| 735 | +617 |
- } else {
+ cast_and_validate = function(values) {
|
||
| 736 | -12x | -
- NULL- |
- ||
| 737 | -+ | 618 | +11x |
- }+ values |
| 738 | +619 |
}, |
||
| 739 | +620 | |||
| 740 | +621 |
- # @description+ # Checks length of selection. |
||
| 741 | +622 |
- # Module server function to handle NA values in the `FilterState`.+ check_length = function(values) {
|
||
| 742 | -+ | |||
| 623 | +11x |
- # Sets `private$slice$keep_na` according to the selection+ values |
||
| 743 | +624 |
- # and updates the relevant UI element if `private$slice$keep_na` has been changed by the api.+ }, |
||
| 744 | +625 |
- # @param id (`character(1)`) `shiny` module instance id.+ |
||
| 745 | +626 |
- # @return `NULL`, invisibly.+ # Filters out erroneous values from vector. |
||
| 746 | +627 |
- keep_na_srv = function(id) {
+ # |
||
| 747 | -12x | +|||
| 628 | +
- moduleServer(id, function(input, output, session) {
+ # @param values vector of values |
|||
| 748 | +629 |
- # 1. renderUI is used here as an observer which triggers only if output is visible+ # |
||
| 749 | +630 |
- # and if the reactive changes - reactive triggers only if the output is visible.+ # @return vector in which values that cannot be set in this FilterState have been dropped |
||
| 750 | +631 |
- # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)+ remove_out_of_bounds_values = function(values) {
|
||
| 751 | -12x | +632 | +31x |
- output$trigger_visible <- renderUI({
+ values |
| 752 | -12x | +|||
| 633 | +
- updateCountText(+ }, |
|||
| 753 | -12x | +|||
| 634 | +
- inputId = "count_label",+ |
|||
| 754 | -12x | +|||
| 635 | +
- label = "Keep NA",+ # Checks if the selection is valid in terms of class and length. |
|||
| 755 | -12x | +|||
| 636 | +
- countmax = private$na_count,+ # It should not return anything but raise an error if selection |
|||
| 756 | -12x | +|||
| 637 | +
- countnow = private$filtered_na_count()+ # has a wrong class or is outside of possible choices |
|||
| 757 | +638 |
- )+ validate_selection = function(value) {
|
||
| 758 | -12x | +|||
| 639 | +! |
- NULL+ invisible(NULL) |
||
| 759 | +640 |
- })+ }, |
||
| 760 | +641 | |||
| 761 | +642 |
- # this observer is needed in the situation when private$keep_inf has been+ # @description |
||
| 762 | +643 |
- # changed directly by the api - then it's needed to rerender UI element+ # Checks whether the current settings actually cause any values to be omitted. |
||
| 763 | +644 |
- # to show relevant values+ # @return logical scalar |
||
| 764 | -12x | +|||
| 645 | +
- private$observers$keep_na_api <- observeEvent(+ is_any_filtered = function() {
|
|||
| 765 | -12x | +646 | +75x |
- ignoreNULL = FALSE, # nothing selected is possible for NA+ if (private$is_choice_limited) {
|
| 766 | -12x | +647 | +6x |
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ TRUE |
| 767 | -12x | +648 | +69x |
- eventExpr = private$get_keep_na(),+ } else if (!setequal(private$get_selected(), private$get_choices())) {
|
| 768 | -12x | +649 | +56x |
- handlerExpr = {
+ TRUE |
| 769 | -! | +|||
| 650 | +13x |
- if (!setequal(private$get_keep_na(), input$value)) {
+ } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
|
||
| 770 | -! | +|||
| 651 | +4x |
- logger::log_trace("FilterState$keep_na_srv@1 changed reactive value, id: { private$get_id() }")
+ TRUE |
||
| 771 | -! | +|||
| 652 | +
- updateCheckboxInput(+ } else {
|
|||
| 772 | -! | +|||
| 653 | +9x |
- inputId = "value",+ FALSE |
||
| 773 | -! | +|||
| 654 | +
- label = sprintf("Keep NA (%s/%s)", private$filtered_na_count(), private$na_count),
+ } |
|||
| 774 | -! | +|||
| 655 | +
- value = private$get_keep_na()+ }, |
|||
| 775 | +656 |
- )+ |
||
| 776 | +657 |
- }+ # shiny modules ----- |
||
| 777 | +658 |
- }+ |
||
| 778 | +659 |
- )+ # @description |
||
| 779 | -12x | +|||
| 660 | +
- private$observers$keep_na <- observeEvent(+ # Server module to display filter summary |
|||
| 780 | -12x | +|||
| 661 | +
- ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput`+ # @param id (`character(1)`) `shiny` module instance id. |
|||
| 781 | -12x | +|||
| 662 | +
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ ui_summary = function(id) {
|
|||
| 782 | +663 | 12x |
- eventExpr = input$value,+ ns <- NS(id) |
|
| 783 | +664 | 12x |
- handlerExpr = {
- |
- |
| 784 | -! | -
- logger::log_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
+ uiOutput(ns("summary"), class = "filter-card-summary")
|
||
| 785 | -! | +|||
| 665 | +
- keep_na <- if (is.null(input$value)) {
+ }, |
|||
| 786 | -! | +|||
| 666 | +
- FALSE+ |
|||
| 787 | +667 |
- } else {
+ # @description |
||
| 788 | -! | +|||
| 668 | +
- input$value+ # UI module to display filter summary |
|||
| 789 | +669 |
- }+ # @param id (`character(1)`) `shiny` module instance id. |
||
| 790 | -! | +|||
| 670 | +
- private$set_keep_na(keep_na)+ # @return Nothing. Renders the UI. |
|||
| 791 | +671 |
- }+ server_summary = function(id) {
|
||
| 792 | -+ | |||
| 672 | +12x |
- )+ moduleServer( |
||
| 793 | +673 | 12x |
- invisible(NULL)+ id = id, |
|
| 794 | -+ | |||
| 674 | +12x |
- })+ function(input, output, session) {
|
||
| 795 | -+ | |||
| 675 | +12x |
- }+ output$summary <- renderUI(private$content_summary()) |
||
| 796 | +676 |
- )+ } |
||
| 797 | +677 |
- )+ ) |
| 1 | +678 |
- # DateFilterState ------+ }, |
|
| 2 | +679 | ||
| 3 | +680 |
- #' @name DateFilterState+ # module with inputs |
|
| 4 | +681 |
- #' @docType class+ ui_inputs = function(id) {
|
|
| 5 | -+ | ||
| 682 | +! |
- #'+ stop("abstract class")
|
|
| 6 | +683 |
- #' @title `FilterState` object for `Date` data+ }, |
|
| 7 | +684 |
- #'+ # module with inputs |
|
| 8 | +685 |
- #' @description Manages choosing a range of `Date`s.+ server_inputs = function(id) {
|
|
| 9 | -+ | ||
| 686 | +! |
- #'+ stop("abstract class")
|
|
| 10 | +687 |
- #' @examples+ }, |
|
| 11 | +688 |
- #' # use non-exported function from teal.slice+ |
|
| 12 | +689 |
- #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
+ # @description |
|
| 13 | +690 |
- #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
+ # Module displaying inputs in a fixed filter state. |
|
| 14 | +691 |
- #' DateFilterState <- getFromNamespace("DateFilterState", "teal.slice")
+ # There are no input widgets, only selection visualizations. |
|
| 15 | +692 |
- #'+ # @param id (`character(1)`) `shiny` module instance id. |
|
| 16 | +693 |
- #' library(shiny)+ ui_inputs_fixed = function(id) {
|
|
| 17 | -+ | ||
| 694 | +! |
- #'+ ns <- NS(id) |
|
| 18 | -+ | ||
| 695 | +! |
- #' filter_state <- DateFilterState$new(+ tags$div( |
|
| 19 | -+ | ||
| 696 | +! |
- #' x = c(Sys.Date() + seq(1:10), NA),+ class = "choices_state", |
|
| 20 | -+ | ||
| 697 | +! |
- #' slice = teal_slice(varname = "x", dataname = "data"),+ uiOutput(ns("selection"))
|
|
| 21 | +698 |
- #' extract_type = character(0)+ ) |
|
| 22 | +699 |
- #' )+ }, |
|
| 23 | +700 |
- #' isolate(filter_state$get_call())+ |
|
| 24 | +701 |
- #' filter_state$set_state(+ # @description |
|
| 25 | +702 |
- #' teal_slice(+ # Module creating the display of a fixed filter state. |
|
| 26 | +703 |
- #' dataname = "data",+ # @param id (`character(1)`) `shiny` module instance id. |
|
| 27 | +704 |
- #' varname = "x",+ server_inputs_fixed = function(id) {
|
|
| 28 | -+ | ||
| 705 | +! |
- #' selected = c(Sys.Date() + 3L, Sys.Date() + 8L),+ stop("abstract class")
|
|
| 29 | +706 |
- #' keep_na = TRUE+ }, |
|
| 30 | +707 |
- #' )+ |
|
| 31 | +708 |
- #' )+ # @description |
|
| 32 | +709 |
- #' isolate(filter_state$get_call())+ # Module UI function displaying input to keep or remove NA in the `FilterState` call. |
|
| 33 | +710 |
- #'+ # Renders a checkbox input only when variable with which `FilterState` has been created contains NAs. |
|
| 34 | +711 |
- #' # working filter in an app+ # @param id (`character(1)`) `shiny` module instance id. |
|
| 35 | +712 |
- #' library(shinyjs)+ keep_na_ui = function(id) {
|
|
| 36 | -+ | ||
| 713 | +12x |
- #'+ ns <- NS(id) |
|
| 37 | -+ | ||
| 714 | +12x |
- #' dates <- c(Sys.Date() - 100, Sys.Date())+ if (private$na_count > 0) {
|
|
| 38 | -+ | ||
| 715 | +! |
- #' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA)+ isolate({
|
|
| 39 | -+ | ||
| 716 | +! |
- #' fs <- DateFilterState$new(+ countmax <- private$na_count |
|
| 40 | -+ | ||
| 717 | +! |
- #' x = data_date,+ countnow <- private$filtered_na_count() |
|
| 41 | -+ | ||
| 718 | +! |
- #' slice = teal_slice(+ ui_input <- checkboxInput( |
|
| 42 | -+ | ||
| 719 | +! |
- #' dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE+ inputId = ns("value"),
|
|
| 43 | -+ | ||
| 720 | +! |
- #' )+ label = tags$span( |
|
| 44 | -+ | ||
| 721 | +! |
- #' )+ id = ns("count_label"),
|
|
| 45 | -+ | ||
| 722 | +! |
- #'+ make_count_text( |
|
| 46 | -+ | ||
| 723 | +! |
- #' ui <- fluidPage(+ label = "Keep NA", |
|
| 47 | -+ | ||
| 724 | +! |
- #' useShinyjs(),+ countmax = countmax, |
|
| 48 | -+ | ||
| 725 | +! |
- #' include_css_files(pattern = "filter-panel"),+ countnow = countnow |
|
| 49 | +726 |
- #' include_js_files(pattern = "count-bar-labels"),+ ) |
|
| 50 | +727 |
- #' column(4, tags$div(+ ), |
|
| 51 | -+ | ||
| 728 | +! |
- #' tags$h4("DateFilterState"),
+ value = private$get_keep_na() |
|
| 52 | +729 |
- #' fs$ui("fs")
+ ) |
|
| 53 | -+ | ||
| 730 | +! |
- #' )),+ tags$div( |
|
| 54 | -+ | ||
| 731 | +! |
- #' column(4, tags$div(+ uiOutput(ns("trigger_visible"), inline = TRUE),
|
|
| 55 | -+ | ||
| 732 | +! |
- #' id = "outputs", # div id is needed for toggling the element+ ui_input |
|
| 56 | +733 |
- #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
+ ) |
|
| 57 | +734 |
- #' textOutput("condition_date"), tags$br(),
+ }) |
|
| 58 | +735 |
- #' tags$h4("Unformatted state"), # display raw filter state
+ } else {
|
|
| 59 | -+ | ||
| 736 | +12x |
- #' textOutput("unformatted_date"), tags$br(),
+ NULL |
|
| 60 | +737 |
- #' tags$h4("Formatted state"), # display human readable filter state
+ } |
|
| 61 | +738 |
- #' textOutput("formatted_date"), tags$br()
+ }, |
|
| 62 | +739 |
- #' )),+ |
|
| 63 | +740 |
- #' column(4, tags$div(+ # @description |
|
| 64 | +741 |
- #' tags$h4("Programmatic filter control"),
+ # Module server function to handle NA values in the `FilterState`. |
|
| 65 | +742 |
- #' actionButton("button1_date", "set drop NA", width = "100%"), tags$br(),
+ # Sets `private$slice$keep_na` according to the selection |
|
| 66 | +743 |
- #' actionButton("button2_date", "set keep NA", width = "100%"), tags$br(),
+ # and updates the relevant UI element if `private$slice$keep_na` has been changed by the api. |
|
| 67 | +744 |
- #' actionButton("button3_date", "set a range", width = "100%"), tags$br(),
+ # @param id (`character(1)`) `shiny` module instance id. |
|
| 68 | +745 |
- #' actionButton("button4_date", "set full range", width = "100%"), tags$br(),
+ # @return `NULL`, invisibly. |
|
| 69 | +746 |
- #' actionButton("button0_date", "set initial state", width = "100%"), tags$br()
+ keep_na_srv = function(id) {
|
|
| 70 | -+ | ||
| 747 | +12x |
- #' ))+ moduleServer(id, function(input, output, session) {
|
|
| 71 | +748 |
- #' )+ # 1. renderUI is used here as an observer which triggers only if output is visible |
|
| 72 | +749 |
- #'+ # and if the reactive changes - reactive triggers only if the output is visible. |
|
| 73 | +750 |
- #' server <- function(input, output, session) {
+ # 2. We want to trigger change of the labels only if reactive count changes (not underlying data) |
|
| 74 | -+ | ||
| 751 | +12x |
- #' fs$server("fs")
+ output$trigger_visible <- renderUI({
|
|
| 75 | -+ | ||
| 752 | +12x |
- #' output$condition_date <- renderPrint(fs$get_call())+ updateCountText( |
|
| 76 | -+ | ||
| 753 | +12x |
- #' output$formatted_date <- renderText(fs$format())+ inputId = "count_label", |
|
| 77 | -+ | ||
| 754 | +12x |
- #' output$unformatted_date <- renderPrint(fs$get_state())+ label = "Keep NA", |
|
| 78 | -+ | ||
| 755 | +12x |
- #' # modify filter state programmatically+ countmax = private$na_count, |
|
| 79 | -+ | ||
| 756 | +12x |
- #' observeEvent(+ countnow = private$filtered_na_count() |
|
| 80 | +757 |
- #' input$button1_date,+ ) |
|
| 81 | -+ | ||
| 758 | +12x |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))+ NULL |
|
| 82 | +759 |
- #' )+ }) |
|
| 83 | +760 |
- #' observeEvent(+ |
|
| 84 | +761 |
- #' input$button2_date,+ # this observer is needed in the situation when private$keep_inf has been |
|
| 85 | +762 |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ # changed directly by the api - then it's needed to rerender UI element |
|
| 86 | +763 |
- #' )+ # to show relevant values |
|
| 87 | -+ | ||
| 764 | +12x |
- #' observeEvent(+ private$observers$keep_na_api <- observeEvent( |
|
| 88 | -+ | ||
| 765 | +12x |
- #' input$button3_date,+ ignoreNULL = FALSE, # nothing selected is possible for NA |
|
| 89 | -+ | ||
| 766 | +12x |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)]))+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
|
| 90 | -+ | ||
| 767 | +12x |
- #' )+ eventExpr = private$get_keep_na(), |
|
| 91 | -+ | ||
| 768 | +12x |
- #' observeEvent(+ handlerExpr = {
|
|
| 92 | -+ | ||
| 769 | +! |
- #' input$button4_date,+ if (!setequal(private$get_keep_na(), input$value)) {
|
|
| 93 | -+ | ||
| 770 | +! |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates))+ logger::log_trace("FilterState$keep_na_srv@1 changed reactive value, id: { private$get_id() }")
|
|
| 94 | -+ | ||
| 771 | +! |
- #' )+ updateCheckboxInput( |
|
| 95 | -+ | ||
| 772 | +! |
- #' observeEvent(+ inputId = "value", |
|
| 96 | -+ | ||
| 773 | +! |
- #' input$button0_date,+ label = sprintf("Keep NA (%s/%s)", private$filtered_na_count(), private$na_count),
|
|
| 97 | -+ | ||
| 774 | +! |
- #' fs$set_state(+ value = private$get_keep_na() |
|
| 98 | +775 |
- #' teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE)
+ ) |
|
| 99 | +776 |
- #' )+ } |
|
| 100 | +777 |
- #' )+ } |
|
| 101 | +778 |
- #' }+ ) |
|
| 102 | -+ | ||
| 779 | +12x |
- #'+ private$observers$keep_na <- observeEvent( |
|
| 103 | -+ | ||
| 780 | +12x |
- #' if (interactive()) {
+ ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput` |
|
| 104 | -+ | ||
| 781 | +12x |
- #' shinyApp(ui, server)+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
|
| 105 | -+ | ||
| 782 | +12x |
- #' }+ eventExpr = input$value, |
|
| 106 | -+ | ||
| 783 | +12x |
- #'+ handlerExpr = {
|
|
| 107 | -+ | ||
| 784 | +! |
- #' @keywords internal+ logger::log_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
|
|
| 108 | -+ | ||
| 785 | +! |
- #'+ keep_na <- if (is.null(input$value)) {
|
|
| 109 | -+ | ||
| 786 | +! |
- DateFilterState <- R6::R6Class( # nolint+ FALSE |
|
| 110 | +787 |
- "DateFilterState",+ } else {
|
|
| 111 | -+ | ||
| 788 | +! |
- inherit = FilterState,+ input$value |
|
| 112 | +789 |
-
+ } |
|
| 113 | -+ | ||
| 790 | +! |
- # public methods ----+ private$set_keep_na(keep_na) |
|
| 114 | +791 |
-
+ } |
|
| 115 | +792 |
- public = list(+ ) |
|
| 116 | -+ | ||
| 793 | +12x |
-
+ invisible(NULL) |
|
| 117 | +794 |
- #' @description+ }) |
|
| 118 | +795 |
- #' Initialize a `FilterState` object.+ } |
|
| 119 | +796 |
- #'+ ) |
|
| 120 | +797 |
- #' @param x (`Date`)+ ) |
| 121 | +1 |
- #' variable to be filtered.+ # LogicalFilterState ------ |
||
| 122 | +2 |
- #' @param x_reactive (`reactive`)+ |
||
| 123 | +3 |
- #' returning vector of the same type as `x`. Is used to update+ #' @name LogicalFilterState |
||
| 124 | +4 |
- #' counts following the change in values of the filtered dataset.+ #' @docType class |
||
| 125 | +5 |
- #' If it is set to `reactive(NULL)` then counts based on filtered+ #' |
||
| 126 | +6 |
- #' dataset are not shown.+ #' @title `FilterState` object for logical data |
||
| 127 | +7 |
- #' @param slice (`teal_slice`)+ #' |
||
| 128 | +8 |
- #' specification of this filter state.+ #' @description Manages choosing a logical state. |
||
| 129 | +9 |
- #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.+ #' |
||
| 130 | +10 |
- #' `get_state` returns `teal_slice` object which can be reused in other places.+ #' @examples |
||
| 131 | +11 |
- #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.+ #' # use non-exported function from teal.slice |
||
| 132 | +12 |
- #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.+ #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
||
| 133 | +13 |
- #' @param extract_type (`character`)+ #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
||
| 134 | +14 |
- #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ #' LogicalFilterState <- getFromNamespace("LogicalFilterState", "teal.slice")
|
||
| 135 | +15 |
- #' - `character(0)` (default) `varname` in the condition call will not be prefixed+ #' |
||
| 136 | +16 |
- #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`+ #' library(shiny) |
||
| 137 | +17 |
- #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`+ #' |
||
| 138 | +18 |
- #'+ #' filter_state <- LogicalFilterState$new( |
||
| 139 | +19 |
- #' @return Object of class `DateFilterState`, invisibly.+ #' x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE), |
||
| 140 | +20 |
- #'+ #' slice = teal_slice(varname = "x", dataname = "data") |
||
| 141 | +21 |
- initialize = function(x,+ #' ) |
||
| 142 | +22 |
- x_reactive = reactive(NULL),+ #' isolate(filter_state$get_call()) |
||
| 143 | +23 |
- slice,+ #' filter_state$set_state( |
||
| 144 | +24 |
- extract_type = character(0)) {
+ #' teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE) |
||
| 145 | -24x | +|||
| 25 | +
- isolate({
+ #' ) |
|||
| 146 | -24x | +|||
| 26 | +
- checkmate::assert_date(x)+ #' isolate(filter_state$get_call()) |
|||
| 147 | -23x | +|||
| 27 | +
- checkmate::assert_class(x_reactive, "reactive")+ #' |
|||
| 148 | +28 |
-
+ #' # working filter in an app |
||
| 149 | -23x | +|||
| 29 | +
- super$initialize(+ #' library(shinyjs) |
|||
| 150 | -23x | +|||
| 30 | +
- x = x,+ #' |
|||
| 151 | -23x | +|||
| 31 | +
- x_reactive = x_reactive,+ #' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA) |
|||
| 152 | -23x | +|||
| 32 | +
- slice = slice,+ #' fs <- LogicalFilterState$new( |
|||
| 153 | -23x | +|||
| 33 | +
- extract_type = extract_type+ #' x = data_logical, |
|||
| 154 | +34 |
- )+ #' slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE) |
||
| 155 | -23x | +|||
| 35 | +
- checkmate::assert_date(slice$choices, null.ok = TRUE)+ #' ) |
|||
| 156 | -22x | +|||
| 36 | +
- private$set_choices(slice$choices)+ #' |
|||
| 157 | -14x | +|||
| 37 | +
- if (is.null(slice$selected)) slice$selected <- slice$choices+ #' ui <- fluidPage( |
|||
| 158 | -22x | +|||
| 38 | +
- private$set_selected(slice$selected)+ #' useShinyjs(), |
|||
| 159 | +39 |
- })+ #' include_css_files(pattern = "filter-panel"), |
||
| 160 | +40 |
-
+ #' include_js_files(pattern = "count-bar-labels"), |
||
| 161 | -21x | +|||
| 41 | +
- invisible(self)+ #' column(4, tags$div( |
|||
| 162 | +42 |
- },+ #' tags$h4("LogicalFilterState"),
|
||
| 163 | +43 |
-
+ #' fs$ui("fs")
|
||
| 164 | +44 |
- #' @description+ #' )), |
||
| 165 | +45 |
- #' Returns reproducible condition call for current selection.+ #' column(4, tags$div( |
||
| 166 | +46 |
- #' For this class returned call looks like+ #' id = "outputs", # div id is needed for toggling the element |
||
| 167 | +47 |
- #' `<varname> >= <min value> & <varname> <= <max value>` with optional `is.na(<varname>)`.+ #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
||
| 168 | +48 |
- #' @param dataname (`character(1)`) containing possibly prefixed name of data set+ #' textOutput("condition_logical"), tags$br(),
|
||
| 169 | +49 |
- #' @return `call` or `NULL`+ #' tags$h4("Unformatted state"), # display raw filter state
|
||
| 170 | +50 |
- #'+ #' textOutput("unformatted_logical"), tags$br(),
|
||
| 171 | +51 |
- get_call = function(dataname) {
+ #' tags$h4("Formatted state"), # display human readable filter state
|
||
| 172 | -7x | +|||
| 52 | +
- if (isFALSE(private$is_any_filtered())) {
+ #' textOutput("formatted_logical"), tags$br()
|
|||
| 173 | -1x | +|||
| 53 | +
- return(NULL)+ #' )), |
|||
| 174 | +54 |
- }+ #' column(4, tags$div( |
||
| 175 | -6x | +|||
| 55 | +
- choices <- as.character(private$get_selected())+ #' tags$h4("Programmatic filter control"),
|
|||
| 176 | -6x | +|||
| 56 | +
- varname <- private$get_varname_prefixed(dataname)+ #' actionButton("button1_logical", "set drop NA", width = "100%"), tags$br(),
|
|||
| 177 | -6x | +|||
| 57 | +
- filter_call <-+ #' actionButton("button2_logical", "set keep NA", width = "100%"), tags$br(),
|
|||
| 178 | -6x | +|||
| 58 | +
- call(+ #' actionButton("button3_logical", "set a selection", width = "100%"), tags$br(),
|
|||
| 179 | +59 |
- "&",+ #' actionButton("button0_logical", "set initial state", width = "100%"), tags$br()
|
||
| 180 | -6x | +|||
| 60 | +
- call(">=", varname, call("as.Date", choices[1L])),
+ #' )) |
|||
| 181 | -6x | +|||
| 61 | +
- call("<=", varname, call("as.Date", choices[2L]))
+ #' ) |
|||
| 182 | +62 |
- )+ #' |
||
| 183 | -6x | +|||
| 63 | +
- private$add_keep_na_call(filter_call, varname)+ #' server <- function(input, output, session) {
|
|||
| 184 | +64 |
- }+ #' fs$server("fs")
|
||
| 185 | +65 |
- ),+ #' output$condition_logical <- renderPrint(fs$get_call()) |
||
| 186 | +66 |
-
+ #' output$formatted_logical <- renderText(fs$format()) |
||
| 187 | +67 |
- # private methods ----+ #' output$unformatted_logical <- renderPrint(fs$get_state()) |
||
| 188 | +68 |
-
+ #' # modify filter state programmatically |
||
| 189 | +69 |
- private = list(+ #' observeEvent( |
||
| 190 | +70 |
- set_choices = function(choices) {
+ #' input$button1_logical, |
||
| 191 | -22x | +|||
| 71 | +
- if (is.null(choices)) {
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) |
|||
| 192 | -19x | +|||
| 72 | +
- choices <- range(private$x, na.rm = TRUE)+ #' ) |
|||
| 193 | +73 |
- } else {
+ #' observeEvent( |
||
| 194 | -3x | +|||
| 74 | +
- choices_adjusted <- c(max(choices[1L], min(private$x)), min(choices[2L], max(private$x)))+ #' input$button2_logical, |
|||
| 195 | -3x | +|||
| 75 | +
- if (any(choices != choices_adjusted)) {
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
|||
| 196 | -1x | +|||
| 76 | +
- warning(sprintf(+ #' ) |
|||
| 197 | -1x | +|||
| 77 | +
- "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",+ #' observeEvent( |
|||
| 198 | -1x | +|||
| 78 | +
- private$get_varname(), private$get_dataname()+ #' input$button3_logical, |
|||
| 199 | +79 |
- ))+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE)) |
||
| 200 | -1x | +|||
| 80 | +
- choices <- choices_adjusted+ #' ) |
|||
| 201 | +81 |
- }+ #' observeEvent( |
||
| 202 | -3x | +|||
| 82 | +
- if (choices[1L] >= choices[2L]) {
+ #' input$button0_logical, |
|||
| 203 | -1x | +|||
| 83 | +
- warning(sprintf(+ #' fs$set_state( |
|||
| 204 | -1x | +|||
| 84 | +
- "Invalid choices: lower is higher / equal to upper, or not in range of variable values.+ #' teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE) |
|||
| 205 | -1x | +|||
| 85 | +
- Setting defaults. Varname: %s, dataname: %s.",+ #' ) |
|||
| 206 | -1x | +|||
| 86 | +
- private$get_varname(), private$get_dataname()+ #' ) |
|||
| 207 | +87 |
- ))+ #' } |
||
| 208 | -1x | +|||
| 88 | +
- choices <- range(private$x, na.rm = TRUE)+ #' |
|||
| 209 | +89 |
- }+ #' if (interactive()) {
|
||
| 210 | +90 |
- }+ #' shinyApp(ui, server) |
||
| 211 | -22x | +|||
| 91 | +
- private$set_is_choice_limited(private$x, choices)+ #' } |
|||
| 212 | -22x | +|||
| 92 | +
- private$x <- private$x[(private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x)]+ #' |
|||
| 213 | -22x | +|||
| 93 | +
- private$teal_slice$choices <- choices+ #' @keywords internal |
|||
| 214 | -22x | +|||
| 94 | +
- invisible(NULL)+ #' |
|||
| 215 | +95 |
- },+ LogicalFilterState <- R6::R6Class( # nolint |
||
| 216 | +96 |
-
+ "LogicalFilterState", |
||
| 217 | +97 |
- # @description+ inherit = FilterState, |
||
| 218 | +98 |
- # Check whether the initial choices filter out some values of x and set the flag in case.+ |
||
| 219 | +99 |
- set_is_choice_limited = function(xl, choices) {
+ # public methods ---- |
||
| 220 | -22x | +|||
| 100 | +
- private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE))+ public = list( |
|||
| 221 | -22x | +|||
| 101 | +
- invisible(NULL)+ |
|||
| 222 | +102 |
- },+ #' @description |
||
| 223 | +103 |
- cast_and_validate = function(values) {
+ #' Initialize a `FilterState` object. |
||
| 224 | -33x | +|||
| 104 | +
- tryCatch(+ #' |
|||
| 225 | -33x | +|||
| 105 | +
- expr = {
+ #' @param x (`logical`) |
|||
| 226 | -33x | +|||
| 106 | +
- values <- as.Date(values, origin = "1970-01-01")+ #' variable to be filtered. |
|||
| 227 | -! | +|||
| 107 | +
- if (anyNA(values)) stop()+ #' @param x_reactive (`reactive`) |
|||
| 228 | -30x | +|||
| 108 | +
- values+ #' returning vector of the same type as `x`. Is used to update |
|||
| 229 | +109 |
- },+ #' counts following the change in values of the filtered dataset. |
||
| 230 | -33x | +|||
| 110 | +
- error = function(e) stop("Vector of set values must contain values coercible to Date.")
+ #' If it is set to `reactive(NULL)` then counts based on filtered |
|||
| 231 | +111 |
- )+ #' dataset are not shown. |
||
| 232 | +112 |
- },+ #' @param slice (`teal_slice`) |
||
| 233 | +113 |
- check_length = function(values) {
+ #' specification of this filter state. |
||
| 234 | -1x | +|||
| 114 | +
- if (length(values) != 2) stop("Vector of set values must have length two.")
+ #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|||
| 235 | -29x | +|||
| 115 | +
- if (values[1] > values[2]) {
+ #' `get_state` returns `teal_slice` object which can be reused in other places. |
|||
| 236 | -1x | +|||
| 116 | +
- warning(+ #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|||
| 237 | -1x | +|||
| 117 | +
- sprintf(+ #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|||
| 238 | -1x | +|||
| 118 | +
- "Start date %s is set after the end date %s, the values will be replaced with a default date range.",+ #' @param extract_type (`character`) |
|||
| 239 | -1x | +|||
| 119 | +
- values[1], values[2]+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|||
| 240 | +120 |
- )+ #' - `character(0)` (default) `varname` in the condition call will not be prefixed |
||
| 241 | +121 |
- )+ #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
||
| 242 | -1x | +|||
| 122 | +
- values <- isolate(private$get_choices())+ #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|||
| 243 | +123 |
- }+ #' |
||
| 244 | -29x | +|||
| 124 | +
- values+ #' @return Object of class `LogicalFilterState`, invisibly. |
|||
| 245 | +125 |
- },+ #' |
||
| 246 | +126 |
- remove_out_of_bounds_values = function(values) {
+ initialize = function(x, |
||
| 247 | -29x | +|||
| 127 | +
- choices <- private$get_choices()+ x_reactive = reactive(NULL), |
|||
| 248 | -29x | +|||
| 128 | +
- if (values[1] < choices[1L] | values[1] > choices[2L]) {
+ extract_type = character(0), |
|||
| 249 | -5x | +|||
| 129 | +
- warning(+ slice) {
|
|||
| 250 | -5x | +130 | +16x |
- sprintf(+ isolate({
|
| 251 | -5x | +131 | +16x |
- "Value: %s is outside of the possible range for column %s of dataset %s, setting minimum possible value.",+ checkmate::assert_logical(x) |
| 252 | -5x | +132 | +15x |
- values[1], private$get_varname(), private$get_dataname()+ checkmate::assert_logical(slice$selected, null.ok = TRUE) |
| 253 | -+ | |||
| 133 | +14x |
- )+ super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type) |
||
| 254 | +134 |
- )+ |
||
| 255 | -5x | -
- values[1] <- choices[1L]- |
- ||
| 256 | -+ | 135 | +14x |
- }+ private$set_choices(slice$choices) |
| 257 | -+ | |||
| 136 | +! |
-
+ if (is.null(slice$multiple)) slice$multiple <- FALSE |
||
| 258 | -29x | +137 | +14x |
- if (values[2] > choices[2L] | values[2] < choices[1L]) {
+ if (is.null(slice$selected) && slice$multiple) {
|
| 259 | -5x | +138 | +7x |
- warning(+ slice$selected <- private$get_choices() |
| 260 | -5x | +139 | +7x |
- sprintf(+ } else if (length(slice$selected) != 1 && !slice$multiple) {
|
| 261 | -5x | +140 | +3x |
- "Value: %s is outside of the possible range for column %s of dataset %s, setting maximum possible value.",+ slice$selected <- TRUE |
| 262 | -5x | +|||
| 141 | +
- values[2], private$get_varname(), private$get_dataname()+ } |
|||
| 263 | -+ | |||
| 142 | +14x |
- )+ private$set_selected(slice$selected) |
||
| 264 | -+ | |||
| 143 | +14x |
- )+ df <- factor(x, levels = c(TRUE, FALSE)) |
||
| 265 | -5x | +144 | +14x |
- values[2] <- choices[2L]+ tbl <- table(df) |
| 266 | -+ | |||
| 145 | +14x |
- }+ private$set_choices_counts(tbl) |
||
| 267 | +146 |
-
+ }) |
||
| 268 | -29x | +147 | +14x |
- values+ invisible(self) |
| 269 | +148 |
}, |
||
| 270 | +149 | |||
| 271 | +150 |
- # shiny modules ----+ #' @description |
||
| 272 | +151 |
-
+ #' Returns reproducible condition call for current selection. |
||
| 273 | +152 |
- # @description+ #' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally `is.na(<varname>)` |
||
| 274 | +153 |
- # UI Module for `DateFilterState`.+ #' @param dataname name of data set; defaults to `private$get_dataname()` |
||
| 275 | +154 |
- # This UI element contains two date selections for `min` and `max`+ #' @return `call` |
||
| 276 | +155 |
- # of the range and a checkbox whether to keep the `NA` values.+ #' |
||
| 277 | +156 |
- # @param id (`character(1)`) `shiny` module instance id.+ get_call = function(dataname) {
|
||
| 278 | -+ | |||
| 157 | +6x |
- ui_inputs = function(id) {
+ if (isFALSE(private$is_any_filtered())) {
|
||
| 279 | +158 | ! |
- ns <- NS(id)+ return(NULL) |
|
| 280 | -! | +|||
| 159 | +
- isolate({
+ } |
|||
| 281 | -! | +|||
| 160 | +4x |
- tags$div(+ if (missing(dataname)) dataname <- private$get_dataname() |
||
| 282 | -! | +|||
| 161 | +6x |
- tags$div(+ varname <- private$get_varname_prefixed(dataname) |
||
| 283 | -! | +|||
| 162 | +6x |
- class = "flex",+ choices <- private$get_selected() |
||
| 284 | -! | +|||
| 163 | +6x |
- actionButton(+ n_choices <- length(choices) |
||
| 285 | -! | +|||
| 164 | +
- class = "date_reset_button",+ |
|||
| 286 | -! | +|||
| 165 | +6x |
- inputId = ns("start_date_reset"),
+ filter_call <- |
||
| 287 | -! | +|||
| 166 | +6x |
- label = NULL,+ if (n_choices == 1 && choices) {
|
||
| 288 | -! | +|||
| 167 | +1x |
- icon = icon("fas fa-undo")
+ varname |
||
| 289 | -+ | |||
| 168 | +6x |
- ),+ } else if (n_choices == 1 && !choices) {
|
||
| 290 | -! | +|||
| 169 | +4x |
- tags$div(+ call("!", varname)
|
||
| 291 | -! | +|||
| 170 | +
- class = "w-80 filter_datelike_input",+ } else {
|
|||
| 292 | -! | +|||
| 171 | +1x |
- dateRangeInput(+ call("%in%", varname, make_c_call(choices))
|
||
| 293 | -! | +|||
| 172 | +
- inputId = ns("selection"),
+ } |
|||
| 294 | -! | +|||
| 173 | +6x |
- label = NULL,+ private$add_keep_na_call(filter_call, varname) |
||
| 295 | -! | +|||
| 174 | +
- start = private$get_selected()[1],+ } |
|||
| 296 | -! | +|||
| 175 | +
- end = private$get_selected()[2],+ ), |
|||
| 297 | -! | +|||
| 176 | +
- min = private$get_choices()[1L],+ |
|||
| 298 | -! | +|||
| 177 | +
- max = private$get_choices()[2L],+ # private members ---- |
|||
| 299 | -! | +|||
| 178 | +
- width = "100%"+ private = list( |
|||
| 300 | +179 |
- )+ choices_counts = integer(0), |
||
| 301 | +180 |
- ),+ |
||
| 302 | -! | +|||
| 181 | +
- actionButton(+ # private methods ---- |
|||
| 303 | -! | +|||
| 182 | +
- class = "date_reset_button",+ set_choices = function(choices) {
|
|||
| 304 | -! | +|||
| 183 | +14x |
- inputId = ns("end_date_reset"),
+ private$teal_slice$choices <- c(TRUE, FALSE) |
||
| 305 | -! | +|||
| 184 | +14x |
- label = NULL,+ invisible(NULL) |
||
| 306 | -! | +|||
| 185 | +
- icon = icon("fas fa-undo")
+ }, |
|||
| 307 | +186 |
- )+ # @description |
||
| 308 | +187 |
- ),+ # Sets choices_counts private field |
||
| 309 | -! | +|||
| 188 | +
- private$keep_na_ui(ns("keep_na"))
+ set_choices_counts = function(choices_counts) {
|
|||
| 310 | -+ | |||
| 189 | +14x |
- )+ private$choices_counts <- choices_counts+ |
+ ||
| 190 | +14x | +
+ invisible(NULL) |
||
| 311 | +191 |
- })+ }, |
||
| 312 | +192 |
- },+ cast_and_validate = function(values) {
+ |
+ ||
| 193 | +21x | +
+ tryCatch(+ |
+ ||
| 194 | +21x | +
+ expr = {
+ |
+ ||
| 195 | +21x | +
+ values <- as.logical(values)+ |
+ ||
| 196 | +1x | +
+ if (anyNA(values)) stop()+ |
+ ||
| 197 | +20x | +
+ values |
||
| 313 | +198 |
-
+ },+ |
+ ||
| 199 | +21x | +
+ error = function(e) stop("Vector of set values must contain values coercible to logical.")
|
||
| 314 | +200 |
- # @description+ ) |
||
| 315 | +201 |
- # Server module+ }, |
||
| 316 | +202 |
- # @param id (`character(1)`) `shiny` module instance id.+ # If multiple forbidden but selected, restores previous selection with warning. |
||
| 317 | +203 |
- # @return `NULL`.+ check_length = function(values) {
+ |
+ ||
| 204 | +20x | +
+ if (!private$is_multiple() && length(values) > 1) {
+ |
+ ||
| 205 | +1x | +
+ warning(+ |
+ ||
| 206 | +1x | +
+ sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
+ |
+ ||
| 207 | +1x | +
+ "Maintaining previous selection." |
||
| 318 | +208 |
- server_inputs = function(id) {
+ ) |
||
| 319 | -! | +|||
| 209 | +1x |
- moduleServer(+ values <- isolate(private$get_selected()) |
||
| 320 | -! | +|||
| 210 | +
- id = id,+ } |
|||
| 321 | -! | +|||
| 211 | +20x |
- function(input, output, session) {
+ values |
||
| 322 | -! | +|||
| 212 | +
- logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }")
+ }, |
|||
| 323 | +213 | |||
| 324 | +214 |
- # this observer is needed in the situation when teal_slice$selected has been+ # Answers the question of whether the current settings and values selected actually filters out any values. |
||
| 325 | +215 |
- # changed directly by the api - then it's needed to rerender UI element+ # @return logical scalar |
||
| 326 | +216 |
- # to show relevant values+ is_any_filtered = function() {
|
||
| 327 | -! | +|||
| 217 | +6x |
- private$observers$seletion_api <- observeEvent(+ if (private$is_choice_limited) {
|
||
| 328 | +218 | ! |
- ignoreNULL = TRUE, # dates needs to be selected+ TRUE |
|
| 329 | -! | +|||
| 219 | +6x |
- ignoreInit = TRUE,+ } else if (all(private$choices_counts > 0)) {
|
||
| 330 | -! | +|||
| 220 | +6x |
- eventExpr = private$get_selected(),+ TRUE |
||
| 331 | -! | +|||
| 221 | +
- handlerExpr = {
+ } else if ( |
|||
| 332 | +222 | ! |
- if (!setequal(private$get_selected(), input$selection)) {
+ setequal(private$get_selected(), private$get_choices()) && |
|
| 333 | +223 | ! |
- logger::log_trace("DateFilterState$server@1 state changed, id: { private$get_id() }")
+ !anyNA(private$get_selected(), private$get_choices()) |
|
| 334 | -! | +|||
| 224 | +
- updateDateRangeInput(+ ) {
|
|||
| 335 | +225 | ! |
- session = session,+ TRUE |
|
| 336 | +226 | ! |
- inputId = "selection",+ } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
|
|
| 337 | +227 | ! |
- start = private$get_selected()[1],+ TRUE+ |
+ |
| 228 | ++ |
+ } else {
|
||
| 338 | +229 | ! |
- end = private$get_selected()[2]+ FALSE |
|
| 339 | +230 |
- )+ } |
||
| 340 | +231 |
- }+ }, |
||
| 341 | +232 |
- }+ |
||
| 342 | +233 |
- )+ # shiny modules ---- |
||
| 343 | +234 | |||
| 344 | -! | +|||
| 235 | +
- private$observers$selection <- observeEvent(+ # @description |
|||
| 345 | -! | +|||
| 236 | +
- ignoreNULL = TRUE, # dates needs to be selected+ # UI Module for `EmptyFilterState`. |
|||
| 346 | -! | +|||
| 237 | +
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ # This UI element contains available choices selection and+ |
+ |||
| 238 | ++ |
+ # checkbox whether to keep or not keep the `NA` values.+ |
+ ||
| 239 | ++ |
+ # @param id (`character(1)`) `shiny` module instance id.+ |
+ ||
| 240 | ++ |
+ ui_inputs = function(id) {
|
||
| 347 | +241 | ! |
- eventExpr = input$selection,+ ns <- NS(id) |
|
| 348 | +242 | ! |
- handlerExpr = {
+ isolate({
|
|
| 349 | +243 | ! |
- logger::log_trace("DateFilterState$server@2 selection changed, id: { private$get_id() }")
+ countsmax <- private$choices_counts |
|
| 350 | +244 | ! |
- start_date <- input$selection[1]+ countsnow <- if (!is.null(private$x_reactive())) {
|
|
| 351 | +245 | ! |
- end_date <- input$selection[2]+ unname(table(factor(private$x_reactive(), levels = private$get_choices()))) |
|
| 352 | +246 |
-
+ } else {
|
||
| 353 | +247 | ! |
- if (is.na(start_date) || is.na(end_date) || start_date > end_date) {
+ NULL |
|
| 354 | -! | +|||
| 248 | +
- updateDateRangeInput(+ } |
|||
| 355 | -! | +|||
| 249 | +
- session = session,+ |
|||
| 356 | +250 | ! |
- inputId = "selection",+ labels <- countBars( |
|
| 357 | +251 | ! |
- start = private$get_selected()[1],+ inputId = ns("labels"),
|
|
| 358 | +252 | ! |
- end = private$get_selected()[2]+ choices = as.character(private$get_choices()), |
|
| 359 | -+ | |||
| 253 | +! |
- )+ countsnow = countsnow, |
||
| 360 | +254 | ! |
- showNotification(+ countsmax = countsmax |
|
| 361 | -! | +|||
| 255 | +
- "Start date must not be greater than the end date. Setting back to previous value.",+ ) |
|||
| 362 | +256 | ! |
- type = "warning"+ ui_input <- if (private$is_multiple()) {
|
|
| 363 | -+ | |||
| 257 | +! |
- )+ checkboxGroupInput( |
||
| 364 | +258 | ! |
- return(NULL)+ inputId = ns("selection"),
|
|
| 365 | -+ | |||
| 259 | +! |
- }+ label = NULL, |
||
| 366 | -+ | |||
| 260 | +! |
-
+ selected = isolate(as.character(private$get_selected())), |
||
| 367 | +261 | ! |
- private$set_selected(c(start_date, end_date))+ choiceNames = labels, |
|
| 368 | -+ | |||
| 262 | +! |
- }+ choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
|
||
| 369 | -+ | |||
| 263 | +! |
- )+ width = "100%" |
||
| 370 | +264 |
-
+ ) |
||
| 371 | +265 |
-
+ } else {
|
||
| 372 | +266 | ! |
- private$keep_na_srv("keep_na")
- |
- |
| 373 | -- |
-
+ radioButtons( |
||
| 374 | +267 | ! |
- private$observers$reset1 <- observeEvent(input$start_date_reset, {
+ inputId = ns("selection"),
|
|
| 375 | +268 | ! |
- logger::log_trace("DateFilterState$server@3 reset start date, id: { private$get_id() }")
+ label = NULL, |
|
| 376 | +269 | ! |
- updateDateRangeInput(+ selected = isolate(as.character(private$get_selected())), |
|
| 377 | +270 | ! |
- session = session,+ choiceNames = labels, |
|
| 378 | +271 | ! |
- inputId = "selection",+ choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
|
|
| 379 | +272 | ! |
- start = private$get_choices()[1L]+ width = "100%" |
|
| 380 | +273 |
- )+ ) |
||
| 381 | +274 |
- })+ } |
||
| 382 | -+ | |||
| 275 | +! |
-
+ tags$div( |
||
| 383 | +276 | ! |
- private$observers$reset2 <- observeEvent(input$end_date_reset, {
+ tags$div( |
|
| 384 | +277 | ! |
- logger::log_trace("DateFilterState$server@4 reset end date, id: { private$get_id() }")
+ class = "choices_state", |
|
| 385 | +278 | ! |
- updateDateRangeInput(+ uiOutput(ns("trigger_visible"), inline = TRUE),
|
|
| 386 | +279 | ! |
- session = session,+ ui_input |
|
| 387 | -! | +|||
| 280 | +
- inputId = "selection",+ ), |
|||
| 388 | +281 | ! |
- end = private$get_choices()[2L]+ private$keep_na_ui(ns("keep_na"))
|
|
| 389 | +282 |
- )+ ) |
||
| 390 | +283 |
- })+ }) |
||
| 391 | +284 |
-
+ }, |
||
| 392 | -! | +|||
| 285 | +
- logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
+
|
|||
| 393 | -! | +|||
| 286 | +
- NULL+ # @description |
|||
| 394 | +287 |
- }+ # Server module |
||
| 395 | +288 |
- )+ # @param id (`character(1)`) `shiny` module instance id. |
||
| 396 | +289 |
- },+ # @return `NULL`. |
||
| 397 | +290 |
- server_inputs_fixed = function(id) {
+ server_inputs = function(id) {
|
||
| 398 | +291 | ! |
moduleServer( |
|
| 399 | +292 | ! |
id = id, |
|
| 400 | +293 | ! |
function(input, output, session) {
|
|
| 401 | -! | +|||
| 294 | +
- logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }")
+ # this observer is needed in the situation when teal_slice$selected has been |
|||
| 402 | +295 |
-
+ # changed directly by the api - then it's needed to rerender UI element+ |
+ ||
| 296 | ++ |
+ # to show relevant values |
||
| 403 | +297 | ! |
- output$selection <- renderUI({
+ non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive())) |
|
| 404 | +298 | ! |
- vals <- format(private$get_selected(), nsmall = 3)+ output$trigger_visible <- renderUI({
|
|
| 405 | +299 | ! |
- tags$div(+ logger::log_trace("LogicalFilterState$server@1 updating count labels, id: { private$get_id() }")
+ |
+ |
| 300 | ++ | + | ||
| 406 | +301 | ! |
- tags$div(icon("calendar-days"), vals[1]),
+ countsnow <- if (!is.null(private$x_reactive())) {
|
|
| 407 | +302 | ! |
- tags$div(span(" - "), icon("calendar-days"), vals[2])
+ unname(table(factor(non_missing_values(), levels = private$get_choices()))) |
|
| 408 | +303 |
- )+ } else {
+ |
+ ||
| 304 | +! | +
+ NULL |
||
| 409 | +305 |
- })+ } |
||
| 410 | +306 | |||
| 411 | +307 | ! |
- logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
+ updateCountBars( |
|
| 412 | +308 | ! |
- NULL- |
- |
| 413 | -- |
- }- |
- ||
| 414 | -- |
- )+ inputId = "labels", |
||
| 415 | -+ | |||
| 309 | +! |
- },+ choices = as.character(private$get_choices()), |
||
| 416 | -+ | |||
| 310 | +! |
-
+ countsmax = private$choices_counts, |
||
| 417 | -+ | |||
| 311 | +! |
- # @description+ countsnow = countsnow |
||
| 418 | +312 |
- # Server module to display filter summary+ ) |
||
| 419 | -+ | |||
| 313 | +! |
- # renders text describing selected date range and+ NULL |
||
| 420 | +314 |
- # if NA are included also+ }) |
||
| 421 | +315 |
- content_summary = function(id) {
+
|
||
| 422 | +316 | ! |
- selected <- as.character(private$get_selected())+ private$observers$seleted_api <- observeEvent( |
|
| 423 | +317 | ! |
- min <- selected[1]+ ignoreNULL = !private$is_multiple(), |
|
| 424 | +318 | ! |
- max <- selected[2]+ ignoreInit = TRUE, |
|
| 425 | +319 | ! |
- tagList(+ eventExpr = private$get_selected(), |
|
| 426 | +320 | ! |
- tags$span(+ handlerExpr = {
|
|
| 427 | +321 | ! |
- class = "filter-card-summary-value",+ if (!setequal(private$get_selected(), input$selection)) {
|
|
| 428 | +322 | ! |
- HTML(min, "–", max)- |
- |
| 429 | -- |
- ),+ logger::log_trace("LogicalFilterState$server@1 state changed, id: { private$get_id() }")
|
||
| 430 | +323 | ! |
- tags$span(+ if (private$is_multiple()) {
|
|
| 431 | +324 | ! |
- class = "filter-card-summary-controls",+ updateCheckboxGroupInput( |
|
| 432 | +325 | ! |
- if (private$na_count > 0) {
+ inputId = "selection", |
|
| 433 | +326 | ! |
- tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
+ selected = private$get_selected() |
|
| 434 | +327 |
- }+ ) |
||
| 435 | +328 |
- )+ } else {
|
||
| 436 | -+ | |||
| 329 | +! |
- )+ updateRadioButtons( |
||
| 437 | -+ | |||
| 330 | +! |
- }+ inputId = "selection", |
||
| 438 | -+ | |||
| 331 | +! |
- )+ selected = private$get_selected() |
||
| 439 | +332 |
- )+ ) |
| 1 | +333 |
- # DatetimeFilterState ------+ } |
|
| 2 | +334 |
-
+ } |
|
| 3 | +335 |
- #' @rdname DatetimeFilterState+ } |
|
| 4 | +336 |
- #' @docType class+ ) |
|
| 5 | +337 |
- #'+ |
|
| 6 | -+ | ||
| 338 | +! |
- #' @title `FilterState` object for date time data+ private$observers$selection <- observeEvent( |
|
| 7 | -+ | ||
| 339 | +! |
- #'+ ignoreNULL = FALSE, |
|
| 8 | -+ | ||
| 340 | +! |
- #' @description Manages choosing a range of date-times.+ ignoreInit = TRUE, |
|
| 9 | -+ | ||
| 341 | +! |
- #'+ eventExpr = input$selection, |
|
| 10 | -+ | ||
| 342 | +! |
- #' @examples+ handlerExpr = {
|
|
| 11 | -+ | ||
| 343 | +! |
- #' # use non-exported function from teal.slice+ logger::log_trace("LogicalFilterState$server@2 selection changed, id: { private$get_id() }")
|
|
| 12 | +344 |
- #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
+ # for private$is_multiple() == TRUE input$selection will always have value |
|
| 13 | -+ | ||
| 345 | +! |
- #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
+ if (is.null(input$selection) && isFALSE(private$is_multiple())) {
|
|
| 14 | -+ | ||
| 346 | +! |
- #' DatetimeFilterState <- getFromNamespace("DatetimeFilterState", "teal.slice")
+ selection_state <- private$get_selected() |
|
| 15 | +347 |
- #'+ } else {
|
|
| 16 | -+ | ||
| 348 | +! |
- #' library(shiny)+ selection_state <- as.logical(input$selection) |
|
| 17 | +349 |
- #'+ } |
|
| 18 | +350 |
- #' filter_state <- DatetimeFilterState$new(+ |
|
| 19 | -+ | ||
| 351 | +! |
- #' x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA),+ if (is.null(selection_state)) {
|
|
| 20 | -+ | ||
| 352 | +! |
- #' slice = teal_slice(varname = "x", dataname = "data"),+ selection_state <- logical(0) |
|
| 21 | +353 |
- #' extract_type = character(0)+ } |
|
| 22 | -+ | ||
| 354 | +! |
- #' )+ private$set_selected(selection_state) |
|
| 23 | +355 |
- #' isolate(filter_state$get_call())+ } |
|
| 24 | +356 |
- #' filter_state$set_state(+ ) |
|
| 25 | +357 |
- #' teal_slice(+ |
|
| 26 | -+ | ||
| 358 | +! |
- #' dataname = "data",+ private$keep_na_srv("keep_na")
|
|
| 27 | +359 |
- #' varname = "x",+ |
|
| 28 | -+ | ||
| 360 | +! |
- #' selected = c(Sys.time() + 3L, Sys.time() + 8L),+ logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
|
|
| 29 | -+ | ||
| 361 | +! |
- #' keep_na = TRUE+ NULL |
|
| 30 | +362 |
- #' )+ } |
|
| 31 | +363 |
- #' )+ ) |
|
| 32 | +364 |
- #' isolate(filter_state$get_call())+ }, |
|
| 33 | +365 |
- #'+ server_inputs_fixed = function(id) {
|
|
| 34 | -+ | ||
| 366 | +! |
- #' # working filter in an app+ moduleServer( |
|
| 35 | -+ | ||
| 367 | +! |
- #' library(shinyjs)+ id = id, |
|
| 36 | -+ | ||
| 368 | +! |
- #'+ function(input, output, session) {
|
|
| 37 | -+ | ||
| 369 | +! |
- #' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00"))
+ logger::log_trace("LogicalFilterState$server initializing, id: { private$get_id() }")
|
|
| 38 | +370 |
- #' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA)+ |
|
| 39 | -+ | ||
| 371 | +! |
- #' fs <- DatetimeFilterState$new(+ output$selection <- renderUI({
|
|
| 40 | -+ | ||
| 372 | +! |
- #' x = data_datetime,+ countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices()))) |
|
| 41 | -+ | ||
| 373 | +! |
- #' slice = teal_slice(+ countsmax <- private$choices_counts |
|
| 42 | +374 |
- #' varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE+ |
|
| 43 | -+ | ||
| 375 | +! |
- #' )+ ind <- private$get_choices() %in% private$get_selected() |
|
| 44 | -+ | ||
| 376 | +! |
- #' )+ countBars( |
|
| 45 | -+ | ||
| 377 | +! |
- #'+ inputId = session$ns("labels"),
|
|
| 46 | -+ | ||
| 378 | +! |
- #' ui <- fluidPage(+ choices = private$get_selected(), |
|
| 47 | -+ | ||
| 379 | +! |
- #' useShinyjs(),+ countsnow = countsnow[ind], |
|
| 48 | -+ | ||
| 380 | +! |
- #' include_css_files(pattern = "filter-panel"),+ countsmax = countsmax[ind] |
|
| 49 | +381 |
- #' include_js_files(pattern = "count-bar-labels"),+ ) |
|
| 50 | +382 |
- #' column(4, tags$div(+ }) |
|
| 51 | +383 |
- #' tags$h4("DatetimeFilterState"),
+
|
|
| 52 | -+ | ||
| 384 | +! |
- #' fs$ui("fs")
+ logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
|
|
| 53 | -+ | ||
| 385 | +! |
- #' )),+ NULL |
|
| 54 | +386 |
- #' column(4, tags$div(+ } |
|
| 55 | +387 |
- #' id = "outputs", # div id is needed for toggling the element+ ) |
|
| 56 | +388 |
- #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
+ }, |
|
| 57 | +389 |
- #' textOutput("condition_datetime"), tags$br(),
+
|
|
| 58 | +390 |
- #' tags$h4("Unformatted state"), # display raw filter state
+ # @description |
|
| 59 | +391 |
- #' textOutput("unformatted_datetime"), tags$br(),
+ # Server module to display filter summary |
|
| 60 | +392 |
- #' tags$h4("Formatted state"), # display human readable filter state
+ # renders text describing whether TRUE or FALSE is selected |
|
| 61 | +393 |
- #' textOutput("formatted_datetime"), tags$br()
+ # and if NA are included also |
|
| 62 | +394 |
- #' )),+ content_summary = function(id) {
|
|
| 63 | -+ | ||
| 395 | +! |
- #' column(4, tags$div(+ tagList( |
|
| 64 | -+ | ||
| 396 | +! |
- #' tags$h4("Programmatic filter control"),
+ tags$span( |
|
| 65 | -+ | ||
| 397 | +! |
- #' actionButton("button1_datetime", "set drop NA", width = "100%"), tags$br(),
+ class = "filter-card-summary-value", |
|
| 66 | -+ | ||
| 398 | +! |
- #' actionButton("button2_datetime", "set keep NA", width = "100%"), tags$br(),
+ toString(private$get_selected()) |
|
| 67 | +399 |
- #' actionButton("button3_datetime", "set a range", width = "100%"), tags$br(),
+ ), |
|
| 68 | -+ | ||
| 400 | +! |
- #' actionButton("button4_datetime", "set full range", width = "100%"), tags$br(),
+ tags$span( |
|
| 69 | -+ | ||
| 401 | +! |
- #' actionButton("button0_datetime", "set initial state", width = "100%"), tags$br()
+ class = "filter-card-summary-controls", |
|
| 70 | -+ | ||
| 402 | +! |
- #' ))+ if (private$na_count > 0) {
|
|
| 71 | -+ | ||
| 403 | +! |
- #' )+ tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
|
|
| 72 | +404 |
- #'+ } |
|
| 73 | +405 |
- #' server <- function(input, output, session) {
+ ) |
|
| 74 | +406 |
- #' fs$server("fs")
+ ) |
|
| 75 | +407 |
- #' output$condition_datetime <- renderPrint(fs$get_call())+ } |
|
| 76 | +408 |
- #' output$formatted_datetime <- renderText(fs$format())+ ) |
|
| 77 | +409 |
- #' output$unformatted_datetime <- renderPrint(fs$get_state())+ ) |
| 78 | +1 |
- #' # modify filter state programmatically+ # FilteredDataset abstract -------- |
||
| 79 | +2 |
- #' observeEvent(+ |
||
| 80 | +3 |
- #' input$button1_datetime,+ #' @name FilteredDataset |
||
| 81 | +4 |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))+ #' @docType class |
||
| 82 | +5 |
- #' )+ #' |
||
| 83 | +6 |
- #' observeEvent(+ #' @title `FilteredDataset` `R6` class |
||
| 84 | +7 |
- #' input$button2_datetime,+ #' @description |
||
| 85 | +8 |
- #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ #' `FilteredDataset` is a class which renders/controls `FilterStates`(s) |
||
| 86 | +9 |
- #' )+ #' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one |
||
| 87 | +10 |
- #' observeEvent(+ #' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects. |
||
| 88 | +11 |
- #' input$button3_datetime,+ #' Each `FilterStates` is responsible for one filter/subset expression applied for specific |
||
| 89 | +12 |
- #' fs$set_state(+ #' components of the dataset. |
||
| 90 | +13 |
- #' teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)])+ #' |
||
| 91 | +14 |
- #' )+ #' @keywords internal |
||
| 92 | +15 |
- #' )+ FilteredDataset <- R6::R6Class( # nolint |
||
| 93 | +16 |
- #' observeEvent(+ "FilteredDataset", |
||
| 94 | +17 |
- #' input$button4_datetime,+ # public methods ---- |
||
| 95 | +18 |
- #' fs$set_state(+ public = list( |
||
| 96 | +19 |
- #' teal_slice(dataname = "data", varname = "x", selected = datetimes)+ #' @description |
||
| 97 | +20 |
- #' )+ #' Initializes this `FilteredDataset` object. |
||
| 98 | +21 |
- #' )+ #' |
||
| 99 | +22 |
- #' observeEvent(+ #' @param dataset any object |
||
| 100 | +23 |
- #' input$button0_datetime,+ #' @param dataname (`character(1)`) |
||
| 101 | +24 |
- #' fs$set_state(+ #' syntactically valid name given to the dataset. |
||
| 102 | +25 |
- #' teal_slice(+ #' @param keys (`character`) optional |
||
| 103 | +26 |
- #' dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE+ #' vector of primary key column names. |
||
| 104 | +27 |
- #' )+ #' @param label (`character(1)`) |
||
| 105 | +28 |
- #' )+ #' label to describe the dataset. |
||
| 106 | +29 |
- #' )+ #' |
||
| 107 | +30 |
- #' }+ #' @return Object of class `FilteredDataset`, invisibly. |
||
| 108 | +31 |
- #'+ #' |
||
| 109 | +32 |
- #' if (interactive()) {
+ initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label", exact = TRUE)) {
|
||
| 110 | -+ | |||
| 33 | +153x |
- #' shinyApp(ui, server)+ logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
|
||
| 111 | +34 |
- #' }+ |
||
| 112 | +35 |
- #'+ # dataset assertion in child classes |
||
| 113 | -+ | |||
| 36 | +153x |
- #' @keywords internal+ check_simple_name(dataname) |
||
| 114 | -+ | |||
| 37 | +151x |
- #'+ checkmate::assert_character(keys, any.missing = FALSE) |
||
| 115 | -+ | |||
| 38 | +151x |
- DatetimeFilterState <- R6::R6Class( # nolint+ checkmate::assert_character(label, null.ok = TRUE) |
||
| 116 | +39 |
- "DatetimeFilterState",+ |
||
| 117 | -+ | |||
| 40 | +151x |
- inherit = FilterState,+ logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
|
||
| 118 | -+ | |||
| 41 | +151x |
-
+ private$dataset <- dataset |
||
| 119 | -+ | |||
| 42 | +151x |
- # public methods ----+ private$dataname <- dataname |
||
| 120 | -+ | |||
| 43 | +151x |
-
+ private$keys <- keys |
||
| 121 | -+ | |||
| 44 | +151x |
- public = list(+ private$label <- if (is.null(label)) character(0) else label |
||
| 122 | +45 | |||
| 123 | +46 |
- #' @description+ # function executing reactive call and returning data |
||
| 124 | -+ | |||
| 47 | +151x |
- #' Initialize a `FilterState` object. This class+ private$data_filtered_fun <- function(sid = "") {
|
||
| 125 | -+ | |||
| 48 | +24x |
- #' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by+ checkmate::assert_character(sid)+ |
+ ||
| 49 | +24x | +
+ if (length(sid)) {
+ |
+ ||
| 50 | +24x | +
+ logger::log_trace("filtering data dataname: { dataname }, sid: { sid }")
|
||
| 126 | +51 |
- #' default. However, in case when using this module in `teal` app, one needs+ } else {
+ |
+ ||
| 52 | +! | +
+ logger::log_trace("filtering data dataname: { private$dataname }")
|
||
| 127 | +53 |
- #' timezone of the app user. App user timezone is taken from `session$userData$timezone`+ }+ |
+ ||
| 54 | +24x | +
+ env <- new.env(parent = parent.env(globalenv()))+ |
+ ||
| 55 | +24x | +
+ env[[dataname]] <- private$dataset+ |
+ ||
| 56 | +24x | +
+ filter_call <- self$get_call(sid)+ |
+ ||
| 57 | +24x | +
+ eval_expr_with_msg(filter_call, env)+ |
+ ||
| 58 | +24x | +
+ get(x = dataname, envir = env) |
||
| 128 | +59 |
- #' and is set only if object is initialized in `shiny`.+ } |
||
| 129 | +60 |
- #'+ + |
+ ||
| 61 | +151x | +
+ private$data_filtered <- reactive(private$data_filtered_fun())+ |
+ ||
| 62 | +151x | +
+ logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
+ |
+ ||
| 63 | +151x | +
+ invisible(self) |
||
| 130 | +64 |
- #' @param x (`POSIXct` or `POSIXlt`)+ }, |
||
| 131 | +65 |
- #' variable to be filtered.+ |
||
| 132 | +66 |
- #' @param x_reactive (`reactive`)+ #' @description |
||
| 133 | +67 |
- #' returning vector of the same type as `x`. Is used to update+ #' Returns a formatted string representing this `FilteredDataset` object. |
||
| 134 | +68 |
- #' counts following the change in values of the filtered dataset.+ #' |
||
| 135 | +69 |
- #' If it is set to `reactive(NULL)` then counts based on filtered+ #' @param show_all (`logical(1)`) passed to `format.teal_slice`. |
||
| 136 | +70 |
- #' dataset are not shown.+ #' @param trim_lines (`logical(1)`) passed to `format.teal_slice`. |
||
| 137 | +71 |
- #' @param slice (`teal_slice`)+ #' |
||
| 138 | +72 |
- #' specification of this filter state.+ #' @return The formatted character string. |
||
| 139 | +73 |
- #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.+ #' |
||
| 140 | +74 |
- #' `get_state` returns `teal_slice` object which can be reused in other places.+ format = function(show_all = FALSE, trim_lines = TRUE) {
+ |
+ ||
| 75 | +24x | +
+ sprintf(+ |
+ ||
| 76 | +24x | +
+ "%s:\n%s",+ |
+ ||
| 77 | +24x | +
+ class(self)[1],+ |
+ ||
| 78 | +24x | +
+ format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines) |
||
| 141 | +79 |
- #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.+ ) |
||
| 142 | +80 |
- #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.+ }, |
||
| 143 | +81 |
- #' @param extract_type (`character`)+ |
||
| 144 | +82 |
- #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ #' @description |
||
| 145 | +83 |
- #' - `character(0)` (default) `varname` in the condition call will not be prefixed+ #' Prints this `FilteredDataset` object. |
||
| 146 | +84 |
- #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`+ #' |
||
| 147 | +85 |
- #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`+ #' @param ... additional arguments passed to `format`. |
||
| 148 | +86 |
#' |
||
| 149 | +87 |
- #' @return Object of class `DatetimeFilterState`, invisibly.+ print = function(...) {
+ |
+ ||
| 88 | +10x | +
+ cat(isolate(self$format(...)), "\n") |
||
| 150 | +89 |
- #'+ }, |
||
| 151 | +90 |
- initialize = function(x,+ |
||
| 152 | +91 |
- x_reactive = reactive(NULL),+ #' @description |
||
| 153 | +92 |
- extract_type = character(0),+ #' Removes all filter items applied to this dataset. |
||
| 154 | +93 |
- slice) {
+ #' |
||
| 155 | -25x | +|||
| 94 | +
- isolate({
+ #' @param force (`logical(1)`) |
|||
| 156 | -25x | +|||
| 95 | +
- checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
+ #' flag specifying whether to include anchored filter states. |
|||
| 157 | -24x | +|||
| 96 | +
- checkmate::assert_class(x_reactive, "reactive")+ #' |
|||
| 158 | +97 |
-
+ #' @return `NULL`. |
||
| 159 | -24x | +|||
| 98 | +
- super$initialize(+ clear_filter_states = function(force = FALSE) {
|
|||
| 160 | -24x | +99 | +14x |
- x = x,+ logger::log_trace("Removing filters from FilteredDataset: { deparse1(self$get_dataname()) }")
|
| 161 | -24x | +100 | +14x |
- x_reactive = x_reactive,+ lapply( |
| 162 | -24x | +101 | +14x |
- slice = slice,+ private$get_filter_states(), |
| 163 | -24x | +102 | +14x |
- extract_type = extract_type+ function(filter_states) filter_states$clear_filter_states(force) |
| 164 | +103 |
- )+ ) |
||
| 165 | -24x | +104 | +14x |
- checkmate::assert_multi_class(slice$choices, c("POSIXct", "POSIXlt"), null.ok = TRUE)
+ logger::log_trace("Removed filters from FilteredDataset: { deparse1(self$get_dataname()) }")
|
| 166 | -23x | +105 | +14x |
- private$set_choices(slice$choices)+ NULL |
| 167 | -15x | +|||
| 106 | +
- if (is.null(slice$selected)) slice$selected <- slice$choices+ }, |
|||
| 168 | -23x | +|||
| 107 | +
- private$set_selected(slice$selected)+ |
|||
| 169 | +108 |
- })+ # managing filter states ----- |
||
| 170 | +109 | |||
| 171 | -22x | +|||
| 110 | +
- invisible(self)+ # getters ---- |
|||
| 172 | +111 |
- },+ #' @description |
||
| 173 | +112 |
-
+ #' Gets a filter expression. |
||
| 174 | +113 |
- #' @description+ #' |
||
| 175 | +114 |
- #' Returns reproducible condition call for current selection.+ #' This function returns filter calls equivalent to selected items |
||
| 176 | +115 |
- #' For this class returned call looks like+ #' within each of `filter_states`. Configuration of the calls is constant and |
||
| 177 | +116 |
- #' `<varname> >= as.POSIXct(<min>) & <varname> <= <max>)` with optional `is.na(<varname>)`.+ #' depends on `filter_states` type and order which are set during initialization. |
||
| 178 | +117 |
- #' @param dataname name of data set; defaults to `private$get_dataname()`+ #' |
||
| 179 | +118 |
- #' @return `call`+ #' @param sid (`character`) |
||
| 180 | +119 |
- #'+ #' when specified, the method returns code containing conditions calls of |
||
| 181 | +120 |
- get_call = function(dataname) {
+ #' `FilterState` objects with `sid` different to this `sid` argument. |
||
| 182 | -7x | +|||
| 121 | +
- if (isFALSE(private$is_any_filtered())) {
+ #' |
|||
| 183 | -1x | +|||
| 122 | +
- return(NULL)+ #' @return Either a `list` of filter `call`s, or `NULL`. |
|||
| 184 | +123 |
- }+ get_call = function(sid = "") {
|
||
| 185 | -4x | +124 | +47x |
- if (missing(dataname)) dataname <- private$get_dataname()+ filter_call <- Filter( |
| 186 | -6x | -
- varname <- private$get_varname_prefixed(dataname)- |
- ||
| 187 | -6x | +125 | +47x |
- choices <- private$get_selected()+ f = Negate(is.null), |
| 188 | -6x | +126 | +47x |
- tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone"))+ x = lapply(private$get_filter_states(), function(x) x$get_call(sid)) |
| 189 | -6x | +|||
| 127 | +
- class <- class(choices)[1L]+ ) |
|||
| 190 | -6x | +128 | +47x |
- date_fun <- as.name(+ if (length(filter_call) == 0) {
|
| 191 | -6x | +129 | +29x |
- switch(class,+ return(NULL) |
| 192 | -6x | +|||
| 130 | +
- "POSIXct" = "as.POSIXct",+ } |
|||
| 193 | -6x | +131 | +18x |
- "POSIXlt" = "as.POSIXlt"+ filter_call |
| 194 | +132 |
- )+ }, |
||
| 195 | +133 |
- )- |
- ||
| 196 | -6x | -
- choices <- as.character(choices + c(0, 1))- |
- ||
| 197 | -6x | -
- filter_call <-- |
- ||
| 198 | -6x | -
- call(+ |
||
| 199 | +134 |
- "&",- |
- ||
| 200 | -6x | -
- call(+ #' @description |
||
| 201 | +135 |
- ">=",- |
- ||
| 202 | -6x | -
- varname,+ #' Gets states of all contained `FilterState` objects. |
||
| 203 | -6x | +|||
| 136 | +
- as.call(list(date_fun, choices[1L], tz = tzone))+ #' |
|||
| 204 | +137 |
- ),+ #' @return A `teal_slices` object. |
||
| 205 | -6x | +|||
| 138 | +
- call(+ #' |
|||
| 206 | +139 |
- "<",+ get_filter_state = function() {
|
||
| 207 | -6x | +140 | +184x |
- varname,+ states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state())) |
| 208 | -6x | +141 | +184x |
- as.call(list(date_fun, choices[2L], tz = tzone))+ do.call(c, states) |
| 209 | +142 |
- )+ }, |
||
| 210 | +143 |
- )- |
- ||
| 211 | -6x | -
- private$add_keep_na_call(filter_call, varname)+ |
||
| 212 | +144 |
- }+ #' @description |
||
| 213 | +145 |
- ),+ #' Set filter state. |
||
| 214 | +146 |
-
+ #' |
||
| 215 | +147 |
- # private members ----+ #' @param state (`teal_slices`) |
||
| 216 | +148 |
-
+ #' |
||
| 217 | +149 |
- private = list(+ #' @return Virtual method, returns nothing and raises error. |
||
| 218 | +150 |
- # private methods ----+ #' |
||
| 219 | +151 |
- set_choices = function(choices) {
- |
- ||
| 220 | -23x | -
- if (is.null(choices)) {
+ set_filter_state = function(state) {
|
||
| 221 | -20x | +|||
| 152 | +! |
- choices <- as.POSIXct(trunc(range(private$x, na.rm = TRUE), units = "secs"))+ stop("set_filter_state is an abstract class method.")
|
||
| 222 | +153 |
- } else {
+ }, |
||
| 223 | -3x | +|||
| 154 | +
- choices <- as.POSIXct(choices, units = "secs")+ |
|||
| 224 | -3x | +|||
| 155 | +
- choices_adjusted <- c(+ #' @description |
|||
| 225 | -3x | +|||
| 156 | +
- max(choices[1L], min(as.POSIXct(private$x), na.rm = TRUE)),+ #' Gets the number of `FilterState` objects in all `FilterStates` in this `FilteredDataset`. |
|||
| 226 | -3x | +|||
| 157 | +
- min(choices[2L], max(as.POSIXct(private$x), na.rm = TRUE))+ #' @return `integer(1)` |
|||
| 227 | +158 |
- )+ get_filter_count = function() {
|
||
| 228 | -3x | +159 | +16x |
- if (any(choices != choices_adjusted)) {
+ length(self$get_filter_state()) |
| 229 | -1x | +|||
| 160 | +
- warning(sprintf(+ }, |
|||
| 230 | -1x | +|||
| 161 | +
- "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",+ |
|||
| 231 | -1x | +|||
| 162 | +
- private$get_varname(), private$get_dataname()+ #' @description |
|||
| 232 | +163 |
- ))+ #' Gets the name of the dataset. |
||
| 233 | -1x | +|||
| 164 | +
- choices <- choices_adjusted+ #' |
|||
| 234 | +165 |
- }+ #' @return A character string. |
||
| 235 | -3x | +|||
| 166 | +
- if (choices[1L] >= choices[2L]) {
+ get_dataname = function() {
|
|||
| 236 | -1x | +167 | +8x |
- warning(sprintf(+ private$dataname |
| 237 | -1x | +|||
| 168 | +
- "Invalid choices: lower is higher / equal to upper, or not in range of variable values.+ }, |
|||
| 238 | -1x | +|||
| 169 | +
- Setting defaults. Varname: %s, dataname: %s.",+ |
|||
| 239 | -1x | +|||
| 170 | +
- private$get_varname(), private$get_dataname()+ #' @description |
|||
| 240 | +171 |
- ))+ #' Gets the dataset object in this `FilteredDataset`. |
||
| 241 | -1x | +|||
| 172 | +
- choices <- range(private$x, na.rm = TRUE)+ #' |
|||
| 242 | +173 |
- }+ #' @param filtered (`logical(1)`) |
||
| 243 | +174 |
- }+ #' |
||
| 244 | +175 |
-
+ #' @return |
||
| 245 | -23x | +|||
| 176 | +
- private$set_is_choice_limited(private$x, choices)+ #' The stored dataset. If `data.frame` or `MultiAssayExperiment`, |
|||
| 246 | -23x | +|||
| 177 | +
- private$x <- private$x[+ #' either raw or as a reactive with current filters applied (depending on `filtered`). |
|||
| 247 | +178 |
- (+ #' |
||
| 248 | -23x | +|||
| 179 | +
- as.POSIXct(trunc(private$x, units = "secs")) >= choices[1L] &+ get_dataset = function(filtered = FALSE) {
|
|||
| 249 | -23x | +180 | +51x |
- as.POSIXct(trunc(private$x, units = "secs")) <= choices[2L]+ if (filtered) {
|
| 250 | -23x | +181 | +33x |
- ) | is.na(private$x)+ private$data_filtered |
| 251 | +182 |
- ]+ } else {
|
||
| 252 | -23x | +183 | +18x |
- private$teal_slice$choices <- choices+ private$dataset |
| 253 | -23x | +|||
| 184 | +
- invisible(NULL)+ } |
|||
| 254 | +185 |
}, |
||
| 255 | +186 | |||
| 256 | +187 |
- # @description+ #' @description |
||
| 257 | +188 |
- # Check whether the initial choices filter out some values of x and set the flag in case.+ #' Get filter overview of a dataset. |
||
| 258 | +189 |
- set_is_choice_limited = function(xl, choices = NULL) {
+ #' @return Virtual method, returns nothing and raises an error. |
||
| 259 | -23x | +|||
| 190 | +
- private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE))+ get_filter_overview = function() {
|
|||
| 260 | -23x | +|||
| 191 | +! |
- invisible(NULL)+ stop("get_filter_overview is an abstract class method")
|
||
| 261 | +192 |
}, |
||
| 262 | +193 |
- cast_and_validate = function(values) {
+
|
||
| 263 | -34x | +|||
| 194 | +
- tryCatch(+ #' @description |
|||
| 264 | -34x | +|||
| 195 | +
- expr = {
+ #' Gets the key columns for this dataset. |
|||
| 265 | -34x | +|||
| 196 | +
- values <- as.POSIXct(values, origin = "1970-01-01 00:00:00")+ #' @return Character vector of variable names |
|||
| 266 | -! | +|||
| 197 | +
- if (anyNA(values)) stop()+ get_keys = function() {
|
|||
| 267 | -31x | +198 | +133x |
- values+ private$keys |
| 268 | +199 |
- },+ }, |
||
| 269 | -34x | +|||
| 200 | +
- error = function(e) stop("Vector of set values must contain values coercible to POSIX.")
+
|
|||
| 270 | +201 |
- )+ #' @description |
||
| 271 | +202 |
- },+ #' Gets the dataset label. |
||
| 272 | +203 |
- check_length = function(values) {
- |
- ||
| 273 | -1x | -
- if (length(values) != 2) stop("Vector of set values must have length two.")
- |
- ||
| 274 | -30x | -
- if (values[1] > values[2]) {
- |
- ||
| 275 | -1x | -
- warning(- |
- ||
| 276 | -1x | -
- sprintf(- |
- ||
| 277 | -1x | -
- "Start date '%s' is set after the end date '%s', the values will be replaced by a default datetime range.",- |
- ||
| 278 | -1x | -
- values[1], values[2]- |
- ||
| 279 | -- |
- )- |
- ||
| 280 | -- |
- )- |
- ||
| 281 | -1x | -
- values <- isolate(private$get_choices())+ #' @return Character string. |
||
| 282 | +204 |
- }+ get_dataset_label = function() {
|
||
| 283 | -30x | +205 | +2x |
- values+ private$label |
| 284 | +206 |
}, |
||
| 285 | -- |
- remove_out_of_bounds_values = function(values) {
- |
- ||
| 286 | -30x | -
- choices <- private$get_choices()- |
- ||
| 287 | -30x | -
- if (values[1] < choices[1L] || values[1] > choices[2L]) {
- |
- ||
| 288 | -5x | -
- warning(- |
- ||
| 289 | -5x | -
- sprintf(- |
- ||
| 290 | -5x | -
- "Value: %s is outside of the range for the column '%s' in dataset '%s', setting minimum possible value.",- |
- ||
| 291 | -5x | -
- values[1], private$get_varname(), toString(private$get_dataname())- |
- ||
| 292 | -- |
- )- |
- ||
| 293 | -- |
- )- |
- ||
| 294 | -5x | -
- values[1] <- choices[1L]- |
- ||
| 295 | -- |
- }- |
- ||
| 296 | -- | - - | -||
| 297 | -30x | -
- if (values[2] > choices[2L] | values[2] < choices[1L]) {
- |
- ||
| 298 | -5x | -
- warning(- |
- ||
| 299 | -5x | -
- sprintf(- |
- ||
| 300 | -5x | -
- "Value: '%s' is outside of the range for the column '%s' in dataset '%s', setting maximum possible value.",- |
- ||
| 301 | -5x | -
- values[2], private$get_varname(), toString(private$get_dataname())- |
- ||
| 302 | -- |
- )- |
- ||
| 303 | -- |
- )- |
- ||
| 304 | -5x | -
- values[2] <- choices[2L]- |
- ||
| 305 | -- |
- }- |
- ||
| 306 | +207 | |||
| 307 | -30x | -
- values- |
- ||
| 308 | -- |
- },- |
- ||
| 309 | +208 |
-
+ # modules ------ |
||
| 310 | +209 |
- # shiny modules ----+ #' @description |
||
| 311 | +210 |
-
+ #' `shiny` module containing active filters for a dataset, along with a title and a remove button. |
||
| 312 | +211 |
- # @description+ #' @param id (`character(1)`) |
||
| 313 | +212 |
- # UI Module for `DatetimeFilterState`.+ #' `shiny` module instance id. |
||
| 314 | +213 |
- # This UI element contains two date-time selections for `min` and `max`+ #' |
||
| 315 | +214 |
- # of the range and a checkbox whether to keep the `NA` values.+ #' @return `shiny.tag` |
||
| 316 | +215 |
- # @param id (`character(1)`) `shiny` module instance id.+ ui_active = function(id) {
|
||
| 317 | -+ | |||
| 216 | +! |
- ui_inputs = function(id) {
+ dataname <- self$get_dataname() |
||
| 318 | +217 | ! |
- ns <- NS(id)+ checkmate::assert_string(dataname) |
|
| 319 | +218 | |||
| 320 | +219 | ! |
- isolate({
+ ns <- NS(id) |
|
| 321 | +220 | ! |
- ui_input_1 <- shinyWidgets::airDatepickerInput(+ if_multiple_filter_states <- length(private$get_filter_states()) > 1 |
|
| 322 | +221 | ! |
- inputId = ns("selection_start"),
+ tags$span( |
|
| 323 | +222 | ! |
- value = private$get_selected()[1],+ id = id, |
|
| 324 | +223 | ! |
- startView = private$get_selected()[1],+ include_css_files("filter-panel"),
|
|
| 325 | +224 | ! |
- timepicker = TRUE,+ tags$div( |
|
| 326 | +225 | ! |
- minDate = private$get_choices()[1L],+ id = ns("whole_ui"), # to hide it entirely
|
|
| 327 | +226 | ! |
- maxDate = private$get_choices()[2L],+ fluidRow( |
|
| 328 | +227 | ! |
- update_on = "close",+ column( |
|
| 329 | +228 | ! |
- addon = "none",+ width = 8, |
|
| 330 | +229 | ! |
- position = "bottom right"+ tags$span(dataname, class = "filter_panel_dataname") |
|
| 331 | +230 |
- )+ ), |
||
| 332 | +231 | ! |
- ui_input_2 <- shinyWidgets::airDatepickerInput(+ column( |
|
| 333 | +232 | ! |
- inputId = ns("selection_end"),
+ width = 4, |
|
| 334 | +233 | ! |
- value = private$get_selected()[2],+ tagList( |
|
| 335 | +234 | ! |
- startView = private$get_selected()[2],+ actionLink( |
|
| 336 | +235 | ! |
- timepicker = TRUE,+ ns("remove_filters"),
|
|
| 337 | +236 | ! |
- minDate = private$get_choices()[1L],+ label = "", |
|
| 338 | +237 | ! |
- maxDate = private$get_choices()[2L],+ icon = icon("circle-xmark", lib = "font-awesome"),
|
|
| 339 | +238 | ! |
- update_on = "close",+ class = "remove pull-right" |
|
| 340 | -! | +|||
| 239 | +
- addon = "none",+ ), |
|||
| 341 | +240 | ! |
- position = "bottom right"+ actionLink( |
|
| 342 | -+ | |||
| 241 | +! |
- )+ ns("collapse"),
|
||
| 343 | +242 | ! |
- ui_reset_1 <- actionButton(+ label = "", |
|
| 344 | +243 | ! |
- class = "date_reset_button",+ icon = icon("angle-down", lib = "font-awesome"),
|
|
| 345 | +244 | ! |
- inputId = ns("start_date_reset"),
+ class = "remove pull-right" |
|
| 346 | -! | +|||
| 245 | +
- label = NULL,+ ) |
|||
| 347 | -! | +|||
| 246 | +
- icon = icon("fas fa-undo")
+ ) |
|||
| 348 | +247 |
- )+ ) |
||
| 349 | -! | +|||
| 248 | +
- ui_reset_2 <- actionButton(+ ), |
|||
| 350 | +249 | ! |
- class = "date_reset_button",+ shinyjs::hidden( |
|
| 351 | +250 | ! |
- inputId = ns("end_date_reset"),
+ tags$div( |
|
| 352 | +251 | ! |
- label = NULL,+ id = ns("filter_count_ui"),
|
|
| 353 | +252 | ! |
- icon = icon("fas fa-undo")
+ tagList( |
|
| 354 | -+ | |||
| 253 | +! |
- )+ textOutput(ns("filter_count")),
|
||
| 355 | +254 | ! |
- ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm"))+ tags$br() |
|
| 356 | -! | +|||
| 255 | +
- ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm"))+ ) |
|||
| 357 | +256 |
-
+ ) |
||
| 358 | -! | +|||
| 257 | +
- tags$div(+ ), |
|||
| 359 | +258 | ! |
tags$div( |
|
| 360 | -! | +|||
| 259 | +
- class = "flex",+ # id needed to insert and remove UI to filter single variable as needed |
|||
| 361 | -! | +|||
| 260 | +
- ui_reset_1,+ # it is currently also used by the above module to entirely hide this panel |
|||
| 362 | +261 | ! |
- tags$div(+ id = ns("filters"),
|
|
| 363 | +262 | ! |
- class = "flex w-80 filter_datelike_input",+ class = "parent-hideable-list-group", |
|
| 364 | +263 | ! |
- tags$div(class = "w-45 text-center", ui_input_1),+ tagList( |
|
| 365 | +264 | ! |
- tags$span(+ lapply( |
|
| 366 | +265 | ! |
- class = "input-group-addon w-10",+ names(private$get_filter_states()), |
|
| 367 | +266 | ! |
- tags$span(class = "input-group-text w-100 justify-content-center", "to"),+ function(x) {
|
|
| 368 | +267 | ! |
- title = "Times are displayed in the local timezone and are converted to UTC in the analysis"+ tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x))) |
|
| 369 | +268 |
- ),- |
- ||
| 370 | -! | -
- tags$div(class = "w-45 text-center", ui_input_2)+ } |
||
| 371 | +269 |
- ),- |
- ||
| 372 | -! | -
- ui_reset_2+ ) |
||
| 373 | +270 |
- ),+ ) |
||
| 374 | -! | +|||
| 271 | +
- private$keep_na_ui(ns("keep_na"))
+ ) |
|||
| 375 | +272 |
) |
||
| 376 | +273 |
- })+ ) |
||
| 377 | +274 |
}, |
||
| 378 | +275 | |||
| 379 | +276 |
- # @description+ #' @description |
||
| 380 | +277 |
- # Server module+ #' Server module for a dataset active filters. |
||
| 381 | +278 |
- # @param id (`character(1)`) `shiny` module instance id.+ #' |
||
| 382 | +279 |
- # @return `NULL`.+ #' @param id (`character(1)`) |
||
| 383 | +280 |
- server_inputs = function(id) {
- |
- ||
| 384 | -! | -
- moduleServer(+ #' `shiny` module instance id. |
||
| 385 | -! | +|||
| 281 | +
- id = id,+ #' @return `NULL`. |
|||
| 386 | -! | +|||
| 282 | +
- function(input, output, session) {
+ srv_active = function(id) {
|
|||
| 387 | -! | +|||
| 283 | +7x |
- logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
+ moduleServer( |
||
| 388 | -+ | |||
| 284 | +7x |
- # this observer is needed in the situation when teal_slice$selected has been+ id = id, |
||
| 389 | -+ | |||
| 285 | +7x |
- # changed directly by the api - then it's needed to rerender UI element+ function(input, output, session) {
|
||
| 390 | -+ | |||
| 286 | +7x |
- # to show relevant values+ dataname <- self$get_dataname() |
||
| 391 | -! | +|||
| 287 | +7x |
- private$observers$selection_api <- observeEvent(+ logger::log_trace("FilteredDataset$srv_active initializing, dataname: { dataname }")
|
||
| 392 | -! | +|||
| 288 | +7x |
- ignoreNULL = TRUE, # dates needs to be selected+ checkmate::assert_string(dataname) |
||
| 393 | -! | +|||
| 289 | +7x |
- ignoreInit = TRUE, # on init selected == default, so no need to trigger+ output$filter_count <- renderText( |
||
| 394 | -! | +|||
| 290 | +7x |
- eventExpr = private$get_selected(),+ sprintf( |
||
| 395 | -! | +|||
| 291 | +7x |
- handlerExpr = {
+ "%d filter%s applied", |
||
| 396 | -! | +|||
| 292 | +7x |
- start_date <- input$selection_start+ self$get_filter_count(), |
||
| 397 | -! | +|||
| 293 | +7x |
- end_date <- input$selection_end+ if (self$get_filter_count() != 1) "s" else "" |
||
| 398 | -! | +|||
| 294 | +
- if (!all(private$get_selected() == c(start_date, end_date))) {
+ ) |
|||
| 399 | -! | +|||
| 295 | +
- logger::log_trace("DatetimeFilterState$server@1 state changed, id: { private$get_id() }")
+ ) |
|||
| 400 | -! | +|||
| 296 | +
- if (private$get_selected()[1] != start_date) {
+
|
|||
| 401 | -! | +|||
| 297 | +7x |
- shinyWidgets::updateAirDateInput(+ lapply( |
||
| 402 | -! | +|||
| 298 | +7x |
- session = session,+ names(private$get_filter_states()), |
||
| 403 | -! | +|||
| 299 | +7x |
- inputId = "selection_start",+ function(x) {
|
||
| 404 | -! | +|||
| 300 | +12x |
- value = private$get_selected()[1]+ private$get_filter_states()[[x]]$srv_active(id = x) |
||
| 405 | +301 |
- )+ } |
||
| 406 | +302 |
- }+ ) |
||
| 407 | +303 | |||
| 408 | -! | +|||
| 304 | +7x |
- if (private$get_selected()[2] != end_date) {
+ observeEvent(self$get_filter_state(), {
|
||
| 409 | -! | +|||
| 305 | +8x |
- shinyWidgets::updateAirDateInput(+ shinyjs::hide("filter_count_ui")
|
||
| 410 | -! | +|||
| 306 | +8x |
- session = session,+ shinyjs::show("filters")
|
||
| 411 | -! | +|||
| 307 | +8x |
- inputId = "selection_end",+ shinyjs::toggle("remove_filters", condition = length(self$get_filter_state()) != 0)
|
||
| 412 | -! | +|||
| 308 | +8x |
- value = private$get_selected()[2]+ shinyjs::toggle("collapse", condition = length(self$get_filter_state()) != 0)
|
||
| 413 | +309 |
- )+ }) |
||
| 414 | +310 |
- }+ |
||
| 415 | -+ | |||
| 311 | +7x |
- }+ observeEvent(input$collapse, {
|
||
| 416 | -+ | |||
| 312 | +! |
- }+ shinyjs::toggle("filter_count_ui")
|
||
| 417 | -+ | |||
| 313 | +! |
- )+ shinyjs::toggle("filters")
+ |
+ ||
| 314 | +! | +
+ toggle_icon(session$ns("collapse"), c("fa-angle-right", "fa-angle-down"))
|
||
| 418 | +315 |
-
+ }) |
||
| 419 | +316 | |||
| 420 | -! | +|||
| 317 | +7x |
- private$observers$selection_start <- observeEvent(+ observeEvent(input$remove_filters, {
|
||
| 421 | -! | +|||
| 318 | +1x |
- ignoreNULL = TRUE, # dates needs to be selected+ logger::log_trace("FilteredDataset$srv_active@1 removing all non-anchored filters, dataname: { dataname }")
|
||
| 422 | -! | +|||
| 319 | +1x |
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ self$clear_filter_states() |
||
| 423 | -! | +|||
| 320 | +1x |
- eventExpr = input$selection_start,+ logger::log_trace("FilteredDataset$srv_active@1 removed all non-anchored filters, dataname: { dataname }")
|
||
| 424 | -! | +|||
| 321 | +
- handlerExpr = {
+ }) |
|||
| 425 | -! | +|||
| 322 | +
- logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
+
|
|||
| 426 | -! | +|||
| 323 | +7x |
- start_date <- input$selection_start+ logger::log_trace("FilteredDataset$initialized, dataname: { dataname }")
|
||
| 427 | -! | +|||
| 324 | +
- end_date <- private$get_selected()[[2]]+ |
|||
| 428 | -! | +|||
| 325 | +7x |
- tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))+ NULL |
||
| 429 | -! | +|||
| 326 | +
- attr(start_date, "tzone") <- tzone+ } |
|||
| 430 | +327 |
-
+ ) |
||
| 431 | -! | +|||
| 328 | +
- if (start_date > end_date) {
+ }, |
|||
| 432 | -! | +|||
| 329 | +
- showNotification(+ |
|||
| 433 | -! | +|||
| 330 | +
- "Start date must not be greater than the end date. Ignoring selection.",+ #' @description |
|||
| 434 | -! | +|||
| 331 | +
- type = "warning"+ #' UI module to add filter variable for this dataset. |
|||
| 435 | +332 |
- )+ #' |
||
| 436 | -! | +|||
| 333 | +
- shinyWidgets::updateAirDateInput(+ #' @param id (`character(1)`) |
|||
| 437 | -! | +|||
| 334 | +
- session = session,+ #' `shiny` module instance id. |
|||
| 438 | -! | +|||
| 335 | +
- inputId = "selection_start",+ #' |
|||
| 439 | -! | +|||
| 336 | +
- value = private$get_selected()[1] # sets back to latest selected value+ #' @return Virtual method, returns nothing and raises error. |
|||
| 440 | +337 |
- )+ ui_add = function(id) {
|
||
| 441 | -! | +|||
| 338 | +1x |
- return(NULL)+ stop("Pure virtual method")
|
||
| 442 | +339 |
- }+ }, |
||
| 443 | +340 | |||
| 444 | -! | +|||
| 341 | +
- private$set_selected(c(start_date, end_date))+ #' @description |
|||
| 445 | +342 |
- }+ #' Server module to add filter variable for this dataset. |
||
| 446 | +343 | ++ |
+ #' For this class `srv_add` calls multiple modules+ |
+ |
| 344 | ++ |
+ #' of the same name from `FilterStates` as `MAEFilteredDataset`+ |
+ ||
| 345 | ++ |
+ #' contains one `FilterStates` object for `colData` and one for each experiment.+ |
+ ||
| 346 | ++ |
+ #'+ |
+ ||
| 347 | ++ |
+ #' @param id (`character(1)`)+ |
+ ||
| 348 | ++ |
+ #' `shiny` module instance id.+ |
+ ||
| 349 | ++ |
+ #'+ |
+ ||
| 350 | ++ |
+ #' @return `NULL`.+ |
+ ||
| 351 | ++ |
+ srv_add = function(id) {
+ |
+ ||
| 352 | +2x | +
+ moduleServer(+ |
+ ||
| 353 | +2x | +
+ id = id,+ |
+ ||
| 354 | +2x | +
+ function(input, output, session) {
+ |
+ ||
| 355 | +2x | +
+ logger::log_trace("MAEFilteredDataset$srv_add initializing, dataname: { deparse1(self$get_dataname()) }")
+ |
+ ||
| 356 | +2x | +
+ elems <- private$get_filter_states()+ |
+ ||
| 357 | +2x | +
+ elem_names <- names(private$get_filter_states())+ |
+ ||
| 358 | +2x | +
+ lapply(+ |
+ ||
| 359 | +2x | +
+ elem_names,+ |
+ ||
| 360 | +2x | +
+ function(elem_name) elems[[elem_name]]$srv_add(elem_name)+ |
+ ||
| 361 |
) |
|||
| 362 | +2x | +
+ logger::log_trace("MAEFilteredDataset$srv_add initialized, dataname: { deparse1(self$get_dataname()) }")
+ |
+ ||
| 363 | +2x | +
+ NULL+ |
+ ||
| 364 | ++ |
+ }+ |
+ ||
| 365 | ++ |
+ )+ |
+ ||
| 366 | ++ |
+ }+ |
+ ||
| 367 | ++ |
+ ),+ |
+ ||
| 368 | ++ |
+ # private fields ----+ |
+ ||
| 369 | ++ |
+ private = list(+ |
+ ||
| 370 | ++ |
+ dataset = NULL, # data.frame or MultiAssayExperiment+ |
+ ||
| 371 | ++ |
+ data_filtered = NULL,+ |
+ ||
| 372 | ++ |
+ data_filtered_fun = NULL, # function+ |
+ ||
| 373 | ++ |
+ filter_states = list(),+ |
+ ||
| 374 | ++ |
+ dataname = character(0),+ |
+ ||
| 375 | ++ |
+ keys = character(0),+ |
+ ||
| 376 | ++ |
+ label = character(0),+ |
+ ||
| 377 | ++ | + + | +||
| 378 | ++ |
+ # Adds `FilterStates` to the `private$filter_states`.+ |
+ ||
| 379 | ++ |
+ # `FilterStates` is added once for each element of the dataset.+ |
+ ||
| 380 | ++ |
+ # @param filter_states (`FilterStates`)+ |
+ ||
| 381 | ++ |
+ # @param id (`character(1)`)+ |
+ ||
| 382 | ++ |
+ add_filter_states = function(filter_states, id) {
+ |
+ ||
| 383 | +225x | +
+ checkmate::assert_class(filter_states, "FilterStates")+ |
+ ||
| 384 | +225x | +
+ checkmate::assert_string(id)+ |
+ ||
| 385 | +225x | +
+ x <- stats::setNames(list(filter_states), id)+ |
+ ||
| 386 | +225x | +
+ private$filter_states <- c(private$get_filter_states(), x)+ |
+ ||
| 387 | ++ |
+ },+ |
+ ||
| 388 | ++ | + + | +||
| 389 | ++ |
+ # @description+ |
+ ||
| 390 | ++ |
+ # Gets `FilterStates` objects in this `FilteredDataset`.+ |
+ ||
| 391 | ++ |
+ # @return list of `FilterStates` objects.+ |
+ ||
| 392 | ++ |
+ get_filter_states = function() {
+ |
+ ||
| 393 | +684x | +
+ private$filter_states+ |
+ ||
| 394 | ++ |
+ }+ |
+ ||
| 395 | ++ |
+ )+ |
+ ||
| 396 | ++ |
+ )+ |
+
| 1 | ++ |
+ # DataframeFilteredDataset ------+ |
+ |
| 2 | ++ | + + | +|
| 3 | ++ |
+ #' @name DataframeFilteredDataset+ |
+ |
| 4 | ++ |
+ #' @docType class+ |
+ |
| 5 | ++ |
+ #' @title The `DataframeFilteredDataset` `R6` class+ |
+ |
| 6 | ++ |
+ #'+ |
+ |
| 7 | ++ |
+ #' @examples+ |
+ |
| 8 | ++ |
+ #' # use non-exported function from teal.slice+ |
+ |
| 9 | ++ |
+ #' DataframeFilteredDataset <- getFromNamespace("DataframeFilteredDataset", "teal.slice")
+ |
+ |
| 10 | ++ |
+ #'+ |
+ |
| 11 | ++ |
+ #' library(shiny)+ |
+ |
| 12 | ++ |
+ #'+ |
+ |
| 13 | ++ |
+ #' ds <- DataframeFilteredDataset$new(iris, "iris")+ |
+ |
| 14 | ++ |
+ #' ds$set_filter_state(+ |
+ |
| 15 | ++ |
+ #' teal_slices(+ |
+ |
| 16 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),+ |
+ |
| 17 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))+ |
+ |
| 18 | ++ |
+ #' )+ |
+ |
| 19 | ++ |
+ #' )+ |
+ |
| 20 | ++ |
+ #' isolate(ds$get_filter_state())+ |
+ |
| 21 | ++ |
+ #' isolate(ds$get_call())+ |
+ |
| 22 | ++ |
+ #'+ |
+ |
| 23 | ++ |
+ #' ## set_filter_state+ |
+ |
| 24 | ++ |
+ #' dataset <- DataframeFilteredDataset$new(iris, "iris")+ |
+ |
| 25 | ++ |
+ #' fs <- teal_slices(+ |
+ |
| 26 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),+ |
+ |
| 27 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))+ |
+ |
| 28 | ++ |
+ #' )+ |
+ |
| 29 | ++ |
+ #' dataset$set_filter_state(state = fs)+ |
+ |
| 30 | ++ |
+ #' isolate(dataset$get_filter_state())+ |
+ |
| 31 | ++ |
+ #'+ |
+ |
| 32 | ++ |
+ #' @keywords internal+ |
+ |
| 33 | ++ |
+ #'+ |
+ |
| 34 | ++ |
+ DataframeFilteredDataset <- R6::R6Class( # nolint+ |
+ |
| 35 | ++ |
+ classname = "DataframeFilteredDataset",+ |
+ |
| 36 | ++ |
+ inherit = FilteredDataset,+ |
+ |
| 37 | ++ | + + | +|
| 38 | ++ |
+ # public fields ----+ |
+ |
| 39 | ++ |
+ public = list(+ |
+ |
| 40 | ++ | + + | +|
| 41 | ++ |
+ #' @description+ |
+ |
| 42 | ++ |
+ #' Initializes this `DataframeFilteredDataset` object.+ |
+ |
| 43 | ++ |
+ #'+ |
+ |
| 44 | ++ |
+ #' @param dataset (`data.frame`)+ |
+ |
| 45 | ++ |
+ #' single `data.frame` for which filters are rendered.+ |
+ |
| 46 | ++ |
+ #' @param dataname (`character(1)`)+ |
+ |
| 47 | ++ |
+ #' syntactically valid name given to the dataset.+ |
+ |
| 48 | ++ |
+ #' @param keys (`character`) optional+ |
+ |
| 49 | ++ |
+ #' vector of primary key column names.+ |
+ |
| 50 | ++ |
+ #' @param parent_name (`character(1)`)+ |
+ |
| 51 | ++ |
+ #' name of the parent dataset.+ |
+ |
| 52 | ++ |
+ #' @param parent (`reactive`)+ |
+ |
| 53 | ++ |
+ #' that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`.+ |
+ |
| 54 | ++ |
+ #' Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset`+ |
+ |
| 55 | ++ |
+ #' based on the changes in `parent`.+ |
+ |
| 56 | ++ |
+ #' @param join_keys (`character`)+ |
+ |
| 57 | ++ |
+ #' vector of names of columns in this dataset to join with `parent` dataset.+ |
+ |
| 58 | ++ |
+ #' If column names in the parent do not match these, they should be given as the names of this vector.+ |
+ |
| 447 | +59 | ++ |
+ #' @param label (`character(1)`)+ |
+
| 60 | ++ |
+ #' label to describe the dataset.+ |
+ |
| 61 | ++ |
+ #'+ |
+ |
| 62 | ++ |
+ #' @return Object of class `DataframeFilteredDataset`, invisibly.+ |
+ |
| 63 | ++ |
+ #'+ |
+ |
| 64 | ++ |
+ initialize = function(dataset,+ |
+ |
| 65 | ++ |
+ dataname,+ |
+ |
| 66 | ++ |
+ keys = character(0),+ |
+ |
| 67 | ++ |
+ parent_name = character(0),+ |
+ |
| 68 | ++ |
+ parent = NULL,+ |
+ |
| 69 | ++ |
+ join_keys = character(0),+ |
+ |
| 70 | ++ |
+ label = character(0)) {
+ |
+ |
| 71 | +103x | +
+ checkmate::assert_data_frame(dataset)+ |
+ |
| 72 | +101x | +
+ super$initialize(dataset, dataname, keys, label)+ |
+ |
| 73 | |||
| 448 | -! | +||
| 74 | +
- private$observers$selection_end <- observeEvent(+ # overwrite filtered_data if there is relationship with parent dataset |
||
| 449 | -! | +||
| 75 | +99x |
- ignoreNULL = TRUE, # dates needs to be selected+ if (!is.null(parent)) {
|
|
| 450 | -! | +||
| 76 | +10x |
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ checkmate::assert_character(parent_name, len = 1) |
|
| 451 | -! | +||
| 77 | +10x |
- eventExpr = input$selection_end,+ checkmate::assert_character(join_keys, min.len = 1)+ |
+ |
| 78 | ++ | + + | +|
| 79 | +10x | +
+ private$parent_name <- parent_name+ |
+ |
| 80 | +10x | +
+ private$join_keys <- join_keys+ |
+ |
| 81 | ++ | + + | +|
| 82 | +10x | +
+ private$data_filtered_fun <- function(sid = "") {
+ |
+ |
| 83 | +8x | +
+ checkmate::assert_character(sid)+ |
+ |
| 84 | +8x | +
+ if (length(sid)) {
+ |
+ |
| 85 | +8x | +
+ logger::log_trace("filtering data dataname: { dataname }, sid: { sid }")
+ |
+ |
| 86 | ++ |
+ } else {
|
|
| 452 | +87 | ! |
- handlerExpr = {
+ logger::log_trace("filtering data dataname: { private$dataname }")
+ |
+
| 88 | ++ |
+ }+ |
+ |
| 89 | +8x | +
+ env <- new.env(parent = parent.env(globalenv()))+ |
+ |
| 90 | +8x | +
+ env[[dataname]] <- private$dataset+ |
+ |
| 91 | +8x | +
+ env[[parent_name]] <- parent()+ |
+ |
| 92 | +8x | +
+ filter_call <- self$get_call(sid)+ |
+ |
| 93 | +8x | +
+ eval_expr_with_msg(filter_call, env)+ |
+ |
| 94 | +8x | +
+ get(x = dataname, envir = env)+ |
+ |
| 95 | ++ |
+ }+ |
+ |
| 96 | ++ |
+ }+ |
+ |
| 97 | ++ | + + | +|
| 98 | +99x | +
+ private$add_filter_states(+ |
+ |
| 99 | +99x | +
+ filter_states = init_filter_states(+ |
+ |
| 100 | +99x | +
+ data = dataset,+ |
+ |
| 101 | +99x | +
+ data_reactive = private$data_filtered_fun,+ |
+ |
| 102 | +99x | +
+ dataname = dataname,+ |
+ |
| 103 | +99x | +
+ keys = self$get_keys()+ |
+ |
| 104 | ++ |
+ ),+ |
+ |
| 105 | +99x | +
+ id = "filter"+ |
+ |
| 106 | ++ |
+ )+ |
+ |
| 107 | ++ | + + | +|
| 108 | ++ |
+ # todo: Should we make these defaults? It could be handled by the app developer+ |
+ |
| 109 | +99x | +
+ if (!is.null(parent)) {
+ |
+ |
| 110 | +10x | +
+ fs <- teal_slices(+ |
+ |
| 111 | +10x | +
+ exclude_varnames = structure(+ |
+ |
| 112 | +10x | +
+ list(intersect(colnames(dataset), colnames(isolate(parent())))),+ |
+ |
| 113 | +10x | +
+ names = private$dataname+ |
+ |
| 114 | ++ |
+ )+ |
+ |
| 115 | ++ |
+ )+ |
+ |
| 116 | +10x | +
+ self$set_filter_state(fs)+ |
+ |
| 117 | ++ |
+ }+ |
+ |
| 118 | ++ | + + | +|
| 119 | +99x | +
+ invisible(self)+ |
+ |
| 120 | ++ |
+ },+ |
+ |
| 121 | ++ | + + | +|
| 122 | ++ |
+ #' @description+ |
+ |
| 123 | ++ |
+ #' Gets the subset expression.+ |
+ |
| 124 | ++ |
+ #'+ |
+ |
| 125 | ++ |
+ #' This function returns subset expressions equivalent to selected items+ |
+ |
| 126 | ++ |
+ #' within each of `filter_states`. Configuration of the expressions is constant and+ |
+ |
| 127 | ++ |
+ #' depends on `filter_states` type and order which are set during initialization.+ |
+ |
| 128 | ++ |
+ #' This class contains single `FilterStates` which contains single `state_list`+ |
+ |
| 129 | ++ |
+ #' and all `FilterState` objects apply to one argument (`...`) in a `dplyr::filter` call.+ |
+ |
| 130 | ++ |
+ #'+ |
+ |
| 131 | ++ |
+ #' @param sid (`character`) |
|
| 453 | -! | +||
| 132 | +
- start_date <- private$get_selected()[1]+ #' when specified, the method returns code containing conditions calls of |
||
| 454 | -! | +||
| 133 | +
- end_date <- input$selection_end+ #' `FilterState` objects with `sid` different to that of this `sid` argument. |
||
| 455 | -! | +||
| 134 | +
- tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))+ #' |
||
| 456 | -! | +||
| 135 | +
- attr(end_date, "tzone") <- tzone+ #' @return Either a `list` of length 1 containing a filter `call`, or `NULL`. |
||
| 457 | +136 |
-
+ get_call = function(sid = "") {
|
|
| 458 | -! | +||
| 137 | +42x |
- if (start_date > end_date) {
+ logger::log_trace("DataframeFilteredDataset$get_call initializing for dataname: { private$dataname }")
|
|
| 459 | -! | +||
| 138 | +42x |
- showNotification(+ filter_call <- super$get_call(sid) |
|
| 460 | -! | +||
| 139 | +42x |
- "End date must not be lower than the start date. Ignoring selection.",+ dataname <- private$dataname |
|
| 461 | -! | +||
| 140 | +42x |
- type = "warning"+ parent_dataname <- private$parent_name |
|
| 462 | +141 |
- )+ |
|
| 463 | -! | +||
| 142 | +42x |
- shinyWidgets::updateAirDateInput(+ if (!identical(parent_dataname, character(0))) {
|
|
| 464 | -! | +||
| 143 | +9x |
- session = session,+ join_keys <- private$join_keys |
|
| 465 | -! | +||
| 144 | +9x |
- inputId = "selection_end",+ parent_keys <- unname(join_keys) |
|
| 466 | -! | +||
| 145 | +9x |
- value = private$get_selected()[2] # sets back to latest selected value+ dataset_keys <- names(join_keys) |
|
| 467 | +146 |
- )+ + |
+ |
| 147 | +9x | +
+ y_arg <- if (length(parent_keys) == 0L) {
|
|
| 468 | +148 | ! |
- return(NULL)+ parent_dataname |
| 469 | +149 |
- }+ } else {
|
|
| 470 | -+ | ||
| 150 | +9x |
-
+ sprintf( |
|
| 471 | -! | +||
| 151 | +9x |
- private$set_selected(c(start_date, end_date))+ "%s[, c(%s), drop = FALSE]", |
|
| 472 | -! | +||
| 152 | +9x |
- logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
+ parent_dataname, |
|
| 473 | -+ | ||
| 153 | +9x |
- }+ toString(dQuote(parent_keys, q = FALSE)) |
|
| 474 | +154 |
) |
|
| 475 | +155 | - - | -|
| 476 | -! | -
- private$keep_na_srv("keep_na")
+ } |
|
| 477 | +156 | ||
| 478 | -! | +||
| 157 | +9x |
- private$observers$reset1 <- observeEvent(+ more_args <- if (length(parent_keys) == 0 || length(dataset_keys) == 0) {
|
|
| 479 | +158 | ! |
- ignoreInit = TRUE, # reset button shouldn't be trigger on init+ list() |
| 480 | -! | +||
| 159 | +9x |
- ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL+ } else if (identical(parent_keys, dataset_keys)) {
|
|
| 481 | -! | +||
| 160 | +7x |
- input$start_date_reset,+ list(by = parent_keys) |
|
| 482 | +161 |
- {
+ } else {
|
|
| 483 | -! | +||
| 162 | +2x |
- shinyWidgets::updateAirDateInput(+ list(by = stats::setNames(parent_keys, dataset_keys)) |
|
| 484 | -! | +||
| 163 | +
- session = session,+ } |
||
| 485 | -! | +||
| 164 | +
- inputId = "selection_start",+ |
||
| 486 | -! | +||
| 165 | +9x |
- value = private$get_choices()[1L]+ merge_call <- call( |
|
| 487 | +166 |
- )+ "<-", |
|
| 488 | -! | +||
| 167 | +9x |
- logger::log_trace("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
+ as.name(dataname), |
|
| 489 | -+ | ||
| 168 | +9x |
- }+ as.call( |
|
| 490 | -+ | ||
| 169 | +9x |
- )+ c( |
|
| 491 | -! | +||
| 170 | +9x |
- private$observers$reset2 <- observeEvent(+ str2lang("dplyr::inner_join"),
|
|
| 492 | -! | +||
| 171 | +9x |
- ignoreInit = TRUE, # reset button shouldn't be trigger on init+ x = as.name(dataname), |
|
| 493 | -! | +||
| 172 | +9x |
- ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL+ y = str2lang(y_arg), |
|
| 494 | -! | +||
| 173 | +9x |
- input$end_date_reset,+ more_args |
|
| 495 | +174 |
- {
+ ) |
|
| 496 | -! | +||
| 175 | +
- shinyWidgets::updateAirDateInput(+ ) |
||
| 497 | -! | +||
| 176 | +
- session = session,+ ) |
||
| 498 | -! | +||
| 177 | +
- inputId = "selection_end",+ |
||
| 499 | -! | +||
| 178 | +9x |
- value = private$get_choices()[2L]+ filter_call <- c(filter_call, merge_call) |
|
| 500 | +179 |
- )+ } |
|
| 501 | -! | +||
| 180 | +42x |
- logger::log_trace("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
+ logger::log_trace("DataframeFilteredDataset$get_call initializing for dataname: { private$dataname }")
|
|
| 502 | -+ | ||
| 181 | +42x |
- }+ filter_call |
|
| 503 | +182 |
- )+ }, |
|
| 504 | +183 | ||
| 505 | -! | -
- logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
- |
- |
| 506 | -! | +||
| 184 | +
- NULL+ #' @description |
||
| 507 | +185 |
- }+ #' Set filter state. |
|
| 508 | +186 |
- )+ #' |
|
| 509 | +187 |
- },+ #' @param state (`teal_slices`) |
|
| 510 | +188 |
- server_inputs_fixed = function(id) {
+ #' @return `NULL`, invisibly. |
|
| 511 | -! | +||
| 189 | +
- moduleServer(+ #' |
||
| 512 | -! | +||
| 190 | +
- id = id,+ set_filter_state = function(state) {
|
||
| 513 | -! | +||
| 191 | +81x |
- function(input, output, session) {
+ isolate({
|
|
| 514 | -! | +||
| 192 | +81x |
- logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
|
|
| 515 | -+ | ||
| 193 | +81x |
-
+ checkmate::assert_class(state, "teal_slices") |
|
| 516 | -! | +||
| 194 | +80x |
- output$selection <- renderUI({
+ lapply(state, function(slice) {
|
|
| 517 | -! | +||
| 195 | +97x |
- vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3)+ checkmate::assert_true(slice$dataname == private$dataname) |
|
| 518 | -! | +||
| 196 | +
- tags$div(+ }) |
||
| 519 | -! | +||
| 197 | +80x |
- tags$div(icon("clock"), vals[1]),
+ private$get_filter_states()[[1L]]$set_filter_state(state = state) |
|
| 520 | -! | +||
| 198 | +80x |
- tags$div(span(" - "), icon("clock"), vals[2])
+ invisible(NULL) |
|
| 521 | +199 |
- )+ }) |
|
| 522 | +200 |
- })+ }, |
|
| 523 | +201 | ||
| 524 | -! | -
- logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
- |
- |
| 525 | -! | +||
| 202 | +
- NULL+ #' @description |
||
| 526 | +203 |
- }+ #' Remove one or more `FilterState` form a `FilteredDataset`. |
|
| 527 | +204 |
- )+ #' |
|
| 528 | +205 |
- },+ #' @param state (`teal_slices`) |
|
| 529 | +206 |
-
+ #' specifying `FilterState` objects to remove; |
|
| 530 | +207 |
- # @description+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored |
|
| 531 | +208 |
- # UI module to display filter summary+ #' |
|
| 532 | +209 |
- # renders text describing selected date range and+ #' @return `NULL`, invisibly. |
|
| 533 | +210 |
- # if NA are included also+ #' |
|
| 534 | +211 |
- content_summary = function(id) {
+ remove_filter_state = function(state) {
|
|
| 535 | -! | +||
| 212 | +11x |
- selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S")+ checkmate::assert_class(state, "teal_slices") |
|
| 536 | -! | +||
| 213 | +
- min <- selected[1]+ |
||
| 537 | -! | +||
| 214 | +11x |
- max <- selected[2]+ isolate({
|
|
| 538 | -! | +||
| 215 | +11x |
- tagList(+ logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")
|
|
| 539 | -! | +||
| 216 | +
- tags$span(+ |
||
| 540 | -! | +||
| 217 | +11x |
- class = "filter-card-summary-value",+ varnames <- unique(unlist(lapply(state, "[[", "varname"))) |
|
| 541 | -! | +||
| 218 | +11x |
- HTML(min, "–", max)+ private$get_filter_states()[[1]]$remove_filter_state(state) |
|
| 542 | +219 |
- ),+ |
|
| 543 | -! | +||
| 220 | +11x |
- tags$span(+ logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
|
|
| 544 | -! | +||
| 221 | +
- class = "filter-card-summary-controls",+ }) |
||
| 545 | -! | +||
| 222 | +
- if (private$na_count > 0) {
+
|
||
| 546 | -! | +||
| 223 | +11x |
- tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
+ invisible(NULL) |
|
| 547 | +224 |
- }+ }, |
|
| 548 | +225 |
- )+ |
|
| 549 | +226 |
- )+ #' @description |
|
| 550 | +227 |
- }+ #' UI module to add filter variable for this dataset. |
|
| 551 | +228 |
- )+ #' |
|
| 552 | +229 |
- )+ #' @param id (`character(1)`) |
| 1 | +230 |
- # MatrixFilterStates ------+ #' `shiny` module instance id. |
||
| 2 | +231 |
-
+ #' |
||
| 3 | +232 |
- #' @name MatrixFilterStates+ #' @return `shiny.tag` |
||
| 4 | +233 |
- #' @docType class+ ui_add = function(id) {
|
||
| 5 | -+ | |||
| 234 | +! |
- #' @title `FilterStates` subclass for matrices+ ns <- NS(id) |
||
| 6 | -+ | |||
| 235 | +! |
- #' @description Handles filter states in a `matrix`.+ tagList( |
||
| 7 | -+ | |||
| 236 | +! |
- #' @keywords internal+ tags$label("Add", tags$code(self$get_dataname()), "filter"),
|
||
| 8 | -+ | |||
| 237 | +! |
- #'+ private$get_filter_states()[["filter"]]$ui_add(id = ns("filter"))
|
||
| 9 | +238 |
- MatrixFilterStates <- R6::R6Class( # nolint+ ) |
||
| 10 | +239 |
- classname = "MatrixFilterStates",+ }, |
||
| 11 | +240 |
- inherit = FilterStates,+ |
||
| 12 | +241 |
-
+ #' @description |
||
| 13 | +242 |
- # public methods ----+ #' Creates row for filter overview in the form of \cr |
||
| 14 | +243 |
- public = list(+ #' `dataname -- observations (remaining/total)` - data.frame |
||
| 15 | +244 |
- #' @description+ #' @return A `data.frame`. |
||
| 16 | +245 |
- #' Initialize `MatrixFilterStates` object.+ get_filter_overview = function() {
|
||
| 17 | -+ | |||
| 246 | +12x |
- #'+ logger::log_trace("FilteredDataset$srv_filter_overview initialized")
|
||
| 18 | +247 |
- #' @param data (`matrix`)+ # Gets filter overview subjects number and returns a list |
||
| 19 | +248 |
- #' the `R` object which `subset` function is applied on.+ # of the number of subjects of filtered/non-filtered datasets |
||
| 20 | -+ | |||
| 249 | +12x |
- #' @param data_reactive (`function(sid)`)+ subject_keys <- if (length(private$parent_name) > 0) {
|
||
| 21 | -+ | |||
| 250 | +1x |
- #' should return a `matrix` object or `NULL`.+ names(private$join_keys) |
||
| 22 | +251 |
- #' This object is needed for the `FilterState` counts being updated on a change in filters.+ } else {
|
||
| 23 | -+ | |||
| 252 | +11x |
- #' If function returns `NULL` then filtered counts are not shown.+ self$get_keys() |
||
| 24 | +253 |
- #' Function has to have `sid` argument being a character.+ } |
||
| 25 | -+ | |||
| 254 | +12x |
- #' @param dataname (`character(1)`)+ dataset <- self$get_dataset() |
||
| 26 | -+ | |||
| 255 | +12x |
- #' name of the data used in the subset expression.+ data_filtered <- self$get_dataset(TRUE) |
||
| 27 | -+ | |||
| 256 | +12x |
- #' Passed to the function argument attached to this `FilterStates`.+ if (length(subject_keys) == 0) {
|
||
| 28 | -+ | |||
| 257 | +10x |
- #' @param datalabel (`character(1)`) optional+ data.frame( |
||
| 29 | -+ | |||
| 258 | +10x |
- #' text label. Should be a name of experiment.+ dataname = private$dataname, |
||
| 30 | -+ | |||
| 259 | +10x |
- #'+ obs = nrow(dataset), |
||
| 31 | -+ | |||
| 260 | +10x |
- initialize = function(data,+ obs_filtered = nrow(data_filtered()) |
||
| 32 | +261 |
- data_reactive = function(sid = "") NULL,+ ) |
||
| 33 | +262 |
- dataname,+ } else {
|
||
| 34 | -+ | |||
| 263 | +2x |
- datalabel = NULL) {
+ data.frame( |
||
| 35 | -26x | +264 | +2x |
- checkmate::assert_matrix(data)+ dataname = private$dataname, |
| 36 | -25x | +265 | +2x |
- super$initialize(data, data_reactive, dataname, datalabel)+ obs = nrow(dataset), |
| 37 | -25x | +266 | +2x |
- private$set_filterable_varnames(include_varnames = colnames(private$data))+ obs_filtered = nrow(data_filtered()),+ |
+
| 267 | +2x | +
+ subjects = nrow(unique(dataset[subject_keys])),+ |
+ ||
| 268 | +2x | +
+ subjects_filtered = nrow(unique(data_filtered()[subject_keys])) |
||
| 38 | +269 | ++ |
+ )+ |
+ |
| 270 | ++ |
+ }+ |
+ ||
| 271 |
} |
|||
| 39 | +272 |
), |
||
| 40 | +273 | ++ | + + | +|
| 274 | ++ |
+ # private fields ----+ |
+ ||
| 275 |
private = list( |
|||
| 41 | +276 |
- extract_type = "matrix"+ parent_name = character(0), |
||
| 42 | +277 | ++ |
+ join_keys = character(0)+ |
+ |
| 278 |
) |
|||
| 43 | +279 |
)@@ -50090,14 +49783,14 @@ teal.slice coverage - 65.96% |
| 1 |
- # ChoicesFilterState ------+ # DatetimeFilterState ------ |
|||
| 3 |
- #' @name ChoicesFilterState+ #' @rdname DatetimeFilterState |
|||
| 6 |
- #' @title `FilterState` object for categorical data+ #' @title `FilterState` object for date time data |
|||
| 8 |
- #' @description Manages choosing elements from a set.+ #' @description Manages choosing a range of date-times. |
|||
| 14 |
- #' ChoicesFilterState <- getFromNamespace("ChoicesFilterState", "teal.slice")
+ #' DatetimeFilterState <- getFromNamespace("DatetimeFilterState", "teal.slice")
|
|||
| 18 |
- #' filter_state <- ChoicesFilterState$new(+ #' filter_state <- DatetimeFilterState$new( |
|||
| 19 |
- #' x = c(LETTERS, NA),+ #' x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA), |
|||
| 20 |
- #' slice = teal_slice(varname = "var", dataname = "data")+ #' slice = teal_slice(varname = "x", dataname = "data"), |
|||
| 21 |
- #' )+ #' extract_type = character(0) |
|||
| 22 |
- #' isolate(filter_state$get_call())+ #' ) |
|||
| 23 |
- #' filter_state$set_state(+ #' isolate(filter_state$get_call()) |
|||
| 24 |
- #' teal_slice(+ #' filter_state$set_state( |
|||
| 25 |
- #' dataname = "data",+ #' teal_slice( |
|||
| 26 |
- #' varname = "var",+ #' dataname = "data", |
|||
| 27 |
- #' selected = "A",+ #' varname = "x", |
|||
| 28 |
- #' keep_na = TRUE+ #' selected = c(Sys.time() + 3L, Sys.time() + 8L), |
|||
| 29 |
- #' )+ #' keep_na = TRUE |
|||
| 30 |
- #' )+ #' ) |
|||
| 31 |
- #' isolate(filter_state$get_call())+ #' ) |
|||
| 32 |
- #'+ #' isolate(filter_state$get_call()) |
|||
| 33 |
- #' # working filter in an app+ #' |
|||
| 34 |
- #' library(shinyjs)+ #' # working filter in an app |
|||
| 35 |
- #'+ #' library(shinyjs) |
|||
| 36 |
- #' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA)+ #' |
|||
| 37 |
- #' attr(data_choices, "label") <- "lowercase letters"+ #' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00"))
|
|||
| 38 |
- #' fs <- ChoicesFilterState$new(+ #' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA) |
|||
| 39 |
- #' x = data_choices,+ #' fs <- DatetimeFilterState$new( |
|||
| 40 |
- #' slice = teal_slice(+ #' x = data_datetime, |
|||
| 41 |
- #' dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE
+ #' slice = teal_slice( |
|||
| 42 |
- #' )+ #' varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE |
|||
| 43 |
- #' )+ #' ) |
|||
| 44 |
- #'+ #' ) |
|||
| 45 |
- #' ui <- fluidPage(+ #' |
|||
| 46 |
- #' useShinyjs(),+ #' ui <- fluidPage( |
|||
| 47 |
- #' include_css_files(pattern = "filter-panel"),+ #' useShinyjs(), |
|||
| 48 |
- #' include_js_files(pattern = "count-bar-labels"),+ #' include_css_files(pattern = "filter-panel"), |
|||
| 49 |
- #' column(4, tags$div(+ #' include_js_files(pattern = "count-bar-labels"), |
|||
| 50 |
- #' tags$h4("ChoicesFilterState"),
+ #' column(4, tags$div( |
|||
| 51 |
- #' fs$ui("fs")
+ #' tags$h4("DatetimeFilterState"),
|
|||
| 52 |
- #' )),+ #' fs$ui("fs")
|
|||
| 53 |
- #' column(4, tags$div(+ #' )), |
|||
| 54 |
- #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
+ #' column(4, tags$div( |
|||
| 55 |
- #' textOutput("condition_choices"), tags$br(),
+ #' id = "outputs", # div id is needed for toggling the element |
|||
| 56 |
- #' tags$h4("Unformatted state"), # display raw filter state
+ #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|||
| 57 |
- #' textOutput("unformatted_choices"), tags$br(),
+ #' textOutput("condition_datetime"), tags$br(),
|
|||
| 58 |
- #' tags$h4("Formatted state"), # display human readable filter state
+ #' tags$h4("Unformatted state"), # display raw filter state
|
|||
| 59 |
- #' textOutput("formatted_choices"), tags$br()
+ #' textOutput("unformatted_datetime"), tags$br(),
|
|||
| 60 |
- #' )),+ #' tags$h4("Formatted state"), # display human readable filter state
|
|||
| 61 |
- #' column(4, tags$div(+ #' textOutput("formatted_datetime"), tags$br()
|
|||
| 62 |
- #' tags$h4("Programmatic filter control"),
+ #' )), |
|||
| 63 |
- #' actionButton("button1_choices", "set drop NA", width = "100%"), tags$br(),
+ #' column(4, tags$div( |
|||
| 64 |
- #' actionButton("button2_choices", "set keep NA", width = "100%"), tags$br(),
+ #' tags$h4("Programmatic filter control"),
|
|||
| 65 |
- #' actionButton("button3_choices", "set selection: a, b", width = "100%"), tags$br(),
+ #' actionButton("button1_datetime", "set drop NA", width = "100%"), tags$br(),
|
|||
| 66 |
- #' actionButton("button4_choices", "deselect all", width = "100%"), tags$br(),
+ #' actionButton("button2_datetime", "set keep NA", width = "100%"), tags$br(),
|
|||
| 67 |
- #' actionButton("button0_choices", "set initial state", width = "100%"), tags$br()
+ #' actionButton("button3_datetime", "set a range", width = "100%"), tags$br(),
|
|||
| 68 |
- #' ))+ #' actionButton("button4_datetime", "set full range", width = "100%"), tags$br(),
|
|||
| 69 |
- #' )+ #' actionButton("button0_datetime", "set initial state", width = "100%"), tags$br()
|
|||
| 70 |
- #'+ #' )) |
|||
| 71 |
- #' server <- function(input, output, session) {
+ #' ) |
|||
| 72 |
- #' fs$server("fs")
+ #' |
|||
| 73 |
- #' output$condition_choices <- renderPrint(fs$get_call())+ #' server <- function(input, output, session) {
|
|||
| 74 |
- #' output$formatted_choices <- renderText(fs$format())+ #' fs$server("fs")
|
|||
| 75 |
- #' output$unformatted_choices <- renderPrint(fs$get_state())+ #' output$condition_datetime <- renderPrint(fs$get_call()) |
|||
| 76 |
- #' # modify filter state programmatically+ #' output$formatted_datetime <- renderText(fs$format()) |
|||
| 77 |
- #' observeEvent(+ #' output$unformatted_datetime <- renderPrint(fs$get_state()) |
|||
| 78 |
- #' input$button1_choices,+ #' # modify filter state programmatically |
|||
| 79 |
- #' fs$set_state(+ #' observeEvent( |
|||
| 80 |
- #' teal_slice(dataname = "data", varname = "variable", keep_na = FALSE)+ #' input$button1_datetime, |
|||
| 81 |
- #' )+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) |
|||
| 84 |
- #' input$button2_choices,+ #' input$button2_datetime, |
|||
| 85 |
- #' fs$set_state(+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
|||
| 86 |
- #' teal_slice(dataname = "data", varname = "variable", keep_na = TRUE)+ #' ) |
|||
| 87 |
- #' )+ #' observeEvent( |
|||
| 88 |
- #' )+ #' input$button3_datetime, |
|||
| 89 |
- #' observeEvent(+ #' fs$set_state( |
|||
| 90 |
- #' input$button3_choices,+ #' teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)]) |
|||
| 91 |
- #' fs$set_state(+ #' ) |
|||
| 92 |
- #' teal_slice(dataname = "data", varname = "variable", selected = c("a", "b"))
+ #' ) |
|||
| 93 |
- #' )+ #' observeEvent( |
|||
| 94 |
- #' )+ #' input$button4_datetime, |
|||
| 95 |
- #' observeEvent(+ #' fs$set_state( |
|||
| 96 |
- #' input$button4_choices,+ #' teal_slice(dataname = "data", varname = "x", selected = datetimes) |
|||
| 97 |
- #' fs$set_state(+ #' ) |
|||
| 98 |
- #' teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE)+ #' ) |
|||
| 99 |
- #' )+ #' observeEvent( |
|||
| 100 |
- #' )+ #' input$button0_datetime, |
|||
| 101 |
- #' observeEvent(+ #' fs$set_state( |
|||
| 102 |
- #' input$button0_choices,+ #' teal_slice( |
|||
| 103 |
- #' fs$set_state(+ #' dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE |
|||
| 104 |
- #' teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE)
+ #' ) |
|||
| 115 |
- ChoicesFilterState <- R6::R6Class( # nolint+ DatetimeFilterState <- R6::R6Class( # nolint |
|||
| 116 |
- "ChoicesFilterState",+ "DatetimeFilterState", |
|||
| 124 |
- #' Initialize a `FilterState` object.+ #' Initialize a `FilterState` object. This class |
|||
| 125 |
- #'+ #' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by |
|||
| 126 |
- #' @param x (`character`)+ #' default. However, in case when using this module in `teal` app, one needs |
|||
| 127 |
- #' variable to be filtered.+ #' timezone of the app user. App user timezone is taken from `session$userData$timezone` |
|||
| 128 |
- #' @param x_reactive (`reactive`)+ #' and is set only if object is initialized in `shiny`. |
|||
| 129 |
- #' returning vector of the same type as `x`. Is used to update+ #' |
|||
| 130 |
- #' counts following the change in values of the filtered dataset.+ #' @param x (`POSIXct` or `POSIXlt`) |
|||
| 131 |
- #' If it is set to `reactive(NULL)` then counts based on filtered+ #' variable to be filtered. |
|||
| 132 |
- #' dataset are not shown.+ #' @param x_reactive (`reactive`) |
|||
| 133 |
- #' @param slice (`teal_slice`)+ #' returning vector of the same type as `x`. Is used to update |
|||
| 134 |
- #' specification of this filter state.+ #' counts following the change in values of the filtered dataset. |
|||
| 135 |
- #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.+ #' If it is set to `reactive(NULL)` then counts based on filtered |
|||
| 136 |
- #' `get_state` returns `teal_slice` object which can be reused in other places.+ #' dataset are not shown. |
|||
| 137 |
- #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.+ #' @param slice (`teal_slice`) |
|||
| 138 |
- #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.+ #' specification of this filter state. |
|||
| 139 |
- #' @param extract_type (`character`)+ #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|||
| 140 |
- #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ #' `get_state` returns `teal_slice` object which can be reused in other places. |
|||
| 141 |
- #' - `character(0)` (default) `varname` in the condition call will not be prefixed+ #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|||
| 142 |
- #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`+ #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|||
| 143 |
- #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`+ #' @param extract_type (`character`) |
|||
| 144 |
- #'+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|||
| 145 |
- #' @return Object of class `ChoicesFilterState`, invisibly.+ #' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|||
| 146 |
- #'+ #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|||
| 147 |
- initialize = function(x,+ #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|||
| 148 |
- x_reactive = reactive(NULL),+ #' |
|||
| 149 |
- slice,+ #' @return Object of class `DatetimeFilterState`, invisibly. |
|||
| 150 |
- extract_type = character(0)) {
+ #' |
|||
| 151 | -159x | +
- isolate({
+ initialize = function(x, |
||
| 152 | -159x | +
- checkmate::assert(+ x_reactive = reactive(NULL), |
||
| 153 | -159x | +
- is.character(x),+ extract_type = character(0), |
||
| 154 | -159x | +
- is.factor(x),+ slice) {
|
||
| 155 | -159x | +25x |
- length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
+ isolate({
|
|
| 156 | -159x | +25x |
- combine = "or"+ checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
|
|
| 157 | -+ | 24x |
- )+ checkmate::assert_class(x_reactive, "reactive") |
|
| 159 | -159x | +24x |
- x_factor <- if (!is.factor(x)) {
+ super$initialize( |
|
| 160 | -124x | +24x |
- structure(+ x = x, |
|
| 161 | -124x | -
- factor(as.character(x), levels = as.character(sort(unique(x)))),- |
- ||
| 162 | -124x | -
- label = attr(x, "label", exact = TRUE)- |
- ||
| 163 | -- |
- )- |
- ||
| 164 | -- |
- } else {
- |
- ||
| 165 | -35x | -
- x- |
- ||
| 166 | -- |
- }- |
- ||
| 167 | -- | - - | -||
| 168 | -159x | -
- super$initialize(- |
- ||
| 169 | -159x | -
- x = x_factor,- |
- ||
| 170 | -159x | +24x |
x_reactive = x_reactive, |
|
| 171 | -159x | +162 | +24x |
slice = slice, |
| 172 | -159x | +163 | +24x |
extract_type = extract_type |
| 173 | +164 |
) |
||
| 174 | -159x | -
- private$set_choices(slice$choices)- |
- ||
| 175 | -159x | -
- if (is.null(slice$selected) && slice$multiple) {
- |
- ||
| 176 | -42x | -
- slice$selected <- private$get_choices()- |
- ||
| 177 | -117x | -
- } else if (is.null(slice$selected)) {
- |
- ||
| 178 | -1x | -
- slice$selected <- private$get_choices()[1]- |
- ||
| 179 | -116x | -
- } else if (length(slice$selected) > 1 && !slice$multiple) {
- |
- ||
| 180 | -1x | -
- warning(- |
- ||
| 181 | -1x | +165 | +24x |
- "ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ",+ checkmate::assert_multi_class(slice$choices, c("POSIXct", "POSIXlt"), null.ok = TRUE)
|
| 182 | -1x | -
- "Only the first value will be used."- |
- ||
| 183 | -+ | 166 | +23x |
- )+ private$set_choices(slice$choices) |
| 184 | -1x | -
- slice$selected <- slice$selected[1]- |
- ||
| 185 | -+ | 167 | +15x |
- }+ if (is.null(slice$selected)) slice$selected <- slice$choices |
| 186 | -159x | +168 | +23x |
private$set_selected(slice$selected) |
| 187 | -159x | -
- private$data_class <- class(x)[1L]- |
- ||
| 188 | -159x | -
- if (inherits(x, "POSIXt")) {
- |
- ||
| 189 | -9x | -
- private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))- |
- ||
| 190 | +169 |
- }+ }) |
||
| 191 | +170 | |||
| 192 | -159x | -
- private$set_choices_counts(unname(table(x_factor)))- |
- ||
| 193 | -- |
- })- |
- ||
| 194 | -159x | +171 | +22x |
invisible(self) |
| 195 | +172 |
}, |
||
| 196 | +173 | |||
| 197 | +174 |
#' @description |
||
| 198 | +175 |
#' Returns reproducible condition call for current selection. |
||
| 199 | +176 |
#' For this class returned call looks like |
||
| 200 | +177 |
- #' `<varname> %in% c(<values selected>)` with optional `is.na(<varname>)`.+ #' `<varname> >= as.POSIXct(<min>) & <varname> <= <max>)` with optional `is.na(<varname>)`. |
||
| 201 | +178 |
- #' @param dataname (`character(1)`) name of data set; defaults to `private$get_dataname()`+ #' @param dataname name of data set; defaults to `private$get_dataname()` |
||
| 202 | +179 |
- #' @return `call` or `NULL`+ #' @return `call` |
||
| 203 | +180 |
#' |
||
| 204 | +181 |
get_call = function(dataname) {
|
||
| 205 | -60x | -
- if (isFALSE(private$is_any_filtered())) {
- |
- ||
| 206 | +182 | 7x |
- return(NULL)- |
- |
| 207 | -- |
- }- |
- ||
| 208 | -29x | -
- if (missing(dataname)) dataname <- private$get_dataname()- |
- ||
| 209 | -53x | -
- varname <- private$get_varname_prefixed(dataname)- |
- ||
| 210 | -53x | -
- selected <- private$get_selected()- |
- ||
| 211 | -53x | -
- if (length(selected) == 0) {
- |
- ||
| 212 | -6x | -
- choices <- private$get_choices()- |
- ||
| 213 | -6x | -
- fun_compare <- if (length(choices) == 1L) "==" else "%in%"- |
- ||
| 214 | -6x | -
- filter_call <- call("!", call(fun_compare, varname, make_c_call(as.character(choices))))
- |
- ||
| 215 | -- |
- } else {
- |
- ||
| 216 | -47x | -
- if (setequal(na.omit(private$x), selected)) {
- |
- ||
| 217 | -3x | -
- filter_call <- NULL- |
- ||
| 218 | -- |
- } else {
- |
- ||
| 219 | -44x | -
- fun_compare <- if (length(selected) == 1L) "==" else "%in%"- |
- ||
| 220 | -- | - - | -||
| 221 | -44x | -
- if (private$data_class != "factor") {
+ if (isFALSE(private$is_any_filtered())) {
|
||
| 222 | -37x | -
- selected <- do.call(sprintf("as.%s", private$data_class), list(x = selected))
- |
- ||
| 223 | -+ | 183 | +1x |
- }+ return(NULL) |
| 224 | +184 |
-
+ } |
||
| 225 | -44x | +185 | +4x |
- filter_call <-+ if (missing(dataname)) dataname <- private$get_dataname() |
| 226 | -44x | +186 | +6x |
- if (inherits(selected, "Date")) {
+ varname <- private$get_varname_prefixed(dataname) |
| 227 | -1x | +187 | +6x |
- call(fun_compare, varname, call("as.Date", make_c_call(as.character(selected))))
+ choices <- private$get_selected() |
| 228 | -44x | +188 | +6x |
- } else if (inherits(selected, c("POSIXct", "POSIXlt"))) {
+ tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone")) |
| 229 | -2x | +189 | +6x |
- class <- class(selected)[1L]+ class <- class(choices)[1L] |
| 230 | -2x | +190 | +6x |
- date_fun <- as.name(+ date_fun <- as.name( |
| 231 | -2x | +191 | +6x |
- switch(class,+ switch(class, |
| 232 | -2x | +192 | +6x |
- "POSIXct" = "as.POSIXct",+ "POSIXct" = "as.POSIXct", |
| 233 | -2x | +193 | +6x |
- "POSIXlt" = "as.POSIXlt"+ "POSIXlt" = "as.POSIXlt" |
| 234 | +194 |
- )+ ) |
||
| 235 | +195 |
- )- |
- ||
| 236 | -2x | -
- call(+ ) |
||
| 237 | -2x | +196 | +6x |
- fun_compare,+ choices <- as.character(choices + c(0, 1)) |
| 238 | -2x | +197 | +6x |
- varname,+ filter_call <- |
| 239 | -2x | +198 | +6x |
- as.call(list(date_fun, make_c_call(as.character(selected)), tz = private$tzone))+ call( |
| 240 | +199 |
- )+ "&", |
||
| 241 | -+ | |||
| 200 | +6x |
- } else {
+ call( |
||
| 242 | +201 |
- # This handles numerics, characters, and factors.+ ">=", |
||
| 243 | -41x | -
- call(fun_compare, varname, make_c_call(selected))- |
- ||
| 244 | -+ | 202 | +6x |
- }+ varname, |
| 245 | -+ | |||
| 203 | +6x |
- }+ as.call(list(date_fun, choices[1L], tz = tzone)) |
||
| 246 | +204 |
- }+ ), |
||
| 247 | -53x | -
- private$add_keep_na_call(filter_call, varname)- |
- ||
| 248 | -+ | 205 | +6x |
- }+ call( |
| 249 | +206 |
- ),+ "<", |
||
| 250 | -+ | |||
| 207 | +6x |
-
+ varname, |
||
| 251 | -+ | |||
| 208 | +6x |
- # private members ----+ as.call(list(date_fun, choices[2L], tz = tzone)) |
||
| 252 | +209 |
- private = list(+ ) |
||
| 253 | +210 |
- x = NULL,+ ) |
||
| 254 | -+ | |||
| 211 | +6x |
- choices_counts = integer(0),+ private$add_keep_na_call(filter_call, varname) |
||
| 255 | +212 |
- data_class = character(0), # stores class of filtered variable so that it can be restored in $get_call+ } |
||
| 256 | +213 |
- tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call+ ), |
||
| 257 | +214 | |||
| 258 | +215 |
- # private methods ----+ # private members ---- |
||
| 259 | +216 | |||
| 260 | -- |
- # @description- |
- ||
| 261 | +217 |
- # Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices+ private = list( |
||
| 262 | +218 |
- # are limited by default from the start.+ # private methods ---- |
||
| 263 | +219 |
set_choices = function(choices) {
|
||
| 264 | -159x | +220 | +23x |
if (is.null(choices)) {
|
| 265 | -144x | +221 | +20x |
- choices <- levels(private$x)+ choices <- as.POSIXct(trunc(range(private$x, na.rm = TRUE), units = "secs")) |
| 266 | +222 |
} else {
|
||
| 267 | -15x | +223 | +3x |
- choices <- as.character(choices)+ choices <- as.POSIXct(choices, units = "secs") |
| 268 | -15x | +224 | +3x |
- choices_adjusted <- choices[choices %in% levels(private$x)]+ choices_adjusted <- c( |
| 269 | -15x | +225 | +3x |
- if (length(setdiff(choices, choices_adjusted)) > 0L) {
+ max(choices[1L], min(as.POSIXct(private$x), na.rm = TRUE)), |
| 270 | -2x | +226 | +3x |
- warning(+ min(choices[2L], max(as.POSIXct(private$x), na.rm = TRUE))+ |
+
| 227 | ++ |
+ ) |
||
| 271 | -2x | +228 | +3x |
- sprintf(+ if (any(choices != choices_adjusted)) {
|
| 272 | -2x | +229 | +1x |
- "Some choices not found in data. Adjusting. Filter id: %s.",+ warning(sprintf( |
| 273 | -2x | +230 | +1x |
- private$get_id()+ "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", |
| 274 | -+ | |||
| 231 | +1x |
- )+ private$get_varname(), private$get_dataname() |
||
| 275 | +232 |
- )+ )) |
||
| 276 | -2x | +233 | +1x |
choices <- choices_adjusted |
| 277 | +234 |
} |
||
| 278 | -15x | +235 | +3x |
- if (length(choices) == 0) {
+ if (choices[1L] >= choices[2L]) {
|
| 279 | +236 | 1x |
- warning(+ warning(sprintf( |
|
| 280 | +237 | 1x |
- sprintf(+ "Invalid choices: lower is higher / equal to upper, or not in range of variable values. |
|
| 281 | +238 | 1x |
- "None of the choices were found in data. Setting defaults. Filter id: %s.",+ Setting defaults. Varname: %s, dataname: %s.", |
|
| 282 | +239 | 1x |
- private$get_id()- |
- |
| 283 | -- |
- )+ private$get_varname(), private$get_dataname() |
||
| 284 | +240 |
- )+ )) |
||
| 285 | +241 | 1x |
- choices <- levels(private$x)+ choices <- range(private$x, na.rm = TRUE) |
|
| 286 | +242 |
} |
||
| 287 | +243 |
} |
||
| 288 | -159x | +|||
| 244 | +
- private$set_is_choice_limited(private$x, choices)+ |
|||
| 289 | -159x | +245 | +23x |
- private$teal_slice$choices <- choices+ private$set_is_choice_limited(private$x, choices) |
| 290 | -159x | +246 | +23x |
- private$x <- private$x[(private$x %in% private$get_choices()) | is.na(private$x)]+ private$x <- private$x[ |
| 291 | -159x | +|||
| 247 | +
- private$x <- droplevels(private$x)+ ( |
|||
| 292 | -159x | -
- invisible(NULL)- |
- ||
| 293 | -+ | 248 | +23x |
- },+ as.POSIXct(trunc(private$x, units = "secs")) >= choices[1L] & |
| 294 | -+ | |||
| 249 | +23x |
- # @description+ as.POSIXct(trunc(private$x, units = "secs")) <= choices[2L] |
||
| 295 | -+ | |||
| 250 | +23x |
- # Check whether the initial choices filter out some values of x and set the flag in case.+ ) | is.na(private$x) |
||
| 296 | +251 |
- set_is_choice_limited = function(x, choices) {
+ ] |
||
| 297 | -159x | +252 | +23x |
- xl <- x[!is.na(x)]+ private$teal_slice$choices <- choices |
| 298 | -159x | +253 | +23x |
- private$is_choice_limited <- length(setdiff(xl, choices)) > 0L+ invisible(NULL) |
| 299 | -159x | +|||
| 254 | +
- invisible(NULL)+ }, |
|||
| 300 | +255 |
- },+ |
||
| 301 | +256 |
# @description |
||
| 302 | +257 |
- # Sets choices_counts private field.+ # Check whether the initial choices filter out some values of x and set the flag in case. |
||
| 303 | +258 |
- set_choices_counts = function(choices_counts) {
+ set_is_choice_limited = function(xl, choices = NULL) {
|
||
| 304 | -159x | +259 | +23x |
- private$choices_counts <- choices_counts+ private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE)) |
| 305 | -159x | +260 | +23x |
invisible(NULL) |
| 306 | +261 |
}, |
||
| 307 | +262 |
- # @description+ cast_and_validate = function(values) {
|
||
| 308 | -+ | |||
| 263 | +34x |
- # Checks how many counts of each choice is present in the data.+ tryCatch( |
||
| 309 | -+ | |||
| 264 | +34x |
- get_choices_counts = function() {
+ expr = {
|
||
| 310 | -! | +|||
| 265 | +34x |
- if (!is.null(private$x_reactive)) {
+ values <- as.POSIXct(values, origin = "1970-01-01 00:00:00") |
||
| 311 | +266 | ! |
- table(factor(private$x_reactive(), levels = private$get_choices()))- |
- |
| 312 | -- |
- } else {
+ if (anyNA(values)) stop() |
||
| 313 | -! | +|||
| 267 | +31x |
- NULL+ values |
||
| 314 | +268 |
- }+ }, |
||
| 315 | -+ | |||
| 269 | +34x |
- },+ error = function(e) stop("Vector of set values must contain values coercible to POSIX.")
|
||
| 316 | +270 |
- # @description+ ) |
||
| 317 | +271 |
- # Checks whether the input should be rendered as a checkboxgroup/radiobutton or a drop-down.+ }, |
||
| 318 | +272 |
- is_checkboxgroup = function() {
+ check_length = function(values) {
|
||
| 319 | -23x | +273 | +1x |
- length(private$get_choices()) <= getOption("teal.threshold_slider_vs_checkboxgroup")
+ if (length(values) != 2) stop("Vector of set values must have length two.")
|
| 320 | -+ | |||
| 274 | +30x |
- },+ if (values[1] > values[2]) {
|
||
| 321 | -+ | |||
| 275 | +1x |
- cast_and_validate = function(values) {
+ warning( |
||
| 322 | -188x | +276 | +1x |
- tryCatch(+ sprintf( |
| 323 | -188x | +277 | +1x |
- expr = {
+ "Start date '%s' is set after the end date '%s', the values will be replaced by a default datetime range.", |
| 324 | -188x | +278 | +1x |
- values <- as.character(values)+ values[1], values[2] |
| 325 | -! | +|||
| 279 | +
- if (anyNA(values)) stop()+ ) |
|||
| 326 | +280 |
- },+ ) |
||
| 327 | -188x | +281 | +1x |
- error = function(e) stop("The vector of set values must contain values coercible to character.")
+ values <- isolate(private$get_choices()) |
| 328 | +282 |
- )+ } |
||
| 329 | -188x | +283 | +30x |
values |
| 330 | +284 |
}, |
||
| 331 | +285 |
- # If multiple forbidden but selected, restores previous selection with warning.+ remove_out_of_bounds_values = function(values) {
|
||
| 332 | -+ | |||
| 286 | +30x |
- check_length = function(values) {
+ choices <- private$get_choices() |
||
| 333 | -188x | +287 | +30x |
- if (!private$is_multiple() && length(values) > 1) {
+ if (values[1] < choices[1L] || values[1] > choices[2L]) {
|
| 334 | -1x | +288 | +5x |
warning( |
| 335 | -1x | +289 | +5x |
- sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
+ sprintf( |
| 336 | -1x | +290 | +5x |
- "Maintaining previous selection."+ "Value: %s is outside of the range for the column '%s' in dataset '%s', setting minimum possible value.", |
| 337 | -+ | |||
| 291 | +5x |
- )+ values[1], private$get_varname(), toString(private$get_dataname()) |
||
| 338 | -1x | +|||
| 292 | +
- values <- isolate(private$get_selected())+ ) |
|||
| 339 | +293 |
- }+ ) |
||
| 340 | -188x | +294 | +5x |
- values+ values[1] <- choices[1L] |
| 341 | +295 |
- },+ } |
||
| 342 | +296 |
- remove_out_of_bounds_values = function(values) {
+
|
||
| 343 | -188x | +297 | +30x |
- in_choices_mask <- values %in% private$get_choices()+ if (values[2] > choices[2L] | values[2] < choices[1L]) {
|
| 344 | -188x | +298 | +5x |
- if (length(values[!in_choices_mask]) > 0) {
+ warning( |
| 345 | -17x | +299 | +5x |
- warning(paste(+ sprintf( |
| 346 | -17x | +300 | +5x |
- "Values:", toString(values[!in_choices_mask], width = 360),+ "Value: '%s' is outside of the range for the column '%s' in dataset '%s', setting maximum possible value.", |
| 347 | -17x | +301 | +5x |
- "are not in choices of column", private$get_varname(), "in dataset", private$get_dataname(), "."+ values[2], private$get_varname(), toString(private$get_dataname()) |
| 348 | +302 |
- ))+ ) |
||
| 349 | +303 | ++ |
+ )+ |
+ |
| 304 | +5x | +
+ values[2] <- choices[2L]+ |
+ ||
| 305 |
} |
|||
| 306 | ++ | + + | +||
| 350 | -188x | +307 | +30x |
- values[in_choices_mask]+ values |
| 351 | +308 |
}, |
||
| 352 | +309 | |||
| 353 | +310 |
# shiny modules ---- |
||
| 354 | +311 | |||
| 355 | +312 |
# @description |
||
| 356 | +313 |
- # UI Module for `ChoicesFilterState`.+ # UI Module for `DatetimeFilterState`. |
||
| 357 | +314 |
- # This UI element contains available choices selection and+ # This UI element contains two date-time selections for `min` and `max` |
||
| 358 | +315 |
- # checkbox whether to keep or not keep the `NA` values.+ # of the range and a checkbox whether to keep the `NA` values. |
||
| 359 | +316 |
# @param id (`character(1)`) `shiny` module instance id. |
||
| 360 | +317 |
ui_inputs = function(id) {
|
||
| 361 | -7x | +|||
| 318 | +! |
ns <- NS(id) |
||
| 362 | +319 | |||
| 363 | -- |
- # we need to isolate UI to not rettrigger renderUI- |
- ||
| 364 | -7x | +|||
| 320 | +! |
isolate({
|
||
| 365 | -7x | -
- countsmax <- private$choices_counts- |
- ||
| 366 | -7x | +|||
| 321 | +! |
- countsnow <- if (!is.null(private$x_reactive())) {
+ ui_input_1 <- shinyWidgets::airDatepickerInput( |
||
| 367 | +322 | ! |
- unname(table(factor(private$x_reactive(), levels = private$get_choices())))+ inputId = ns("selection_start"),
|
|
| 368 | -+ | |||
| 323 | +! |
- }+ value = private$get_selected()[1], |
||
| 369 | -+ | |||
| 324 | +! |
-
+ startView = private$get_selected()[1], |
||
| 370 | -7x | +|||
| 325 | +! |
- ui_input <- if (private$is_checkboxgroup()) {
+ timepicker = TRUE, |
||
| 371 | -7x | +|||
| 326 | +! |
- labels <- countBars(+ minDate = private$get_choices()[1L], |
||
| 372 | -7x | +|||
| 327 | +! |
- inputId = ns("labels"),
+ maxDate = private$get_choices()[2L], |
||
| 373 | -7x | +|||
| 328 | +! |
- choices = private$get_choices(),+ update_on = "close", |
||
| 374 | -7x | +|||
| 329 | +! |
- countsnow = countsnow,+ addon = "none", |
||
| 375 | -7x | +|||
| 330 | +! |
- countsmax = countsmax+ position = "bottom right" |
||
| 376 | +331 |
- )+ ) |
||
| 377 | -7x | +|||
| 332 | +! |
- tags$div(+ ui_input_2 <- shinyWidgets::airDatepickerInput( |
||
| 378 | -7x | +|||
| 333 | +! |
- class = "choices_state",+ inputId = ns("selection_end"),
|
||
| 379 | -7x | +|||
| 334 | +! |
- if (private$is_multiple()) {
+ value = private$get_selected()[2], |
||
| 380 | -7x | +|||
| 335 | +! |
- checkboxGroupInput(+ startView = private$get_selected()[2], |
||
| 381 | -7x | +|||
| 336 | +! |
- inputId = ns("selection"),
+ timepicker = TRUE, |
||
| 382 | -7x | +|||
| 337 | +! |
- label = NULL,+ minDate = private$get_choices()[1L], |
||
| 383 | -7x | +|||
| 338 | +! |
- selected = private$get_selected(),+ maxDate = private$get_choices()[2L], |
||
| 384 | -7x | +|||
| 339 | +! |
- choiceNames = labels,+ update_on = "close", |
||
| 385 | -7x | +|||
| 340 | +! |
- choiceValues = private$get_choices(),+ addon = "none", |
||
| 386 | -7x | +|||
| 341 | +! |
- width = "100%"+ position = "bottom right" |
||
| 387 | +342 |
- )+ ) |
||
| 388 | -+ | |||
| 343 | +! |
- } else {
+ ui_reset_1 <- actionButton( |
||
| 389 | +344 | ! |
- radioButtons(+ class = "date_reset_button", |
|
| 390 | +345 | ! |
- inputId = ns("selection"),
+ inputId = ns("start_date_reset"),
|
|
| 391 | +346 | ! |
- label = NULL,+ label = NULL, |
|
| 392 | +347 | ! |
- selected = private$get_selected(),+ icon = icon("fas fa-undo")
|
|
| 393 | -! | +|||
| 348 | +
- choiceNames = labels,+ ) |
|||
| 394 | +349 | ! |
- choiceValues = private$get_choices(),+ ui_reset_2 <- actionButton( |
|
| 395 | +350 | ! |
- width = "100%"+ class = "date_reset_button", |
|
| 396 | -+ | |||
| 351 | +! |
- )+ inputId = ns("end_date_reset"),
|
||
| 397 | -+ | |||
| 352 | +! |
- }+ label = NULL, |
||
| 398 | -+ | |||
| 353 | +! |
- )+ icon = icon("fas fa-undo")
|
||
| 399 | +354 |
- } else {
+ ) |
||
| 400 | +355 | ! |
- labels <- mapply(+ ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm")) |
|
| 401 | +356 | ! |
- FUN = make_count_text,+ ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm")) |
|
| 402 | -! | +|||
| 357 | +
- label = private$get_choices(),+ |
|||
| 403 | +358 | ! |
- countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,+ tags$div( |
|
| 404 | +359 | ! |
- countmax = countsmax- |
- |
| 405 | -- |
- )- |
- ||
| 406 | -- |
-
+ tags$div( |
||
| 407 | +360 | ! |
- teal.widgets::optionalSelectInput(+ class = "flex", |
|
| 408 | +361 | ! |
- inputId = ns("selection"),
+ ui_reset_1, |
|
| 409 | +362 | ! |
- choices = stats::setNames(private$get_choices(), labels),+ tags$div( |
|
| 410 | +363 | ! |
- selected = private$get_selected(),+ class = "flex w-80 filter_datelike_input", |
|
| 411 | +364 | ! |
- multiple = private$is_multiple(),+ tags$div(class = "w-45 text-center", ui_input_1), |
|
| 412 | +365 | ! |
- options = shinyWidgets::pickerOptions(+ tags$span( |
|
| 413 | +366 | ! |
- actionsBox = TRUE,+ class = "input-group-addon w-10", |
|
| 414 | +367 | ! |
- liveSearch = (length(private$get_choices()) > 10),+ tags$span(class = "input-group-text w-100 justify-content-center", "to"), |
|
| 415 | +368 | ! |
- noneSelectedText = "Select a value"+ title = "Times are displayed in the local timezone and are converted to UTC in the analysis" |
|
| 416 | +369 |
- )+ ), |
||
| 417 | -+ | |||
| 370 | +! |
- )+ tags$div(class = "w-45 text-center", ui_input_2) |
||
| 418 | +371 |
- }- |
- ||
| 419 | -7x | -
- tags$div(+ ), |
||
| 420 | -7x | +|||
| 372 | +! |
- uiOutput(ns("trigger_visible")),
+ ui_reset_2 |
||
| 421 | -7x | +|||
| 373 | +
- ui_input,+ ), |
|||
| 422 | -7x | +|||
| 374 | +! |
private$keep_na_ui(ns("keep_na"))
|
||
| 423 | +375 |
) |
||
| 424 | +376 |
}) |
||
| 425 | +377 |
}, |
||
| 426 | +378 | |||
| 427 | +379 |
# @description |
||
| 428 | +380 |
# Server module |
||
| 429 | +381 |
# @param id (`character(1)`) `shiny` module instance id. |
||
| 430 | +382 |
# @return `NULL`. |
||
| 431 | +383 |
server_inputs = function(id) {
|
||
| 432 | -7x | +|||
| 384 | +! |
moduleServer( |
||
| 433 | -7x | +|||
| 385 | +! |
id = id, |
||
| 434 | -7x | +|||
| 386 | +! |
function(input, output, session) {
|
||
| 435 | -7x | -
- logger::log_trace("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }")
- |
- ||
| 436 | -+ | |||
| 387 | +! |
-
+ logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
|
||
| 437 | +388 |
- # 1. renderUI is used here as an observer which triggers only if output is visible+ # this observer is needed in the situation when teal_slice$selected has been |
||
| 438 | +389 |
- # and if the reactive changes - reactive triggers only if the output is visible.+ # changed directly by the api - then it's needed to rerender UI element |
||
| 439 | +390 |
- # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)- |
- ||
| 440 | -7x | -
- non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))+ # to show relevant values |
||
| 441 | -7x | +|||
| 391 | +! |
- output$trigger_visible <- renderUI({
+ private$observers$selection_api <- observeEvent( |
||
| 442 | -7x | +|||
| 392 | +! |
- logger::log_trace("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")
+ ignoreNULL = TRUE, # dates needs to be selected |
||
| 443 | -+ | |||
| 393 | +! |
-
+ ignoreInit = TRUE, # on init selected == default, so no need to trigger |
||
| 444 | -7x | +|||
| 394 | +! |
- countsnow <- if (!is.null(private$x_reactive())) {
+ eventExpr = private$get_selected(), |
||
| 445 | +395 | ! |
- unname(table(factor(non_missing_values(), levels = private$get_choices())))+ handlerExpr = {
|
|
| 446 | -+ | |||
| 396 | +! |
- }+ start_date <- input$selection_start |
||
| 447 | -+ | |||
| 397 | +! |
-
+ end_date <- input$selection_end |
||
| 448 | -+ | |||
| 398 | +! |
- # update should be based on a change of counts only+ if (!all(private$get_selected() == c(start_date, end_date))) {
|
||
| 449 | -7x | +|||
| 399 | +! |
- isolate({
+ logger::log_trace("DatetimeFilterState$server@1 state changed, id: { private$get_id() }")
|
||
| 450 | -7x | +|||
| 400 | +! |
- if (private$is_checkboxgroup()) {
+ if (private$get_selected()[1] != start_date) {
|
||
| 451 | -7x | +|||
| 401 | +! |
- updateCountBars(+ shinyWidgets::updateAirDateInput( |
||
| 452 | -7x | +|||
| 402 | +! |
- inputId = "labels",+ session = session, |
||
| 453 | -7x | +|||
| 403 | +! |
- choices = private$get_choices(),+ inputId = "selection_start", |
||
| 454 | -7x | +|||
| 404 | +! |
- countsmax = private$choices_counts,+ value = private$get_selected()[1] |
||
| 455 | -7x | +|||
| 405 | +
- countsnow = countsnow+ ) |
|||
| 456 | +406 |
- )+ } |
||
| 457 | +407 |
- } else {
+
|
||
| 458 | +408 | ! |
- labels <- mapply(+ if (private$get_selected()[2] != end_date) {
|
|
| 459 | +409 | ! |
- FUN = make_count_text,+ shinyWidgets::updateAirDateInput( |
|
| 460 | +410 | ! |
- label = private$get_choices(),+ session = session, |
|
| 461 | +411 | ! |
- countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,+ inputId = "selection_end", |
|
| 462 | +412 | ! |
- countmax = private$choices_counts+ value = private$get_selected()[2] |
|
| 463 | +413 |
- )+ )+ |
+ ||
| 414 | ++ |
+ }+ |
+ ||
| 415 | ++ |
+ }+ |
+ ||
| 416 | ++ |
+ }+ |
+ ||
| 417 | ++ |
+ )+ |
+ ||
| 418 | ++ | + + | +||
| 419 | ++ | + | ||
| 464 | +420 | ! |
- teal.widgets::updateOptionalSelectInput(+ private$observers$selection_start <- observeEvent( |
|
| 465 | +421 | ! |
- session = session,+ ignoreNULL = TRUE, # dates needs to be selected |
|
| 466 | +422 | ! |
- inputId = "selection",+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
|
| 467 | +423 | ! |
- choices = stats::setNames(private$get_choices(), labels),+ eventExpr = input$selection_start, |
|
| 468 | +424 | ! |
- selected = private$get_selected()+ handlerExpr = {
|
|
| 469 | -+ | |||
| 425 | +! |
- )+ logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
|
||
| 470 | -+ | |||
| 426 | +! |
- }+ start_date <- input$selection_start |
||
| 471 | -7x | +|||
| 427 | +! |
- NULL+ end_date <- private$get_selected()[[2]] |
||
| 472 | -+ | |||
| 428 | +! |
- })+ tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone")) |
||
| 473 | -+ | |||
| 429 | +! |
- })+ attr(start_date, "tzone") <- tzone |
||
| 474 | +430 | |||
| 475 | -7x | -
- if (private$is_checkboxgroup()) {
- |
- ||
| 476 | -7x | +|||
| 431 | +! |
- private$observers$selection <- observeEvent(+ if (start_date > end_date) {
|
||
| 477 | -7x | +|||
| 432 | +! |
- ignoreNULL = FALSE,+ showNotification( |
||
| 478 | -7x | +|||
| 433 | +! |
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ "Start date must not be greater than the end date. Ignoring selection.", |
||
| 479 | -7x | +|||
| 434 | +! |
- eventExpr = input$selection,+ type = "warning" |
||
| 480 | -7x | +|||
| 435 | +
- handlerExpr = {
+ ) |
|||
| 481 | +436 | ! |
- logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
+ shinyWidgets::updateAirDateInput( |
|
| 482 | -+ | |||
| 437 | +! |
-
+ session = session, |
||
| 483 | +438 | ! |
- selection <- if (is.null(input$selection) && private$is_multiple()) {
+ inputId = "selection_start", |
|
| 484 | +439 | ! |
- character(0)+ value = private$get_selected()[1] # sets back to latest selected value |
|
| 485 | +440 |
- } else {
+ ) |
||
| 486 | +441 | ! |
- input$selection+ return(NULL) |
|
| 487 | +442 |
- }+ } |
||
| 488 | +443 | |||
| 489 | +444 | ! |
- private$set_selected(selection)+ private$set_selected(c(start_date, end_date)) |
|
| 490 | +445 |
- }+ } |
||
| 491 | +446 |
- )+ ) |
||
| 492 | +447 |
- } else {
- |
- ||
| 493 | -! | -
- private$observers$selection <- observeEvent(- |
- ||
| 494 | -! | -
- ignoreNULL = FALSE,+ |
||
| 495 | +448 | ! |
- ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ private$observers$selection_end <- observeEvent( |
|
| 496 | +449 | ! |
- eventExpr = input$selection_open, # observe click on a dropdown+ ignoreNULL = TRUE, # dates needs to be selected |
|
| 497 | +450 | ! |
- handlerExpr = {
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
|
| 498 | +451 | ! |
- if (!isTRUE(input$selection_open)) { # only when the dropdown got closed
+ eventExpr = input$selection_end, |
|
| 499 | -! | -
- logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
- |
- ||
| 500 | -+ | 452 | +! |
-
+ handlerExpr = {
|
| 501 | +453 | ! |
- selection <- if (is.null(input$selection) && private$is_multiple()) {
+ start_date <- private$get_selected()[1] |
|
| 502 | +454 | ! |
- character(0)+ end_date <- input$selection_end |
|
| 503 | +455 | ! |
- } else if (isTRUE(length(input$selection) != 1) && !private$is_multiple()) {
+ tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone")) |
|
| 504 | -+ | |||
| 456 | +! |
- # In optionalSelectInput user is able to select mutliple options. But if FilterState is not multiple+ attr(end_date, "tzone") <- tzone |
||
| 505 | +457 |
- # we should prevent this selection to be processed further.+ |
||
| 506 | -+ | |||
| 458 | +! |
- # This is why notification is thrown and dropdown is changed back to latest selected.+ if (start_date > end_date) {
|
||
| 507 | +459 | ! |
- showNotification(paste(+ showNotification( |
|
| 508 | +460 | ! |
- "This filter exclusively supports single selection.",+ "End date must not be lower than the start date. Ignoring selection.", |
|
| 509 | +461 | ! |
- "Any additional choices made will be disregarded."+ type = "warning" |
|
| 510 | +462 |
- ))+ ) |
||
| 511 | +463 | ! |
- teal.widgets::updateOptionalSelectInput(+ shinyWidgets::updateAirDateInput( |
|
| 512 | +464 | ! |
- session, "selection",+ session = session, |
|
| 513 | +465 | ! |
- selected = private$get_selected()- |
- |
| 514 | -- |
- )+ inputId = "selection_end", |
||
| 515 | +466 | ! |
- return(NULL)+ value = private$get_selected()[2] # sets back to latest selected value |
|
| 516 | +467 |
- } else {
+ ) |
||
| 517 | +468 | ! |
- input$selection+ return(NULL) |
|
| 518 | +469 |
- }- |
- ||
| 519 | -! | -
- private$set_selected(selection)+ } |
||
| 520 | +470 |
- }+ |
||
| 521 | -+ | |||
| 471 | +! |
- }+ private$set_selected(c(start_date, end_date)) |
||
| 522 | -+ | |||
| 472 | +! |
- )+ logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
|
||
| 523 | +473 |
- }+ } |
||
| 524 | +474 |
-
+ ) |
||
| 525 | +475 | |||
| 526 | -7x | +|||
| 476 | +! |
private$keep_na_srv("keep_na")
|
||
| 527 | +477 | |||
| 528 | -- |
- # this observer is needed in the situation when teal_slice$selected has been- |
- ||
| 529 | -+ | |||
| 478 | +! |
- # changed directly by the api - then it's needed to rerender UI element+ private$observers$reset1 <- observeEvent( |
||
| 530 | -+ | |||
| 479 | +! |
- # to show relevant values+ ignoreInit = TRUE, # reset button shouldn't be trigger on init |
||
| 531 | -7x | +|||
| 480 | +! |
- private$observers$selection_api <- observeEvent(private$get_selected(), {
+ ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL |
||
| 532 | -+ | |||
| 481 | +! |
- # it's important to not retrigger when the input$selection is the same as reactive values+ input$start_date_reset, |
||
| 533 | +482 |
- # kept in the teal_slice$selected- |
- ||
| 534 | -2x | -
- if (!setequal(input$selection, private$get_selected())) {
+ {
|
||
| 535 | -2x | +|||
| 483 | +! |
- logger::log_trace("ChoicesFilterState$server@1 state changed, id: { private$get_id() }")
+ shinyWidgets::updateAirDateInput( |
||
| 536 | -2x | +|||
| 484 | +! |
- if (private$is_checkboxgroup()) {
+ session = session, |
||
| 537 | -2x | +|||
| 485 | +! |
- if (private$is_multiple()) {
+ inputId = "selection_start", |
||
| 538 | -2x | +|||
| 486 | +! |
- updateCheckboxGroupInput(+ value = private$get_choices()[1L] |
||
| 539 | -2x | +|||
| 487 | +
- inputId = "selection",+ ) |
|||
| 540 | -2x | +|||
| 488 | +! |
- selected = private$get_selected()+ logger::log_trace("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
|
||
| 541 | +489 |
- )+ } |
||
| 542 | +490 |
- } else {
+ ) |
||
| 543 | +491 | ! |
- updateRadioButtons(+ private$observers$reset2 <- observeEvent( |
|
| 544 | +492 | ! |
- inputId = "selection",+ ignoreInit = TRUE, # reset button shouldn't be trigger on init |
|
| 545 | +493 | ! |
- selected = private$get_selected()+ ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL |
|
| 546 | -+ | |||
| 494 | +! |
- )+ input$end_date_reset, |
||
| 547 | +495 |
- }+ {
|
||
| 548 | -+ | |||
| 496 | +! |
- } else {
+ shinyWidgets::updateAirDateInput( |
||
| 549 | +497 | ! |
- teal.widgets::updateOptionalSelectInput(+ session = session, |
|
| 550 | +498 | ! |
- session, "selection",+ inputId = "selection_end", |
|
| 551 | +499 | ! |
- selected = private$get_selected()+ value = private$get_choices()[2L] |
|
| 552 | +500 |
- )+ ) |
||
| 553 | -+ | |||
| 501 | +! |
- }+ logger::log_trace("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
|
||
| 554 | +502 |
} |
||
| 555 | +503 |
- })+ ) |
||
| 556 | +504 | |||
| 557 | -7x | +|||
| 505 | +! |
- logger::log_trace("ChoicesFilterState$server_inputs initialized, id: { private$get_id() }")
+ logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
|
||
| 558 | -7x | +|||
| 506 | +! |
NULL |
||
| 559 | +507 |
} |
||
| 560 | +508 |
) |
||
| 561 | +509 |
}, |
||
| 562 | +510 |
server_inputs_fixed = function(id) {
|
||
| 563 | +511 | ! |
moduleServer( |
|
| 564 | +512 | ! |
id = id, |
|
| 565 | +513 | ! |
function(input, output, session) {
|
|
| 566 | +514 | ! |
- logger::log_trace("ChoicesFilterState$server_inputs_fixed initializing, id: { private$get_id() }")
+ logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
|
|
| 567 | +515 | |||
| 568 | +516 | ! |
output$selection <- renderUI({
|
|
| 569 | -! | -
- countsnow <- if (!is.null(private$x_reactive())) {
- |
- ||
| 570 | -! | -
- unname(table(factor(private$x_reactive(), levels = private$get_choices())))- |
- ||
| 571 | -- |
- }- |
- ||
| 572 | -! | -
- countsmax <- private$choices_counts- |
- ||
| 573 | -- | - - | -||
| 574 | -! | -
- ind <- private$get_choices() %in% isolate(private$get_selected())- |
- ||
| 575 | -! | -
- countBars(- |
- ||
| 576 | +517 | ! |
- inputId = session$ns("labels"),
+ vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3) |
|
| 577 | +518 | ! |
- choices = isolate(private$get_selected()),+ tags$div( |
|
| 578 | +519 | ! |
- countsnow = countsnow[ind],+ tags$div(icon("clock"), vals[1]),
|
|
| 579 | +520 | ! |
- countsmax = countsmax[ind]+ tags$div(span(" - "), icon("clock"), vals[2])
|
|
| 580 | +521 |
) |
||
| 581 | +522 |
}) |
||
| 582 | +523 | |||
| 583 | +524 | ! |
- logger::log_trace("ChoicesFilterState$server_inputs_fixed initialized, id: { private$get_id() }")
+ logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
|
|
| 584 | +525 | ! |
NULL |
|
| 585 | +526 |
} |
||
| 586 | +527 |
) |
||
| 587 | +528 |
}, |
||
| 588 | +529 | |||
| 589 | +530 |
# @description |
||
| 590 | +531 |
# UI module to display filter summary |
||
| 591 | +532 |
- # renders text describing number of selected levels+ # renders text describing selected date range and |
||
| 592 | +533 |
- # and if NA are included also+ # if NA are included also |
||
| 593 | +534 |
content_summary = function(id) {
|
||
| 594 | -7x | -
- selected <- private$get_selected()- |
- ||
| 595 | -7x | -
- selected_text <-- |
- ||
| 596 | -7x | -
- if (length(selected) == 0L) {
- |
- ||
| 597 | +535 | ! |
- "no selection"- |
- |
| 598 | -- |
- } else {
- |
- ||
| 599 | -7x | -
- if (sum(nchar(selected)) <= 40L) {
- |
- ||
| 600 | -7x | -
- paste(selected, collapse = ", ")- |
- ||
| 601 | -- |
- } else {
+ selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S") |
||
| 602 | +536 | ! |
- paste(length(selected), "levels selected")- |
- |
| 603 | -- |
- }+ min <- selected[1] |
||
| 604 | -+ | |||
| 537 | +! |
- }+ max <- selected[2] |
||
| 605 | -7x | +|||
| 538 | +! |
tagList( |
||
| 606 | -7x | +|||
| 539 | +! |
tags$span( |
||
| 607 | -7x | +|||
| 540 | +! |
class = "filter-card-summary-value", |
||
| 608 | -7x | +|||
| 541 | +! |
- selected_text+ HTML(min, "–", max) |
||
| 609 | +542 |
), |
||
| 610 | -7x | +|||
| 543 | +! |
tags$span( |
||
| 611 | -7x | +|||
| 544 | +! |
class = "filter-card-summary-controls", |
||
| 612 | -7x | +|||
| 545 | +! |
if (private$na_count > 0) {
|
||
| 613 | +546 | ! |
tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
|
|
| 614 | +547 |
} |
||
| 615 | +548 |
) |
||
| 616 | +549 |
) |
||
| 617 | +550 |
} |
||
| 618 | +551 |
) |
||
| 619 | +552 |
)@@ -54429,6259 +53653,6526 @@ teal.slice coverage - 65.96% |
| 1 |
- # MAEFilterStates ------+ #' Set "`<choice>:<label>`" type of names |
||
| 2 |
-
+ #' |
||
| 3 |
- #' @name MAEFilterStates+ #' @description `r lifecycle::badge("stable")`
|
||
| 4 |
- #' @docType class+ #' |
||
| 5 |
- #' @title `FilterStates` subclass for `MultiAssayExperiment`s+ #' This is often useful for as it marks up the drop-down boxes for [shiny::selectInput()]. |
||
| 6 |
- #' @description Handles filter states in a `MultiAssayExperiment`.+ #' |
||
| 7 |
- #' @keywords internal+ #' @details |
||
| 8 |
- #'+ #' If either `choices` or `labels` are factors, they are coerced to character. |
||
| 9 |
- MAEFilterStates <- R6::R6Class( # nolint+ #' Duplicated elements from `choices` get removed. |
||
| 10 |
- classname = "MAEFilterStates",+ #' |
||
| 11 |
- inherit = FilterStates,+ #' @param choices (`character` or `numeric` or `logical`) vector |
||
| 12 |
- # public methods ----+ #' @param labels (`character`) vector containing labels to be applied to `choices`. If `NA` then |
||
| 13 |
- public = list(+ #' "Label Missing" will be used. |
||
| 14 |
- #' @description+ #' @param subset a vector that is a subset of `choices`. This is useful if |
||
| 15 |
- #' Initialize `MAEFilterStates` object.+ #' only a few variables need to be named. If this argument is used, the returned vector will |
||
| 16 |
- #'+ #' match its order. |
||
| 17 |
- #' @param data (`MultiAssayExperiment`)+ #' @param types vector containing the types of the columns. |
||
| 18 |
- #' the `R` object which `MultiAssayExperiment::subsetByColData` function is applied on.+ #' |
||
| 19 |
- #' @param data_reactive (`function(sid)`)+ #' @return A named character vector. |
||
| 20 |
- #' should return a `MultiAssayExperiment` object or `NULL`.+ #' |
||
| 21 |
- #' This object is needed for the `FilterState` counts being updated+ #' @keywords internal |
||
| 22 |
- #' on a change in filters. If function returns `NULL` then filtered counts are not shown.+ #' |
||
| 23 |
- #' Function has to have `sid` argument being a character.+ choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
|
||
| 24 | -+ | 9x |
- #' @param dataname (`character(1)`)+ if (is.factor(choices)) {
|
| 25 | -+ | ! |
- #' name of the data used in the subset expression.+ choices <- as.character(choices) |
| 26 |
- #' Passed to the function argument attached to this `FilterStates`.+ } |
||
| 27 |
- #' @param datalabel (`character(1)`) optional+ |
||
| 28 | -+ | 9x |
- #' text label.+ stopifnot( |
| 29 | -+ | 9x |
- #' @param varlabels (`character`)+ is.character(choices) || |
| 30 | -+ | 9x |
- #' labels of the variables used in this object.+ is.numeric(choices) || |
| 31 | -+ | 9x |
- #' @param keys (`character`)+ is.logical(choices) || |
| 32 | -+ | 9x |
- #' key column names.+ (length(choices) == 1 && is.na(choices)) |
| 33 |
- #'+ ) |
||
| 34 |
- initialize = function(data,+ |
||
| 35 | -+ | 9x |
- data_reactive = function(sid = "") NULL,+ if (is.factor(labels)) {
|
| 36 | -+ | ! |
- dataname,+ labels <- as.character(labels) |
| 37 |
- datalabel = "subjects",+ } |
||
| 38 |
- keys = character(0)) {
+
|
||
| 39 | -26x | +9x |
- if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ checkmate::assert_character(labels[!is.na(labels)], any.missing = FALSE) |
| 40 | -! | +9x |
- stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ if (length(choices) != length(labels)) {
|
| 41 | -+ | ! |
- }+ stop("length of choices must be the same as labels")
|
| 42 | -26x | +
- checkmate::assert_function(data_reactive, args = "sid")+ } |
|
| 43 | -26x | +9x |
- checkmate::assert_class(data, "MultiAssayExperiment")+ stopifnot(is.null(subset) || is.vector(subset)) |
| 44 | -+ | 9x |
-
+ stopifnot(is.null(types) || is.vector(types)) |
| 45 | -25x | +
- data <- SummarizedExperiment::colData(data)+ |
|
| 46 | -25x | +9x |
- data_reactive <- function(sid = "") SummarizedExperiment::colData(data_reactive(sid = sid))+ if (is.vector(types)) {
|
| 47 | -25x | +9x |
- super$initialize(data, data_reactive, dataname, datalabel)+ stopifnot(length(choices) == length(types)) |
| 48 | -25x | +
- private$keys <- keys+ } |
|
| 49 | -25x | +
- private$set_filterable_varnames(include_varnames = colnames(data))+ |
|
| 50 | -+ | 9x |
-
+ if (!is.null(subset)) {
|
| 51 | -25x | +! |
- invisible(self)+ if (!all(subset %in% choices)) {
|
| 52 | +! | +
+ stop("all of subset variables must be in choices")
+ |
+ |
| 53 |
} |
||
| 54 | +! | +
+ labels <- labels[choices %in% subset]+ |
+ |
| 55 | +! | +
+ types <- types[choices %in% subset]+ |
+ |
| 56 | +! | +
+ choices <- choices[choices %in% subset]+ |
+ |
| 53 | +57 |
- ),+ } |
|
| 54 | +58 | ||
| 59 | +9x | +
+ is_dupl <- duplicated(choices)+ |
+ |
| 60 | +9x | +
+ choices <- choices[!is_dupl]+ |
+ |
| 61 | +9x | +
+ labels <- labels[!is_dupl]+ |
+ |
| 62 | +9x | +
+ types <- types[!is_dupl]+ |
+ |
| 63 | +9x | +
+ labels[is.na(labels)] <- "Label Missing"+ |
+ |
| 64 | +9x | +
+ raw_labels <- labels+ |
+ |
| 65 | +9x | +
+ combined_labels <- if (length(choices) > 0) {
+ |
+ |
| 66 | +9x | +
+ paste0(choices, ": ", labels)+ |
+ |
| 55 | +67 |
- # private fields ----+ } else {
+ |
+ |
| 68 | +! | +
+ character(0) |
|
| 56 | +69 |
-
+ } |
|
| 57 | +70 |
- private = list(+ + |
+ |
| 71 | +9x | +
+ if (!is.null(subset)) {
+ |
+ |
| 72 | +! | +
+ ord <- match(subset, choices)+ |
+ |
| 73 | +! | +
+ choices <- choices[ord]+ |
+ |
| 74 | +! | +
+ raw_labels <- raw_labels[ord]+ |
+ |
| 75 | +! | +
+ combined_labels <- combined_labels[ord]+ |
+ |
| 76 | +! | +
+ types <- types[ord] |
|
| 58 | +77 |
- extract_type = "list",+ }+ |
+ |
| 78 | +9x | +
+ choices <- structure(+ |
+ |
| 79 | +9x | +
+ choices,+ |
+ |
| 80 | +9x | +
+ names = combined_labels,+ |
+ |
| 81 | +9x | +
+ raw_labels = raw_labels,+ |
+ |
| 82 | +9x | +
+ combined_labels = combined_labels,+ |
+ |
| 83 | +9x | +
+ class = c("choices_labeled", "character"),
+ |
+ |
| 84 | +9x | +
+ types = types |
|
| 59 | +85 |
- fun = quote(MultiAssayExperiment::subsetByColData)+ ) |
|
| 60 | +86 |
- )+ + |
+ |
| 87 | +9x | +
+ choices |
|
| 61 | +88 |
- )+ } |
| 1 |
- #' Initialize `FilteredDataset`+ # MAEFilterStates ------ |
||
| 2 |
- #'+ |
||
| 3 |
- #' Initializes a `FilteredDataset` object corresponding to the class of the filtered dataset.+ #' @name MAEFilterStates |
||
| 4 |
- #'+ #' @docType class |
||
| 5 |
- #' @param dataset any object+ #' @title `FilterStates` subclass for `MultiAssayExperiment`s |
||
| 6 |
- #' @param dataname (`character(1)`)+ #' @description Handles filter states in a `MultiAssayExperiment`. |
||
| 7 |
- #' syntactically valid name given to the dataset.+ #' @keywords internal |
||
| 8 |
- #' @param keys (`character`) optional+ #' |
||
| 9 |
- #' vector of primary key column names.+ MAEFilterStates <- R6::R6Class( # nolint |
||
| 10 |
- #' @param parent_name (`character(1)`)+ classname = "MAEFilterStates", |
||
| 11 |
- #' name of the parent dataset.+ inherit = FilterStates, |
||
| 12 |
- #' @param parent (`reactive`)+ # public methods ---- |
||
| 13 |
- #' that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`.+ public = list( |
||
| 14 |
- #' Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset`+ #' @description |
||
| 15 |
- #' based on the changes in `parent`.+ #' Initialize `MAEFilterStates` object. |
||
| 16 |
- #' @param join_keys (`character`)+ #' |
||
| 17 |
- #' vector of names of columns in this dataset to join with `parent` dataset.+ #' @param data (`MultiAssayExperiment`) |
||
| 18 |
- #' If column names in the parent do not match these, they should be given as the names of this vector.+ #' the `R` object which `MultiAssayExperiment::subsetByColData` function is applied on. |
||
| 19 |
- #' @param label (`character(1)`)+ #' @param data_reactive (`function(sid)`) |
||
| 20 |
- #' label to describe the dataset.+ #' should return a `MultiAssayExperiment` object or `NULL`. |
||
| 21 |
- #'+ #' This object is needed for the `FilterState` counts being updated |
||
| 22 |
- #' @return Object of class `FilteredDataset`.+ #' on a change in filters. If function returns `NULL` then filtered counts are not shown. |
||
| 23 |
- #'+ #' Function has to have `sid` argument being a character. |
||
| 24 |
- #' @section Warning:+ #' @param dataname (`character(1)`) |
||
| 25 |
- #' This function is exported to allow other packages to extend `teal.slice` but it is treated as internal.+ #' name of the data used in the subset expression. |
||
| 26 |
- #' Breaking changes may occur without warning.+ #' Passed to the function argument attached to this `FilterStates`. |
||
| 27 |
- #' We recommend consulting the package maintainer before using it.+ #' @param datalabel (`character(1)`) optional |
||
| 28 |
- #'+ #' text label. |
||
| 29 |
- #' @examples+ #' @param varlabels (`character`) |
||
| 30 |
- #' # DataframeFilteredDataset example+ #' labels of the variables used in this object. |
||
| 31 |
- #' library(shiny)+ #' @param keys (`character`) |
||
| 32 |
- #'+ #' key column names. |
||
| 33 |
- #' iris_fd <- init_filtered_dataset(iris, dataname = "iris")+ #' |
||
| 34 |
- #' ui <- fluidPage(+ initialize = function(data, |
||
| 35 |
- #' iris_fd$ui_add(id = "add"),+ data_reactive = function(sid = "") NULL, |
||
| 36 |
- #' iris_fd$ui_active("dataset"),
+ dataname, |
||
| 37 |
- #' verbatimTextOutput("call")
+ datalabel = "subjects", |
||
| 38 |
- #' )+ keys = character(0)) {
|
||
| 39 | -+ | 26x |
- #' server <- function(input, output, session) {
+ if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
| 40 | -+ | ! |
- #' iris_fd$srv_add(id = "add")+ stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
|
| 41 |
- #' iris_fd$srv_active(id = "dataset")+ } |
||
| 42 | -+ | 26x |
- #'+ checkmate::assert_function(data_reactive, args = "sid") |
| 43 | -+ | 26x |
- #' output$call <- renderText({
+ checkmate::assert_class(data, "MultiAssayExperiment") |
| 44 |
- #' paste(+ |
||
| 45 | -+ | 25x |
- #' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),+ data <- SummarizedExperiment::colData(data) |
| 46 | -+ | 25x |
- #' collapse = "\n"+ data_reactive <- function(sid = "") SummarizedExperiment::colData(data_reactive(sid = sid)) |
| 47 | -+ | 25x |
- #' )+ super$initialize(data, data_reactive, dataname, datalabel) |
| 48 | -+ | 25x |
- #' })+ private$keys <- keys |
| 49 | -+ | 25x |
- #' }+ private$set_filterable_varnames(include_varnames = colnames(data)) |
| 50 |
- #' if (interactive()) {
+
|
||
| 51 | -+ | 25x |
- #' shinyApp(ui, server)+ invisible(self) |
| 52 |
- #' }+ } |
||
| 53 |
- #'+ ), |
||
| 54 |
- #' @examples+ |
||
| 55 |
- #' \donttest{
+ # private fields ---- |
||
| 56 |
- #' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+
|
||
| 57 |
- #' # MAEFilteredDataset example+ private = list( |
||
| 58 |
- #' library(shiny)+ extract_type = "list", |
||
| 59 |
- #'+ fun = quote(MultiAssayExperiment::subsetByColData) |
||
| 60 |
- #' data(miniACC, package = "MultiAssayExperiment")+ ) |
||
| 61 |
- #'+ ) |
| 62 | +1 |
- #' MAE_fd <- init_filtered_dataset(miniACC, "MAE")+ #' Initialize `FilteredData` |
||
| 63 | +2 |
- #' ui <- fluidPage(+ #' |
||
| 64 | +3 |
- #' MAE_fd$ui_add(id = "add"),+ #' Function creates a `FilteredData` object. |
||
| 65 | +4 |
- #' MAE_fd$ui_active("dataset"),
+ #' |
||
| 66 | +5 |
- #' verbatimTextOutput("call")
+ #' @param x (`named list`) of datasets. |
||
| 67 | +6 |
- #' )+ #' @param join_keys (`join_keys`) see [`teal.data::join_keys()`]. |
||
| 68 | +7 |
- #' server <- function(input, output, session) {
+ #' @param code `r lifecycle::badge("deprecated")`
|
||
| 69 | +8 |
- #' MAE_fd$srv_add(id = "add")+ #' @param check `r lifecycle::badge("deprecated")`
|
||
| 70 | +9 |
- #' MAE_fd$srv_active(id = "dataset")+ #' |
||
| 71 | +10 |
- #' output$call <- renderText({
+ #' @return Object of class `FilteredData`. |
||
| 72 | +11 |
- #' paste(+ #' |
||
| 73 | +12 |
- #' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),+ #' @examples |
||
| 74 | +13 |
- #' collapse = "\n"+ #' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars)) |
||
| 75 | +14 |
- #' )+ #' datasets |
||
| 76 | +15 |
- #' })+ #' |
||
| 77 | +16 |
- #' }+ #' @export |
||
| 78 | +17 |
- #' if (interactive()) {
+ init_filtered_data <- function(x, join_keys = teal.data::join_keys(), code, check) { # nolint
|
||
| 79 | -+ | |||
| 18 | +7x |
- #' shinyApp(ui, server)+ checkmate::assert_list(x, any.missing = FALSE, names = "unique") |
||
| 80 | -+ | |||
| 19 | +6x |
- #' }+ checkmate::assert_class(join_keys, "join_keys") |
||
| 81 | -+ | |||
| 20 | +5x |
- #' }+ if (!missing(code)) {
|
||
| 82 | -+ | |||
| 21 | +! |
- #' }+ lifecycle::deprecate_stop( |
||
| 83 | -+ | |||
| 22 | +! |
- #' @keywords internal+ "0.5.0", |
||
| 84 | -+ | |||
| 23 | +! |
- #' @export+ "init_filtered_data(code = 'No longer supported')" |
||
| 85 | +24 |
- init_filtered_dataset <- function(dataset,+ ) |
||
| 86 | +25 |
- dataname,+ } |
||
| 87 | -+ | |||
| 26 | +5x |
- keys = character(0),+ if (!missing(check)) {
|
||
| 88 | -+ | |||
| 27 | +! |
- parent_name = character(0),+ lifecycle::deprecate_stop( |
||
| 89 | -+ | |||
| 28 | +! |
- parent = reactive(dataset),+ "0.5.0",+ |
+ ||
| 29 | +! | +
+ "init_filtered_data(check = 'No longer supported')" |
||
| 90 | +30 |
- join_keys = character(0),+ ) |
||
| 91 | +31 |
- label = attr(dataset, "label", exact = TRUE)) {
+ } |
||
| 92 | -107x | +32 | +5x |
- UseMethod("init_filtered_dataset")
+ FilteredData$new(x, join_keys = join_keys) |
| 93 | +33 |
} |
||
| 94 | +34 | |||
| 95 | +35 |
- #' @keywords internal+ #' Evaluate expression with meaningful message |
||
| 96 | +36 |
- #' @export+ #' |
||
| 97 | +37 |
- init_filtered_dataset.data.frame <- function(dataset,+ #' Method created for the `FilteredData` object to execute filter call with |
||
| 98 | +38 |
- dataname,+ #' meaningful message. After evaluation used environment should contain |
||
| 99 | +39 |
- keys = character(0),+ #' all necessary bindings. |
||
| 100 | +40 |
- parent_name = character(0),+ #' |
||
| 101 | +41 |
- parent = NULL,+ #' @param expr (`language`) |
||
| 102 | +42 |
- join_keys = character(0),+ #' @param env (`environment`) where expression is evaluated. |
||
| 103 | +43 |
- label = attr(dataset, "label", exact = TRUE)) {
+ #' @return `NULL`, invisibly. |
||
| 104 | -83x | +|||
| 44 | +
- DataframeFilteredDataset$new(+ #' @keywords internal |
|||
| 105 | -83x | +|||
| 45 | +
- dataset = dataset,+ eval_expr_with_msg <- function(expr, env) {
|
|||
| 106 | -83x | +46 | +32x |
- dataname = dataname,+ lapply( |
| 107 | -83x | +47 | +32x |
- keys = keys,+ expr, |
| 108 | -83x | +48 | +32x |
- parent_name = parent_name,+ function(x) {
|
| 109 | -83x | +49 | +19x |
- parent = parent,+ tryCatch( |
| 110 | -83x | +50 | +19x |
- join_keys = join_keys,+ eval(x, envir = env), |
| 111 | -83x | +51 | +19x |
- label = label+ error = function(e) {
|
| 112 | -+ | |||
| 52 | +! |
- )+ stop( |
||
| 113 | -+ | |||
| 53 | +! |
- }+ sprintf( |
||
| 114 | -+ | |||
| 54 | +! |
-
+ "Call execution failed:\n - call:\n %s\n - message:\n %s ", |
||
| 115 | -+ | |||
| 55 | +! |
- #' @keywords internal+ deparse1(x, collapse = "\n"), e |
||
| 116 | +56 |
- #' @export+ ) |
||
| 117 | +57 |
- init_filtered_dataset.MultiAssayExperiment <- function(dataset,+ ) |
||
| 118 | +58 |
- dataname,+ } |
||
| 119 | +59 |
- keys = character(0),+ ) |
||
| 120 | +60 |
- parent_name, # ignored+ } |
||
| 121 | +61 |
- parent, # ignored+ ) |
||
| 122 | -+ | |||
| 62 | +32x |
- join_keys, # ignored+ invisible(NULL) |
||
| 123 | +63 |
- label = attr(dataset, "label", exact = TRUE)) {
- |
- ||
| 124 | -7x | -
- if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
- |
- ||
| 125 | -! | -
- stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ } |
||
| 126 | +64 |
- }- |
- ||
| 127 | -7x | -
- MAEFilteredDataset$new(- |
- ||
| 128 | -7x | -
- dataset = dataset,- |
- ||
| 129 | -7x | -
- dataname = dataname,- |
- ||
| 130 | -7x | -
- keys = keys,- |
- ||
| 131 | -7x | -
- label = label+ |
||
| 132 | +65 |
- )+ |
||
| 133 | +66 |
- }+ #' Toggle button properties. |
||
| 134 | +67 |
-
+ #' |
||
| 135 | +68 |
- #' @keywords internal+ #' Switch between different icons or titles on a button. |
||
| 136 | +69 |
- #' @export+ #' |
||
| 137 | +70 |
- init_filtered_dataset.default <- function(dataset,+ #' Wrapper functions that use `shinyjs::runjs` to change button properties in response to events, |
||
| 138 | +71 |
- dataname,+ #' typically clicking those very buttons. |
||
| 139 | +72 |
- keys, # ignored+ #' `shiny`'s `actionButton` and `actionLink` create `<a>` tags, |
||
| 140 | +73 |
- parent_name, # ignored+ #' which may contain a child `<i>` tag that specifies an icon to be displayed. |
||
| 141 | +74 |
- parent, # ignored+ #' `toggle_icon` calls the `toggleClass` (when `one_way = FALSE`) or |
||
| 142 | +75 |
- join_keys, # ignored+ #' `removeClass` and `addClass` methods (when `one_way = TRUE`) to change icons. |
||
| 143 | +76 |
- label = attr(dataset, "label", exact = TRUE)) {
+ #' `toggle_title` calls the `attr` method to modify the `Title` attribute of the button. |
||
| 144 | -17x | +|||
| 77 | +
- DefaultFilteredDataset$new(+ #' |
|||
| 145 | -17x | +|||
| 78 | +
- dataset = dataset,+ #' @param input_id (`character(1)`) (name-spaced) id of the button |
|||
| 146 | -17x | +|||
| 79 | +
- dataname = dataname,+ #' @param icons,titles (`character(2)`) vector specifying values between which to toggle |
|||
| 147 | -17x | +|||
| 80 | +
- label = label+ #' @param one_way (`logical(1)`) flag specifying whether to keep toggling; |
|||
| 148 | +81 |
- )+ #' if TRUE, the target will be changed |
||
| 149 | +82 |
- }+ #' from the first element of `icons`/`titles` to the second |
| 1 | +83 |
- #' Progress bars with labels+ #' |
||
| 2 | +84 |
- #'+ #' @return `NULL`, invisibly. |
||
| 3 | +85 |
- #' `shiny` element displaying a series of progress bars and observation counts.+ #' |
||
| 4 | +86 |
- #'+ #' @examples |
||
| 5 | +87 |
- #' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input).+ #' # use non-exported function from teal.slice |
||
| 6 | +88 |
- #' @param choices (`vector`) Available values. Used to determine label text.+ #' toggle_icon <- getFromNamespace("toggle_icon", "teal.slice")
|
||
| 7 | +89 |
- #' @param countsmax (`numeric`) Maximum counts of each element. Must be the same length `choices`.+ #' |
||
| 8 | +90 |
- #' @param countsnow (`numeric`) Current counts of each element. Must be the same length `choices`.+ #' library(shiny) |
||
| 9 | +91 |
- #' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`.+ #' library(shinyjs) |
||
| 10 | +92 |
#' |
||
| 11 | +93 |
- #' @return List of `shiny.tag`s.+ #' ui <- fluidPage( |
||
| 12 | +94 |
- #'+ #' useShinyjs(), |
||
| 13 | +95 |
- #' Creates a number of progress bar elements, one for each value of `choices`.+ #' actionButton("hide_content", label = "hide", icon = icon("xmark")),
|
||
| 14 | +96 |
- #' The widths of all progress bars add up to the full width of the container.+ #' actionButton("show_content", label = "show", icon = icon("check")),
|
||
| 15 | +97 |
- #' Each progress bar has a text label that contains the name of the value and the number of counts.+ #' actionButton("toggle_content", label = "toggle", icon = icon("angle-down")),
|
||
| 16 | +98 |
- #'+ #' tags$br(), |
||
| 17 | +99 |
- #' If the filter panel is used with `count_type = "all"`, the progress bars will be filled+ #' tags$div( |
||
| 18 | +100 |
- #' according to the number of counts remaining in the current selection and the label will show+ #' id = "content", |
||
| 19 | +101 |
- #' both the current and the total number of counts.+ #' verbatimTextOutput("printout")
|
||
| 20 | +102 |
- #'+ #' ) |
||
| 21 | +103 |
- #' Each child element can have a unique `id` attribute to be used independently.+ #' ) |
||
| 22 | +104 |
#' |
||
| 23 | +105 |
- #' @examples+ #' server <- function(input, output, session) {
|
||
| 24 | +106 |
- #' # use non-exported function from teal.slice+ #' observeEvent(input$hide_content, |
||
| 25 | +107 |
- #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
+ #' {
|
||
| 26 | +108 |
- #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
+ #' hide("content")
|
||
| 27 | +109 |
- #' countBars <- getFromNamespace("countBars", "teal.slice")
+ #' toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE)
|
||
| 28 | +110 |
- #' updateCountBars <- getFromNamespace("updateCountBars", "teal.slice")
+ #' }, |
||
| 29 | +111 |
- #'+ #' ignoreInit = TRUE |
||
| 30 | +112 |
- #' library(shiny)+ #' ) |
||
| 31 | +113 |
#' |
||
| 32 | +114 |
- #' choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE)
+ #' observeEvent(input$show_content, |
||
| 33 | +115 |
- #' counts <- table(choices)+ #' {
|
||
| 34 | +116 |
- #' labels <- countBars(+ #' show("content")
|
||
| 35 | +117 |
- #' inputId = "counts",+ #' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE)
|
||
| 36 | +118 |
- #' choices = c("a", "b", "c"),
+ #' }, |
||
| 37 | +119 |
- #' countsmax = counts,+ #' ignoreInit = TRUE |
||
| 38 | +120 |
- #' countsnow = unname(counts)+ #' ) |
||
| 39 | +121 |
- #' )+ #' |
||
| 40 | +122 |
- #'+ #' observeEvent(input$toggle_content, |
||
| 41 | +123 |
- #' ui <- fluidPage(+ #' {
|
||
| 42 | +124 |
- #' tags$div(+ #' toggle("content")
|
||
| 43 | +125 |
- #' class = "choices_state",+ #' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"))
|
||
| 44 | +126 |
- #' include_js_files("count-bar-labels.js"),
+ #' }, |
||
| 45 | +127 |
- #' include_css_files(pattern = "filter-panel"),+ #' ignoreInit = TRUE |
||
| 46 | +128 |
- #' checkboxGroupInput(+ #' ) |
||
| 47 | +129 |
- #' inputId = "choices",+ #' |
||
| 48 | +130 |
- #' selected = levels(choices),+ #' output$printout <- renderPrint({
|
||
| 49 | +131 |
- #' choiceNames = labels,+ #' head(faithful, 10) |
||
| 50 | +132 |
- #' choiceValues = levels(choices),+ #' }) |
||
| 51 | +133 |
- #' label = NULL+ #' } |
||
| 52 | +134 |
- #' )+ #' if (interactive()) {
|
||
| 53 | +135 |
- #' )+ #' shinyApp(ui, server) |
||
| 54 | +136 |
- #' )+ #' } |
||
| 55 | +137 |
- #' server <- function(input, output, session) {
+ #' |
||
| 56 | +138 |
- #' observeEvent(input$choices, {
+ #' @name toggle_button |
||
| 57 | +139 |
- #' new_counts <- counts+ #' @rdname toggle_button |
||
| 58 | +140 |
- #' new_counts[!names(new_counts) %in% input$choices] <- 0+ #' @keywords internal |
||
| 59 | +141 |
- #' updateCountBars(+ toggle_icon <- function(input_id, icons, one_way = FALSE) {
|
||
| 60 | -+ | |||
| 142 | +3x |
- #' inputId = "counts",+ checkmate::assert_string(input_id) |
||
| 61 | -+ | |||
| 143 | +3x |
- #' choices = levels(choices),+ checkmate::assert_character(icons, len = 2L) |
||
| 62 | -+ | |||
| 144 | +3x |
- #' countsmax = counts,+ checkmate::assert_flag(one_way) |
||
| 63 | +145 |
- #' countsnow = unname(new_counts)+ + |
+ ||
| 146 | +3x | +
+ expr <-+ |
+ ||
| 147 | +3x | +
+ if (one_way) {
+ |
+ ||
| 148 | +3x | +
+ sprintf(+ |
+ ||
| 149 | +3x | +
+ "$('#%s i').removeClass('%s').addClass('%s');",
+ |
+ ||
| 150 | +3x | +
+ input_id, icons[1], icons[2] |
||
| 64 | +151 |
- #' )+ ) |
||
| 65 | +152 |
- #' })+ } else {
+ |
+ ||
| 153 | +! | +
+ sprintf("$('#%s i').toggleClass('%s');", input_id, paste(icons, collapse = " "))
|
||
| 66 | +154 |
- #' }+ } |
||
| 67 | +155 |
- #'+ + |
+ ||
| 156 | +3x | +
+ shinyjs::runjs(expr) |
||
| 68 | +157 |
- #' if (interactive()) {
+
+ |
+ ||
| 158 | +3x | +
+ invisible(NULL) |
||
| 69 | +159 |
- #' shinyApp(ui, server)+ } |
||
| 70 | +160 |
- #' }+ |
||
| 71 | +161 |
- #'+ #' @rdname toggle_button |
||
| 72 | +162 |
#' @keywords internal |
||
| 73 | +163 |
- #'+ toggle_title <- function(input_id, titles, one_way = FALSE) {
+ |
+ ||
| 164 | +3x | +
+ checkmate::assert_string(input_id)+ |
+ ||
| 165 | +3x | +
+ checkmate::assert_character(titles, len = 2L)+ |
+ ||
| 166 | +3x | +
+ checkmate::assert_flag(one_way) |
||
| 74 | +167 |
- countBars <- function(inputId, choices, countsmax, countsnow = NULL) { # nolint
+
|
||
| 75 | -25x | +168 | +3x | +
+ expr <-+ |
+
| 169 | +3x | +
+ if (one_way) {
+ |
+ ||
| 170 | +3x | +
+ sprintf(+ |
+ ||
| 171 | +3x | +
+ "$('a#%s').attr('title', '%s');",
+ |
+ ||
| 172 | +3x | +
+ input_id, titles[2]+ |
+ ||
| 173 | ++ |
+ )+ |
+ ||
| 174 | ++ |
+ } else {
+ |
+ ||
| 175 | +! |
- checkmate::assert_string(inputId)+ sprintf( |
||
| 76 | -21x | +|||
| 176 | +! |
- checkmate::assert_vector(choices)+ paste0( |
||
| 77 | -20x | +|||
| 177 | +! |
- checkmate::assert_numeric(countsmax, len = length(choices))+ "var button_id = 'a#%1$s';", |
||
| 78 | -17x | +|||
| 178 | +! |
- checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)+ "var curr = $(button_id).attr('title');",
|
||
| 79 | -15x | +|||
| 179 | +! |
- if (!is.null(countsnow)) {
+ "if (curr == '%2$s') { $(button_id).attr('title', '%3$s');",
|
||
| 80 | -7x | +|||
| 180 | +! |
- checkmate::assert_true(all(countsnow <= countsmax))+ "} else { $(button_id).attr('title', '%2$s');",
|
||
| 81 | +181 |
- }+ "}" |
||
| 82 | +182 |
-
+ ), |
||
| 83 | -14x | +|||
| 183 | +! |
- ns <- NS(inputId)+ input_id, titles[1], titles[2] |
||
| 84 | +184 | - - | -||
| 85 | -14x | -
- mapply(+ ) |
||
| 86 | -14x | +|||
| 185 | +
- countBar,+ } |
|||
| 87 | -14x | +|||
| 186 | +
- inputId = ns(seq_along(choices)),+ |
|||
| 88 | -14x | +187 | +3x |
- label = as.character(choices),+ shinyjs::runjs(expr) |
| 89 | -14x | +|||
| 188 | +
- countmax = countsmax,+ |
|||
| 90 | -14x | +189 | +3x |
- countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,+ invisible(NULL) |
| 91 | -14x | +|||
| 190 | +
- MoreArgs = list(+ } |
|||
| 92 | -14x | +|||
| 191 | +
- counttotal = sum(countsmax)+ |
|||
| 93 | +192 |
- ),+ #' @inherit teal.data::topological_sort description details params title |
||
| 94 | -14x | +|||
| 193 | +
- SIMPLIFY = FALSE, USE.NAMES = FALSE+ #' @examples |
|||
| 95 | +194 |
- )+ #' # use non-exported function from teal.slice |
||
| 96 | +195 |
- }+ #' topological_sort <- getFromNamespace("topological_sort", "teal.slice")
|
||
| 97 | +196 |
-
+ #' |
||
| 98 | +197 |
- #' Progress bar with label+ #' topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
|
||
| 99 | +198 |
- #'+ #' topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
|
||
| 100 | +199 |
- #' `shiny` element displaying a progress bar and observation count.+ #' topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
|
||
| 101 | +200 |
- #'+ #' @keywords internal |
||
| 102 | +201 |
- #' A progress bar is created to visualize the number of counts in a variable, with filling and a text label.+ topological_sort <- function(graph) {
|
||
| 103 | -+ | |||
| 202 | +66x |
- #' - progress bar width is derived as a fraction of the container width: `style = "width: <countmax> / <counttotal>%"`,+ utils::getFromNamespace("topological_sort", ns = "teal.data")(graph)
|
||
| 104 | +203 |
- #' - progress bar is filled up to the fraction `<countnow> / <countmax>`,+ } |
| 105 | +1 |
- #' - text label is obtained by `<label> (<countnow> / <countmax>)`.+ # DateFilterState ------ |
|
| 106 | +2 |
- #'+ |
|
| 107 | +3 |
- #' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input).+ #' @name DateFilterState |
|
| 108 | +4 |
- #' @param label (`character(1)`) Text to display followed by counts.+ #' @docType class |
|
| 109 | +5 |
- #' @param countmax (`numeric(1)`) Maximum count for a single element.+ #' |
|
| 110 | +6 |
- #' @param countnow (`numeric(1)`) Current count for a single element.+ #' @title `FilterState` object for `Date` data |
|
| 111 | +7 |
- #' @param counttotal (`numeric(1)`) Sum total of maximum counts of all elements, see `Details`.+ #' |
|
| 112 | +8 |
- #' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`.+ #' @description Manages choosing a range of `Date`s. |
|
| 113 | +9 |
#' |
|
| 114 | +10 |
- #' @return `shiny.tag` object with a progress bar and a label.+ #' @examples |
|
| 115 | +11 |
- #'+ #' # use non-exported function from teal.slice |
|
| 116 | +12 |
- #' @keywords internal+ #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 117 | +13 |
- #'+ #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 118 | +14 |
- countBar <- function(inputId, label, countmax, countnow = NULL, counttotal = countmax) { # nolint
+ #' DateFilterState <- getFromNamespace("DateFilterState", "teal.slice")
|
|
| 119 | -62x | +||
| 15 | +
- checkmate::assert_string(inputId)+ #' |
||
| 120 | -58x | +||
| 16 | +
- checkmate::assert_string(label)+ #' library(shiny) |
||
| 121 | -55x | +||
| 17 | +
- checkmate::assert_number(countmax)+ #' |
||
| 122 | -53x | +||
| 18 | +
- checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax)+ #' filter_state <- DateFilterState$new( |
||
| 123 | -51x | +||
| 19 | +
- checkmate::assert_number(counttotal, lower = countmax)+ #' x = c(Sys.Date() + seq(1:10), NA), |
||
| 124 | +20 |
-
+ #' slice = teal_slice(varname = "x", dataname = "data"), |
|
| 125 | -49x | +||
| 21 | +
- label <- make_count_text(label, countmax = countmax, countnow = countnow)+ #' extract_type = character(0) |
||
| 126 | -49x | +||
| 22 | +
- ns <- NS(inputId)+ #' ) |
||
| 127 | -26x | +||
| 23 | +
- if (is.null(countnow)) countnow <- 0+ #' isolate(filter_state$get_call()) |
||
| 128 | -49x | +||
| 24 | +
- tags$div(+ #' filter_state$set_state( |
||
| 129 | -49x | +||
| 25 | +
- class = "progress state-count-container",+ #' teal_slice( |
||
| 130 | +26 |
- # * .9 to not exceed width of the parent html element+ #' dataname = "data", |
|
| 131 | -49x | +||
| 27 | +
- tags$div(+ #' varname = "x", |
||
| 132 | -49x | +||
| 28 | +
- id = ns("count_bar_filtered"),
+ #' selected = c(Sys.Date() + 3L, Sys.Date() + 8L), |
||
| 133 | -49x | +||
| 29 | +
- class = "progress-bar state-count-bar-filtered",+ #' keep_na = TRUE |
||
| 134 | -49x | +||
| 30 | +
- style = sprintf("width: %s%%", countnow / counttotal * 100),
+ #' ) |
||
| 135 | -49x | +||
| 31 | +
- role = "progressbar",+ #' ) |
||
| 136 | -49x | +||
| 32 | +
- label+ #' isolate(filter_state$get_call()) |
||
| 137 | +33 |
- ),+ #' |
|
| 138 | -49x | +||
| 34 | +
- tags$div(+ #' # working filter in an app |
||
| 139 | -49x | +||
| 35 | +
- id = ns("count_bar_unfiltered"),
+ #' library(shinyjs) |
||
| 140 | -49x | +||
| 36 | +
- class = "progress-bar state-count-bar-unfiltered",+ #' |
||
| 141 | -49x | +||
| 37 | +
- style = sprintf("width: %s%%", (countmax - countnow) / counttotal * 100),
+ #' dates <- c(Sys.Date() - 100, Sys.Date()) |
||
| 142 | -49x | +||
| 38 | +
- role = "progressbar"+ #' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA) |
||
| 143 | +39 |
- )+ #' fs <- DateFilterState$new( |
|
| 144 | +40 |
- )+ #' x = data_date, |
|
| 145 | +41 |
- }+ #' slice = teal_slice( |
|
| 146 | +42 |
-
+ #' dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE |
|
| 147 | +43 |
- #' @rdname countBars+ #' ) |
|
| 148 | +44 |
- updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, countsmax, countsnow = NULL) { # nolint
+ #' ) |
|
| 149 | -7x | +||
| 45 | +
- checkmate::assert_string(inputId)+ #' |
||
| 150 | -7x | +||
| 46 | +
- checkmate::assert_vector(choices)+ #' ui <- fluidPage( |
||
| 151 | -7x | +||
| 47 | +
- checkmate::assert_numeric(countsmax, len = length(choices))+ #' useShinyjs(), |
||
| 152 | -7x | +||
| 48 | +
- checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)+ #' include_css_files(pattern = "filter-panel"), |
||
| 153 | +49 |
-
+ #' include_js_files(pattern = "count-bar-labels"), |
|
| 154 | -7x | +||
| 50 | +
- ns <- NS(inputId)+ #' column(4, tags$div( |
||
| 155 | -7x | +||
| 51 | +
- mapply(+ #' tags$h4("DateFilterState"),
|
||
| 156 | -7x | +||
| 52 | +
- updateCountBar,+ #' fs$ui("fs")
|
||
| 157 | -7x | +||
| 53 | +
- inputId = ns(seq_along(choices)),+ #' )), |
||
| 158 | -7x | +||
| 54 | +
- label = choices,+ #' column(4, tags$div( |
||
| 159 | -7x | +||
| 55 | +
- countmax = countsmax,+ #' id = "outputs", # div id is needed for toggling the element |
||
| 160 | -7x | +||
| 56 | +
- countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,+ #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
||
| 161 | -7x | +||
| 57 | +
- MoreArgs = list(+ #' textOutput("condition_date"), tags$br(),
|
||
| 162 | -7x | +||
| 58 | +
- counttotal = sum(countsmax)+ #' tags$h4("Unformatted state"), # display raw filter state
|
||
| 163 | +59 |
- )+ #' textOutput("unformatted_date"), tags$br(),
|
|
| 164 | +60 |
- )+ #' tags$h4("Formatted state"), # display human readable filter state
|
|
| 165 | -7x | +||
| 61 | +
- invisible(NULL)+ #' textOutput("formatted_date"), tags$br()
|
||
| 166 | +62 |
- }+ #' )), |
|
| 167 | +63 |
-
+ #' column(4, tags$div( |
|
| 168 | +64 |
- #' @rdname countBar+ #' tags$h4("Programmatic filter control"),
|
|
| 169 | +65 |
- updateCountBar <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow = NULL, counttotal) { # nolint
+ #' actionButton("button1_date", "set drop NA", width = "100%"), tags$br(),
|
|
| 170 | -18x | +||
| 66 | +
- checkmate::assert_string(inputId)+ #' actionButton("button2_date", "set keep NA", width = "100%"), tags$br(),
|
||
| 171 | -18x | +||
| 67 | +
- checkmate::assert_string(label)+ #' actionButton("button3_date", "set a range", width = "100%"), tags$br(),
|
||
| 172 | -18x | +||
| 68 | +
- checkmate::assert_number(countmax)+ #' actionButton("button4_date", "set full range", width = "100%"), tags$br(),
|
||
| 173 | -18x | +||
| 69 | +
- checkmate::assert_number(countnow, null.ok = TRUE)+ #' actionButton("button0_date", "set initial state", width = "100%"), tags$br()
|
||
| 174 | -18x | +||
| 70 | +
- checkmate::assert_number(counttotal)+ #' )) |
||
| 175 | +71 |
-
+ #' ) |
|
| 176 | -18x | +||
| 72 | +
- label <- make_count_text(label, countmax = countmax, countnow = countnow)+ #' |
||
| 177 | -18x | +||
| 73 | +
- if (is.null(countnow)) countnow <- countmax+ #' server <- function(input, output, session) {
|
||
| 178 | -18x | +||
| 74 | +
- session$sendCustomMessage(+ #' fs$server("fs")
|
||
| 179 | -18x | +||
| 75 | +
- type = "updateCountBar",+ #' output$condition_date <- renderPrint(fs$get_call()) |
||
| 180 | -18x | +||
| 76 | +
- message = list(+ #' output$formatted_date <- renderText(fs$format()) |
||
| 181 | -18x | +||
| 77 | +
- id = session$ns(inputId),+ #' output$unformatted_date <- renderPrint(fs$get_state()) |
||
| 182 | -18x | +||
| 78 | +
- label = label,+ #' # modify filter state programmatically |
||
| 183 | -18x | +||
| 79 | +
- countmax = countmax,+ #' observeEvent( |
||
| 184 | -18x | +||
| 80 | +
- countnow = countnow,+ #' input$button1_date, |
||
| 185 | -18x | +||
| 81 | +
- counttotal = counttotal+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) |
||
| 186 | +82 |
- )+ #' ) |
|
| 187 | +83 |
- )+ #' observeEvent( |
|
| 188 | +84 |
-
+ #' input$button2_date, |
|
| 189 | -18x | +||
| 85 | +
- invisible(NULL)+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
||
| 190 | +86 |
- }+ #' ) |
|
| 191 | +87 |
-
+ #' observeEvent( |
|
| 192 | +88 |
- #' @rdname countBar+ #' input$button3_date, |
|
| 193 | +89 |
- updateCountText <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow) { # nolint
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)])) |
|
| 194 | -17x | +||
| 90 | +
- checkmate::assert_string(inputId)+ #' ) |
||
| 195 | -17x | +||
| 91 | +
- checkmate::assert_string(label)+ #' observeEvent( |
||
| 196 | -17x | +||
| 92 | +
- checkmate::assert_number(countmax)+ #' input$button4_date, |
||
| 197 | -17x | +||
| 93 | +
- checkmate::assert_number(countnow, null.ok = TRUE)+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates)) |
||
| 198 | -17x | +||
| 94 | +
- label <- make_count_text(label, countmax = countmax, countnow = countnow)+ #' ) |
||
| 199 | -17x | +||
| 95 | +
- session$sendCustomMessage(+ #' observeEvent( |
||
| 200 | -17x | +||
| 96 | +
- type = "updateCountText",+ #' input$button0_date, |
||
| 201 | -17x | +||
| 97 | +
- message = list(+ #' fs$set_state( |
||
| 202 | -17x | +||
| 98 | +
- id = session$ns(inputId),+ #' teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE)
|
||
| 203 | -17x | +||
| 99 | +
- label = label+ #' ) |
||
| 204 | +100 |
- )+ #' ) |
|
| 205 | +101 |
- )+ #' } |
|
| 206 | +102 |
- }+ #' |
|
| 207 | +103 |
-
+ #' if (interactive()) {
|
|
| 208 | +104 |
- #' Build count text+ #' shinyApp(ui, server) |
|
| 209 | +105 |
- #'+ #' } |
|
| 210 | +106 |
- #' Returns a text label describing filtered counts. The text is composed in the following way:+ #' |
|
| 211 | +107 |
- #' - when `countnow` is not `NULL`: `<label> (<countnow>/<countmax>)`+ #' @keywords internal |
|
| 212 | +108 |
- #' - when `countnow` is `NULL`: `<label> (<countmax>)`+ #' |
|
| 213 | +109 |
- #'+ DateFilterState <- R6::R6Class( # nolint |
|
| 214 | +110 |
- #' @param label (`character(1)`) Text displayed before counts.+ "DateFilterState", |
|
| 215 | +111 |
- #' @param countnow (`numeric(1)`) Number of filtered counts.+ inherit = FilterState, |
|
| 216 | +112 |
- #' @param countmax (`numeric(1)`) Number of unfiltered counts.+ |
|
| 217 | +113 |
- #'+ # public methods ---- |
|
| 218 | +114 |
- #' @return A character string.+ |
|
| 219 | +115 |
- #'+ public = list( |
|
| 220 | +116 |
- #' @keywords internal+ |
|
| 221 | +117 |
- #'+ #' @description |
|
| 222 | +118 |
- make_count_text <- function(label, countmax, countnow = NULL) {
+ #' Initialize a `FilterState` object. |
|
| 223 | -96x | +||
| 119 | +
- checkmate::assert_string(label)+ #' |
||
| 224 | -94x | +||
| 120 | +
- checkmate::assert_number(countmax)+ #' @param x (`Date`) |
||
| 225 | -92x | +||
| 121 | +
- checkmate::assert_number(countnow, null.ok = TRUE)+ #' variable to be filtered. |
||
| 226 | -90x | +||
| 122 | +
- sprintf(+ #' @param x_reactive (`reactive`) |
||
| 227 | -90x | +||
| 123 | +
- "%s (%s%s)",+ #' returning vector of the same type as `x`. Is used to update |
||
| 228 | -90x | +||
| 124 | +
- label,+ #' counts following the change in values of the filtered dataset. |
||
| 229 | -90x | +||
| 125 | +
- if (is.null(countnow)) "" else sprintf("%s/", countnow),
+ #' If it is set to `reactive(NULL)` then counts based on filtered |
||
| 230 | -90x | +||
| 126 | +
- countmax+ #' dataset are not shown. |
||
| 231 | +127 |
- )+ #' @param slice (`teal_slice`) |
|
| 232 | +128 |
- }+ #' specification of this filter state. |
| 1 | +129 |
- # EmptyFilterState ------+ #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
||
| 2 | +130 |
-
+ #' `get_state` returns `teal_slice` object which can be reused in other places. |
||
| 3 | +131 |
- #' @name EmptyFilterState+ #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
||
| 4 | +132 |
- #' @docType class+ #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
||
| 5 | +133 |
- #'+ #' @param extract_type (`character`) |
||
| 6 | +134 |
- #' @title `FilterState` object for empty variables+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
||
| 7 | +135 |
- #'+ #' - `character(0)` (default) `varname` in the condition call will not be prefixed |
||
| 8 | +136 |
- #' @description `FilterState` subclass representing an empty variable.+ #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
||
| 9 | +137 |
- #'+ #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
||
| 10 | +138 |
- #' @examples+ #' |
||
| 11 | +139 |
- #' # use non-exported function from teal.slice+ #' @return Object of class `DateFilterState`, invisibly. |
||
| 12 | +140 |
- #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
+ #' |
||
| 13 | +141 |
- #' EmptyFilterState <- getFromNamespace("EmptyFilterState", "teal.slice")
+ initialize = function(x, |
||
| 14 | +142 |
- #'+ x_reactive = reactive(NULL), |
||
| 15 | +143 |
- #' library(shiny)+ slice, |
||
| 16 | +144 |
- #'+ extract_type = character(0)) {
|
||
| 17 | -+ | |||
| 145 | +24x |
- #' filter_state <- EmptyFilterState$new(+ isolate({
|
||
| 18 | -+ | |||
| 146 | +24x |
- #' x = NA,+ checkmate::assert_date(x) |
||
| 19 | -+ | |||
| 147 | +23x |
- #' slice = teal_slice(varname = "x", dataname = "data"),+ checkmate::assert_class(x_reactive, "reactive") |
||
| 20 | +148 |
- #' extract_type = character(0)+ |
||
| 21 | -+ | |||
| 149 | +23x |
- #' )+ super$initialize( |
||
| 22 | -+ | |||
| 150 | +23x |
- #' isolate(filter_state$get_call())+ x = x, |
||
| 23 | -+ | |||
| 151 | +23x |
- #' filter_state$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ x_reactive = x_reactive, |
||
| 24 | -+ | |||
| 152 | +23x |
- #' isolate(filter_state$get_call())+ slice = slice, |
||
| 25 | -+ | |||
| 153 | +23x |
- #'+ extract_type = extract_type |
||
| 26 | +154 |
- #' @keywords internal+ ) |
||
| 27 | -+ | |||
| 155 | +23x |
- #'+ checkmate::assert_date(slice$choices, null.ok = TRUE) |
||
| 28 | -+ | |||
| 156 | +22x |
- EmptyFilterState <- R6::R6Class( # nolint+ private$set_choices(slice$choices) |
||
| 29 | -+ | |||
| 157 | +14x |
- "EmptyFilterState",+ if (is.null(slice$selected)) slice$selected <- slice$choices+ |
+ ||
| 158 | +22x | +
+ private$set_selected(slice$selected) |
||
| 30 | +159 |
- inherit = FilterState,+ }) |
||
| 31 | +160 | |||
| 32 | -+ | |||
| 161 | +21x |
- # public methods ----+ invisible(self) |
||
| 33 | +162 |
- public = list(+ }, |
||
| 34 | +163 | |||
| 35 | +164 |
#' @description |
||
| 36 | +165 |
- #' Initialize `EmptyFilterState` object.+ #' Returns reproducible condition call for current selection. |
||
| 37 | +166 |
- #'+ #' For this class returned call looks like |
||
| 38 | +167 |
- #' @param x (`vector`)+ #' `<varname> >= <min value> & <varname> <= <max value>` with optional `is.na(<varname>)`. |
||
| 39 | +168 |
- #' variable to be filtered,+ #' @param dataname (`character(1)`) containing possibly prefixed name of data set |
||
| 40 | +169 |
- #' @param x_reactive (`reactive`)+ #' @return `call` or `NULL` |
||
| 41 | +170 |
- #' returning vector of the same type as `x`. Is used to update+ #' |
||
| 42 | +171 |
- #' counts following the change in values of the filtered dataset.+ get_call = function(dataname) {
|
||
| 43 | -+ | |||
| 172 | +7x |
- #' If it is set to `reactive(NULL)` then counts based on filtered+ if (isFALSE(private$is_any_filtered())) {
|
||
| 44 | -+ | |||
| 173 | +1x |
- #' dataset are not shown.+ return(NULL) |
||
| 45 | +174 |
- #' @param slice (`teal_slice`)+ } |
||
| 46 | -+ | |||
| 175 | +6x |
- #' specification of this filter state.+ choices <- as.character(private$get_selected()) |
||
| 47 | -+ | |||
| 176 | +6x |
- #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.+ varname <- private$get_varname_prefixed(dataname) |
||
| 48 | -+ | |||
| 177 | +6x |
- #' `get_state` returns `teal_slice` object which can be reused in other places.+ filter_call <- |
||
| 49 | -+ | |||
| 178 | +6x |
- #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.+ call( |
||
| 50 | +179 |
- #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.+ "&", |
||
| 51 | -+ | |||
| 180 | +6x |
- #' @param extract_type (`character`)+ call(">=", varname, call("as.Date", choices[1L])),
|
||
| 52 | -+ | |||
| 181 | +6x |
- #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ call("<=", varname, call("as.Date", choices[2L]))
|
||
| 53 | +182 |
- #' - `character(0)` (default) `varname` in the condition call will not be prefixed+ ) |
||
| 54 | -+ | |||
| 183 | +6x |
- #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`+ private$add_keep_na_call(filter_call, varname) |
||
| 55 | +184 |
- #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`+ } |
||
| 56 | +185 |
- #'+ ), |
||
| 57 | +186 |
- #' @return Object of class `EmptyFilterState`, invisibly.+ |
||
| 58 | +187 |
- #'+ # private methods ---- |
||
| 59 | +188 |
- initialize = function(x,+ |
||
| 60 | +189 |
- x_reactive = reactive(NULL),+ private = list( |
||
| 61 | +190 |
- extract_type = character(0),+ set_choices = function(choices) {
+ |
+ ||
| 191 | +22x | +
+ if (is.null(choices)) {
+ |
+ ||
| 192 | +19x | +
+ choices <- range(private$x, na.rm = TRUE) |
||
| 62 | +193 |
- slice) {
+ } else {
|
||
| 63 | -6x | +194 | +3x |
- isolate({
+ choices_adjusted <- c(max(choices[1L], min(private$x)), min(choices[2L], max(private$x))) |
| 64 | -6x | +195 | +3x |
- super$initialize(+ if (any(choices != choices_adjusted)) {
|
| 65 | -6x | +196 | +1x |
- x = x,+ warning(sprintf( |
| 66 | -6x | +197 | +1x |
- x_reactive = x_reactive,+ "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", |
| 67 | -6x | +198 | +1x |
- slice = slice,+ private$get_varname(), private$get_dataname()+ |
+
| 199 | ++ |
+ )) |
||
| 68 | -6x | +200 | +1x |
- extract_type = extract_type+ choices <- choices_adjusted |
| 69 | +201 |
- )+ } |
||
| 70 | -6x | +202 | +3x |
- private$set_choices(slice$choices)+ if (choices[1L] >= choices[2L]) {
|
| 71 | -6x | +203 | +1x |
- private$set_selected(slice$selected)+ warning(sprintf( |
| 72 | -+ | |||
| 204 | +1x |
- })+ "Invalid choices: lower is higher / equal to upper, or not in range of variable values. |
||
| 73 | -+ | |||
| 205 | +1x |
-
+ Setting defaults. Varname: %s, dataname: %s.", |
||
| 74 | -6x | +206 | +1x |
- invisible(self)+ private$get_varname(), private$get_dataname() |
| 75 | +207 |
- },+ )) |
||
| 76 | -+ | |||
| 208 | +1x |
-
+ choices <- range(private$x, na.rm = TRUE) |
||
| 77 | +209 |
- #' @description+ } |
||
| 78 | +210 |
- #' Returns reproducible condition call for current selection relevant for selected variable type.+ }+ |
+ ||
| 211 | +22x | +
+ private$set_is_choice_limited(private$x, choices)+ |
+ ||
| 212 | +22x | +
+ private$x <- private$x[(private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x)]+ |
+ ||
| 213 | +22x | +
+ private$teal_slice$choices <- choices+ |
+ ||
| 214 | +22x | +
+ invisible(NULL) |
||
| 79 | +215 |
- #' Uses internal reactive values, hence must be called in reactive or isolated context.+ }, |
||
| 80 | +216 |
- #' @param dataname name of data set; defaults to `private$get_dataname()`+ |
||
| 81 | +217 |
- #' @return `logical(1)`+ # @description |
||
| 82 | +218 |
- #'+ # Check whether the initial choices filter out some values of x and set the flag in case. |
||
| 83 | +219 |
- get_call = function(dataname) {
+ set_is_choice_limited = function(xl, choices) {
|
||
| 84 | -2x | +220 | +22x |
- if (isFALSE(private$is_any_filtered())) {
+ private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE)) |
| 85 | -1x | +221 | +22x |
- return(NULL)+ invisible(NULL) |
| 86 | +222 |
- }+ }, |
||
| 87 | -1x | +|||
| 223 | +
- if (missing(dataname)) dataname <- private$get_dataname()+ cast_and_validate = function(values) {
|
|||
| 88 | -1x | +224 | +33x |
- filter_call <- if (isTRUE(private$get_keep_na())) {
+ tryCatch( |
| 89 | -! | +|||
| 225 | +33x |
- call("is.na", private$get_varname_prefixed(dataname))
+ expr = {
|
||
| 90 | -+ | |||
| 226 | +33x |
- } else {
+ values <- as.Date(values, origin = "1970-01-01") |
||
| 91 | -1x | +|||
| 227 | +! |
- substitute(!is.na(varname), list(varname = private$get_varname_prefixed(dataname)))+ if (anyNA(values)) stop() |
||
| 92 | -+ | |||
| 228 | +30x |
- }+ values |
||
| 93 | +229 |
- }+ }, |
||
| 94 | -+ | |||
| 230 | +33x |
- ),+ error = function(e) stop("Vector of set values must contain values coercible to Date.")
|
||
| 95 | +231 |
-
+ ) |
||
| 96 | +232 |
- # private members ----+ }, |
||
| 97 | +233 |
- private = list(+ check_length = function(values) {
|
||
| 98 | -+ | |||
| 234 | +1x |
- cache_state = function() {
+ if (length(values) != 2) stop("Vector of set values must have length two.")
|
||
| 99 | -! | +|||
| 235 | +29x |
- private$cache <- private$get_state()+ if (values[1] > values[2]) {
|
||
| 100 | -! | +|||
| 236 | +1x |
- self$set_state(+ warning( |
||
| 101 | -! | +|||
| 237 | +1x |
- list(+ sprintf( |
||
| 102 | -! | +|||
| 238 | +1x |
- keep_na = NULL+ "Start date %s is set after the end date %s, the values will be replaced with a default date range.", |
||
| 103 | -+ | |||
| 239 | +1x |
- )+ values[1], values[2] |
||
| 104 | +240 |
- )+ ) |
||
| 105 | +241 |
- },+ ) |
||
| 106 | -+ | |||
| 242 | +1x |
- set_choices = function(choices) {
+ values <- isolate(private$get_choices()) |
||
| 107 | -6x | +|||
| 243 | +
- private$teal_slice$choices <- choices+ } |
|||
| 108 | -6x | +244 | +29x |
- invisible(NULL)+ values |
| 109 | +245 |
}, |
||
| 110 | +246 |
-
+ remove_out_of_bounds_values = function(values) {
|
||
| 111 | -+ | |||
| 247 | +29x |
-
+ choices <- private$get_choices() |
||
| 112 | -+ | |||
| 248 | +29x |
- # Reports whether the current state filters out any values.(?)+ if (values[1] < choices[1L] | values[1] > choices[2L]) {
|
||
| 113 | -+ | |||
| 249 | +5x |
- # @return `logical(1)`+ warning( |
||
| 114 | -+ | |||
| 250 | +5x |
- #+ sprintf( |
||
| 115 | -+ | |||
| 251 | +5x |
- is_any_filtered = function() {
+ "Value: %s is outside of the possible range for column %s of dataset %s, setting minimum possible value.", |
||
| 116 | -2x | +252 | +5x |
- if (private$is_choice_limited) {
+ values[1], private$get_varname(), private$get_dataname() |
| 117 | -! | +|||
| 253 | +
- TRUE+ ) |
|||
| 118 | +254 |
- } else {
+ ) |
||
| 119 | -2x | +255 | +5x |
- !isTRUE(private$get_keep_na())+ values[1] <- choices[1L] |
| 120 | +256 |
} |
||
| 121 | +257 |
- },+ |
||
| 122 | -+ | |||
| 258 | +29x |
-
+ if (values[2] > choices[2L] | values[2] < choices[1L]) {
|
||
| 123 | -+ | |||
| 259 | +5x |
- # @description+ warning( |
||
| 124 | -+ | |||
| 260 | +5x |
- # UI Module for `EmptyFilterState`.+ sprintf( |
||
| 125 | -+ | |||
| 261 | +5x |
- # This UI element contains a checkbox input to filter or keep missing values.+ "Value: %s is outside of the possible range for column %s of dataset %s, setting maximum possible value.", |
||
| 126 | -+ | |||
| 262 | +5x |
- # @param id (`character(1)`) `shiny` module instance id.+ values[2], private$get_varname(), private$get_dataname() |
||
| 127 | +263 |
- #+ ) |
||
| 128 | +264 |
- ui_inputs = function(id) {
- |
- ||
| 129 | -! | -
- ns <- NS(id)- |
- ||
| 130 | -! | -
- isolate({
- |
- ||
| 131 | -! | -
- tags$div(+ ) |
||
| 132 | -! | +|||
| 265 | +5x |
- tags$span("Variable contains missing values only"),
+ values[2] <- choices[2L] |
||
| 133 | -! | +|||
| 266 | +
- private$keep_na_ui(ns("keep_na"))
+ } |
|||
| 134 | +267 |
- )+ |
||
| 135 | -+ | |||
| 268 | +29x |
- })+ values |
||
| 136 | +269 |
}, |
||
| 137 | +270 | |||
| 138 | +271 |
- # @description+ # shiny modules ---- |
||
| 139 | +272 |
- # Controls state of the `keep_na` checkbox input.+ |
||
| 140 | +273 |
- #+ # @description |
||
| 141 | +274 |
- # @param id (`character(1)`) `shiny` module instance id.+ # UI Module for `DateFilterState`. |
||
| 142 | +275 |
- #+ # This UI element contains two date selections for `min` and `max` |
||
| 143 | +276 |
- # @return `NULL`.+ # of the range and a checkbox whether to keep the `NA` values. |
||
| 144 | +277 |
- #+ # @param id (`character(1)`) `shiny` module instance id. |
||
| 145 | +278 |
- server_inputs = function(id) {
+ ui_inputs = function(id) {
|
||
| 146 | +279 | ! |
- moduleServer(+ ns <- NS(id) |
|
| 147 | +280 | ! |
- id = id,+ isolate({
|
|
| 148 | +281 | ! |
- function(input, output, session) {
+ tags$div( |
|
| 149 | +282 | ! |
- private$keep_na_srv("keep_na")
- |
- |
| 150 | -- |
- }- |
- ||
| 151 | -- |
- )- |
- ||
| 152 | -- |
- },+ tags$div( |
||
| 153 | -+ | |||
| 283 | +! |
- server_inputs_fixed = function(id) {
+ class = "flex", |
||
| 154 | +284 | ! |
- moduleServer(+ actionButton( |
|
| 155 | +285 | ! |
- id = id,+ class = "date_reset_button", |
|
| 156 | +286 | ! |
- function(input, output, session) {
+ inputId = ns("start_date_reset"),
|
|
| 157 | +287 | ! |
- output$selection <- renderUI({
+ label = NULL, |
|
| 158 | +288 | ! |
- tags$span("Variable contains missing values only")
+ icon = icon("fas fa-undo")
|
|
| 159 | +289 |
- })+ ), |
||
| 160 | +290 | ! |
- NULL- |
- |
| 161 | -- |
- }+ tags$div( |
||
| 162 | -+ | |||
| 291 | +! |
- )+ class = "w-80 filter_datelike_input", |
||
| 163 | -+ | |||
| 292 | +! |
- },+ dateRangeInput( |
||
| 164 | -+ | |||
| 293 | +! |
-
+ inputId = ns("selection"),
|
||
| 165 | -+ | |||
| 294 | +! |
- # @description+ label = NULL, |
||
| 166 | -+ | |||
| 295 | +! |
- # Server module to display filter summary+ start = private$get_selected()[1], |
||
| 167 | -+ | |||
| 296 | +! |
- # Doesn't render anything+ end = private$get_selected()[2], |
||
| 168 | -+ | |||
| 297 | +! |
- content_summary = function(id) {
+ min = private$get_choices()[1L], |
||
| 169 | +298 | ! |
- tags$span("All empty")
+ max = private$get_choices()[2L], |
|
| 170 | -+ | |||
| 299 | +! |
- }+ width = "100%" |
||
| 171 | +300 |
- )+ ) |
||
| 172 | +301 |
- )+ ), |
| 1 | -+ | ||
| 302 | +! |
- #' Initialize `FilteredData`+ actionButton( |
|
| 2 | -+ | ||
| 303 | +! |
- #'+ class = "date_reset_button", |
|
| 3 | -+ | ||
| 304 | +! |
- #' Function creates a `FilteredData` object.+ inputId = ns("end_date_reset"),
|
|
| 4 | -+ | ||
| 305 | +! |
- #'+ label = NULL, |
|
| 5 | -+ | ||
| 306 | +! |
- #' @param x (`named list`) of datasets.+ icon = icon("fas fa-undo")
|
|
| 6 | +307 |
- #' @param join_keys (`join_keys`) see [`teal.data::join_keys()`].+ ) |
|
| 7 | +308 |
- #' @param code `r lifecycle::badge("deprecated")`
+ ), |
|
| 8 | -+ | ||
| 309 | +! |
- #' @param check `r lifecycle::badge("deprecated")`
+ private$keep_na_ui(ns("keep_na"))
|
|
| 9 | +310 |
- #'+ ) |
|
| 10 | +311 |
- #' @return Object of class `FilteredData`.+ }) |
|
| 11 | +312 |
- #'+ }, |
|
| 12 | +313 |
- #' @examples+ |
|
| 13 | +314 |
- #' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars))+ # @description |
|
| 14 | +315 |
- #' datasets+ # Server module |
|
| 15 | +316 |
- #'+ # @param id (`character(1)`) `shiny` module instance id. |
|
| 16 | +317 |
- #' @export+ # @return `NULL`. |
|
| 17 | +318 |
- init_filtered_data <- function(x, join_keys = teal.data::join_keys(), code, check) { # nolint
- |
- |
| 18 | -7x | -
- checkmate::assert_list(x, any.missing = FALSE, names = "unique")- |
- |
| 19 | -6x | -
- checkmate::assert_class(join_keys, "join_keys")+ server_inputs = function(id) {
|
|
| 20 | -5x | +||
| 319 | +! |
- if (!missing(code)) {
+ moduleServer( |
|
| 21 | +320 | ! |
- lifecycle::deprecate_stop(+ id = id, |
| 22 | +321 | ! |
- "0.5.0",+ function(input, output, session) {
|
| 23 | +322 | ! |
- "init_filtered_data(code = 'No longer supported')"+ logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }")
|
| 24 | +323 |
- )+ |
|
| 25 | +324 |
- }+ # this observer is needed in the situation when teal_slice$selected has been |
|
| 26 | -5x | +||
| 325 | +
- if (!missing(check)) {
+ # changed directly by the api - then it's needed to rerender UI element |
||
| 27 | -! | +||
| 326 | +
- lifecycle::deprecate_stop(+ # to show relevant values |
||
| 28 | +327 | ! |
- "0.5.0",+ private$observers$seletion_api <- observeEvent( |
| 29 | +328 | ! |
- "init_filtered_data(check = 'No longer supported')"+ ignoreNULL = TRUE, # dates needs to be selected |
| 30 | -+ | ||
| 329 | +! |
- )+ ignoreInit = TRUE, |
|
| 31 | -+ | ||
| 330 | +! |
- }+ eventExpr = private$get_selected(), |
|
| 32 | -5x | +||
| 331 | +! |
- FilteredData$new(x, join_keys = join_keys)+ handlerExpr = {
|
|
| 33 | -+ | ||
| 332 | +! |
- }+ if (!setequal(private$get_selected(), input$selection)) {
|
|
| 34 | -+ | ||
| 333 | +! |
-
+ logger::log_trace("DateFilterState$server@1 state changed, id: { private$get_id() }")
|
|
| 35 | -+ | ||
| 334 | +! |
- #' Evaluate expression with meaningful message+ updateDateRangeInput( |
|
| 36 | -+ | ||
| 335 | +! |
- #'+ session = session, |
|
| 37 | -+ | ||
| 336 | +! |
- #' Method created for the `FilteredData` object to execute filter call with+ inputId = "selection", |
|
| 38 | -+ | ||
| 337 | +! |
- #' meaningful message. After evaluation used environment should contain+ start = private$get_selected()[1], |
|
| 39 | -+ | ||
| 338 | +! |
- #' all necessary bindings.+ end = private$get_selected()[2] |
|
| 40 | +339 |
- #'+ ) |
|
| 41 | +340 |
- #' @param expr (`language`)+ } |
|
| 42 | +341 |
- #' @param env (`environment`) where expression is evaluated.+ } |
|
| 43 | +342 |
- #' @return `NULL`, invisibly.+ ) |
|
| 44 | +343 |
- #' @keywords internal+ |
|
| 45 | -+ | ||
| 344 | +! |
- eval_expr_with_msg <- function(expr, env) {
+ private$observers$selection <- observeEvent( |
|
| 46 | -32x | +||
| 345 | +! |
- lapply(+ ignoreNULL = TRUE, # dates needs to be selected |
|
| 47 | -32x | +||
| 346 | +! |
- expr,+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
|
| 48 | -32x | +||
| 347 | +! |
- function(x) {
+ eventExpr = input$selection, |
|
| 49 | -19x | +||
| 348 | +! |
- tryCatch(+ handlerExpr = {
|
|
| 50 | -19x | +||
| 349 | +! |
- eval(x, envir = env),+ logger::log_trace("DateFilterState$server@2 selection changed, id: { private$get_id() }")
|
|
| 51 | -19x | +||
| 350 | +! |
- error = function(e) {
+ start_date <- input$selection[1] |
|
| 52 | +351 | ! |
- stop(+ end_date <- input$selection[2] |
| 53 | -! | +||
| 352 | +
- sprintf(+ |
||
| 54 | +353 | ! |
- "Call execution failed:\n - call:\n %s\n - message:\n %s ",+ if (is.na(start_date) || is.na(end_date) || start_date > end_date) {
|
| 55 | +354 | ! |
- deparse1(x, collapse = "\n"), e+ updateDateRangeInput( |
| 56 | -+ | ||
| 355 | +! |
- )+ session = session, |
|
| 57 | -+ | ||
| 356 | +! |
- )+ inputId = "selection", |
|
| 58 | -+ | ||
| 357 | +! |
- }+ start = private$get_selected()[1], |
|
| 59 | -+ | ||
| 358 | +! |
- )+ end = private$get_selected()[2] |
|
| 60 | +359 |
- }+ ) |
|
| 61 | -+ | ||
| 360 | +! |
- )+ showNotification( |
|
| 62 | -32x | +||
| 361 | +! |
- invisible(NULL)+ "Start date must not be greater than the end date. Setting back to previous value.", |
|
| 63 | -+ | ||
| 362 | +! |
- }+ type = "warning" |
|
| 64 | +363 |
-
+ ) |
|
| 65 | -+ | ||
| 364 | +! |
-
+ return(NULL) |
|
| 66 | +365 |
- #' Toggle button properties.+ } |
|
| 67 | +366 |
- #'+ |
|
| 68 | -+ | ||
| 367 | +! |
- #' Switch between different icons or titles on a button.+ private$set_selected(c(start_date, end_date)) |
|
| 69 | +368 |
- #'+ } |
|
| 70 | +369 |
- #' Wrapper functions that use `shinyjs::runjs` to change button properties in response to events,+ ) |
|
| 71 | +370 |
- #' typically clicking those very buttons.+ |
|
| 72 | +371 |
- #' `shiny`'s `actionButton` and `actionLink` create `<a>` tags,+ |
|
| 73 | -+ | ||
| 372 | +! |
- #' which may contain a child `<i>` tag that specifies an icon to be displayed.+ private$keep_na_srv("keep_na")
|
|
| 74 | +373 |
- #' `toggle_icon` calls the `toggleClass` (when `one_way = FALSE`) or+ |
|
| 75 | -+ | ||
| 374 | +! |
- #' `removeClass` and `addClass` methods (when `one_way = TRUE`) to change icons.+ private$observers$reset1 <- observeEvent(input$start_date_reset, {
|
|
| 76 | -+ | ||
| 375 | +! |
- #' `toggle_title` calls the `attr` method to modify the `Title` attribute of the button.+ logger::log_trace("DateFilterState$server@3 reset start date, id: { private$get_id() }")
|
|
| 77 | -+ | ||
| 376 | +! |
- #'+ updateDateRangeInput( |
|
| 78 | -+ | ||
| 377 | +! |
- #' @param input_id (`character(1)`) (name-spaced) id of the button+ session = session, |
|
| 79 | -+ | ||
| 378 | +! |
- #' @param icons,titles (`character(2)`) vector specifying values between which to toggle+ inputId = "selection", |
|
| 80 | -+ | ||
| 379 | +! |
- #' @param one_way (`logical(1)`) flag specifying whether to keep toggling;+ start = private$get_choices()[1L] |
|
| 81 | +380 |
- #' if TRUE, the target will be changed+ ) |
|
| 82 | +381 |
- #' from the first element of `icons`/`titles` to the second+ }) |
|
| 83 | +382 |
- #'+ |
|
| 84 | -+ | ||
| 383 | +! |
- #' @return `NULL`, invisibly.+ private$observers$reset2 <- observeEvent(input$end_date_reset, {
|
|
| 85 | -+ | ||
| 384 | +! |
- #'+ logger::log_trace("DateFilterState$server@4 reset end date, id: { private$get_id() }")
|
|
| 86 | -+ | ||
| 385 | +! |
- #' @examples+ updateDateRangeInput( |
|
| 87 | -+ | ||
| 386 | +! |
- #' # use non-exported function from teal.slice+ session = session, |
|
| 88 | -+ | ||
| 387 | +! |
- #' toggle_icon <- getFromNamespace("toggle_icon", "teal.slice")
+ inputId = "selection", |
|
| 89 | -+ | ||
| 388 | +! |
- #'+ end = private$get_choices()[2L] |
|
| 90 | +389 |
- #' library(shiny)+ ) |
|
| 91 | +390 |
- #' library(shinyjs)+ }) |
|
| 92 | +391 |
- #'+ |
|
| 93 | -+ | ||
| 392 | +! |
- #' ui <- fluidPage(+ logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
|
|
| 94 | -+ | ||
| 393 | +! |
- #' useShinyjs(),+ NULL |
|
| 95 | +394 |
- #' actionButton("hide_content", label = "hide", icon = icon("xmark")),
+ } |
|
| 96 | +395 |
- #' actionButton("show_content", label = "show", icon = icon("check")),
+ ) |
|
| 97 | +396 |
- #' actionButton("toggle_content", label = "toggle", icon = icon("angle-down")),
+ }, |
|
| 98 | +397 |
- #' tags$br(),+ server_inputs_fixed = function(id) {
|
|
| 99 | -+ | ||
| 398 | +! |
- #' tags$div(+ moduleServer( |
|
| 100 | -+ | ||
| 399 | +! |
- #' id = "content",+ id = id, |
|
| 101 | -+ | ||
| 400 | +! |
- #' verbatimTextOutput("printout")
+ function(input, output, session) {
|
|
| 102 | -+ | ||
| 401 | +! |
- #' )+ logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }")
|
|
| 103 | +402 |
- #' )+ |
|
| 104 | -+ | ||
| 403 | +! |
- #'+ output$selection <- renderUI({
|
|
| 105 | -+ | ||
| 404 | +! |
- #' server <- function(input, output, session) {
+ vals <- format(private$get_selected(), nsmall = 3) |
|
| 106 | -+ | ||
| 405 | +! |
- #' observeEvent(input$hide_content,+ tags$div( |
|
| 107 | -+ | ||
| 406 | +! |
- #' {
+ tags$div(icon("calendar-days"), vals[1]),
|
|
| 108 | -+ | ||
| 407 | +! |
- #' hide("content")
+ tags$div(span(" - "), icon("calendar-days"), vals[2])
|
|
| 109 | +408 |
- #' toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE)
+ ) |
|
| 110 | +409 |
- #' },+ }) |
|
| 111 | +410 |
- #' ignoreInit = TRUE+ |
|
| 112 | -+ | ||
| 411 | +! |
- #' )+ logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
|
|
| 113 | -+ | ||
| 412 | +! |
- #'+ NULL |
|
| 114 | +413 |
- #' observeEvent(input$show_content,+ } |
|
| 115 | +414 |
- #' {
+ ) |
|
| 116 | +415 |
- #' show("content")
+ }, |
|
| 117 | +416 |
- #' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE)
+
|
|
| 118 | +417 |
- #' },+ # @description |
|
| 119 | +418 |
- #' ignoreInit = TRUE+ # Server module to display filter summary |
|
| 120 | +419 |
- #' )+ # renders text describing selected date range and |
|
| 121 | +420 |
- #'+ # if NA are included also |
|
| 122 | +421 |
- #' observeEvent(input$toggle_content,+ content_summary = function(id) {
|
|
| 123 | -+ | ||
| 422 | +! |
- #' {
+ selected <- as.character(private$get_selected()) |
|
| 124 | -+ | ||
| 423 | +! |
- #' toggle("content")
+ min <- selected[1] |
|
| 125 | -+ | ||
| 424 | +! |
- #' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"))
+ max <- selected[2] |
|
| 126 | -+ | ||
| 425 | +! |
- #' },+ tagList( |
|
| 127 | -+ | ||
| 426 | +! |
- #' ignoreInit = TRUE+ tags$span( |
|
| 128 | -+ | ||
| 427 | +! |
- #' )+ class = "filter-card-summary-value", |
|
| 129 | -+ | ||
| 428 | +! |
- #'+ HTML(min, "–", max) |
|
| 130 | +429 |
- #' output$printout <- renderPrint({
+ ), |
|
| 131 | -+ | ||
| 430 | +! |
- #' head(faithful, 10)+ tags$span( |
|
| 132 | -+ | ||
| 431 | +! |
- #' })+ class = "filter-card-summary-controls", |
|
| 133 | -+ | ||
| 432 | +! |
- #' }+ if (private$na_count > 0) {
|
|
| 134 | -+ | ||
| 433 | +! |
- #' if (interactive()) {
+ tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
|
|
| 135 | +434 |
- #' shinyApp(ui, server)+ } |
|
| 136 | +435 |
- #' }+ ) |
|
| 137 | +436 |
- #'+ ) |
|
| 138 | +437 |
- #' @name toggle_button+ } |
|
| 139 | +438 |
- #' @rdname toggle_button+ ) |
|
| 140 | +439 |
- #' @keywords internal+ ) |
| 141 | +1 |
- toggle_icon <- function(input_id, icons, one_way = FALSE) {
- |
- |
| 142 | -3x | -
- checkmate::assert_string(input_id)- |
- |
| 143 | -3x | -
- checkmate::assert_character(icons, len = 2L)- |
- |
| 144 | -3x | -
- checkmate::assert_flag(one_way)+ # FilterPanelAPI ------ |
|
| 145 | +2 | ||
| 146 | -3x | -
- expr <-- |
- |
| 147 | -3x | -
- if (one_way) {
- |
- |
| 148 | -3x | +||
| 3 | +
- sprintf(+ #' @name FilterPanelAPI |
||
| 149 | -3x | +||
| 4 | +
- "$('#%s i').removeClass('%s').addClass('%s');",
+ #' @docType class |
||
| 150 | -3x | +||
| 5 | +
- input_id, icons[1], icons[2]+ #' |
||
| 151 | +6 |
- )+ #' @title Class to encapsulate the API of the filter panel of a teal app |
|
| 152 | +7 |
- } else {
+ #' |
|
| 153 | -! | +||
| 8 | +
- sprintf("$('#%s i').toggleClass('%s');", input_id, paste(icons, collapse = " "))
+ #' @description |
||
| 154 | +9 |
- }+ #' An API class for managing filter states in a teal application's filter panel. |
|
| 155 | +10 |
-
+ #' |
|
| 156 | -3x | +||
| 11 | +
- shinyjs::runjs(expr)+ #' @details |
||
| 157 | +12 |
-
+ #' The purpose of this class is to encapsulate the API of the filter panel in a |
|
| 158 | -3x | +||
| 13 | +
- invisible(NULL)+ #' new class `FilterPanelAPI` so that it can be passed and used in the server |
||
| 159 | +14 |
- }+ #' call of any module instead of passing the whole `FilteredData` object. |
|
| 160 | +15 |
-
+ #' |
|
| 161 | +16 |
- #' @rdname toggle_button+ #' This class is supported by methods to set, get, remove filter states in the |
|
| 162 | +17 |
- #' @keywords internal+ #' filter panel API. |
|
| 163 | +18 |
- toggle_title <- function(input_id, titles, one_way = FALSE) {
+ #' |
|
| 164 | -3x | +||
| 19 | +
- checkmate::assert_string(input_id)+ #' @examples |
||
| 165 | -3x | +||
| 20 | +
- checkmate::assert_character(titles, len = 2L)+ #' library(shiny) |
||
| 166 | -3x | +||
| 21 | +
- checkmate::assert_flag(one_way)+ #' |
||
| 167 | +22 |
-
+ #' fd <- init_filtered_data(list(iris = iris)) |
|
| 168 | -3x | +||
| 23 | +
- expr <-+ #' fpa <- FilterPanelAPI$new(fd) |
||
| 169 | -3x | +||
| 24 | +
- if (one_way) {
+ #' |
||
| 170 | -3x | +||
| 25 | +
- sprintf(+ #' # get the actual filter state --> empty named list |
||
| 171 | -3x | +||
| 26 | +
- "$('a#%s').attr('title', '%s');",
+ #' isolate(fpa$get_filter_state()) |
||
| 172 | -3x | +||
| 27 | +
- input_id, titles[2]+ #' |
||
| 173 | +28 |
- )+ #' # set a filter state |
|
| 174 | +29 |
- } else {
+ #' set_filter_state( |
|
| 175 | -! | +||
| 30 | +
- sprintf(+ #' fpa, |
||
| 176 | -! | +||
| 31 | +
- paste0(+ #' teal_slices( |
||
| 177 | -! | +||
| 32 | +
- "var button_id = 'a#%1$s';",+ #' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE) |
||
| 178 | -! | +||
| 33 | +
- "var curr = $(button_id).attr('title');",
+ #' ) |
||
| 179 | -! | +||
| 34 | +
- "if (curr == '%2$s') { $(button_id).attr('title', '%3$s');",
+ #' ) |
||
| 180 | -! | +||
| 35 | +
- "} else { $(button_id).attr('title', '%2$s');",
+ #' |
||
| 181 | +36 |
- "}"+ #' # get the actual filter state --> named list with filters |
|
| 182 | +37 |
- ),+ #' isolate(fpa$get_filter_state()) |
|
| 183 | -! | +||
| 38 | +
- input_id, titles[1], titles[2]+ #' |
||
| 184 | +39 |
- )+ #' # remove all_filter_states |
|
| 185 | +40 |
- }+ #' fpa$clear_filter_states() |
|
| 186 | +41 |
-
+ #' |
|
| 187 | -3x | +||
| 42 | +
- shinyjs::runjs(expr)+ #' # get the actual filter state --> empty named list |
||
| 188 | +43 |
-
+ #' isolate(fpa$get_filter_state()) |
|
| 189 | -3x | +||
| 44 | +
- invisible(NULL)+ #' |
||
| 190 | +45 |
- }+ #' @export |
|
| 191 | +46 |
-
+ #' |
|
| 192 | +47 |
- #' @inherit teal.data::topological_sort description details params title+ FilterPanelAPI <- R6::R6Class( # nolint |
|
| 193 | +48 |
- #' @examples+ "FilterPanelAPI", |
|
| 194 | +49 |
- #' # use non-exported function from teal.slice+ # public methods ---- |
|
| 195 | +50 |
- #' topological_sort <- getFromNamespace("topological_sort", "teal.slice")
+ public = list( |
|
| 196 | +51 |
- #'+ #' @description |
|
| 197 | +52 |
- #' topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
+ #' Initialize a `FilterPanelAPI` object. |
|
| 198 | +53 |
- #' topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
+ #' @param datasets (`FilteredData`) |
|
| 199 | +54 |
- #' topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
+ #' |
|
| 200 | +55 |
- #' @keywords internal+ initialize = function(datasets) {
+ |
+ |
| 56 | +8x | +
+ checkmate::assert_class(datasets, "FilteredData")+ |
+ |
| 57 | +6x | +
+ private$filtered_data <- datasets |
|
| 201 | +58 |
- topological_sort <- function(graph) {
+ }, |
|
| 202 | -66x | +||
| 59 | +
- utils::getFromNamespace("topological_sort", ns = "teal.data")(graph)
+
|
||
| 203 | +60 |
- }+ #' @description |
| 1 | +61 |
- .onLoad <- function(libname, pkgname) { # nolint
+ #' Gets the reactive values from the active `FilterState` objects of the `FilteredData` object. |
|
| 2 | +62 |
- # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R+ #' |
|
| 3 | -! | +||
| 63 | +
- teal_default_options <- list(teal.threshold_slider_vs_checkboxgroup = 5)+ #' Gets all active filters in the form of a nested list. |
||
| 4 | -! | +||
| 64 | +
- op <- options()+ #' The output list is a compatible input to `set_filter_state`. |
||
| 5 | -! | +||
| 65 | +
- toset <- !(names(teal_default_options) %in% names(op))+ #' |
||
| 6 | -! | +||
| 66 | +
- if (any(toset)) options(teal_default_options[toset])+ #' @return `list` with named elements corresponding to `FilteredDataset` objects with active filters. |
||
| 7 | +67 |
-
+ #' |
|
| 8 | +68 |
- # Set up the teal logger instance+ get_filter_state = function() {
|
|
| 9 | -! | +||
| 69 | +8x |
- teal.logger::register_logger("teal.slice")
+ private$filtered_data$get_filter_state() |
|
| 10 | -! | +||
| 70 | +
- teal.logger::register_handlers("teal.slice")
+ }, |
||
| 11 | +71 | ||
| 12 | -! | +||
| 72 | +
- invisible()+ #' @description |
||
| 13 | +73 |
- }+ #' Sets active filter states. |
|
| 14 | +74 |
-
+ #' @param filter (`teal_slices`) |
|
| 15 | +75 |
- ### GLOBAL VARIABLES ###+ #' |
|
| 16 | +76 |
-
+ #' @return `NULL`, invisibly. |
|
| 17 | +77 |
- .filterable_class <- c("logical", "integer", "numeric", "factor", "character", "Date", "POSIXct", "POSIXlt")
+ #' |
|
| 18 | +78 |
-
+ set_filter_state = function(filter) {
+ |
+ |
| 79 | +5x | +
+ private$filtered_data$set_filter_state(filter)+ |
+ |
| 80 | +5x | +
+ invisible(NULL) |
|
| 19 | +81 | ++ |
+ },+ |
+
| 82 | |||
| 20 | +83 |
- ### END GLOBAL VARIABLES ###+ #' @description |
|
| 21 | +84 |
-
+ #' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object. |
|
| 22 | +85 |
-
+ #' |
|
| 23 | +86 |
- ### ENSURE CHECK PASSES+ #' @param filter (`teal_slices`) |
|
| 24 | +87 |
-
+ #' specifying `FilterState` objects to remove; |
|
| 25 | +88 |
- # This function is necessary for check to properly process code dependencies within R6 classes.+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored |
|
| 26 | +89 |
- # If `package` is listed in `Imports` in `DESCRIPTION`,+ #' |
|
| 27 | +90 |
- # (1) check goes through `NAMESPACE` looking for any `importFrom(package,<foo>)` statements+ #' @return `NULL`, invisibly. |
|
| 28 | +91 |
- # or an `import(package)` statement. If none are found,+ #' |
|
| 29 | +92 |
- # (2) check looks for `package::*` calls in the code. If none are found again,+ remove_filter_state = function(filter) {
+ |
+ |
| 93 | +1x | +
+ private$filtered_data$remove_filter_state(filter)+ |
+ |
| 94 | +1x | +
+ invisible(NULL) |
|
| 30 | +95 |
- # (3) check throws a NOTE;+ }, |
|
| 31 | +96 |
- # # Namespaces in Imports field not imported from:+ |
|
| 32 | +97 |
- # # 'package'+ #' @description |
|
| 33 | +98 |
- # # All declared Imports should be used.+ #' Remove all `FilterStates` of the `FilteredData` object. |
|
| 34 | +99 |
- # This note is banned by our CI.+ #' |
|
| 35 | +100 |
- # When package::* statements are made within an R6 class, they are not registered.+ #' @param datanames (`character`) |
|
| 36 | +101 |
- # This function provides single references to the imported namespaces for check to notice.+ #' `datanames` to remove their `FilterStates`; |
|
| 37 | +102 |
- .rectify_dependencies_check <- function() {
+ #' omit to remove all `FilterStates` in the `FilteredData` object |
|
| 38 | -! | +||
| 103 | +
- dplyr::filter+ #' |
||
| 39 | -! | +||
| 104 | +
- grDevices::rgb+ #' @return `NULL`, invisibly. |
||
| 40 | -! | +||
| 105 | +
- htmltools::tagInsertChildren+ #' |
||
| 41 | -! | +||
| 106 | +
- lifecycle::badge+ clear_filter_states = function(datanames) {
|
||
| 42 | -! | +||
| 107 | +2x |
- logger::log_trace+ datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames |
|
| 43 | -! | +||
| 108 | +2x |
- plotly::plot_ly+ private$filtered_data$clear_filter_states(datanames = datanames_to_remove) |
|
| 44 | -! | +||
| 109 | +2x |
- shinycssloaders::withSpinner+ invisible(NULL) |
|
| 45 | -! | +||
| 110 | +
- shinyWidgets::pickerOptions+ } |
||
| 46 | -! | +||
| 111 | +
- teal.data::datanames+ ), |
||
| 47 | -! | +||
| 112 | +
- teal.widgets::optionalSelectInput+ # private methods ---- |
||
| 48 | +113 |
- }+ private = list( |
|
| 49 | +114 |
-
+ filtered_data = NULL |
|
| 50 | +115 |
-
+ ) |
|
| 51 | +116 |
- ### END ENSURE CHECK PASSES+ ) |
| 1 |
- # FilterPanelAPI ------+ #' Initialize `FilteredDataset` |
||
| 2 |
-
+ #' |
||
| 3 |
- #' @name FilterPanelAPI+ #' Initializes a `FilteredDataset` object corresponding to the class of the filtered dataset. |
||
| 4 |
- #' @docType class+ #' |
||
| 5 |
- #'+ #' @param dataset any object |
||
| 6 |
- #' @title Class to encapsulate the API of the filter panel of a teal app+ #' @param dataname (`character(1)`) |
||
| 7 |
- #'+ #' syntactically valid name given to the dataset. |
||
| 8 |
- #' @description+ #' @param keys (`character`) optional |
||
| 9 |
- #' An API class for managing filter states in a teal application's filter panel.+ #' vector of primary key column names. |
||
| 10 |
- #'+ #' @param parent_name (`character(1)`) |
||
| 11 |
- #' @details+ #' name of the parent dataset. |
||
| 12 |
- #' The purpose of this class is to encapsulate the API of the filter panel in a+ #' @param parent (`reactive`) |
||
| 13 |
- #' new class `FilterPanelAPI` so that it can be passed and used in the server+ #' that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`. |
||
| 14 |
- #' call of any module instead of passing the whole `FilteredData` object.+ #' Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset` |
||
| 15 |
- #'+ #' based on the changes in `parent`. |
||
| 16 |
- #' This class is supported by methods to set, get, remove filter states in the+ #' @param join_keys (`character`) |
||
| 17 |
- #' filter panel API.+ #' vector of names of columns in this dataset to join with `parent` dataset. |
||
| 18 |
- #'+ #' If column names in the parent do not match these, they should be given as the names of this vector. |
||
| 19 |
- #' @examples+ #' @param label (`character(1)`) |
||
| 20 |
- #' library(shiny)+ #' label to describe the dataset. |
||
| 22 |
- #' fd <- init_filtered_data(list(iris = iris))+ #' @return Object of class `FilteredDataset`. |
||
| 23 |
- #' fpa <- FilterPanelAPI$new(fd)+ #' |
||
| 24 |
- #'+ #' @section Warning: |
||
| 25 |
- #' # get the actual filter state --> empty named list+ #' This function is exported to allow other packages to extend `teal.slice` but it is treated as internal. |
||
| 26 |
- #' isolate(fpa$get_filter_state())+ #' Breaking changes may occur without warning. |
||
| 27 |
- #'+ #' We recommend consulting the package maintainer before using it. |
||
| 28 |
- #' # set a filter state+ #' |
||
| 29 |
- #' set_filter_state(+ #' @examples |
||
| 30 |
- #' fpa,+ #' # DataframeFilteredDataset example |
||
| 31 |
- #' teal_slices(+ #' library(shiny) |
||
| 32 |
- #' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)+ #' |
||
| 33 |
- #' )+ #' iris_fd <- init_filtered_dataset(iris, dataname = "iris") |
||
| 34 |
- #' )+ #' ui <- fluidPage( |
||
| 35 |
- #'+ #' iris_fd$ui_add(id = "add"), |
||
| 36 |
- #' # get the actual filter state --> named list with filters+ #' iris_fd$ui_active("dataset"),
|
||
| 37 |
- #' isolate(fpa$get_filter_state())+ #' verbatimTextOutput("call")
|
||
| 38 |
- #'+ #' ) |
||
| 39 |
- #' # remove all_filter_states+ #' server <- function(input, output, session) {
|
||
| 40 |
- #' fpa$clear_filter_states()+ #' iris_fd$srv_add(id = "add") |
||
| 41 |
- #'+ #' iris_fd$srv_active(id = "dataset") |
||
| 42 |
- #' # get the actual filter state --> empty named list+ #' |
||
| 43 |
- #' isolate(fpa$get_filter_state())+ #' output$call <- renderText({
|
||
| 44 |
- #'+ #' paste( |
||
| 45 |
- #' @export+ #' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"), |
||
| 46 |
- #'+ #' collapse = "\n" |
||
| 47 |
- FilterPanelAPI <- R6::R6Class( # nolint+ #' ) |
||
| 48 |
- "FilterPanelAPI",+ #' }) |
||
| 49 |
- # public methods ----+ #' } |
||
| 50 |
- public = list(+ #' if (interactive()) {
|
||
| 51 |
- #' @description+ #' shinyApp(ui, server) |
||
| 52 |
- #' Initialize a `FilterPanelAPI` object.+ #' } |
||
| 53 |
- #' @param datasets (`FilteredData`)+ #' |
||
| 54 |
- #'+ #' @examples |
||
| 55 |
- initialize = function(datasets) {
+ #' \donttest{
|
||
| 56 | -8x | +
- checkmate::assert_class(datasets, "FilteredData")+ #' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
|
| 57 | -6x | +
- private$filtered_data <- datasets+ #' # MAEFilteredDataset example |
|
| 58 |
- },+ #' library(shiny) |
||
| 59 |
-
+ #' |
||
| 60 |
- #' @description+ #' data(miniACC, package = "MultiAssayExperiment") |
||
| 61 |
- #' Gets the reactive values from the active `FilterState` objects of the `FilteredData` object.+ #' |
||
| 62 |
- #'+ #' MAE_fd <- init_filtered_dataset(miniACC, "MAE") |
||
| 63 |
- #' Gets all active filters in the form of a nested list.+ #' ui <- fluidPage( |
||
| 64 |
- #' The output list is a compatible input to `set_filter_state`.+ #' MAE_fd$ui_add(id = "add"), |
||
| 65 |
- #'+ #' MAE_fd$ui_active("dataset"),
|
||
| 66 |
- #' @return `list` with named elements corresponding to `FilteredDataset` objects with active filters.+ #' verbatimTextOutput("call")
|
||
| 67 |
- #'+ #' ) |
||
| 68 |
- get_filter_state = function() {
+ #' server <- function(input, output, session) {
|
||
| 69 | -8x | +
- private$filtered_data$get_filter_state()+ #' MAE_fd$srv_add(id = "add") |
|
| 70 |
- },+ #' MAE_fd$srv_active(id = "dataset") |
||
| 71 |
-
+ #' output$call <- renderText({
|
||
| 72 |
- #' @description+ #' paste( |
||
| 73 |
- #' Sets active filter states.+ #' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"), |
||
| 74 |
- #' @param filter (`teal_slices`)+ #' collapse = "\n" |
||
| 75 |
- #'+ #' ) |
||
| 76 |
- #' @return `NULL`, invisibly.+ #' }) |
||
| 77 |
- #'+ #' } |
||
| 78 |
- set_filter_state = function(filter) {
+ #' if (interactive()) {
|
||
| 79 | -5x | +
- private$filtered_data$set_filter_state(filter)+ #' shinyApp(ui, server) |
|
| 80 | -5x | +
- invisible(NULL)+ #' } |
|
| 81 |
- },+ #' } |
||
| 82 |
-
+ #' } |
||
| 83 |
- #' @description+ #' @keywords internal |
||
| 84 |
- #' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object.+ #' @export |
||
| 85 |
- #'+ init_filtered_dataset <- function(dataset, |
||
| 86 |
- #' @param filter (`teal_slices`)+ dataname, |
||
| 87 |
- #' specifying `FilterState` objects to remove;+ keys = character(0), |
||
| 88 |
- #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored+ parent_name = character(0), |
||
| 89 |
- #'+ parent = reactive(dataset), |
||
| 90 |
- #' @return `NULL`, invisibly.+ join_keys = character(0), |
||
| 91 |
- #'+ label = attr(dataset, "label", exact = TRUE)) {
|
||
| 92 | -+ | 107x |
- remove_filter_state = function(filter) {
+ UseMethod("init_filtered_dataset")
|
| 93 | -1x | +
- private$filtered_data$remove_filter_state(filter)+ } |
|
| 94 | -1x | +
- invisible(NULL)+ |
|
| 95 |
- },+ #' @keywords internal |
||
| 96 |
-
+ #' @export |
||
| 97 |
- #' @description+ init_filtered_dataset.data.frame <- function(dataset, |
||
| 98 |
- #' Remove all `FilterStates` of the `FilteredData` object.+ dataname, |
||
| 99 |
- #'+ keys = character(0), |
||
| 100 |
- #' @param datanames (`character`)+ parent_name = character(0), |
||
| 101 |
- #' `datanames` to remove their `FilterStates`;+ parent = NULL, |
||
| 102 |
- #' omit to remove all `FilterStates` in the `FilteredData` object+ join_keys = character(0), |
||
| 103 |
- #'+ label = attr(dataset, "label", exact = TRUE)) {
|
||
| 104 | -+ | 83x |
- #' @return `NULL`, invisibly.+ DataframeFilteredDataset$new( |
| 105 | -+ | 83x |
- #'+ dataset = dataset, |
| 106 | -+ | 83x |
- clear_filter_states = function(datanames) {
+ dataname = dataname, |
| 107 | -2x | +83x |
- datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames+ keys = keys, |
| 108 | -2x | +83x |
- private$filtered_data$clear_filter_states(datanames = datanames_to_remove)+ parent_name = parent_name, |
| 109 | -2x | +83x |
- invisible(NULL)+ parent = parent, |
| 110 | -+ | 83x |
- }+ join_keys = join_keys, |
| 111 | -+ | 83x |
- ),+ label = label |
| 112 |
- # private methods ----+ ) |
||
| 113 |
- private = list(+ } |
||
| 114 |
- filtered_data = NULL+ |
||
| 115 |
- )+ #' @keywords internal |
||
| 116 |
- )+ #' @export+ |
+ ||
| 117 | ++ |
+ init_filtered_dataset.MultiAssayExperiment <- function(dataset,+ |
+ |
| 118 | ++ |
+ dataname,+ |
+ |
| 119 | ++ |
+ keys = character(0),+ |
+ |
| 120 | ++ |
+ parent_name, # ignored+ |
+ |
| 121 | ++ |
+ parent, # ignored+ |
+ |
| 122 | ++ |
+ join_keys, # ignored+ |
+ |
| 123 | ++ |
+ label = attr(dataset, "label", exact = TRUE)) {
+ |
+ |
| 124 | +7x | +
+ if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ |
+ |
| 125 | +! | +
+ stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ |
+ |
| 126 | ++ |
+ }+ |
+ |
| 127 | +7x | +
+ MAEFilteredDataset$new(+ |
+ |
| 128 | +7x | +
+ dataset = dataset,+ |
+ |
| 129 | +7x | +
+ dataname = dataname,+ |
+ |
| 130 | +7x | +
+ keys = keys,+ |
+ |
| 131 | +7x | +
+ label = label+ |
+ |
| 132 | ++ |
+ )+ |
+ |
| 133 | ++ |
+ }+ |
+ |
| 134 | ++ | + + | +|
| 135 | ++ |
+ #' @keywords internal+ |
+ |
| 136 | ++ |
+ #' @export+ |
+ |
| 137 | ++ |
+ init_filtered_dataset.default <- function(dataset,+ |
+ |
| 138 | ++ |
+ dataname,+ |
+ |
| 139 | ++ |
+ keys, # ignored+ |
+ |
| 140 | ++ |
+ parent_name, # ignored+ |
+ |
| 141 | ++ |
+ parent, # ignored+ |
+ |
| 142 | ++ |
+ join_keys, # ignored+ |
+ |
| 143 | ++ |
+ label = attr(dataset, "label", exact = TRUE)) {
+ |
+ |
| 144 | +17x | +
+ DefaultFilteredDataset$new(+ |
+ |
| 145 | +17x | +
+ dataset = dataset,+ |
+ |
| 146 | +17x | +
+ dataname = dataname,+ |
+ |
| 147 | +17x | +
+ label = label+ |
+ |
| 148 | ++ |
+ )+ |
+ |
| 149 | ++ |
+ } |
| 1 |
- #' Initialize `FilterStates` object+ # FilterStateExpr ------ |
||
| 2 |
- #'+ |
||
| 3 |
- #' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`)+ #' @name FilterStateExpr |
||
| 4 |
- #' object to subset.+ #' @docType class |
||
| 5 |
- #' @param data_reactive (`function(sid)`)+ #' |
||
| 6 |
- #' should return an object of the same type as `data` or `NULL`.+ #' @title `FilterStateExpr` `R6` class |
||
| 7 |
- #' This function is needed for the `FilterState` `shiny` module to update counts if filtered data changes.+ #' |
||
| 8 |
- #' If function returns `NULL` then filtered counts are not shown.+ #' @description Sister class to `FilterState` that handles arbitrary filter expressions. |
||
| 9 |
- #' Function has to have `sid` argument being a character which is related to `sid` argument in the `get_call` method.+ #' |
||
| 10 |
- #' @param dataname (`character(1)`)+ #' @details |
||
| 11 |
- #' name of the data used in the subset expression,+ #' Creates a filter state around a predefined condition call (logical predicate). |
||
| 12 |
- #' passed to the function argument attached to this `FilterStates`.+ #' The condition call is independent of the data |
||
| 13 |
- #' @param datalabel (`character(1)`) optional+ #' and the filter card allows no interaction (the filter is always fixed). |
||
| 14 |
- #' text label.+ #' |
||
| 15 |
- #' @param ... optional,+ #' @examples |
||
| 16 |
- #' additional arguments for specific classes: keys.+ #' # use non-exported function from teal.slice |
||
| 17 |
- #'+ #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
||
| 18 |
- #' @return Object of class `FilterStates`.+ #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
||
| 19 |
- #'+ #' FilterStateExpr <- getFromNamespace("FilterStateExpr", "teal.slice")
|
||
| 20 |
- #' @keywords internal+ #' |
||
| 21 |
- #' @examples+ #' filter_state <- FilterStateExpr$new( |
||
| 22 |
- #' # use non-exported function from teal.slice+ #' slice = teal_slice( |
||
| 23 |
- #' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
+ #' dataname = "x", |
||
| 24 |
- #'+ #' id = "FA", |
||
| 25 |
- #' df <- data.frame(+ #' title = "Adult females", |
||
| 26 |
- #' character = letters,+ #' expr = "sex == 'F' & age >= 18" |
||
| 27 |
- #' numeric = seq_along(letters),+ #' ) |
||
| 28 |
- #' date = seq(Sys.Date(), length.out = length(letters), by = "1 day"),+ #' ) |
||
| 29 |
- #' datetime = seq(Sys.time(), length.out = length(letters), by = "33.33 hours")+ #' filter_state$get_call() |
||
| 30 |
- #' )+ #' |
||
| 31 |
- #' rf <- init_filter_states(+ #' # working filter in an app |
||
| 32 |
- #' data = df,+ #' library(shiny) |
||
| 33 |
- #' dataname = "DF"+ #' library(shinyjs) |
||
| 34 |
- #' )+ #' |
||
| 35 |
- #'+ #' ui <- fluidPage( |
||
| 36 |
- #' library(shiny)+ #' useShinyjs(), |
||
| 37 |
- #' ui <- fluidPage(+ #' include_css_files(pattern = "filter-panel"), |
||
| 38 |
- #' actionButton("clear", tags$span(icon("xmark"), "Remove all filters")),
+ #' include_js_files(pattern = "count-bar-labels"), |
||
| 39 |
- #' rf$ui_add(id = "add"),+ #' column(4, tags$div( |
||
| 40 |
- #' rf$ui_active("states"),
+ #' tags$h4("ChoicesFilterState"),
|
||
| 41 |
- #' verbatimTextOutput("expr"),
+ #' filter_state$ui("fs")
|
||
| 42 |
- #' )+ #' )), |
||
| 43 |
- #'+ #' column(8, tags$div( |
||
| 44 |
- #' server <- function(input, output, session) {
+ #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
||
| 45 |
- #' rf$srv_add(id = "add")+ #' textOutput("condition_choices"), tags$br(),
|
||
| 46 |
- #' rf$srv_active(id = "states")+ #' tags$h4("Unformatted state"), # display raw filter state
|
||
| 47 |
- #' output$expr <- renderText({
+ #' textOutput("unformatted_choices"), tags$br(),
|
||
| 48 |
- #' deparse1(rf$get_call(), collapse = "\n")+ #' tags$h4("Formatted state"), # display human readable filter state
|
||
| 49 |
- #' })+ #' textOutput("formatted_choices"), tags$br()
|
||
| 50 |
- #' observeEvent(input$clear, rf$clear_filter_states())+ #' )) |
||
| 51 |
- #' }+ #' ) |
||
| 53 |
- #' if (interactive()) {
+ #' server <- function(input, output, session) {
|
||
| 54 |
- #' shinyApp(ui, server)+ #' filter_state$server("fs")
|
||
| 55 |
- #' }+ #' output$condition_choices <- renderPrint(filter_state$get_call()) |
||
| 56 |
- #'+ #' output$formatted_choices <- renderText(filter_state$format()) |
||
| 57 |
- #' @export+ #' output$unformatted_choices <- renderPrint(filter_state$get_state()) |
||
| 58 |
- #'+ #' } |
||
| 59 |
- init_filter_states <- function(data,+ #' |
||
| 60 |
- data_reactive = reactive(NULL),+ #' if (interactive()) {
|
||
| 61 |
- dataname,+ #' shinyApp(ui, server) |
||
| 62 |
- datalabel = NULL,+ #' } |
||
| 63 |
- ...) {
+ #' |
||
| 64 | -229x | +
- UseMethod("init_filter_states")
+ #' @keywords internal |
|
| 65 |
- }+ #' |
||
| 66 |
-
+ FilterStateExpr <- R6::R6Class( # nolint |
||
| 67 |
- #' @keywords internal+ classname = "FilterStateExpr", |
||
| 68 |
- #' @export+ # public methods ---- |
||
| 69 |
- init_filter_states.data.frame <- function(data, # nolint+ public = list( |
||
| 70 |
- data_reactive = function(sid = "") NULL,+ #' @description |
||
| 71 |
- dataname,+ #' Initialize a `FilterStateExpr` object. |
||
| 72 |
- datalabel = NULL,+ #' @param slice (`teal_slice_expr`) |
||
| 73 |
- keys = character(0),+ #' @return Object of class `FilterStateExpr`, invisibly. |
||
| 74 |
- ...) {
+ #' |
||
| 75 | -100x | +
- DFFilterStates$new(+ initialize = function(slice) {
|
|
| 76 | -100x | +15x |
- data = data,+ checkmate::assert_class(slice, "teal_slice_expr") |
| 77 | -100x | +14x |
- data_reactive = data_reactive,+ private$teal_slice <- slice |
| 78 | -100x | +14x |
- dataname = dataname,+ invisible(self) |
| 79 | -100x | +
- datalabel = datalabel,+ }, |
|
| 80 | -100x | +
- keys = keys+ |
|
| 81 |
- )+ #' @description |
||
| 82 |
- }+ #' Returns a formatted string representing this `FilterStateExpr` object. |
||
| 83 |
-
+ #' |
||
| 84 |
- #' @keywords internal+ #' @param show_all (`logical(1)`) passed to `format.teal_slice` |
||
| 85 |
- #' @export+ #' @param trim_lines (`logical(1)`) passed to `format.teal_slice` |
||
| 86 |
- init_filter_states.matrix <- function(data, # nolint+ #' |
||
| 87 |
- data_reactive = function(sid = "") NULL,+ #' @return `character(1)` the formatted string |
||
| 88 |
- dataname,+ #' |
||
| 89 |
- datalabel = NULL,+ format = function(show_all = FALSE, trim_lines = TRUE) {
|
||
| 90 | -+ | 12x |
- ...) {
+ sprintf( |
| 91 | -22x | +12x |
- MatrixFilterStates$new(+ "%s:\n%s", |
| 92 | -22x | +12x |
- data = data,+ class(self)[1], |
| 93 | -22x | +12x |
- data_reactive = data_reactive,+ format(self$get_state(), show_all = show_all, trim_lines = trim_lines) |
| 94 | -22x | +
- dataname = dataname,+ ) |
|
| 95 | -22x | +
- datalabel = datalabel+ }, |
|
| 96 |
- )+ |
||
| 97 |
- }+ #' @description |
||
| 98 |
-
+ #' Prints this `FilterStateExpr` object. |
||
| 99 |
- #' @keywords internal+ #' @param ... arguments passed to the `format` method |
||
| 100 |
- #' @export+ #' @return `NULL`, invisibly. |
||
| 101 |
- init_filter_states.MultiAssayExperiment <- function(data, # nolint+ #' |
||
| 102 |
- data_reactive = function(sid = "") NULL,+ print = function(...) {
|
||
| 103 | -+ | 1x |
- dataname,+ cat(isolate(self$format(...))) |
| 104 |
- datalabel = "subjects",+ }, |
||
| 105 |
- keys = character(0),+ |
||
| 106 |
- ...) {
+ #' @description |
||
| 107 | -22x | +
- if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ #' Returns a complete description of this filter state. |
|
| 108 | -! | +
- stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ #' |
|
| 109 |
- }+ #' @return A `teal_slice` object. |
||
| 110 | -22x | +
- MAEFilterStates$new(+ #' |
|
| 111 | -22x | +
- data = data,+ get_state = function() {
|
|
| 112 | -22x | +26x |
- data_reactive = data_reactive,+ private$teal_slice |
| 113 | -22x | +
- dataname = dataname,+ }, |
|
| 114 | -22x | +
- datalabel = datalabel,+ |
|
| 115 | -22x | +
- keys = keys+ #' @description |
|
| 116 |
- )+ #' Does nothing. Exists for compatibility. |
||
| 117 |
- }+ #' |
||
| 118 |
-
+ #' @param state (`teal_slice`) |
||
| 119 |
- #' @keywords internal+ #' |
||
| 120 |
- #' @export+ #' @return `self`, invisibly. |
||
| 121 |
- init_filter_states.SummarizedExperiment <- function(data, # nolint+ #' |
||
| 122 |
- data_reactive = function(sid = "") NULL,+ set_state = function(state) {
|
||
| 123 | -+ | 1x |
- dataname,+ checkmate::assert_class(state, "teal_slice_expr") |
| 124 | -+ | 1x |
- datalabel = NULL,+ invisible(self) |
| 125 |
- ...) {
+ }, |
||
| 126 | -85x | +
- if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
+
|
|
| 127 | -! | +
- stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
+ #' @description |
|
| 128 |
- }+ #' Get reproducible call. |
||
| 129 | -85x | +
- SEFilterStates$new(+ #' |
|
| 130 | -85x | +
- data = data,+ #' @param dataname (`ignored`) for a consistency with `FilterState` |
|
| 131 | -85x | +
- data_reactive = data_reactive,+ #' |
|
| 132 | -85x | +
- dataname = dataname,+ #' Returns reproducible condition call for current selection relevant |
|
| 133 | -85x | +
- datalabel = datalabel+ #' for selected variable type. |
|
| 134 |
- )+ #' Method is using internal reactive values which makes it reactive |
||
| 135 |
- }+ #' and must be executed in reactive or isolated context. |
||
| 136 |
-
+ #' |
||
| 137 |
- #' Gets supported filterable variable names+ #' @return `call` or `NULL` |
||
| 138 |
- #'+ #' |
||
| 139 |
- #' Gets filterable variable names from a given object. The names match variables+ get_call = function(dataname) {
|
||
| 140 | -+ | 2x |
- #' of classes in an vector `teal.slice:::.filterable_class`.+ isolate(str2lang(private$teal_slice$expr)) |
| 141 |
- #' @param data+ }, |
||
| 142 |
- #' the `R` object containing elements which class can be checked through `vapply` or `apply`.+ |
||
| 143 |
- #' @return `character` vector of variable names.+ #' @description |
||
| 144 |
- #' @examples+ #' Destroy observers stored in `private$observers`. |
||
| 145 |
- #' # use non-exported function from teal.slice+ #' |
||
| 146 |
- #' get_supported_filter_varnames <- getFromNamespace("get_supported_filter_varnames", "teal.slice")
+ #' @return `NULL`, invisibly. |
||
| 147 |
- #'+ #' |
||
| 148 |
- #' df <- data.frame(+ destroy_observers = function() {
|
||
| 149 | -+ | ! |
- #' a = letters[1:3],+ lapply(private$observers, function(x) x$destroy()) |
| 150 |
- #' b = 1:3,+ |
||
| 151 | -+ | ! |
- #' c = Sys.Date() + 1:3,+ if (!is.null(private$destroy_shiny)) {
|
| 152 | -+ | ! |
- #' d = Sys.time() + 1:3,+ private$destroy_shiny() |
| 153 |
- #' z = complex(3)+ } |
||
| 154 | -+ | ! |
- #' )+ invisible(NULL) |
| 155 |
- #' get_supported_filter_varnames(df)+ }, |
||
| 156 |
- #' @keywords internal+ |
||
| 157 |
- #' @export+ # public shiny modules ---- |
||
| 158 |
- get_supported_filter_varnames <- function(data) {
+
|
||
| 159 | -227x | +
- UseMethod("get_supported_filter_varnames")
+ #' @description |
|
| 160 |
- }+ #' `shiny` module server. |
||
| 161 |
-
+ #' |
||
| 162 |
- #' @keywords internal+ #' @param id (`character(1)`) |
||
| 163 |
- #' @export+ #' `shiny` module instance id. |
||
| 164 |
- get_supported_filter_varnames.default <- function(data) { # nolint
+ #' |
||
| 165 | -198x | +
- is_expected_class <- vapply(+ #' @return Reactive expression signaling that the remove button has been clicked. |
|
| 166 | -198x | +
- X = data,+ #' |
|
| 167 | -198x | +
- FUN = function(x) any(class(x) %in% .filterable_class),+ server = function(id) {
|
|
| 168 | -198x | +! |
- FUN.VALUE = logical(1)+ moduleServer( |
| 169 | -+ | ! |
- )+ id = id, |
| 170 | -198x | +! |
- names(is_expected_class[is_expected_class])+ function(input, output, session) {
|
| 171 | -+ | ! |
- }+ private$server_summary("summary")
|
| 173 | -+ | ! |
- #' @keywords internal+ private$destroy_shiny <- function() {
|
| 174 | -+ | ! |
- #' @export+ logger::log_trace("Destroying FilterStateExpr inputs; id: { private$get_id() }")
|
| 175 |
- get_supported_filter_varnames.matrix <- function(data) { # nolint
+ # remove values from the input list |
||
| 176 | -+ | ! |
- # all columns are the same type in matrix+ lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) |
| 177 | -29x | +
- is_expected_class <- class(data[, 1]) %in% .filterable_class+ } |
|
| 178 | -29x | +
- if (is_expected_class && !is.null(colnames(data))) {
+
|
|
| 179 | -26x | +! |
- colnames(data)+ reactive(input$remove) # back to parent to remove self |
| 180 |
- } else {
+ } |
||
| 181 | -3x | +
- character(0)+ ) |
|
| 182 |
- }+ }, |
||
| 183 |
- }+ |
||
| 184 |
-
+ #' @description |
||
| 185 |
- #' @keywords internal+ #' `shiny` module UI. |
||
| 186 |
- #' @export+ #' The UI for this class contains simple message stating that it is not supported. |
||
| 187 |
- get_supported_filter_varnames.MultiAssayExperiment <- function(data) { # nolint
+ #' @param id (`character(1)`) |
||
| 188 | -! | +
- data <- SummarizedExperiment::colData(data)+ #' `shiny` module instance id. |
|
| 189 |
- # all columns are the same type in matrix+ #' @param parent_id (`character(1)`) |
||
| 190 | -! | +
- is_expected_class <- class(data[, 1]) %in% .filterable_class+ #' id of the `FilterStates` card container. |
|
| 191 | -! | +
- if (is_expected_class && !is.null(names(data))) {
+ ui = function(id, parent_id = "cards") {
|
|
| 192 | ! |
- names(data)+ ns <- NS(id) |
|
| 193 | -+ | ! |
- } else {
+ isolate({
|
| 194 | ! |
- character(0)+ tags$div( |
|
| 195 | -+ | ! |
- }+ id = id, |
| 196 | -+ | ! |
- }+ class = "panel filter-card", |
| 197 | -+ | ! |
-
+ include_js_files("count-bar-labels.js"),
|
| 198 | -+ | ! |
- #' Returns a `choices_labeled` object+ tags$div( |
| 199 | -+ | ! |
- #'+ class = "filter-card-header", |
| 200 | -+ | ! |
- #' @param data (`data.frame` or `DFrame` or `list`)+ tags$div( |
| 201 | -+ | ! |
- #' where labels can be taken from in case when `varlabels` is not specified.+ class = "filter-card-title", |
| 202 | -+ | ! |
- #' `data` must be specified if `varlabels` is not specified.+ if (private$is_anchored()) {
|
| 203 | -+ | ! |
- #' @param choices (`character`)+ icon("anchor-lock", class = "filter-card-icon")
|
| 204 |
- #' the vector of chosen variables+ } else {
|
||
| 205 | -+ | ! |
- #' @param varlabels (`character`)+ icon("lock", class = "filter-card-icon")
|
| 206 |
- #' the labels of variables in data+ }, |
||
| 207 | -+ | ! |
- #' @param keys (`character`)+ tags$div(class = "filter-card-varname", tags$strong(private$teal_slice$id)), |
| 208 | -+ | ! |
- #' the names of the key columns in data+ tags$div(class = "filter-card-varlabel", private$teal_slice$title), |
| 209 | -+ | ! |
- #' @return `character(0)` if choices are empty; a `choices_labeled` object otherwise+ tags$div( |
| 210 | -+ | ! |
- #' @keywords internal+ class = "filter-card-controls", |
| 211 | -+ | ! |
- data_choices_labeled <- function(data,+ if (isFALSE(private$is_anchored())) {
|
| 212 | -+ | ! |
- choices,+ actionLink( |
| 213 | -+ | ! |
- varlabels = teal.data::col_labels(data, fill = TRUE),+ inputId = ns("remove"),
|
| 214 | -+ | ! |
- keys = character(0)) {
+ label = icon("circle-xmark", lib = "font-awesome"),
|
| 215 | -9x | +! |
- if (length(choices) == 0) {
+ title = "Remove filter", |
| 216 | ! |
- return(character(0))+ class = "filter-card-remove" |
|
| 217 |
- }+ ) |
||
| 218 | -9x | +
- choice_types <- variable_types(data = data, columns = choices)+ } |
|
| 219 | -9x | +
- choice_types[keys] <- "primary_key"+ ) |
|
| 220 |
-
+ ), |
||
| 221 | -9x | +! |
- choices_labeled(+ tags$div( |
| 222 | -9x | +! |
- choices = choices,+ class = "filter-card-summary", |
| 223 | -9x | +! |
- labels = unname(varlabels[choices]),+ private$ui_summary(ns("summary"))
|
| 224 | -9x | +
- types = choice_types[choices]+ ) |
|
| 225 |
- )+ ) |
||
| 226 |
- }+ ) |
||
| 227 |
-
+ }) |
||
| 228 |
- #' @noRd+ } |
||
| 229 |
- #' @keywords internal+ ), |
||
| 230 |
- get_varlabels <- function(data) {
+
|
||
| 231 | -9x | +
- if (!is.array(data)) {
+ # private members ---- |
|
| 232 | -9x | +
- vapply(+ |
|
| 233 | -9x | +
- colnames(data),+ private = list( |
|
| 234 | -9x | +
- FUN = function(x) {
+ observers = NULL, # stores observers |
|
| 235 | -42x | +
- label <- attr(data[[x]], "label")+ teal_slice = NULL, # stores reactiveValues |
|
| 236 | -42x | +
- if (is.null(label)) {
+ destroy_shiny = NULL, # function is set in server |
|
| 237 | -40x | +
- x+ |
|
| 238 |
- } else {
+ # @description |
||
| 239 | -2x | +
- label+ # Get id of the teal_slice. |
|
| 240 |
- }+ # @return `character(1)` |
||
| 241 |
- },+ get_id = function() {
|
||
| 242 | -9x | +! |
- FUN.VALUE = character(1)+ isolate(private$teal_slice$id) |
| 243 |
- )+ }, |
||
| 244 | - |
- } else {
- |
- |
| 245 | -! | -
- character(0)- |
- |
| 246 | -- |
- }- |
- |
| 247 | -- |
- }- |
-
| 1 | -- |
- # FilterStateExpr ------- |
- |
| 2 | -|||
| 3 | -- |
- #' @name FilterStateExpr- |
- |
| 4 | +245 |
- #' @docType class+ # Check whether this filter is anchored (cannot be removed). |
|
| 5 | +246 |
- #'+ # @return `logical(1)` |
|
| 6 | +247 |
- #' @title `FilterStateExpr` `R6` class+ is_anchored = function() {
|
|
| 7 | -+ | ||
| 248 | +! |
- #'+ isolate(isTRUE(private$teal_slice$anchored)) |
|
| 8 | +249 |
- #' @description Sister class to `FilterState` that handles arbitrary filter expressions.+ }, |
|
| 9 | +250 |
- #'+ |
|
| 10 | +251 |
- #' @details+ # @description |
|
| 11 | +252 |
- #' Creates a filter state around a predefined condition call (logical predicate).+ # Server module to display filter summary |
|
| 12 | +253 |
- #' The condition call is independent of the data+ # @param id `shiny` id parameter |
|
| 13 | +254 |
- #' and the filter card allows no interaction (the filter is always fixed).+ ui_summary = function(id) {
|
|
| 14 | -+ | ||
| 255 | +! |
- #'+ ns <- NS(id) |
|
| 15 | -+ | ||
| 256 | +! |
- #' @examples+ uiOutput(ns("summary"), class = "filter-card-summary")
|
|
| 16 | +257 |
- #' # use non-exported function from teal.slice+ }, |
|
| 17 | +258 |
- #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
+
|
|
| 18 | +259 |
- #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
+ # @description |
|
| 19 | +260 |
- #' FilterStateExpr <- getFromNamespace("FilterStateExpr", "teal.slice")
+ # UI module to display filter summary |
|
| 20 | +261 |
- #'+ # @param shiny `id` parameter passed to moduleServer |
|
| 21 | +262 |
- #' filter_state <- FilterStateExpr$new(+ # renders text describing current state |
|
| 22 | +263 |
- #' slice = teal_slice(+ server_summary = function(id) {
|
|
| 23 | -+ | ||
| 264 | +! |
- #' dataname = "x",+ moduleServer( |
|
| 24 | -+ | ||
| 265 | +! |
- #' id = "FA",+ id = id, |
|
| 25 | -+ | ||
| 266 | +! |
- #' title = "Adult females",+ function(input, output, session) {
|
|
| 26 | -+ | ||
| 267 | +! |
- #' expr = "sex == 'F' & age >= 18"+ output$summary <- renderUI(private$content_summary()) |
|
| 27 | +268 |
- #' )+ } |
|
| 28 | +269 |
- #' )+ ) |
|
| 29 | +270 |
- #' filter_state$get_call()+ }, |
|
| 30 | +271 |
- #'+ content_summary = function() {
|
|
| 31 | -+ | ||
| 272 | +! |
- #' # working filter in an app+ isolate(private$teal_slice$expr) |
|
| 32 | +273 |
- #' library(shiny)+ } |
|
| 33 | +274 |
- #' library(shinyjs)+ ) |
|
| 34 | +275 |
- #'+ ) |
| 35 | +1 |
- #' ui <- fluidPage(+ .onLoad <- function(libname, pkgname) { # nolint
|
|
| 36 | +2 |
- #' useShinyjs(),+ # adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R |
|
| 37 | -+ | ||
| 3 | +! |
- #' include_css_files(pattern = "filter-panel"),+ teal_default_options <- list(teal.threshold_slider_vs_checkboxgroup = 5) |
|
| 38 | -+ | ||
| 4 | +! |
- #' include_js_files(pattern = "count-bar-labels"),+ op <- options() |
|
| 39 | -+ | ||
| 5 | +! |
- #' column(4, tags$div(+ toset <- !(names(teal_default_options) %in% names(op)) |
|
| 40 | -+ | ||
| 6 | +! |
- #' tags$h4("ChoicesFilterState"),
+ if (any(toset)) options(teal_default_options[toset]) |
|
| 41 | +7 |
- #' filter_state$ui("fs")
+
|
|
| 42 | +8 |
- #' )),+ # Set up the teal logger instance |
|
| 43 | -+ | ||
| 9 | +! |
- #' column(8, tags$div(+ teal.logger::register_logger("teal.slice")
|
|
| 44 | -+ | ||
| 10 | +! |
- #' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
+ teal.logger::register_handlers("teal.slice")
|
|
| 45 | +11 |
- #' textOutput("condition_choices"), tags$br(),
+
|
|
| 46 | -+ | ||
| 12 | +! |
- #' tags$h4("Unformatted state"), # display raw filter state
+ invisible() |
|
| 47 | +13 |
- #' textOutput("unformatted_choices"), tags$br(),
+ } |
|
| 48 | +14 |
- #' tags$h4("Formatted state"), # display human readable filter state
+
|
|
| 49 | +15 |
- #' textOutput("formatted_choices"), tags$br()
+ ### GLOBAL VARIABLES ### |
|
| 50 | +16 |
- #' ))+ |
|
| 51 | +17 |
- #' )+ .filterable_class <- c("logical", "integer", "numeric", "factor", "character", "Date", "POSIXct", "POSIXlt")
|
|
| 52 | +18 |
- #'+ |
|
| 53 | +19 |
- #' server <- function(input, output, session) {
+
|
|
| 54 | +20 |
- #' filter_state$server("fs")
+ ### END GLOBAL VARIABLES ### |
|
| 55 | +21 |
- #' output$condition_choices <- renderPrint(filter_state$get_call())+ |
|
| 56 | +22 |
- #' output$formatted_choices <- renderText(filter_state$format())+ |
|
| 57 | +23 |
- #' output$unformatted_choices <- renderPrint(filter_state$get_state())+ ### ENSURE CHECK PASSES |
|
| 58 | +24 |
- #' }+ |
|
| 59 | +25 |
- #'+ # This function is necessary for check to properly process code dependencies within R6 classes. |
|
| 60 | +26 |
- #' if (interactive()) {
+ # If `package` is listed in `Imports` in `DESCRIPTION`, |
|
| 61 | +27 |
- #' shinyApp(ui, server)+ # (1) check goes through `NAMESPACE` looking for any `importFrom(package,<foo>)` statements |
|
| 62 | +28 |
- #' }+ # or an `import(package)` statement. If none are found, |
|
| 63 | +29 |
- #'+ # (2) check looks for `package::*` calls in the code. If none are found again, |
|
| 64 | +30 |
- #' @keywords internal+ # (3) check throws a NOTE; |
|
| 65 | +31 |
- #'+ # # Namespaces in Imports field not imported from: |
|
| 66 | +32 |
- FilterStateExpr <- R6::R6Class( # nolint+ # # 'package' |
|
| 67 | +33 |
- classname = "FilterStateExpr",+ # # All declared Imports should be used. |
|
| 68 | +34 |
- # public methods ----+ # This note is banned by our CI. |
|
| 69 | +35 |
- public = list(+ # When package::* statements are made within an R6 class, they are not registered. |
|
| 70 | +36 |
- #' @description+ # This function provides single references to the imported namespaces for check to notice. |
|
| 71 | +37 |
- #' Initialize a `FilterStateExpr` object.+ .rectify_dependencies_check <- function() {
|
|
| 72 | -+ | ||
| 38 | +! |
- #' @param slice (`teal_slice_expr`)+ dplyr::filter |
|
| 73 | -+ | ||
| 39 | +! |
- #' @return Object of class `FilterStateExpr`, invisibly.+ grDevices::rgb |
|
| 74 | -+ | ||
| 40 | +! |
- #'+ htmltools::tagInsertChildren |
|
| 75 | -+ | ||
| 41 | +! |
- initialize = function(slice) {
+ lifecycle::badge |
|
| 76 | -15x | +||
| 42 | +! |
- checkmate::assert_class(slice, "teal_slice_expr")+ logger::log_trace |
|
| 77 | -14x | +||
| 43 | +! |
- private$teal_slice <- slice+ plotly::plot_ly |
|
| 78 | -14x | +||
| 44 | +! |
- invisible(self)+ shinycssloaders::withSpinner |
|
| 79 | -+ | ||
| 45 | +! |
- },+ shinyWidgets::pickerOptions |
|
| 80 | -+ | ||
| 46 | +! |
-
+ teal.data::datanames |
|
| 81 | -+ | ||
| 47 | +! |
- #' @description+ teal.widgets::optionalSelectInput |
|
| 82 | +48 |
- #' Returns a formatted string representing this `FilterStateExpr` object.+ } |
|
| 83 | +49 |
- #'+ |
|
| 84 | +50 |
- #' @param show_all (`logical(1)`) passed to `format.teal_slice`+ |
|
| 85 | +51 |
- #' @param trim_lines (`logical(1)`) passed to `format.teal_slice`+ ### END ENSURE CHECK PASSES |
| 86 | +1 |
- #'+ # This file contains helper functions used in unit tests. |
||
| 87 | +2 |
- #' @return `character(1)` the formatted string+ |
||
| 88 | +3 |
- #'+ # compares specified fields between two `teal_slice` objects |
||
| 89 | +4 |
- format = function(show_all = FALSE, trim_lines = TRUE) {
+ #' @noRd |
||
| 90 | -12x | +|||
| 5 | +
- sprintf(+ #' @keywords internal |
|||
| 91 | -12x | +|||
| 6 | +
- "%s:\n%s",+ compare_slices <- function(ts1, ts2, fields) {
|
|||
| 92 | -12x | +7 | +9x |
- class(self)[1],+ isolate( |
| 93 | -12x | +8 | +9x |
- format(self$get_state(), show_all = show_all, trim_lines = trim_lines)+ all(vapply(fields, function(x) identical(ts1[[x]], ts2[[x]]), logical(1L))) |
| 94 | +9 |
- )+ ) |
||
| 95 | +10 |
- },+ } |
||
| 96 | +11 | |||
| 97 | -- |
- #' @description- |
- ||
| 98 | +12 |
- #' Prints this `FilterStateExpr` object.+ |
||
| 99 | +13 |
- #' @param ... arguments passed to the `format` method+ # compare two teal_slice |
||
| 100 | +14 |
- #' @return `NULL`, invisibly.+ #' @noRd |
||
| 101 | +15 |
- #'+ #' @keywords internal |
||
| 102 | +16 |
- print = function(...) {
+ expect_identical_slice <- function(x, y) {
|
||
| 103 | -1x | +17 | +34x |
- cat(isolate(self$format(...)))+ isolate({
|
| 104 | -+ | |||
| 18 | +34x |
- },+ testthat::expect_true( |
||
| 105 | -+ | |||
| 19 | +34x |
-
+ setequal( |
||
| 106 | -+ | |||
| 20 | +34x |
- #' @description+ reactiveValuesToList(x), |
||
| 107 | -+ | |||
| 21 | +34x |
- #' Returns a complete description of this filter state.+ reactiveValuesToList(y) |
||
| 108 | +22 |
- #'+ ) |
||
| 109 | +23 |
- #' @return A `teal_slice` object.+ ) |
||
| 110 | +24 |
- #'+ }) |
||
| 111 | +25 |
- get_state = function() {
- |
- ||
| 112 | -26x | -
- private$teal_slice+ } |
||
| 113 | +26 |
- },+ |
||
| 114 | +27 |
-
+ # compare two teal_slices |
||
| 115 | +28 |
- #' @description+ #' @noRd |
||
| 116 | +29 |
- #' Does nothing. Exists for compatibility.+ #' @keywords internal |
||
| 117 | +30 |
- #'+ expect_identical_slices <- function(x, y) {
|
||
| 118 | -+ | |||
| 31 | +12x |
- #' @param state (`teal_slice`)+ isolate({
|
||
| 119 | -+ | |||
| 32 | +12x |
- #'+ mapply( |
||
| 120 | -+ | |||
| 33 | +12x |
- #' @return `self`, invisibly.+ function(x, y) {
|
||
| 121 | -+ | |||
| 34 | +27x |
- #'+ expect_identical_slice(x, y) |
||
| 122 | +35 |
- set_state = function(state) {
+ }, |
||
| 123 | -1x | +36 | +12x |
- checkmate::assert_class(state, "teal_slice_expr")+ x = x, |
| 124 | -1x | +37 | +12x |
- invisible(self)+ y = y |
| 125 | +38 |
- },+ )+ |
+ ||
| 39 | +12x | +
+ testthat::expect_identical(attributes(x), attributes(y)) |
||
| 126 | +40 |
-
+ }) |
||
| 127 | +41 |
- #' @description+ } |
| 128 | +1 |
- #' Get reproducible call.+ # EmptyFilterState ------ |
|
| 129 | +2 |
- #'+ |
|
| 130 | +3 |
- #' @param dataname (`ignored`) for a consistency with `FilterState`+ #' @name EmptyFilterState |
|
| 131 | +4 |
- #'+ #' @docType class |
|
| 132 | +5 |
- #' Returns reproducible condition call for current selection relevant+ #' |
|
| 133 | +6 |
- #' for selected variable type.+ #' @title `FilterState` object for empty variables |
|
| 134 | +7 |
- #' Method is using internal reactive values which makes it reactive+ #' |
|
| 135 | +8 |
- #' and must be executed in reactive or isolated context.+ #' @description `FilterState` subclass representing an empty variable. |
|
| 136 | +9 |
- #'+ #' |
|
| 137 | +10 |
- #' @return `call` or `NULL`+ #' @examples |
|
| 138 | +11 |
- #'+ #' # use non-exported function from teal.slice |
|
| 139 | +12 |
- get_call = function(dataname) {
+ #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 140 | -2x | +||
| 13 | +
- isolate(str2lang(private$teal_slice$expr))+ #' EmptyFilterState <- getFromNamespace("EmptyFilterState", "teal.slice")
|
||
| 141 | +14 |
- },+ #' |
|
| 142 | +15 |
-
+ #' library(shiny) |
|
| 143 | +16 |
- #' @description+ #' |
|
| 144 | +17 |
- #' Destroy observers stored in `private$observers`.+ #' filter_state <- EmptyFilterState$new( |
|
| 145 | +18 |
- #'+ #' x = NA, |
|
| 146 | +19 |
- #' @return `NULL`, invisibly.+ #' slice = teal_slice(varname = "x", dataname = "data"), |
|
| 147 | +20 |
- #'+ #' extract_type = character(0) |
|
| 148 | +21 |
- destroy_observers = function() {
+ #' ) |
|
| 149 | -! | +||
| 22 | +
- lapply(private$observers, function(x) x$destroy())+ #' isolate(filter_state$get_call()) |
||
| 150 | +23 |
-
+ #' filter_state$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
|
| 151 | -! | +||
| 24 | +
- if (!is.null(private$destroy_shiny)) {
+ #' isolate(filter_state$get_call()) |
||
| 152 | -! | +||
| 25 | +
- private$destroy_shiny()+ #' |
||
| 153 | +26 |
- }+ #' @keywords internal |
|
| 154 | -! | +||
| 27 | +
- invisible(NULL)+ #' |
||
| 155 | +28 |
- },+ EmptyFilterState <- R6::R6Class( # nolint |
|
| 156 | +29 |
-
+ "EmptyFilterState", |
|
| 157 | +30 |
- # public shiny modules ----+ inherit = FilterState, |
|
| 158 | +31 | ||
| 159 | +32 |
- #' @description+ # public methods ---- |
|
| 160 | +33 |
- #' `shiny` module server.+ public = list( |
|
| 161 | +34 |
- #'+ |
|
| 162 | +35 |
- #' @param id (`character(1)`)+ #' @description |
|
| 163 | +36 |
- #' `shiny` module instance id.+ #' Initialize `EmptyFilterState` object. |
|
| 164 | +37 |
#' |
|
| 165 | +38 |
- #' @return Reactive expression signaling that the remove button has been clicked.+ #' @param x (`vector`) |
|
| 166 | +39 |
- #'+ #' variable to be filtered, |
|
| 167 | +40 |
- server = function(id) {
- |
- |
| 168 | -! | -
- moduleServer(- |
- |
| 169 | -! | -
- id = id,- |
- |
| 170 | -! | -
- function(input, output, session) {
+ #' @param x_reactive (`reactive`) |
|
| 171 | -! | +||
| 41 | +
- private$server_summary("summary")
+ #' returning vector of the same type as `x`. Is used to update |
||
| 172 | +42 |
-
+ #' counts following the change in values of the filtered dataset. |
|
| 173 | -! | +||
| 43 | +
- private$destroy_shiny <- function() {
+ #' If it is set to `reactive(NULL)` then counts based on filtered |
||
| 174 | -! | +||
| 44 | +
- logger::log_trace("Destroying FilterStateExpr inputs; id: { private$get_id() }")
+ #' dataset are not shown. |
||
| 175 | +45 |
- # remove values from the input list+ #' @param slice (`teal_slice`) |
|
| 176 | -! | +||
| 46 | +
- lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)+ #' specification of this filter state. |
||
| 177 | +47 |
- }+ #' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 178 | +48 |
-
+ #' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 179 | -! | +||
| 49 | +
- reactive(input$remove) # back to parent to remove self+ #' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
||
| 180 | +50 |
- }+ #' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 181 | +51 |
- )+ #' @param extract_type (`character`) |
|
| 182 | +52 |
- },+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 183 | +53 |
-
+ #' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 184 | +54 |
- #' @description+ #' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 185 | +55 |
- #' `shiny` module UI.+ #' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 186 | +56 |
- #' The UI for this class contains simple message stating that it is not supported.+ #' |
|
| 187 | +57 |
- #' @param id (`character(1)`)+ #' @return Object of class `EmptyFilterState`, invisibly. |
|
| 188 | +58 |
- #' `shiny` module instance id.+ #' |
|
| 189 | +59 |
- #' @param parent_id (`character(1)`)+ initialize = function(x, |
|
| 190 | +60 |
- #' id of the `FilterStates` card container.+ x_reactive = reactive(NULL), |
|
| 191 | +61 |
- ui = function(id, parent_id = "cards") {
+ extract_type = character(0), |
|
| 192 | -! | +||
| 62 | +
- ns <- NS(id)+ slice) {
|
||
| 193 | -! | +||
| 63 | +6x |
isolate({
|
|
| 194 | -! | -
- tags$div(- |
- |
| 195 | -! | -
- id = id,- |
- |
| 196 | -! | +||
| 64 | +6x |
- class = "panel filter-card",+ super$initialize( |
|
| 197 | -! | +||
| 65 | +6x |
- include_js_files("count-bar-labels.js"),
+ x = x, |
|
| 198 | -! | +||
| 66 | +6x |
- tags$div(+ x_reactive = x_reactive, |
|
| 199 | -! | +||
| 67 | +6x |
- class = "filter-card-header",+ slice = slice, |
|
| 200 | -! | +||
| 68 | +6x |
- tags$div(+ extract_type = extract_type |
|
| 201 | -! | +||
| 69 | +
- class = "filter-card-title",+ ) |
||
| 202 | -! | +||
| 70 | +6x |
- if (private$is_anchored()) {
+ private$set_choices(slice$choices) |
|
| 203 | -! | +||
| 71 | +6x |
- icon("anchor-lock", class = "filter-card-icon")
+ private$set_selected(slice$selected) |
|
| 204 | +72 |
- } else {
- |
- |
| 205 | -! | -
- icon("lock", class = "filter-card-icon")
+ }) |
|
| 206 | +73 |
- },- |
- |
| 207 | -! | -
- tags$div(class = "filter-card-varname", tags$strong(private$teal_slice$id)),+ |
|
| 208 | -! | +||
| 74 | +6x |
- tags$div(class = "filter-card-varlabel", private$teal_slice$title),+ invisible(self) |
|
| 209 | -! | +||
| 75 | +
- tags$div(+ }, |
||
| 210 | -! | +||
| 76 | +
- class = "filter-card-controls",+ |
||
| 211 | -! | +||
| 77 | +
- if (isFALSE(private$is_anchored())) {
+ #' @description |
||
| 212 | -! | +||
| 78 | +
- actionLink(+ #' Returns reproducible condition call for current selection relevant for selected variable type. |
||
| 213 | -! | +||
| 79 | +
- inputId = ns("remove"),
+ #' Uses internal reactive values, hence must be called in reactive or isolated context. |
||
| 214 | -! | +||
| 80 | +
- label = icon("circle-xmark", lib = "font-awesome"),
+ #' @param dataname name of data set; defaults to `private$get_dataname()` |
||
| 215 | -! | +||
| 81 | +
- title = "Remove filter",+ #' @return `logical(1)` |
||
| 216 | -! | +||
| 82 | +
- class = "filter-card-remove"+ #' |
||
| 217 | +83 |
- )+ get_call = function(dataname) {
|
|
| 218 | -+ | ||
| 84 | +2x |
- }+ if (isFALSE(private$is_any_filtered())) {
|
|
| 219 | -+ | ||
| 85 | +1x |
- )+ return(NULL) |
|
| 220 | +86 |
- ),+ } |
|
| 221 | -! | +||
| 87 | +1x |
- tags$div(+ if (missing(dataname)) dataname <- private$get_dataname() |
|
| 222 | -! | +||
| 88 | +1x |
- class = "filter-card-summary",+ filter_call <- if (isTRUE(private$get_keep_na())) {
|
|
| 223 | +89 | ! |
- private$ui_summary(ns("summary"))
- |
-
| 224 | -- |
- )+ call("is.na", private$get_varname_prefixed(dataname))
|
|
| 225 | +90 |
- )+ } else {
|
|
| 226 | -+ | ||
| 91 | +1x |
- )+ substitute(!is.na(varname), list(varname = private$get_varname_prefixed(dataname))) |
|
| 227 | +92 |
- })+ } |
|
| 228 | +93 |
} |
|
| 229 | +94 |
), |
|
| 230 | +95 | ||
| 231 | +96 |
# private members ---- |
|
| 232 | +97 |
-
+ private = list( |
|
| 233 | +98 |
- private = list(+ cache_state = function() {
|
|
| 234 | -+ | ||
| 99 | +! |
- observers = NULL, # stores observers+ private$cache <- private$get_state() |
|
| 235 | -+ | ||
| 100 | +! |
- teal_slice = NULL, # stores reactiveValues+ self$set_state( |
|
| 236 | -+ | ||
| 101 | +! |
- destroy_shiny = NULL, # function is set in server+ list( |
|
| 237 | -+ | ||
| 102 | +! |
-
+ keep_na = NULL |
|
| 238 | +103 |
- # @description+ ) |
|
| 239 | +104 |
- # Get id of the teal_slice.+ ) |
|
| 240 | +105 |
- # @return `character(1)`+ }, |
|
| 241 | +106 |
- get_id = function() {
+ set_choices = function(choices) {
|
|
| 242 | -! | +||
| 107 | +6x |
- isolate(private$teal_slice$id)+ private$teal_slice$choices <- choices |
|
| 243 | -+ | ||
| 108 | +6x |
- },+ invisible(NULL) |
|
| 244 | +109 |
-
+ }, |
|
| 245 | +110 |
- # Check whether this filter is anchored (cannot be removed).+ |
|
| 246 | +111 |
- # @return `logical(1)`+ |
|
| 247 | +112 |
- is_anchored = function() {
- |
- |
| 248 | -! | -
- isolate(isTRUE(private$teal_slice$anchored))+ # Reports whether the current state filters out any values.(?) |
|
| 249 | +113 |
- },+ # @return `logical(1)` |
|
| 250 | +114 |
-
+ # |
|
| 251 | +115 |
- # @description+ is_any_filtered = function() {
|
|
| 252 | -+ | ||
| 116 | +2x |
- # Server module to display filter summary+ if (private$is_choice_limited) {
|
|
| 253 | -+ | ||
| 117 | +! |
- # @param id `shiny` id parameter+ TRUE |
|
| 254 | +118 |
- ui_summary = function(id) {
+ } else {
|
|
| 255 | -! | +||
| 119 | +2x |
- ns <- NS(id)+ !isTRUE(private$get_keep_na()) |
|
| 256 | -! | +||
| 120 | +
- uiOutput(ns("summary"), class = "filter-card-summary")
+ } |
||
| 257 | +121 |
}, |
|
| 258 | +122 | ||
| 259 | +123 |
# @description |
|
| 260 | +124 |
- # UI module to display filter summary+ # UI Module for `EmptyFilterState`. |
|
| 261 | +125 |
- # @param shiny `id` parameter passed to moduleServer+ # This UI element contains a checkbox input to filter or keep missing values. |
|
| 262 | +126 |
- # renders text describing current state+ # @param id (`character(1)`) `shiny` module instance id. |
|
| 263 | +127 |
- server_summary = function(id) {
+ #+ |
+ |
| 128 | ++ |
+ ui_inputs = function(id) {
|
|
| 264 | +129 | ! |
- moduleServer(+ ns <- NS(id) |
| 265 | +130 | ! |
- id = id,+ isolate({
|
| 266 | +131 | ! |
- function(input, output, session) {
+ tags$div( |
| 267 | +132 | ! |
- output$summary <- renderUI(private$content_summary())+ tags$span("Variable contains missing values only"),
|
| 268 | -+ | ||
| 133 | +! |
- }+ private$keep_na_ui(ns("keep_na"))
|
|
| 269 | +134 |
- )+ ) |
|
| 270 | +135 |
- },+ }) |
|
| 271 | +136 |
- content_summary = function() {
- |
- |
| 272 | -! | -
- isolate(private$teal_slice$expr)+ }, |
|
| 273 | +137 |
- }+ |
|
| 274 | +138 |
- )+ # @description |
|
| 275 | +139 |
- )+ # Controls state of the `keep_na` checkbox input. |
| 1 | +140 |
- # This file contains helper functions used in unit tests.+ # |
|
| 2 | +141 |
-
+ # @param id (`character(1)`) `shiny` module instance id. |
|
| 3 | +142 |
- # compares specified fields between two `teal_slice` objects+ # |
|
| 4 | +143 |
- #' @noRd+ # @return `NULL`. |
|
| 5 | +144 |
- #' @keywords internal+ # |
|
| 6 | +145 |
- compare_slices <- function(ts1, ts2, fields) {
- |
- |
| 7 | -9x | -
- isolate(- |
- |
| 8 | -9x | -
- all(vapply(fields, function(x) identical(ts1[[x]], ts2[[x]]), logical(1L)))+ server_inputs = function(id) {
|
|
| 9 | -+ | ||
| 146 | +! |
- )+ moduleServer( |
|
| 10 | -+ | ||
| 147 | +! |
- }+ id = id, |
|
| 11 | -+ | ||
| 148 | +! |
-
+ function(input, output, session) {
|
|
| 12 | -+ | ||
| 149 | +! |
-
+ private$keep_na_srv("keep_na")
|
|
| 13 | +150 |
- # compare two teal_slice+ } |
|
| 14 | +151 |
- #' @noRd+ ) |
|
| 15 | +152 |
- #' @keywords internal+ }, |
|
| 16 | +153 |
- expect_identical_slice <- function(x, y) {
+ server_inputs_fixed = function(id) {
|
|
| 17 | -34x | +||
| 154 | +! |
- isolate({
+ moduleServer( |
|
| 18 | -34x | +||
| 155 | +! |
- testthat::expect_true(+ id = id, |
|
| 19 | -34x | +||
| 156 | +! |
- setequal(+ function(input, output, session) {
|
|
| 20 | -34x | +||
| 157 | +! |
- reactiveValuesToList(x),+ output$selection <- renderUI({
|
|
| 21 | -34x | +||
| 158 | +! |
- reactiveValuesToList(y)+ tags$span("Variable contains missing values only")
|
|
| 22 | +159 |
- )+ }) |
|
| 23 | -+ | ||
| 160 | +! |
- )+ NULL |
|
| 24 | +161 |
- })+ } |
|
| 25 | +162 |
- }+ ) |
|
| 26 | +163 |
-
+ }, |
|
| 27 | +164 |
- # compare two teal_slices+ |
|
| 28 | +165 |
- #' @noRd+ # @description |
|
| 29 | +166 |
- #' @keywords internal+ # Server module to display filter summary |
|
| 30 | +167 |
- expect_identical_slices <- function(x, y) {
- |
- |
| 31 | -12x | -
- isolate({
- |
- |
| 32 | -12x | -
- mapply(- |
- |
| 33 | -12x | -
- function(x, y) {
- |
- |
| 34 | -27x | -
- expect_identical_slice(x, y)+ # Doesn't render anything |
|
| 35 | +168 |
- },- |
- |
| 36 | -12x | -
- x = x,+ content_summary = function(id) {
|
|
| 37 | -12x | +||
| 169 | +! |
- y = y+ tags$span("All empty")
|
|
| 38 | +170 |
- )- |
- |
| 39 | -12x | -
- testthat::expect_identical(attributes(x), attributes(y))+ } |
|
| 40 | +171 |
- })+ ) |
|
| 41 | +172 |
- }+ ) |
| 1 |
- # DFFilterStates ------+ #' Managing `FilteredData` states |
||
| 2 |
-
+ #' |
||
| 3 |
- #' @name DFFilterStates+ #' @description `r lifecycle::badge("experimental")`
|
||
| 4 |
- #' @docType class+ #' |
||
| 5 |
- #'+ #' Set, get and remove filter states of `FilteredData` object. |
||
| 6 |
- #' @title `FilterStates` subclass for data frames+ #' |
||
| 7 |
- #'+ #' @name filter_state_api |
||
| 8 |
- #' @description Handles filter states in a `data.frame`.+ #' |
||
| 9 |
- #'+ #' @param datasets (`FilteredData`) |
||
| 10 |
- #' @examples+ #' object to store filter state and filtered datasets, shared across modules |
||
| 11 |
- #' # use non-exported function from teal.slice+ #' |
||
| 12 |
- #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
+ #' see [`FilteredData`] for details |
||
| 13 |
- #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
+ #' |
||
| 14 |
- #' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
+ #' @param filter (`teal_slices`) |
||
| 15 |
- #'+ #' specify filters in place on app start-up |
||
| 16 |
- #' library(shiny)+ #' |
||
| 17 |
- #' library(shinyjs)+ #' @param force (`logical(1)`) |
||
| 18 |
- #'+ #' flag specifying whether to include anchored filter states. |
||
| 19 |
- #' # create data frame to filter+ #' |
||
| 20 |
- #' data_df <- data.frame(+ #' @return |
||
| 21 |
- #' NUM1 = 1:100,+ #' - `set_*`, `remove_*` and `clear_filter_state` return `NULL` invisibly |
||
| 22 |
- #' NUM2 = round(runif(100, min = 20, max = 23)),+ #' - `get_filter_state` returns a named `teal_slices` object |
||
| 23 |
- #' CHAR1 = sample(LETTERS[1:6], size = 100, replace = TRUE),+ #' containing a `teal_slice` for every existing `FilterState` |
||
| 24 |
- #' CHAR2 = sample(c("M", "F"), size = 100, replace = TRUE),
+ #' |
||
| 25 |
- #' DATE = seq(as.Date("2020-01-01"), by = 1, length.out = 100),
+ #' @seealso [`teal_slice`] |
||
| 26 |
- #' DATETIME = as.POSIXct(seq(as.Date("2020-01-01"), by = 1, length.out = 100))
+ #' |
||
| 27 |
- #' )+ #' @examples |
||
| 28 |
- #' data_na <- data.frame(+ #' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars)) |
||
| 29 |
- #' NUM1 = NA,+ #' fs <- teal_slices( |
||
| 30 |
- #' NUM2 = NA,+ #' teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor")),
|
||
| 31 |
- #' CHAR1 = NA,+ #' teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)), |
||
| 32 |
- #' CHAR2 = NA,+ #' teal_slice(dataname = "mtcars", varname = "gear", selected = c(4, 5)), |
||
| 33 |
- #' DATE = NA,+ #' teal_slice(dataname = "mtcars", varname = "carb", selected = c(4, 10)) |
||
| 34 |
- #' DATETIME = NA+ #' ) |
||
| 35 |
- #' )+ #' |
||
| 36 |
- #' data_df <- rbind(data_df, data_na)+ #' # set initial filter state |
||
| 37 |
- #'+ #' set_filter_state(datasets, filter = fs) |
||
| 38 |
- #' # initiate `FilterStates` object+ #' |
||
| 39 |
- #' filter_states_df <- init_filter_states(+ #' # get filter state |
||
| 40 |
- #' data = data_df,+ #' get_filter_state(datasets) |
||
| 41 |
- #' dataname = "dataset",+ #' |
||
| 42 |
- #' datalabel = ("label")
+ #' # modify filter state |
||
| 43 |
- #' )+ #' set_filter_state( |
||
| 44 |
- #'+ #' datasets, |
||
| 45 |
- #' ui <- fluidPage(+ #' teal_slices( |
||
| 46 |
- #' useShinyjs(),+ #' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE) |
||
| 47 |
- #' include_css_files(pattern = "filter-panel"),+ #' ) |
||
| 48 |
- #' include_js_files(pattern = "count-bar-labels"),+ #' ) |
||
| 49 |
- #' column(4, tags$div(+ #' |
||
| 50 |
- #' tags$h4("Active filters"),
+ #' # remove specific filters |
||
| 51 |
- #' filter_states_df$ui_active("fsdf")
+ #' remove_filter_state( |
||
| 52 |
- #' )),+ #' datasets, |
||
| 53 |
- #' column(4, tags$div(+ #' teal_slices( |
||
| 54 |
- #' tags$h4("Manual filter control"),
+ #' teal_slice(dataname = "iris", varname = "Species"), |
||
| 55 |
- #' filter_states_df$ui_add("add_filters"), tags$br(),
+ #' teal_slice(dataname = "mtcars", varname = "gear"), |
||
| 56 |
- #' tags$h4("Condition (i.e. call)"), # display the subset expression generated by this FilterStates
+ #' teal_slice(dataname = "mtcars", varname = "carb") |
||
| 57 |
- #' textOutput("call_df"), tags$br(),
+ #' ) |
||
| 58 |
- #' tags$h4("Formatted state"), # display human readable filter state
+ #' ) |
||
| 59 |
- #' textOutput("formatted_df"), tags$br()
+ #' |
||
| 60 |
- #' )),+ #' # remove all states |
||
| 61 |
- #' column(4, tags$div(+ #' clear_filter_states(datasets) |
||
| 62 |
- #' tags$h4("Programmatic filter control"),
+ #' |
||
| 63 |
- #' actionButton("button1_df", "set NUM1 < 30", width = "100%"), tags$br(),
+ #' @examples |
||
| 64 |
- #' actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), tags$br(),
+ #' \donttest{
|
||
| 65 |
- #' actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"), tags$br(),
+ #' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
||
| 66 |
- #' actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), tags$br(),
+ #' # Requires MultiAssayExperiment from Bioconductor |
||
| 67 |
- #' actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), tags$br(),
+ #' data(miniACC, package = "MultiAssayExperiment") |
||
| 68 |
- #' actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), tags$br(),
+ #' |
||
| 69 |
- #' tags$hr(),+ #' datasets <- init_filtered_data(list(mae = miniACC)) |
||
| 70 |
- #' actionButton("button7_df", "remove NUM1", width = "100%"), tags$br(),
+ #' fs <- teal_slices( |
||
| 71 |
- #' actionButton("button8_df", "remove NUM2", width = "100%"), tags$br(),
+ #' teal_slice( |
||
| 72 |
- #' actionButton("button9_df", "remove CHAR1", width = "100%"), tags$br(),
+ #' dataname = "mae", varname = "years_to_birth", selected = c(30, 50), |
||
| 73 |
- #' actionButton("button10_df", "remove CHAR2", width = "100%"), tags$br(),
+ #' keep_na = TRUE, keep_inf = FALSE |
||
| 74 |
- #' actionButton("button11_df", "remove DATE", width = "100%"), tags$br(),
+ #' ), |
||
| 75 |
- #' actionButton("button12_df", "remove DATETIME", width = "100%"), tags$br(),
+ #' teal_slice( |
||
| 76 |
- #' tags$hr(),+ #' dataname = "mae", varname = "vital_status", selected = "1", |
||
| 77 |
- #' actionButton("button0_df", "clear all filters", width = "100%"), tags$br()
+ #' keep_na = FALSE |
||
| 78 |
- #' ))+ #' ), |
||
| 79 |
- #' )+ #' teal_slice( |
||
| 80 |
- #'+ #' dataname = "mae", varname = "gender", selected = "female", |
||
| 81 |
- #' server <- function(input, output, session) {
+ #' keep_na = TRUE |
||
| 82 |
- #' filter_states_df$srv_add("add_filters")
+ #' ), |
||
| 83 |
- #' filter_states_df$srv_active("fsdf")
+ #' teal_slice( |
||
| 84 |
- #'+ #' dataname = "mae", varname = "ARRAY_TYPE", selected = "", |
||
| 85 |
- #' output$call_df <- renderPrint(filter_states_df$get_call())+ #' keep_na = TRUE, experiment = "RPPAArray", arg = "subset" |
||
| 86 |
- #' output$formatted_df <- renderText(filter_states_df$format())+ #' ) |
||
| 87 |
- #'+ #' ) |
||
| 88 |
- #' observeEvent(input$button1_df, {
+ #' |
||
| 89 |
- #' filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30)))
+ #' # set initial filter state |
||
| 90 |
- #' filter_states_df$set_filter_state(state = filter_state)+ #' set_filter_state(datasets, filter = fs) |
||
| 91 |
- #' })+ #' |
||
| 92 |
- #' observeEvent(input$button2_df, {
+ #' # get filter state |
||
| 93 |
- #' filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21)))
+ #' get_filter_state(datasets) |
||
| 94 |
- #' filter_states_df$set_filter_state(state = filter_state)+ #' |
||
| 95 |
- #' })+ #' # modify filter state |
||
| 96 |
- #' observeEvent(input$button3_df, {
+ #' set_filter_state( |
||
| 97 |
- #' filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D")))
+ #' datasets, |
||
| 98 |
- #' filter_states_df$set_filter_state(state = filter_state)+ #' teal_slices( |
||
| 99 |
- #' })+ #' teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(40, 60)) |
||
| 100 |
- #' observeEvent(input$button4_df, {
+ #' ) |
||
| 101 |
- #' filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F")))
+ #' ) |
||
| 102 |
- #' filter_states_df$set_filter_state(state = filter_state)+ #' |
||
| 103 |
- #' })+ #' # remove specific filters |
||
| 104 |
- #' observeEvent(input$button5_df, {
+ #' remove_filter_state( |
||
| 105 |
- #' filter_state <- teal_slices(+ #' datasets, |
||
| 106 |
- #' teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02"))
+ #' teal_slices( |
||
| 107 |
- #' )+ #' teal_slice(dataname = "mae", varname = "years_to_birth"), |
||
| 108 |
- #' filter_states_df$set_filter_state(state = filter_state)+ #' teal_slice(dataname = "mae", varname = "vital_status") |
||
| 109 |
- #' })+ #' ) |
||
| 110 |
- #' observeEvent(input$button6_df, {
+ #' ) |
||
| 111 |
- #' filter_state <- teal_slices(+ #' |
||
| 112 |
- #' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
+ #' # remove all states |
||
| 113 |
- #' )+ #' clear_filter_states(datasets) |
||
| 114 |
- #' filter_states_df$set_filter_state(state = filter_state)+ #' } |
||
| 115 |
- #' })+ #' } |
||
| 116 |
- #'+ NULL |
||
| 117 |
- #' observeEvent(input$button7_df, {
+
|
||
| 118 |
- #' filter_state <- teal_slices(teal_slice("dataset", "NUM1"))
+ #' @rdname filter_state_api |
||
| 119 |
- #' filter_states_df$remove_filter_state(filter_state)+ #' @export |
||
| 120 |
- #' })+ set_filter_state <- function(datasets, filter) {
|
||
| 121 | -+ | 3x |
- #' observeEvent(input$button8_df, {
+ checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
|
| 122 | -+ | 3x |
- #' filter_state <- teal_slices(teal_slice("dataset", "NUM2"))
+ checkmate::assert_class(filter, "teal_slices") |
| 123 | -+ | 3x |
- #' filter_states_df$remove_filter_state(filter_state)+ datasets$set_filter_state(filter) |
| 124 | -+ | 3x |
- #' })+ invisible(NULL) |
| 125 |
- #' observeEvent(input$button9_df, {
+ } |
||
| 126 |
- #' filter_state <- teal_slices(teal_slice("dataset", "CHAR1"))
+
|
||
| 127 |
- #' filter_states_df$remove_filter_state(filter_state)+ #' @rdname filter_state_api |
||
| 128 |
- #' })+ #' @export |
||
| 129 |
- #' observeEvent(input$button10_df, {
+ get_filter_state <- function(datasets) {
+ |
+ ||
| 130 | +4x | +
+ checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ |
+ |
| 131 | +4x | +
+ if (isRunning()) {
+ |
+ |
| 132 | +! | +
+ datasets$get_filter_state()+ |
+ |
| 133 | ++ |
+ } else {
+ |
+ |
| 134 | +4x | +
+ isolate(datasets$get_filter_state())+ |
+ |
| 135 | ++ |
+ }+ |
+ |
| 136 | ++ |
+ }+ |
+ |
| 137 | ++ | + + | +|
| 138 | ++ |
+ #' @rdname filter_state_api+ |
+ |
| 139 | ++ |
+ #' @export+ |
+ |
| 140 | ++ |
+ remove_filter_state <- function(datasets, filter) {
+ |
+ |
| 141 | +1x | +
+ checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ |
+ |
| 142 | +1x | +
+ checkmate::assert_class(filter, "teal_slices")+ |
+ |
| 143 | ++ | + + | +|
| 144 | +1x | +
+ datasets$remove_filter_state(filter)+ |
+ |
| 145 | +1x | +
+ invisible(NULL)+ |
+ |
| 146 | ++ |
+ }+ |
+ |
| 147 | ++ | + + | +|
| 148 | ++ |
+ #' @rdname filter_state_api+ |
+ |
| 149 | ++ |
+ #' @export+ |
+ |
| 150 | ++ |
+ clear_filter_states <- function(datasets, force = FALSE) {
+ |
+ |
| 151 | +1x | +
+ checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ |
+ |
| 152 | +1x | +
+ datasets$clear_filter_states(force = force)+ |
+ |
| 153 | +1x | +
+ invisible(NULL)+ |
+ |
| 154 | ++ |
+ }+ |
+ |
| 155 | ++ | + | |
| 130 | +156 |
- #' filter_state <- teal_slices(teal_slice("dataset", "CHAR2"))
+ #' Gets filter expression for multiple `datanames` taking into account its order. |
|
| 131 | +157 |
- #' filter_states_df$remove_filter_state(filter_state)+ #' |
|
| 132 | +158 |
- #' })+ #' @description `r lifecycle::badge("stable")`
|
|
| 133 | +159 |
- #' observeEvent(input$button11_df, {
+ #' |
|
| 134 | +160 |
- #' filter_state <- teal_slices(+ #' To be used in `Show R Code` button. |
|
| 135 | +161 |
- #' teal_slice("dataset", "DATE")
+ #' |
|
| 136 | +162 |
- #' )+ #' @param datasets (`FilteredData`) |
|
| 137 | +163 |
- #' filter_states_df$remove_filter_state(filter_state)+ #' @param datanames (`character`) vector of dataset names |
|
| 138 | +164 |
- #' })+ #' |
|
| 139 | +165 |
- #' observeEvent(input$button12_df, {
+ #' @return A character string containing all subset expressions. |
|
| 140 | +166 |
- #' filter_state <- teal_slices(+ #' |
|
| 141 | +167 |
- #' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
+ #' @export |
|
| 142 | +168 |
- #' )+ #' |
|
| 143 | +169 |
- #' filter_states_df$remove_filter_state(filter_state)+ get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
|
|
| 144 | -+ | ||
| 170 | +2x |
- #' })+ checkmate::assert_character(datanames, min.len = 1, any.missing = FALSE) |
|
| 145 | -+ | ||
| 171 | +2x |
- #'+ stopifnot( |
|
| 146 | -+ | ||
| 172 | +2x |
- #' observeEvent(input$button0_df, filter_states_df$clear_filter_states())+ is(datasets, "FilteredData"), |
|
| 147 | -+ | ||
| 173 | +2x |
- #' }+ all(datanames %in% datasets$datanames()) |
|
| 148 | +174 |
- #'+ ) |
|
| 149 | +175 |
- #' if (interactive()) {
+
|
|
| 150 | -+ | ||
| 176 | +2x |
- #' shinyApp(ui, server)+ paste( |
|
| 151 | -+ | ||
| 177 | +2x |
- #' }+ unlist(lapply( |
|
| 152 | -+ | ||
| 178 | +2x |
- #' @keywords internal+ datanames, |
|
| 153 | -+ | ||
| 179 | +2x |
- #'+ function(dataname) {
|
|
| 154 | -+ | ||
| 180 | +4x |
- DFFilterStates <- R6::R6Class( # nolint+ datasets$get_call(dataname) |
|
| 155 | +181 |
- classname = "DFFilterStates",+ } |
|
| 156 | +182 |
- inherit = FilterStates,+ )), |
|
| 157 | -+ | ||
| 183 | +2x |
-
+ collapse = "\n" |
|
| 158 | +184 |
- # public methods ----+ ) |
|
| 159 | +185 |
- public = list(+ } |
| 160 | +1 |
- #' @description+ #' Compose predicates |
||
| 161 | +2 |
- #' Initializes `DFFilterStates` object by setting `dataname`+ #' |
||
| 162 | +3 |
- #' and initializing `state_list` (`shiny::reactiveVal`).+ #' Combines calls with a logical operator. |
||
| 163 | +4 |
- #' This class contains a single `state_list` with no specified name,+ #' |
||
| 164 | +5 |
- #' which means that when calling the subset function associated with this class+ #' This function is used to combine logical predicates produced by `FilterState` objects |
||
| 165 | +6 |
- #' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`).+ #' to build a complete subset expression. |
||
| 166 | +7 |
- #'+ #' |
||
| 167 | +8 |
- #' @param data (`data.frame`)+ #' @param calls (`list`) |
||
| 168 | +9 |
- #' the `R` object which `dplyr::filter` function will be applied on.+ #' containing calls (or symbols) to be combined by `operator` |
||
| 169 | +10 |
- #' @param data_reactive (`function(sid)`)+ #' @param operator (`character(1)`) |
||
| 170 | +11 |
- #' should return a `data.frame` object or `NULL`.+ #' infix operator to use in predicate composition, _e.g._ `"&"` |
||
| 171 | +12 |
- #' This object is needed for the `FilterState` counts being updated on a change in filters.+ #' |
||
| 172 | +13 |
- #' If function returns `NULL` then filtered counts are not shown.+ #' @return |
||
| 173 | +14 |
- #' Function has to have `sid` argument being a character.+ #' A `call` where elements of `calls` are composed with `operator` or `NULL` if `calls` is an empty list. |
||
| 174 | +15 |
- #' @param dataname (`character`)+ #' |
||
| 175 | +16 |
- #' name of the data used in the *subset expression*.+ #' @examples |
||
| 176 | +17 |
- #' Passed to the function argument attached to this `FilterStates`.+ #' # use non-exported function from teal.slice |
||
| 177 | +18 |
- #' @param datalabel (`character(1)`) optional+ #' calls_combine_by <- getFromNamespace("calls_combine_by", "teal.slice")
|
||
| 178 | +19 |
- #' text label.+ #' |
||
| 179 | +20 |
- #' @param keys (`character`)+ #' calls <- list( |
||
| 180 | +21 |
- #' key column names.+ #' quote(SEX == "F"), # subsetting on factor |
||
| 181 | +22 |
- #'+ #' quote(AGE >= 20 & AGE <= 50), # subsetting on range |
||
| 182 | +23 |
- initialize = function(data,+ #' quote(!SURV) # subsetting on logical |
||
| 183 | +24 |
- data_reactive = function(sid = "") NULL,+ #' ) |
||
| 184 | +25 |
- dataname,+ #' calls_combine_by(calls, "&") |
||
| 185 | +26 |
- datalabel = NULL,+ #' |
||
| 186 | +27 |
- keys = character(0)) {
+ #' @keywords internal |
||
| 187 | -103x | +|||
| 28 | +
- checkmate::assert_function(data_reactive, args = "sid")+ #' |
|||
| 188 | -103x | +|||
| 29 | +
- checkmate::assert_data_frame(data)+ calls_combine_by <- function(calls, operator) {
|
|||
| 189 | -103x | +30 | +47x |
- super$initialize(data, data_reactive, dataname, datalabel)+ checkmate::assert_list(calls) |
| 190 | -103x | +31 | +45x |
- private$keys <- keys+ if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
|
| 191 | -103x | -
- private$set_filterable_varnames(include_varnames = colnames(private$data))- |
- ||
| 192 | -- |
- }- |
- ||
| 193 | -+ | 32 | +46x |
- ),+ checkmate::assert_string(operator) |
| 194 | +33 | |||
| 195 | -+ | |||
| 34 | +44x |
- # private members ----+ Reduce( |
||
| 196 | -+ | |||
| 35 | +44x |
- private = list(+ x = calls, |
||
| 197 | -+ | |||
| 36 | +44x |
- fun = quote(dplyr::filter)+ f = function(x, y) call(operator, x, y) |
||
| 198 | +37 |
) |
||
| 199 | +38 |
- )+ } |
| 1 |
- # DefaultFilteredDataset ----+ # DFFilterStates ------ |
||
| 3 |
- #' @name DefaultFilteredDataset+ #' @name DFFilterStates |
||
| 5 |
- #' @title `DefaultFilteredDataset` `R6` class+ #' |
||
| 6 |
- #'+ #' @title `FilterStates` subclass for data frames |
||
| 7 |
- #' @description Stores any object as inert entity. Filtering is not supported.+ #' |
||
| 8 |
- #'+ #' @description Handles filter states in a `data.frame`. |
||
| 9 |
- #' @examples+ #' |
||
| 10 |
- #' # use non-exported function from teal.slice+ #' @examples |
||
| 11 |
- #' DefaultFilteredDataset <- getFromNamespace("DefaultFilteredDataset", "teal.slice")
+ #' # use non-exported function from teal.slice |
||
| 12 |
- #'+ #' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
||
| 13 |
- #' library(shiny)+ #' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
||
| 14 |
- #'+ #' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
|
||
| 15 |
- #' ds <- DefaultFilteredDataset$new(letters, "letters")+ #' |
||
| 16 |
- #' isolate(ds$get_filter_state())+ #' library(shiny) |
||
| 17 |
- #' isolate(ds$get_call())+ #' library(shinyjs) |
||
| 19 |
- #' @keywords internal+ #' # create data frame to filter |
||
| 20 |
- #'+ #' data_df <- data.frame( |
||
| 21 |
- DefaultFilteredDataset <- R6::R6Class( # nolint+ #' NUM1 = 1:100, |
||
| 22 |
- classname = "DefaultFilteredDataset",+ #' NUM2 = round(runif(100, min = 20, max = 23)), |
||
| 23 |
- inherit = FilteredDataset,+ #' CHAR1 = sample(LETTERS[1:6], size = 100, replace = TRUE), |
||
| 24 |
-
+ #' CHAR2 = sample(c("M", "F"), size = 100, replace = TRUE),
|
||
| 25 |
- # public methods ----+ #' DATE = seq(as.Date("2020-01-01"), by = 1, length.out = 100),
|
||
| 26 |
- public = list(+ #' DATETIME = as.POSIXct(seq(as.Date("2020-01-01"), by = 1, length.out = 100))
|
||
| 27 |
-
+ #' ) |
||
| 28 |
- #' @description+ #' data_na <- data.frame( |
||
| 29 |
- #' Initializes this `DefaultFilteredDataset` object.+ #' NUM1 = NA, |
||
| 30 |
- #'+ #' NUM2 = NA, |
||
| 31 |
- #' @param dataset+ #' CHAR1 = NA, |
||
| 32 |
- #' any type of object; will not be filtered.+ #' CHAR2 = NA, |
||
| 33 |
- #' @param dataname (`character(1)`)+ #' DATE = NA, |
||
| 34 |
- #' syntactically valid name given to the dataset.+ #' DATETIME = NA |
||
| 35 |
- #' @param label (`character(1)`)+ #' ) |
||
| 36 |
- #' label to describe the dataset.+ #' data_df <- rbind(data_df, data_na) |
||
| 37 |
- #'+ #' |
||
| 38 |
- #' @return Object of class `DefaultFilteredDataset`, invisibly.+ #' # initiate `FilterStates` object |
||
| 39 |
- #'+ #' filter_states_df <- init_filter_states( |
||
| 40 |
- initialize = function(dataset, dataname, label = character(0)) {
+ #' data = data_df, |
||
| 41 | -24x | +
- super$initialize(dataset = dataset, dataname = dataname, label = label)+ #' dataname = "dataset", |
|
| 42 |
- },+ #' datalabel = ("label")
|
||
| 43 |
-
+ #' ) |
||
| 44 |
- #' @description+ #' |
||
| 45 |
- #' Returns a formatted string representing this `DefaultFilteredDataset` object.+ #' ui <- fluidPage( |
||
| 46 |
- #'+ #' useShinyjs(), |
||
| 47 |
- #' @param show_all (`logical(1)`) for method consistency, ignored.+ #' include_css_files(pattern = "filter-panel"), |
||
| 48 |
- #' @param trim_lines (`logical(1)`) flag specifying whether to trim lines if class names are too long.+ #' include_js_files(pattern = "count-bar-labels"), |
||
| 49 |
- #'+ #' column(4, tags$div( |
||
| 50 |
- #' @return The formatted string.+ #' tags$h4("Active filters"),
|
||
| 51 |
- #'+ #' filter_states_df$ui_active("fsdf")
|
||
| 52 |
- format = function(show_all, trim_lines = FALSE) {
+ #' )), |
||
| 53 | -4x | +
- class_string <- toString(class(private$dataset))+ #' column(4, tags$div( |
|
| 54 | -4x | +
- if (trim_lines) {
+ #' tags$h4("Manual filter control"),
|
|
| 55 | -2x | +
- trim_position <- 37L+ #' filter_states_df$ui_add("add_filters"), tags$br(),
|
|
| 56 | -2x | +
- class_string <- strtrim(class_string, trim_position)+ #' tags$h4("Condition (i.e. call)"), # display the subset expression generated by this FilterStates
|
|
| 57 | -2x | +
- substr(class_string, 35L, 37L) <- "..."+ #' textOutput("call_df"), tags$br(),
|
|
| 58 |
- }+ #' tags$h4("Formatted state"), # display human readable filter state
|
||
| 59 | -4x | +
- sprintf(" - unfiltered dataset:\t\"%s\": %s", private$dataname, class_string)
+ #' textOutput("formatted_df"), tags$br()
|
|
| 60 |
- },+ #' )), |
||
| 61 |
-
+ #' column(4, tags$div( |
||
| 62 |
- #' @param sid (`character(1)`) for method consistency, ignored.+ #' tags$h4("Programmatic filter control"),
|
||
| 63 |
- #' @return `NULL`, invisibly.+ #' actionButton("button1_df", "set NUM1 < 30", width = "100%"), tags$br(),
|
||
| 64 |
- get_call = function(sid) {
+ #' actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), tags$br(),
|
||
| 65 | -1x | +
- invisible(NULL)+ #' actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"), tags$br(),
|
|
| 66 |
- },+ #' actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), tags$br(),
|
||
| 67 |
- #' @return `NULL`, invisibly.+ #' actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), tags$br(),
|
||
| 68 |
- get_filter_state = function() {
+ #' actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), tags$br(),
|
||
| 69 | -2x | +
- invisible(NULL)+ #' tags$hr(), |
|
| 70 |
- },+ #' actionButton("button7_df", "remove NUM1", width = "100%"), tags$br(),
|
||
| 71 |
- #' @param state (`teal_slices`) for method consistency, ignored.+ #' actionButton("button8_df", "remove NUM2", width = "100%"), tags$br(),
|
||
| 72 |
- #' @return `NULL`, invisibly.+ #' actionButton("button9_df", "remove CHAR1", width = "100%"), tags$br(),
|
||
| 73 |
- set_filter_state = function(state) {
+ #' actionButton("button10_df", "remove CHAR2", width = "100%"), tags$br(),
|
||
| 74 | -3x | +
- if (length(state) != 0L) {
+ #' actionButton("button11_df", "remove DATE", width = "100%"), tags$br(),
|
|
| 75 | -1x | +
- warning("DefaultFilterState cannot set state")
+ #' actionButton("button12_df", "remove DATETIME", width = "100%"), tags$br(),
|
|
| 76 |
- }+ #' tags$hr(), |
||
| 77 | -3x | +
- invisible(NULL)+ #' actionButton("button0_df", "clear all filters", width = "100%"), tags$br()
|
|
| 78 |
- },+ #' )) |
||
| 79 |
- #' @param force (`logical(1)`) for method consistency, ignored.+ #' ) |
||
| 80 |
- #' @return `NULL`, invisibly.+ #' |
||
| 81 |
- clear_filter_states = function(force) {
+ #' server <- function(input, output, session) {
|
||
| 82 | -1x | +
- invisible(NULL)+ #' filter_states_df$srv_add("add_filters")
|
|
| 83 |
- },+ #' filter_states_df$srv_active("fsdf")
|
||
| 84 |
-
+ #' |
||
| 85 |
- #' @description+ #' output$call_df <- renderPrint(filter_states_df$get_call()) |
||
| 86 |
- #' Creates row for filter overview in the form of \cr+ #' output$formatted_df <- renderText(filter_states_df$format()) |
||
| 87 |
- #' `dataname` - unsupported data class+ #' |
||
| 88 |
- #' @return A `data.frame`.+ #' observeEvent(input$button1_df, {
|
||
| 89 |
- get_filter_overview = function() {
+ #' filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30)))
|
||
| 90 | -1x | +
- data.frame(dataname = private$dataname, obs = NA, obs_filtered = NA)+ #' filter_states_df$set_filter_state(state = filter_state) |
|
| 91 |
- },+ #' }) |
||
| 92 |
-
+ #' observeEvent(input$button2_df, {
|
||
| 93 |
- # shiny modules ----+ #' filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21)))
|
||
| 94 |
-
+ #' filter_states_df$set_filter_state(state = filter_state) |
||
| 95 |
- #' @description+ #' }) |
||
| 96 |
- #' Overwrites parent method.+ #' observeEvent(input$button3_df, {
|
||
| 97 |
- #' @details+ #' filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D")))
|
||
| 98 |
- #' Blank UI module that would list active filter states for this dataset.+ #' filter_states_df$set_filter_state(state = filter_state) |
||
| 99 |
- #' @param id (`character(1)`)+ #' }) |
||
| 100 |
- #' `shiny` module instance id.+ #' observeEvent(input$button4_df, {
|
||
| 101 |
- #' @return An empty `div`.+ #' filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F")))
|
||
| 102 |
- ui_active = function(id) {
+ #' filter_states_df$set_filter_state(state = filter_state) |
||
| 103 | -! | +
- ns <- NS(id)+ #' }) |
|
| 104 | -! | +
- tags$div()+ #' observeEvent(input$button5_df, {
|
|
| 105 |
- },+ #' filter_state <- teal_slices( |
||
| 106 |
-
+ #' teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02"))
|
||
| 107 |
- #' @description+ #' ) |
||
| 108 |
- #' Overwrites parent method.+ #' filter_states_df$set_filter_state(state = filter_state) |
||
| 109 |
- #' @details+ #' }) |
||
| 110 |
- #' Blank UI module that would list active filter states for this dataset.+ #' observeEvent(input$button6_df, {
|
||
| 111 |
- #' @param id (`character(1)`)+ #' filter_state <- teal_slices( |
||
| 112 |
- #' `shiny` module instance id.+ #' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
|
||
| 113 |
- #' @return An empty `div`.+ #' ) |
||
| 114 |
- ui_add = function(id) {
+ #' filter_states_df$set_filter_state(state = filter_state) |
||
| 115 | -! | +
- ns <- NS(id)+ #' }) |
|
| 116 | -! | +
- tags$div()+ #' |
|
| 117 |
- }+ #' observeEvent(input$button7_df, {
|
||
| 118 |
- ),+ #' filter_state <- teal_slices(teal_slice("dataset", "NUM1"))
|
||
| 119 |
- private = list(+ #' filter_states_df$remove_filter_state(filter_state) |
||
| 120 |
- # private methods ----+ #' }) |
||
| 121 |
- # private fields ----+ #' observeEvent(input$button8_df, {
|
||
| 122 |
- )+ #' filter_state <- teal_slices(teal_slice("dataset", "NUM2"))
|
||
| 123 |
- )+ #' filter_states_df$remove_filter_state(filter_state) |
| 1 | +124 |
- #' Test whether variable name can be used within `Show R Code`+ #' }) |
|
| 2 | +125 |
- #'+ #' observeEvent(input$button9_df, {
|
|
| 3 | +126 |
- #' Variable names containing spaces are problematic and must be wrapped in backticks.+ #' filter_state <- teal_slices(teal_slice("dataset", "CHAR1"))
|
|
| 4 | +127 |
- #' Also, they should not start with a number as `R` may silently make it valid by changing it.+ #' filter_states_df$remove_filter_state(filter_state) |
|
| 5 | +128 |
- #' Therefore, we only allow alphanumeric characters with underscores.+ #' }) |
|
| 6 | +129 |
- #' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters.+ #' observeEvent(input$button10_df, {
|
|
| 7 | +130 |
- #'+ #' filter_state <- teal_slices(teal_slice("dataset", "CHAR2"))
|
|
| 8 | +131 |
- #' @md+ #' filter_states_df$remove_filter_state(filter_state) |
|
| 9 | +132 |
- #'+ #' }) |
|
| 10 | +133 |
- #' @param name (`character`) vector of names to check+ #' observeEvent(input$button11_df, {
|
|
| 11 | +134 |
- #' @return Returns `NULL` or raises error.+ #' filter_state <- teal_slices( |
|
| 12 | +135 |
- #' @keywords internal+ #' teal_slice("dataset", "DATE")
|
|
| 13 | +136 |
- #'+ #' ) |
|
| 14 | +137 |
- check_simple_name <- function(name) {
+ #' filter_states_df$remove_filter_state(filter_state) |
|
| 15 | -273x | +||
| 138 | +
- checkmate::assert_character(name, min.len = 1, any.missing = FALSE)+ #' }) |
||
| 16 | -271x | +||
| 139 | +
- if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
+ #' observeEvent(input$button12_df, {
|
||
| 17 | -5x | +||
| 140 | +
- stop(+ #' filter_state <- teal_slices( |
||
| 18 | -5x | +||
| 141 | +
- "name '",+ #' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
|
||
| 19 | -5x | +||
| 142 | +
- name,+ #' ) |
||
| 20 | -5x | +||
| 143 | +
- "' must only contain alphanumeric characters (with underscores)",+ #' filter_states_df$remove_filter_state(filter_state) |
||
| 21 | -5x | +||
| 144 | +
- " and the first character must be an alphabetic character"+ #' }) |
||
| 22 | +145 |
- )+ #' |
|
| 23 | +146 |
- }+ #' observeEvent(input$button0_df, filter_states_df$clear_filter_states()) |
|
| 24 | +147 |
- }+ #' } |
|
| 25 | +148 |
-
+ #' |
|
| 26 | +149 |
- #' Include `JS` files from `/inst/js/` package directory to application header+ #' if (interactive()) {
|
|
| 27 | +150 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 151 | ++ |
+ #' }+ |
+ |
| 152 | ++ |
+ #' @keywords internal+ |
+ |
| 153 |
#' |
||
| 28 | +154 |
- #' `system.file` should not be used to access files in other packages, it does+ DFFilterStates <- R6::R6Class( # nolint |
|
| 29 | +155 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ classname = "DFFilterStates", |
|
| 30 | +156 |
- #' as needed. Thus, we do not export this method.+ inherit = FilterStates, |
|
| 31 | +157 |
- #'+ |
|
| 32 | +158 |
- #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ # public methods ---- |
|
| 33 | +159 |
- #'+ public = list( |
|
| 34 | +160 |
- #' @return HTML code that includes `JS` files+ #' @description |
|
| 35 | +161 |
- #' @keywords internal+ #' Initializes `DFFilterStates` object by setting `dataname` |
|
| 36 | +162 |
- include_js_files <- function(pattern) {
+ #' and initializing `state_list` (`shiny::reactiveVal`). |
|
| 37 | -12x | +||
| 163 | +
- checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE)+ #' This class contains a single `state_list` with no specified name, |
||
| 38 | -12x | +||
| 164 | +
- js_files <- list.files(+ #' which means that when calling the subset function associated with this class |
||
| 39 | -12x | +||
| 165 | +
- system.file("js", package = "teal.slice", mustWork = TRUE),
+ #' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`). |
||
| 40 | -12x | +||
| 166 | +
- pattern = pattern,+ #' |
||
| 41 | -12x | +||
| 167 | +
- full.names = TRUE+ #' @param data (`data.frame`) |
||
| 42 | +168 |
- )+ #' the `R` object which `dplyr::filter` function will be applied on. |
|
| 43 | -12x | +||
| 169 | +
- singleton(lapply(js_files, includeScript))+ #' @param data_reactive (`function(sid)`) |
||
| 44 | +170 |
- }+ #' should return a `data.frame` object or `NULL`. |
|
| 45 | +171 |
-
+ #' This object is needed for the `FilterState` counts being updated on a change in filters. |
|
| 46 | +172 |
- #' Build concatenating call+ #' If function returns `NULL` then filtered counts are not shown. |
|
| 47 | +173 |
- #'+ #' Function has to have `sid` argument being a character. |
|
| 48 | +174 |
- #' This function takes a vector of values and returns a `c` call. If the vector+ #' @param dataname (`character`) |
|
| 49 | +175 |
- #' has only one element, the element is returned directly.+ #' name of the data used in the *subset expression*. |
|
| 50 | +176 |
- #'+ #' Passed to the function argument attached to this `FilterStates`. |
|
| 51 | +177 |
- #' @param choices A vector of values.+ #' @param datalabel (`character(1)`) optional |
|
| 52 | +178 |
- #'+ #' text label. |
|
| 53 | +179 |
- #' @return A `c` call.+ #' @param keys (`character`) |
|
| 54 | +180 |
- #'+ #' key column names. |
|
| 55 | +181 |
- #' @examples+ #' |
|
| 56 | +182 |
- #' # use non-exported function from teal.slice+ initialize = function(data, |
|
| 57 | +183 |
- #' make_c_call <- getFromNamespace("make_c_call", "teal.slice")
+ data_reactive = function(sid = "") NULL, |
|
| 58 | +184 |
- #' make_c_call(1:3)+ dataname, |
|
| 59 | +185 |
- #' make_c_call(1)+ datalabel = NULL,+ |
+ |
| 186 | ++ |
+ keys = character(0)) {
+ |
+ |
| 187 | +103x | +
+ checkmate::assert_function(data_reactive, args = "sid")+ |
+ |
| 188 | +103x | +
+ checkmate::assert_data_frame(data)+ |
+ |
| 189 | +103x | +
+ super$initialize(data, data_reactive, dataname, datalabel)+ |
+ |
| 190 | +103x | +
+ private$keys <- keys+ |
+ |
| 191 | +103x | +
+ private$set_filterable_varnames(include_varnames = colnames(private$data)) |
|
| 60 | +192 |
- #'+ } |
|
| 61 | +193 |
- #' @keywords internal+ ), |
|
| 62 | +194 |
- make_c_call <- function(choices) {
- |
- |
| 63 | -53x | -
- if (length(choices) > 1) {
+
|
|
| 64 | -26x | +||
| 195 | +
- do.call("call", append(list("c"), choices))
+ # private members ---- |
||
| 65 | +196 |
- } else {
+ private = list( |
|
| 66 | -27x | +||
| 197 | +
- choices+ fun = quote(dplyr::filter) |
||
| 67 | +198 |
- }+ ) |
|
| 68 | +199 |
- }+ ) |
| 1 |
- #' Managing `FilteredData` states+ # DefaultFilteredDataset ---- |
||
| 2 |
- #'+ |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @name DefaultFilteredDataset |
||
| 4 |
- #'+ #' @docType class |
||
| 5 |
- #' Set, get and remove filter states of `FilteredData` object.+ #' @title `DefaultFilteredDataset` `R6` class |
||
| 7 |
- #' @name filter_state_api+ #' @description Stores any object as inert entity. Filtering is not supported. |
||
| 9 |
- #' @param datasets (`FilteredData`)+ #' @examples |
||
| 10 |
- #' object to store filter state and filtered datasets, shared across modules+ #' # use non-exported function from teal.slice |
||
| 11 |
- #'+ #' DefaultFilteredDataset <- getFromNamespace("DefaultFilteredDataset", "teal.slice")
|
||
| 12 |
- #' see [`FilteredData`] for details+ #' |
||
| 13 |
- #'+ #' library(shiny) |
||
| 14 |
- #' @param filter (`teal_slices`)+ #' |
||
| 15 |
- #' specify filters in place on app start-up+ #' ds <- DefaultFilteredDataset$new(letters, "letters") |
||
| 16 |
- #'+ #' isolate(ds$get_filter_state()) |
||
| 17 |
- #' @param force (`logical(1)`)+ #' isolate(ds$get_call()) |
||
| 18 |
- #' flag specifying whether to include anchored filter states.+ #' |
||
| 19 |
- #'+ #' @keywords internal |
||
| 20 |
- #' @return+ #' |
||
| 21 |
- #' - `set_*`, `remove_*` and `clear_filter_state` return `NULL` invisibly+ DefaultFilteredDataset <- R6::R6Class( # nolint |
||
| 22 |
- #' - `get_filter_state` returns a named `teal_slices` object+ classname = "DefaultFilteredDataset", |
||
| 23 |
- #' containing a `teal_slice` for every existing `FilterState`+ inherit = FilteredDataset, |
||
| 24 |
- #'+ |
||
| 25 |
- #' @seealso [`teal_slice`]+ # public methods ---- |
||
| 26 |
- #'+ public = list( |
||
| 27 |
- #' @examples+ |
||
| 28 |
- #' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars))+ #' @description |
||
| 29 |
- #' fs <- teal_slices(+ #' Initializes this `DefaultFilteredDataset` object. |
||
| 30 |
- #' teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor")),
+ #' |
||
| 31 |
- #' teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)),+ #' @param dataset |
||
| 32 |
- #' teal_slice(dataname = "mtcars", varname = "gear", selected = c(4, 5)),+ #' any type of object; will not be filtered. |
||
| 33 |
- #' teal_slice(dataname = "mtcars", varname = "carb", selected = c(4, 10))+ #' @param dataname (`character(1)`) |
||
| 34 |
- #' )+ #' syntactically valid name given to the dataset. |
||
| 35 |
- #'+ #' @param label (`character(1)`) |
||
| 36 |
- #' # set initial filter state+ #' label to describe the dataset. |
||
| 37 |
- #' set_filter_state(datasets, filter = fs)+ #' |
||
| 38 |
- #'+ #' @return Object of class `DefaultFilteredDataset`, invisibly. |
||
| 39 |
- #' # get filter state+ #' |
||
| 40 |
- #' get_filter_state(datasets)+ initialize = function(dataset, dataname, label = character(0)) {
|
||
| 41 | -+ | 24x |
- #'+ super$initialize(dataset = dataset, dataname = dataname, label = label) |
| 42 |
- #' # modify filter state+ }, |
||
| 43 |
- #' set_filter_state(+ |
||
| 44 |
- #' datasets,+ #' @description |
||
| 45 |
- #' teal_slices(+ #' Returns a formatted string representing this `DefaultFilteredDataset` object. |
||
| 46 |
- #' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)+ #' |
||
| 47 |
- #' )+ #' @param show_all (`logical(1)`) for method consistency, ignored. |
||
| 48 |
- #' )+ #' @param trim_lines (`logical(1)`) flag specifying whether to trim lines if class names are too long. |
||
| 49 |
- #'+ #' |
||
| 50 |
- #' # remove specific filters+ #' @return The formatted string. |
||
| 51 |
- #' remove_filter_state(+ #' |
||
| 52 |
- #' datasets,+ format = function(show_all, trim_lines = FALSE) {
|
||
| 53 | -+ | 4x |
- #' teal_slices(+ class_string <- toString(class(private$dataset)) |
| 54 | -+ | 4x |
- #' teal_slice(dataname = "iris", varname = "Species"),+ if (trim_lines) {
|
| 55 | -+ | 2x |
- #' teal_slice(dataname = "mtcars", varname = "gear"),+ trim_position <- 37L |
| 56 | -+ | 2x |
- #' teal_slice(dataname = "mtcars", varname = "carb")+ class_string <- strtrim(class_string, trim_position) |
| 57 | -+ | 2x |
- #' )+ substr(class_string, 35L, 37L) <- "..." |
| 58 |
- #' )+ } |
||
| 59 | -+ | 4x |
- #'+ sprintf(" - unfiltered dataset:\t\"%s\": %s", private$dataname, class_string)
|
| 60 |
- #' # remove all states+ }, |
||
| 61 |
- #' clear_filter_states(datasets)+ |
||
| 62 |
- #'+ #' @param sid (`character(1)`) for method consistency, ignored. |
||
| 63 |
- #' @examples+ #' @return `NULL`, invisibly. |
||
| 64 |
- #' \donttest{
+ get_call = function(sid) {
|
||
| 65 | -+ | 1x |
- #' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ invisible(NULL) |
| 66 |
- #' # Requires MultiAssayExperiment from Bioconductor+ }, |
||
| 67 |
- #' data(miniACC, package = "MultiAssayExperiment")+ #' @return `NULL`, invisibly. |
||
| 68 |
- #'+ get_filter_state = function() {
|
||
| 69 | -+ | 2x |
- #' datasets <- init_filtered_data(list(mae = miniACC))+ invisible(NULL) |
| 70 |
- #' fs <- teal_slices(+ }, |
||
| 71 |
- #' teal_slice(+ #' @param state (`teal_slices`) for method consistency, ignored. |
||
| 72 |
- #' dataname = "mae", varname = "years_to_birth", selected = c(30, 50),+ #' @return `NULL`, invisibly. |
||
| 73 |
- #' keep_na = TRUE, keep_inf = FALSE+ set_filter_state = function(state) {
|
||
| 74 | -+ | 3x |
- #' ),+ if (length(state) != 0L) {
|
| 75 | -+ | 1x |
- #' teal_slice(+ warning("DefaultFilterState cannot set state")
|
| 76 |
- #' dataname = "mae", varname = "vital_status", selected = "1",+ } |
||
| 77 | -+ | 3x |
- #' keep_na = FALSE+ invisible(NULL) |
| 78 |
- #' ),+ }, |
||
| 79 |
- #' teal_slice(+ #' @param force (`logical(1)`) for method consistency, ignored. |
||
| 80 |
- #' dataname = "mae", varname = "gender", selected = "female",+ #' @return `NULL`, invisibly. |
||
| 81 |
- #' keep_na = TRUE+ clear_filter_states = function(force) {
|
||
| 82 | -+ | 1x |
- #' ),+ invisible(NULL) |
| 83 |
- #' teal_slice(+ }, |
||
| 84 |
- #' dataname = "mae", varname = "ARRAY_TYPE", selected = "",+ |
||
| 85 |
- #' keep_na = TRUE, experiment = "RPPAArray", arg = "subset"+ #' @description |
||
| 86 |
- #' )+ #' Creates row for filter overview in the form of \cr |
||
| 87 |
- #' )+ #' `dataname` - unsupported data class |
||
| 88 |
- #'+ #' @return A `data.frame`. |
||
| 89 |
- #' # set initial filter state+ get_filter_overview = function() {
|
||
| 90 | -+ | 1x |
- #' set_filter_state(datasets, filter = fs)+ data.frame(dataname = private$dataname, obs = NA, obs_filtered = NA) |
| 91 |
- #'+ }, |
||
| 92 |
- #' # get filter state+ |
||
| 93 |
- #' get_filter_state(datasets)+ # shiny modules ---- |
||
| 94 |
- #'+ |
||
| 95 |
- #' # modify filter state+ #' @description |
||
| 96 |
- #' set_filter_state(+ #' Overwrites parent method. |
||
| 97 |
- #' datasets,+ #' @details |
||
| 98 |
- #' teal_slices(+ #' Blank UI module that would list active filter states for this dataset. |
||
| 99 |
- #' teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(40, 60))+ #' @param id (`character(1)`) |
||
| 100 |
- #' )+ #' `shiny` module instance id. |
||
| 101 |
- #' )+ #' @return An empty `div`. |
||
| 102 |
- #'+ ui_active = function(id) {
|
||
| 103 | -+ | ! |
- #' # remove specific filters+ ns <- NS(id) |
| 104 | -+ | ! |
- #' remove_filter_state(+ tags$div() |
| 105 |
- #' datasets,+ }, |
||
| 106 |
- #' teal_slices(+ |
||
| 107 |
- #' teal_slice(dataname = "mae", varname = "years_to_birth"),+ #' @description |
||
| 108 |
- #' teal_slice(dataname = "mae", varname = "vital_status")+ #' Overwrites parent method. |
||
| 109 |
- #' )+ #' @details |
||
| 110 |
- #' )+ #' Blank UI module that would list active filter states for this dataset. |
||
| 111 |
- #'+ #' @param id (`character(1)`) |
||
| 112 |
- #' # remove all states+ #' `shiny` module instance id. |
||
| 113 |
- #' clear_filter_states(datasets)+ #' @return An empty `div`. |
||
| 114 |
- #' }+ ui_add = function(id) {
|
||
| 115 | -+ | ! |
- #' }+ ns <- NS(id) |
| 116 | -+ | ! |
- NULL+ tags$div() |
| 117 |
-
+ } |
||
| 118 |
- #' @rdname filter_state_api+ ), |
||
| 119 |
- #' @export+ private = list( |
||
| 120 |
- set_filter_state <- function(datasets, filter) {
+ # private methods ---- |
||
| 121 | -3x | +
- checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ # private fields ---- |
|
| 122 | -3x | +
- checkmate::assert_class(filter, "teal_slices")+ ) |
|
| 123 | -3x | -
- datasets$set_filter_state(filter)- |
- |
| 124 | -3x | +
- invisible(NULL)+ ) |
| 125 | +1 |
- }+ #' Include `CSS` files from `/inst/css/` package directory to application header |
|
| 126 | +2 |
-
+ #' |
|
| 127 | +3 |
- #' @rdname filter_state_api+ #' `system.file` should not be used to access files in other packages, it does |
|
| 128 | +4 |
- #' @export+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 129 | +5 |
- get_filter_state <- function(datasets) {
- |
- |
| 130 | -4x | -
- checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ #' as needed. Thus, we do not export this method. |
|
| 131 | -4x | +||
| 6 | +
- if (isRunning()) {
+ #' |
||
| 132 | -! | +||
| 7 | +
- datasets$get_filter_state()+ #' @param pattern (`character`) pattern of files to be included |
||
| 133 | +8 |
- } else {
+ #' |
|
| 134 | -4x | +||
| 9 | +
- isolate(datasets$get_filter_state())+ #' @return HTML code that includes `CSS` files |
||
| 135 | +10 |
- }+ #' @keywords internal |
|
| 136 | +11 |
- }+ include_css_files <- function(pattern = "*") {
|
|
| 137 | -+ | ||
| 12 | +! |
-
+ css_files <- list.files( |
|
| 138 | -+ | ||
| 13 | +! |
- #' @rdname filter_state_api+ system.file("css", package = "teal.slice", mustWork = TRUE),
|
|
| 139 | -+ | ||
| 14 | +! |
- #' @export+ pattern = pattern, full.names = TRUE |
|
| 140 | +15 |
- remove_filter_state <- function(datasets, filter) {
+ ) |
|
| 141 | -1x | +||
| 16 | +! |
- checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ singleton(tags$head(lapply(css_files, includeCSS))) |
|
| 142 | -1x | +||
| 17 | +
- checkmate::assert_class(filter, "teal_slices")+ } |
| 143 | +1 |
-
+ # MatrixFilterStates ------ |
||
| 144 | -1x | +|||
| 2 | +
- datasets$remove_filter_state(filter)+ |
|||
| 145 | -1x | +|||
| 3 | +
- invisible(NULL)+ #' @name MatrixFilterStates |
|||
| 146 | +4 |
- }+ #' @docType class |
||
| 147 | +5 |
-
+ #' @title `FilterStates` subclass for matrices |
||
| 148 | +6 |
- #' @rdname filter_state_api+ #' @description Handles filter states in a `matrix`. |
||
| 149 | +7 |
- #' @export+ #' @keywords internal |
||
| 150 | +8 |
- clear_filter_states <- function(datasets, force = FALSE) {
+ #' |
||
| 151 | -1x | +|||
| 9 | +
- checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ MatrixFilterStates <- R6::R6Class( # nolint |
|||
| 152 | -1x | +|||
| 10 | +
- datasets$clear_filter_states(force = force)+ classname = "MatrixFilterStates", |
|||
| 153 | -1x | +|||
| 11 | +
- invisible(NULL)+ inherit = FilterStates, |
|||
| 154 | +12 |
- }+ |
||
| 155 | +13 |
-
+ # public methods ---- |
||
| 156 | +14 |
- #' Gets filter expression for multiple `datanames` taking into account its order.+ public = list( |
||
| 157 | +15 |
- #'+ #' @description |
||
| 158 | +16 |
- #' @description `r lifecycle::badge("stable")`
+ #' Initialize `MatrixFilterStates` object. |
||
| 159 | +17 |
- #'+ #' |
||
| 160 | +18 |
- #' To be used in `Show R Code` button.+ #' @param data (`matrix`) |
||
| 161 | +19 |
- #'+ #' the `R` object which `subset` function is applied on. |
||
| 162 | +20 |
- #' @param datasets (`FilteredData`)+ #' @param data_reactive (`function(sid)`) |
||
| 163 | +21 |
- #' @param datanames (`character`) vector of dataset names+ #' should return a `matrix` object or `NULL`. |
||
| 164 | +22 |
- #'+ #' This object is needed for the `FilterState` counts being updated on a change in filters. |
||
| 165 | +23 |
- #' @return A character string containing all subset expressions.+ #' If function returns `NULL` then filtered counts are not shown. |
||
| 166 | +24 |
- #'+ #' Function has to have `sid` argument being a character. |
||
| 167 | +25 |
- #' @export+ #' @param dataname (`character(1)`) |
||
| 168 | +26 |
- #'+ #' name of the data used in the subset expression. |
||
| 169 | +27 |
- get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
+ #' Passed to the function argument attached to this `FilterStates`. |
||
| 170 | -2x | +|||
| 28 | +
- checkmate::assert_character(datanames, min.len = 1, any.missing = FALSE)+ #' @param datalabel (`character(1)`) optional |
|||
| 171 | -2x | +|||
| 29 | +
- stopifnot(+ #' text label. Should be a name of experiment. |
|||
| 172 | -2x | +|||
| 30 | +
- is(datasets, "FilteredData"),+ #' |
|||
| 173 | -2x | +|||
| 31 | +
- all(datanames %in% datasets$datanames())+ initialize = function(data, |
|||
| 174 | +32 |
- )+ data_reactive = function(sid = "") NULL, |
||
| 175 | +33 |
-
+ dataname, |
||
| 176 | -2x | +|||
| 34 | +
- paste(+ datalabel = NULL) {
|
|||
| 177 | -2x | +35 | +26x |
- unlist(lapply(+ checkmate::assert_matrix(data) |
| 178 | -2x | +36 | +25x |
- datanames,+ super$initialize(data, data_reactive, dataname, datalabel) |
| 179 | -2x | +37 | +25x |
- function(dataname) {
+ private$set_filterable_varnames(include_varnames = colnames(private$data)) |
| 180 | -4x | +|||
| 38 | +
- datasets$get_call(dataname)+ } |
|||
| 181 | +39 |
- }+ ), |
||
| 182 | +40 |
- )),+ private = list( |
||
| 183 | -2x | +|||
| 41 | +
- collapse = "\n"+ extract_type = "matrix" |
|||
| 184 | +42 |
) |
||
| 185 | +43 |
- }+ ) |
| 1 |
- #' Compose predicates+ #' Test whether variable name can be used within `Show R Code` |
||
| 3 |
- #' Combines calls with a logical operator.+ #' Variable names containing spaces are problematic and must be wrapped in backticks. |
||
| 4 |
- #'+ #' Also, they should not start with a number as `R` may silently make it valid by changing it. |
||
| 5 |
- #' This function is used to combine logical predicates produced by `FilterState` objects+ #' Therefore, we only allow alphanumeric characters with underscores. |
||
| 6 |
- #' to build a complete subset expression.+ #' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters. |
||
| 8 |
- #' @param calls (`list`)+ #' @md |
||
| 9 |
- #' containing calls (or symbols) to be combined by `operator`+ #' |
||
| 10 |
- #' @param operator (`character(1)`)+ #' @param name (`character`) vector of names to check |
||
| 11 |
- #' infix operator to use in predicate composition, _e.g._ `"&"`+ #' @return Returns `NULL` or raises error. |
||
| 12 |
- #'+ #' @keywords internal |
||
| 13 |
- #' @return+ #' |
||
| 14 |
- #' A `call` where elements of `calls` are composed with `operator` or `NULL` if `calls` is an empty list.+ check_simple_name <- function(name) {
|
||
| 15 | -+ | 273x |
- #'+ checkmate::assert_character(name, min.len = 1, any.missing = FALSE) |
| 16 | -+ | 271x |
- #' @examples+ if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
|
| 17 | -+ | 5x |
- #' # use non-exported function from teal.slice+ stop( |
| 18 | -+ | 5x |
- #' calls_combine_by <- getFromNamespace("calls_combine_by", "teal.slice")
+ "name '", |
| 19 | -+ | 5x |
- #'+ name, |
| 20 | -+ | 5x |
- #' calls <- list(+ "' must only contain alphanumeric characters (with underscores)", |
| 21 | -+ | 5x |
- #' quote(SEX == "F"), # subsetting on factor+ " and the first character must be an alphabetic character" |
| 22 |
- #' quote(AGE >= 20 & AGE <= 50), # subsetting on range+ ) |
||
| 23 |
- #' quote(!SURV) # subsetting on logical+ } |
||
| 24 |
- #' )+ } |
||
| 25 |
- #' calls_combine_by(calls, "&")+ |
||
| 26 |
- #'+ #' Include `JS` files from `/inst/js/` package directory to application header |
||
| 27 |
- #' @keywords internal+ #' |
||
| 28 |
- #'+ #' `system.file` should not be used to access files in other packages, it does |
||
| 29 |
- calls_combine_by <- function(calls, operator) {
+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 30 | -47x | +
- checkmate::assert_list(calls)+ #' as needed. Thus, we do not export this method. |
|
| 31 | -45x | +
- if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
+ #' |
|
| 32 | -46x | +
- checkmate::assert_string(operator)+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file` |
|
| 33 |
-
+ #' |
||
| 34 | -44x | +
- Reduce(+ #' @return HTML code that includes `JS` files |
|
| 35 | -44x | +
- x = calls,+ #' @keywords internal |
|
| 36 | -44x | +
- f = function(x, y) call(operator, x, y)+ include_js_files <- function(pattern) {
|
|
| 37 | +12x | +
+ checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE)+ |
+ |
| 38 | +12x | +
+ js_files <- list.files(+ |
+ |
| 39 | +12x | +
+ system.file("js", package = "teal.slice", mustWork = TRUE),
+ |
+ |
| 40 | +12x | +
+ pattern = pattern,+ |
+ |
| 41 | +12x | +
+ full.names = TRUE+ |
+ |
| 42 |
) |
||
| 43 | +12x | +
+ singleton(lapply(js_files, includeScript))+ |
+ |
| 38 | +44 |
} |
| 1 | +45 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ |
|
| 2 | +46 | ++ |
+ #' Build concatenating call+ |
+
| 47 |
#' |
||
| 3 | +48 |
- #' `system.file` should not be used to access files in other packages, it does+ #' This function takes a vector of values and returns a `c` call. If the vector |
|
| 4 | +49 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' has only one element, the element is returned directly. |
|
| 5 | +50 |
- #' as needed. Thus, we do not export this method.+ #' |
|
| 6 | +51 | ++ |
+ #' @param choices A vector of values.+ |
+
| 52 |
#' |
||
| 7 | +53 |
- #' @param pattern (`character`) pattern of files to be included+ #' @return A `c` call. |
|
| 8 | +54 |
#' |
|
| 9 | +55 |
- #' @return HTML code that includes `CSS` files+ #' @examples |
|
| 10 | +56 |
- #' @keywords internal+ #' # use non-exported function from teal.slice |
|
| 11 | +57 |
- include_css_files <- function(pattern = "*") {
+ #' make_c_call <- getFromNamespace("make_c_call", "teal.slice")
|
|
| 12 | -! | +||
| 58 | +
- css_files <- list.files(+ #' make_c_call(1:3) |
||
| 13 | -! | +||
| 59 | +
- system.file("css", package = "teal.slice", mustWork = TRUE),
+ #' make_c_call(1) |
||
| 14 | -! | +||
| 60 | +
- pattern = pattern, full.names = TRUE+ #' |
||
| 15 | +61 |
- )+ #' @keywords internal |
|
| 16 | -! | +||
| 62 | +
- singleton(tags$head(lapply(css_files, includeCSS)))+ make_c_call <- function(choices) {
+ |
+ ||
| 63 | +55x | +
+ if (length(choices) > 1) {
+ |
+ |
| 64 | +27x | +
+ do.call("call", append(list("c"), choices))
|
|
| 17 | +65 | ++ |
+ } else {
+ |
+
| 66 | +28x | +
+ choices+ |
+ |
| 67 | ++ |
+ }+ |
+ |
| 68 |
} |