| 1 |
#' Specify single filter |
|
| 2 |
#' |
|
| 3 |
#' Create a `teal_slice` object that holds complete information on filtering one variable. |
|
| 4 |
#' Check out [`teal_slice-utilities`] functions for working with `teal_slice` object. |
|
| 5 |
#' |
|
| 6 |
#' `teal_slice` object fully describes filter state and can be used to create, |
|
| 7 |
#' modify, and delete a filter state. A `teal_slice` contains a number of common fields |
|
| 8 |
#' (all named arguments of `teal_slice`), some of which are mandatory, but only |
|
| 9 |
#' `dataname` and either `varname` or `expr` must be specified, while the others have default |
|
| 10 |
#' values. |
|
| 11 |
#' |
|
| 12 |
#' Setting any of the other values to `NULL` means that those properties will not be modified |
|
| 13 |
#' (when setting an existing state) or that they will be determined by data (when creating new a new one). |
|
| 14 |
#' Entire object is `FilterState` class member and can be accessed with `FilterState$get_state()`. |
|
| 15 |
#' |
|
| 16 |
#' A `teal_slice` can come in two flavors: |
|
| 17 |
#' 1. `teal_slice_var` - |
|
| 18 |
#' this describes a typical interactive filter that refers to a single variable, managed by the `FilterState` class. |
|
| 19 |
#' This class is created when `varname` is specified. |
|
| 20 |
#' The object retains all fields specified in the call. `id` can be created by default and need not be specified. |
|
| 21 |
#' 2. `teal_slice_expr` - |
|
| 22 |
#' this describes a filter state that refers to an expression, which can potentially include multiple variables, |
|
| 23 |
#' managed by the `FilterStateExpr` class. |
|
| 24 |
#' This class is created when `expr` is specified. |
|
| 25 |
#' `dataname` and `anchored` are retained, `fixed` is set to `TRUE`, `id` becomes mandatory, `title` |
|
| 26 |
#' remains optional, while other arguments are disregarded. |
|
| 27 |
#' |
|
| 28 |
#' A teal_slice can be passed `FilterState`/`FilterStateExpr` constructors to instantiate an object. |
|
| 29 |
#' It can also be passed to `FilterState$set_state` to modify the state. |
|
| 30 |
#' However, once a `FilterState` is created, only the mutable features can be set with a teal_slice: |
|
| 31 |
#' `selected`, `keep_na` and `keep_inf`. |
|
| 32 |
#' |
|
| 33 |
#' Special consideration is given to two fields: `fixed` and `anchored`. |
|
| 34 |
#' These are always immutable logical flags that default to `FALSE`. |
|
| 35 |
#' In a `FilterState` instantiated with `fixed = TRUE` the features |
|
| 36 |
#' `selected`, `keep_na`, `keep_inf` cannot be changed. |
|
| 37 |
#' Note that a `FilterStateExpr` is always considered to have `fixed = TRUE`. |
|
| 38 |
#' A `FilterState` instantiated with `anchored = TRUE` cannot be removed. |
|
| 39 |
#' |
|
| 40 |
#' @section Filters in `SumarizedExperiment` and `MultiAssayExperiment` objects: |
|
| 41 |
#' |
|
| 42 |
#' To establish a filter on a column in a `data.frame`, `dataname` and `varname` are sufficient. |
|
| 43 |
#' `MultiAssayExperiment` objects can be filtered either on their `colData` slot (which contains subject information) |
|
| 44 |
#' or on their experiments, which are stored in the `experimentList` slot. |
|
| 45 |
#' For filters referring to `colData` no extra arguments are needed. |
|
| 46 |
#' If a filter state is created for an experiment, that experiment name must be specified in the `experiment` argument. |
|
| 47 |
#' Furthermore, to specify filter for an `SummarizedExperiment` one must also set `arg` |
|
| 48 |
#' (`"subset"` or `"select"`, arguments in the [subset()] function for `SummarizedExperiment`) |
|
| 49 |
#' in order to determine whether the filter refers to the `SE`'s `rowData` or `colData`. |
|
| 50 |
#' |
|
| 51 |
#' @param dataname (`character(1)`) name of data set |
|
| 52 |
#' @param varname (`character(1)`) name of variable |
|
| 53 |
#' @param id (`character(1)`) identifier of the filter. Must be specified when `expr` is set. |
|
| 54 |
#' When `varname` is specified then `id` is set to `"{dataname} {varname}"` by default.
|
|
| 55 |
#' @param expr (`character(1)`) string providing a logical expression. |
|
| 56 |
#' Must be a valid `R` expression which can be evaluated in the context of the data set. |
|
| 57 |
#' For a `data.frame` `var == "x"` is sufficient, but `MultiAssayExperiment::subsetByColData` |
|
| 58 |
#' requires `dataname` prefix, *e.g.* `data$var == "x"`. |
|
| 59 |
#' @param choices (`vector`) optional, specifies allowed choices; |
|
| 60 |
#' When specified it should be a subset of values in variable denoted by `varname`; |
|
| 61 |
#' Type and size depends on variable type. Factors are coerced to character. |
|
| 62 |
#' @param selected (`vector`) optional, specifies selected values from `choices`; |
|
| 63 |
#' Type and size depends on variable type. Factors are coerced to character. |
|
| 64 |
#' @param multiple (`logical(1)`) optional flag specifying whether more than one value can be selected; |
|
| 65 |
#' only applicable to `ChoicesFilterState` and `LogicalFilterState` |
|
| 66 |
#' @param keep_na (`logical(1)`) optional flag specifying whether to keep missing values |
|
| 67 |
#' @param keep_inf (`logical(1)`) optional flag specifying whether to keep infinite values |
|
| 68 |
#' @param fixed (`logical(1)`) flag specifying whether to fix this filter state (forbid setting state) |
|
| 69 |
#' @param anchored (`logical(1)`) flag specifying whether to lock this filter state (forbid removing and inactivating) |
|
| 70 |
#' @param title (`character(1)`) optional title of the filter. Ignored when `varname` is set. |
|
| 71 |
#' @param ... additional arguments which can be handled by extensions of `teal.slice` classes. |
|
| 72 |
#' |
|
| 73 |
#' @return A `teal.slice` object. Depending on whether `varname` or `expr` was specified, the resulting |
|
| 74 |
#' `teal_slice` also receives class `teal_slice_var` or `teal_slice_expr`, respectively. |
|
| 75 |
#' |
|
| 76 |
#' @note Date time objects of `POSIX*t` classes are printed as strings after converting to UTC timezone. |
|
| 77 |
#' |
|
| 78 |
#' @examples |
|
| 79 |
#' x1 <- teal_slice( |
|
| 80 |
#' dataname = "data", |
|
| 81 |
#' id = "Female adults", |
|
| 82 |
#' expr = "SEX == 'F' & AGE >= 18", |
|
| 83 |
#' title = "Female adults" |
|
| 84 |
#' ) |
|
| 85 |
#' x2 <- teal_slice( |
|
| 86 |
#' dataname = "data", |
|
| 87 |
#' varname = "var", |
|
| 88 |
#' choices = c("F", "M", "U"),
|
|
| 89 |
#' selected = "F", |
|
| 90 |
#' keep_na = TRUE, |
|
| 91 |
#' keep_inf = TRUE, |
|
| 92 |
#' fixed = FALSE, |
|
| 93 |
#' anchored = FALSE, |
|
| 94 |
#' multiple = TRUE, |
|
| 95 |
#' id = "Gender", |
|
| 96 |
#' extra_arg = "extra" |
|
| 97 |
#' ) |
|
| 98 |
#' |
|
| 99 |
#' is.teal_slice(x1) |
|
| 100 |
#' as.list(x1) |
|
| 101 |
#' as.teal_slice(list(dataname = "a", varname = "var")) |
|
| 102 |
#' format(x1) |
|
| 103 |
#' format(x1, show_all = TRUE, trim_lines = FALSE) |
|
| 104 |
#' print(x1) |
|
| 105 |
#' print(x1, show_all = TRUE, trim_lines = FALSE) |
|
| 106 |
#' |
|
| 107 |
#' @seealso [`teal_slices`], |
|
| 108 |
#' [`is.teal_slice`], [`as.teal_slice`], [`as.list.teal_slice`], [`print.teal_slice`], [`format.teal_slice`] |
|
| 109 |
#' |
|
| 110 |
#' @export |
|
| 111 |
teal_slice <- function(dataname, |
|
| 112 |
varname, |
|
| 113 |
id, |
|
| 114 |
expr, |
|
| 115 |
choices = NULL, |
|
| 116 |
selected = NULL, |
|
| 117 |
keep_na = NULL, |
|
| 118 |
keep_inf = NULL, |
|
| 119 |
fixed = FALSE, |
|
| 120 |
anchored = FALSE, |
|
| 121 |
multiple = TRUE, |
|
| 122 |
title = NULL, |
|
| 123 |
...) {
|
|
| 124 | 612x |
checkmate::assert_string(dataname) |
| 125 | 605x |
checkmate::assert_flag(fixed) |
| 126 | 603x |
checkmate::assert_flag(anchored) |
| 127 | ||
| 128 | 601x |
formal_args <- as.list(environment()) |
| 129 | ||
| 130 | 601x |
if (!missing(expr) && !missing(varname)) {
|
| 131 | 1x |
stop("Must provide either `expr` or `varname`.")
|
| 132 | 600x |
} else if (!missing(expr)) {
|
| 133 | 37x |
checkmate::assert_string(id) |
| 134 | 34x |
checkmate::assert_string(title) |
| 135 | 31x |
checkmate::assert_string(expr) |
| 136 | ||
| 137 | 30x |
formal_args$fixed <- TRUE |
| 138 | 30x |
ts_expr_args <- c("dataname", "id", "expr", "fixed", "anchored", "title")
|
| 139 | 30x |
formal_args <- formal_args[ts_expr_args] |
| 140 | 30x |
ans <- do.call(reactiveValues, c(formal_args, list(...))) |
| 141 | 30x |
class(ans) <- c("teal_slice_expr", "teal_slice", class(ans))
|
| 142 | 563x |
} else if (!missing(varname)) {
|
| 143 | 562x |
checkmate::assert_string(varname) |
| 144 | 559x |
checkmate::assert_multi_class(choices, .filterable_class, null.ok = TRUE) |
| 145 | 558x |
checkmate::assert_multi_class(selected, .filterable_class, null.ok = TRUE) |
| 146 | 556x |
checkmate::assert_flag(keep_na, null.ok = TRUE) |
| 147 | 555x |
checkmate::assert_flag(keep_inf, null.ok = TRUE) |
| 148 | 554x |
checkmate::assert_flag(multiple) |
| 149 | ||
| 150 | 554x |
ts_var_args <- c( |
| 151 | 554x |
"dataname", "varname", "id", "choices", "selected", "keep_na", "keep_inf", |
| 152 | 554x |
"fixed", "anchored", "multiple" |
| 153 |
) |
|
| 154 | 554x |
formal_args <- formal_args[ts_var_args] |
| 155 | 554x |
args <- c(formal_args, list(...)) |
| 156 | 554x |
args[c("choices", "selected")] <-
|
| 157 | 554x |
lapply(args[c("choices", "selected")], function(x) if (is.factor(x)) as.character(x) else x)
|
| 158 | 554x |
if (missing(id)) {
|
| 159 | 543x |
args$id <- get_default_slice_id(args) |
| 160 |
} else {
|
|
| 161 | 11x |
checkmate::assert_string(id) |
| 162 |
} |
|
| 163 | 551x |
ans <- do.call(reactiveValues, args) |
| 164 | 551x |
class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
|
| 165 |
} else {
|
|
| 166 | 1x |
stop("Must provide either `expr` or `varname`.")
|
| 167 |
} |
|
| 168 | ||
| 169 | 581x |
ans |
| 170 |
} |
|
| 171 | ||
| 172 |
#' `teal_slice` utility functions |
|
| 173 |
#' |
|
| 174 |
#' Helper functions for working with [`teal_slice`] object. |
|
| 175 |
#' @param x (`teal.slice`) |
|
| 176 |
#' @param show_all (`logical(1)`) indicating whether to show all fields. If set to `FALSE`, |
|
| 177 |
#' only non-NULL elements will be printed. |
|
| 178 |
#' @param trim_lines (`logical(1)`) indicating whether to trim lines when printing. |
|
| 179 |
#' @param ... additional arguments passed to other functions. |
|
| 180 |
#' @name teal_slice-utilities |
|
| 181 |
#' @inherit teal_slice examples |
|
| 182 |
#' @keywords internal |
|
| 183 | ||
| 184 |
#' @rdname teal_slice-utilities |
|
| 185 |
#' @export |
|
| 186 |
#' |
|
| 187 |
is.teal_slice <- function(x) { # nolint
|
|
| 188 | 4x |
inherits(x, "teal_slice") |
| 189 |
} |
|
| 190 | ||
| 191 |
#' @rdname teal_slice-utilities |
|
| 192 |
#' @export |
|
| 193 |
#' |
|
| 194 |
as.teal_slice <- function(x) { # nolint
|
|
| 195 | 2x |
checkmate::assert_list(x, names = "named") |
| 196 | 2x |
do.call(teal_slice, x) |
| 197 |
} |
|
| 198 | ||
| 199 |
#' @rdname teal_slice-utilities |
|
| 200 |
#' @export |
|
| 201 |
#' |
|
| 202 |
as.list.teal_slice <- function(x, ...) {
|
|
| 203 | 342x |
formal_args <- setdiff(names(formals(teal_slice)), "...") |
| 204 | ||
| 205 | 342x |
x <- if (isRunning()) {
|
| 206 | ! |
reactiveValuesToList(x) |
| 207 |
} else {
|
|
| 208 | 342x |
isolate(reactiveValuesToList(x)) |
| 209 |
} |
|
| 210 | ||
| 211 | 342x |
formal_args <- intersect(formal_args, names(x)) |
| 212 | 342x |
extra_args <- rev(setdiff(names(x), formal_args)) |
| 213 | ||
| 214 | 342x |
x[c(formal_args, extra_args)] |
| 215 |
} |
|
| 216 | ||
| 217 | ||
| 218 |
#' @rdname teal_slice-utilities |
|
| 219 |
#' @export |
|
| 220 |
#' |
|
| 221 |
format.teal_slice <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
|
|
| 222 | 117x |
checkmate::assert_flag(show_all) |
| 223 | 93x |
checkmate::assert_flag(trim_lines) |
| 224 | ||
| 225 | 87x |
x_list <- as.list(x) |
| 226 | 48x |
if (!show_all) x_list <- Filter(Negate(is.null), x_list) |
| 227 | ||
| 228 | 87x |
jsonify(x_list, trim_lines) |
| 229 |
} |
|
| 230 | ||
| 231 |
#' @rdname teal_slice-utilities |
|
| 232 |
#' @export |
|
| 233 |
#' |
|
| 234 |
print.teal_slice <- function(x, ...) {
|
|
| 235 | 16x |
cat(format(x, ...)) |
| 236 | 16x |
invisible(x) |
| 237 |
} |
|
| 238 | ||
| 239 | ||
| 240 |
# format utils ----- |
|
| 241 | ||
| 242 |
#' Convert a list to a justified `JSON` string |
|
| 243 |
#' |
|
| 244 |
#' This function takes a list and converts it to a `JSON` string. |
|
| 245 |
#' The resulting `JSON` string is then optionally justified to improve readability |
|
| 246 |
#' and trimmed to easier fit in the console when printing. |
|
| 247 |
#' |
|
| 248 |
#' @param x (`list`), possibly recursive, obtained from `teal_slice` or `teal_slices`. |
|
| 249 |
#' @param trim_lines (`logical(1)`) flag specifying whether to trim lines of the `JSON` string. |
|
| 250 |
#' @return A `JSON` string representation of the input list. |
|
| 251 |
#' @keywords internal |
|
| 252 |
#' |
|
| 253 |
jsonify <- function(x, trim_lines) {
|
|
| 254 | 133x |
checkmate::assert_list(x) |
| 255 | ||
| 256 | 133x |
x_json <- to_json(x) |
| 257 | 133x |
x_json_justified <- justify_json(x_json) |
| 258 | 123x |
if (trim_lines) x_json_justified <- trim_lines_json(x_json_justified) |
| 259 | 133x |
paste(x_json_justified, collapse = "\n") |
| 260 |
} |
|
| 261 | ||
| 262 |
#' Converts a list to a `JSON` string |
|
| 263 |
#' |
|
| 264 |
#' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string. |
|
| 265 |
#' Ensures proper unboxing of list elements. |
|
| 266 |
#' This function is used by the `format` methods for `teal_slice` and `teal_slices`. |
|
| 267 |
#' @param x (`list`) possibly recursive, obtained from `teal_slice` or `teal_slices`. |
|
| 268 |
#' @return A `JSON` string. |
|
| 269 |
# |
|
| 270 |
#' @param x (`list`) representation of `teal_slices` object. |
|
| 271 |
#' @keywords internal |
|
| 272 |
#' |
|
| 273 |
to_json <- function(x) {
|
|
| 274 | 133x |
no_unbox <- function(x) {
|
| 275 | 2415x |
vars <- c("selected", "choices")
|
| 276 | 2415x |
if (is.list(x)) {
|
| 277 | 391x |
for (var in vars) {
|
| 278 | 307x |
if (!is.null(x[[var]])) x[[var]] <- I(format_time(x[[var]])) |
| 279 |
} |
|
| 280 | 391x |
lapply(x, no_unbox) |
| 281 |
} else {
|
|
| 282 | 2024x |
x |
| 283 |
} |
|
| 284 |
} |
|
| 285 | ||
| 286 | 133x |
jsonlite::toJSON(no_unbox(x), pretty = TRUE, auto_unbox = TRUE, digits = 16, null = "null") |
| 287 |
} |
|
| 288 | ||
| 289 |
#' Format `POSIXt` for storage |
|
| 290 |
#' |
|
| 291 |
#' Convert `POSIXt` date time object to character representation in UTC time zone. |
|
| 292 |
#' |
|
| 293 |
#' Date times are stored as string representations expressed in the UTC time zone. |
|
| 294 |
#' The storage format is `YYYY-MM-DD HH:MM:SS`. |
|
| 295 |
#' |
|
| 296 |
#' @param x (`POSIXt`) vector of date time values or anything else |
|
| 297 |
#' |
|
| 298 |
#' @return If `x` is of class `POSIXt`, a character vector, otherwise `x` itself. |
|
| 299 |
#' |
|
| 300 |
#' @keywords internal |
|
| 301 |
format_time <- function(x) {
|
|
| 302 | 307x |
if ("POSIXt" %in% class(x)) {
|
| 303 | 20x |
format(x, format = "%Y-%m-%d %H:%M:%S", usetz = TRUE, tz = "UTC") |
| 304 |
} else {
|
|
| 305 | 287x |
x |
| 306 |
} |
|
| 307 |
} |
|
| 308 | ||
| 309 |
#' Justify colons in `JSON` string |
|
| 310 |
#' |
|
| 311 |
#' This function takes a `JSON` string as input, splits it into lines, and pads element names |
|
| 312 |
#' with spaces so that colons are justified between lines. |
|
| 313 |
#' |
|
| 314 |
#' @param json (`character(1)`) a `JSON` string. |
|
| 315 |
#' |
|
| 316 |
#' @return A list of character strings, which can be collapsed into a `JSON` string. |
|
| 317 |
#' |
|
| 318 |
#' @keywords internal |
|
| 319 |
justify_json <- function(json) {
|
|
| 320 | 133x |
format_name <- function(name, name_width) {
|
| 321 | 2806x |
if (nchar(name) == 1 || nchar(gsub("\\s", "", name)) <= 2) {
|
| 322 | 640x |
name |
| 323 | 2166x |
} else if (grepl("slices|attributes", name)) {
|
| 324 | 92x |
paste0(name, ":") |
| 325 |
} else {
|
|
| 326 | 2074x |
paste(format(name, width = name_width), ":") |
| 327 |
} |
|
| 328 |
} |
|
| 329 | 133x |
json_lines <- strsplit(json, "\n")[[1]] |
| 330 | 133x |
json_lines_split <- regmatches(json_lines, regexpr(":", json_lines), invert = TRUE)
|
| 331 | 133x |
name_width <- max(unlist(regexpr(":", json_lines))) - 1
|
| 332 | 133x |
vapply(json_lines_split, function(x) paste0(format_name(x[1], name_width), stats::na.omit(x[2])), character(1)) |
| 333 |
} |
|
| 334 | ||
| 335 |
#' Trim lines in `JSON` string |
|
| 336 |
#' |
|
| 337 |
#' This function takes a `JSON` string as input and returns a modified version of the |
|
| 338 |
#' input where the values portion of each line is trimmed for a less messy console output. |
|
| 339 |
#' |
|
| 340 |
#' @param x (`character`) |
|
| 341 |
#' |
|
| 342 |
#' @return A character string trimmed after a certain hard-coded number of characters in the value portion. |
|
| 343 |
#' |
|
| 344 |
#' @keywords internal |
|
| 345 |
#' |
|
| 346 |
trim_lines_json <- function(x) {
|
|
| 347 | 123x |
name_width <- max(unlist(gregexpr(":", x))) - 1
|
| 348 | 123x |
trim_position <- name_width + 37L |
| 349 | 123x |
x_trim <- substr(x, 1, trim_position) |
| 350 | 123x |
substr(x_trim, trim_position - 2, trim_position) <- "..." |
| 351 | 123x |
x_trim |
| 352 |
} |
|
| 353 | ||
| 354 |
#' Default `teal_slice` id |
|
| 355 |
#' |
|
| 356 |
#' Create a slice id if none provided. |
|
| 357 |
#' |
|
| 358 |
#' Function returns a default `id` for a `teal_slice` object which needs |
|
| 359 |
#' to be distinct from other `teal_slice` objects created for any |
|
| 360 |
#' `FilterStates` object. Returned `id` can be treated as a location of |
|
| 361 |
#' a vector on which `FilterState` is built: |
|
| 362 |
#' - for a `data.frame` `id` concatenates `dataname` and `varname`. |
|
| 363 |
#' - for a `MultiAssayExperiment` `id` concatenates `dataname`, `varname`, |
|
| 364 |
#' `experiment` and `arg`, so that one can add `teal_slice` for a `varname` |
|
| 365 |
#' which exists in multiple `SummarizedExperiment`s or exists in both `colData` |
|
| 366 |
#' and `rowData` of given experiment. |
|
| 367 |
#' For such a vector `teal.slice` doesn't allow to activate more than one filters. |
|
| 368 |
#' In case of `teal_slice_expr` `id` is mandatory and must be unique. |
|
| 369 |
#' |
|
| 370 |
#' @param x (`teal_slice` or `list`) |
|
| 371 |
#' @return (`character(1)`) `id` for a `teal_slice` object. |
|
| 372 |
#' |
|
| 373 |
#' @keywords internal |
|
| 374 |
get_default_slice_id <- function(x) {
|
|
| 375 | 678x |
checkmate::assert_multi_class(x, c("teal_slice", "list"))
|
| 376 | 678x |
isolate({
|
| 377 | 678x |
if (inherits(x, "teal_slice_expr") || is.null(x$varname)) {
|
| 378 | 24x |
x$id |
| 379 |
} else {
|
|
| 380 | 654x |
paste( |
| 381 | 654x |
Filter( |
| 382 | 654x |
length, |
| 383 | 654x |
as.list(x)[c("dataname", "varname", "experiment", "arg")]
|
| 384 |
), |
|
| 385 | 654x |
collapse = " " |
| 386 |
) |
|
| 387 |
} |
|
| 388 |
}) |
|
| 389 |
} |
| 1 |
# MAEFilteredDataset ------ |
|
| 2 | ||
| 3 |
#' @name MAEFilteredDataset |
|
| 4 |
#' @docType class |
|
| 5 |
#' @title `MAEFilteredDataset` `R6` class |
|
| 6 |
#' |
|
| 7 |
#' @examplesIf requireNamespace("MultiAssayExperiment")
|
|
| 8 |
#' # use non-exported function from teal.slice |
|
| 9 |
#' MAEFilteredDataset <- getFromNamespace("MAEFilteredDataset", "teal.slice")
|
|
| 10 |
#' |
|
| 11 |
#' data(miniACC, package = "MultiAssayExperiment") |
|
| 12 |
#' dataset <- MAEFilteredDataset$new(miniACC, "MAE") |
|
| 13 |
#' fs <- teal_slices( |
|
| 14 |
#' teal_slice( |
|
| 15 |
#' dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE |
|
| 16 |
#' ), |
|
| 17 |
#' teal_slice( |
|
| 18 |
#' dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE |
|
| 19 |
#' ), |
|
| 20 |
#' teal_slice( |
|
| 21 |
#' dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE |
|
| 22 |
#' ), |
|
| 23 |
#' teal_slice( |
|
| 24 |
#' dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE |
|
| 25 |
#' ) |
|
| 26 |
#' ) |
|
| 27 |
#' dataset$set_filter_state(state = fs) |
|
| 28 |
#' |
|
| 29 |
#' library(shiny) |
|
| 30 |
#' isolate(dataset$get_filter_state()) |
|
| 31 |
#' |
|
| 32 |
#' @keywords internal |
|
| 33 |
#' |
|
| 34 |
MAEFilteredDataset <- R6::R6Class( # nolint |
|
| 35 |
classname = "MAEFilteredDataset", |
|
| 36 |
inherit = FilteredDataset, |
|
| 37 | ||
| 38 |
# public methods ---- |
|
| 39 |
public = list( |
|
| 40 |
#' @description |
|
| 41 |
#' Initialize `MAEFilteredDataset` object. |
|
| 42 |
#' |
|
| 43 |
#' @param dataset (`MulitiAssayExperiment`) |
|
| 44 |
#' single `MulitiAssayExperiment` for which filters are rendered. |
|
| 45 |
#' @param dataname (`character(1)`) |
|
| 46 |
#' syntactically valid name given to the dataset. |
|
| 47 |
#' @param keys (`character`) optional |
|
| 48 |
#' vector of primary key column names. |
|
| 49 |
#' @param label (`character(1)`) |
|
| 50 |
#' label to describe the dataset. |
|
| 51 |
#' |
|
| 52 |
#' @return Object of class `MAEFilteredDataset`, invisibly. |
|
| 53 |
#' |
|
| 54 |
initialize = function(dataset, dataname, keys = character(0), label = character(0)) {
|
|
| 55 | 21x |
if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
| 56 | ! |
stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
|
| 57 |
} |
|
| 58 | 21x |
checkmate::assert_class(dataset, "MultiAssayExperiment") |
| 59 | 19x |
super$initialize(dataset, dataname, keys, label) |
| 60 | 19x |
experiment_names <- names(dataset) |
| 61 | ||
| 62 |
# subsetting by subjects means subsetting by colData(MAE) |
|
| 63 | 19x |
private$add_filter_states( |
| 64 | 19x |
filter_states = init_filter_states( |
| 65 | 19x |
data = dataset, |
| 66 | 19x |
data_reactive = private$data_filtered_fun, |
| 67 | 19x |
dataname = dataname, |
| 68 | 19x |
datalabel = "subjects", |
| 69 | 19x |
keys = self$get_keys() |
| 70 |
), |
|
| 71 | 19x |
id = "subjects" |
| 72 |
) |
|
| 73 |
# elements of the list (experiments) are unknown |
|
| 74 |
# dispatch needed because we can't hardcode methods otherwise: |
|
| 75 |
# if (matrix) else if (SummarizedExperiment) else if ... |
|
| 76 | 19x |
lapply( |
| 77 | 19x |
experiment_names, |
| 78 | 19x |
function(experiment_name) {
|
| 79 | 95x |
data_reactive <- function(sid = "") private$data_filtered_fun(sid)[[experiment_name]] |
| 80 | 95x |
private$add_filter_states( |
| 81 | 95x |
filter_states = init_filter_states( |
| 82 | 95x |
data = dataset[[experiment_name]], |
| 83 | 95x |
data_reactive = data_reactive, |
| 84 | 95x |
dataname = dataname, |
| 85 | 95x |
datalabel = experiment_name |
| 86 |
), |
|
| 87 | 95x |
id = experiment_name |
| 88 |
) |
|
| 89 |
} |
|
| 90 |
) |
|
| 91 |
}, |
|
| 92 | ||
| 93 |
#' @description |
|
| 94 |
#' Set filter state. |
|
| 95 |
#' |
|
| 96 |
#' @param state (`teal_slices`) |
|
| 97 |
#' @return `NULL`, invisibly. |
|
| 98 |
#' |
|
| 99 |
set_filter_state = function(state) {
|
|
| 100 | 13x |
isolate({
|
| 101 | 13x |
logger::log_debug("FilteredDatasetMAE$set_filter_state initializing, dataname: { private$dataname }")
|
| 102 | 13x |
checkmate::assert_class(state, "teal_slices") |
| 103 | 12x |
lapply(state, function(x) {
|
| 104 | 48x |
checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname") |
| 105 |
}) |
|
| 106 | 12x |
super$set_filter_state(state = state) |
| 107 | ||
| 108 |
# set state on subjects |
|
| 109 | 12x |
subject_state <- Filter(function(x) is.null(x$experiment), state) |
| 110 | 12x |
private$get_filter_states()[["subjects"]]$set_filter_state(subject_state) |
| 111 | ||
| 112 |
# set state on experiments |
|
| 113 |
# determine target experiments (defined in teal_slices) |
|
| 114 | 12x |
experiments <- unique(unlist(lapply(state, "[[", "experiment"))) |
| 115 | 12x |
available_experiments <- setdiff(names(private$get_filter_states()), "subjects") |
| 116 | 12x |
excluded_filters <- setdiff(experiments, available_experiments) |
| 117 | 12x |
if (length(excluded_filters)) {
|
| 118 | ! |
stop(sprintf( |
| 119 | ! |
"%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s", |
| 120 | ! |
private$dataname, |
| 121 | ! |
toString(excluded_filters), |
| 122 | ! |
toString(available_experiments) |
| 123 |
)) |
|
| 124 |
} |
|
| 125 | ||
| 126 |
# set states on state_lists with corresponding experiments |
|
| 127 | 12x |
lapply(available_experiments, function(experiment) {
|
| 128 | 60x |
slices <- Filter(function(x) identical(x$experiment, experiment), state) |
| 129 | 60x |
private$get_filter_states()[[experiment]]$set_filter_state(slices) |
| 130 |
}) |
|
| 131 | ||
| 132 | 12x |
invisible(NULL) |
| 133 |
}) |
|
| 134 |
}, |
|
| 135 | ||
| 136 |
#' @description |
|
| 137 |
#' Remove one or more `FilterState` of a `MAEFilteredDataset`. |
|
| 138 |
#' |
|
| 139 |
#' @param state (`teal_slices`) |
|
| 140 |
#' specifying `FilterState` objects to remove; |
|
| 141 |
#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored. |
|
| 142 |
#' |
|
| 143 |
#' @return `NULL`, invisibly. |
|
| 144 |
#' |
|
| 145 |
remove_filter_state = function(state) {
|
|
| 146 | 1x |
checkmate::assert_class(state, "teal_slices") |
| 147 | ||
| 148 | 1x |
isolate({
|
| 149 | 1x |
logger::log_debug("FilteredDatasetMAE$remove_filter_state removing filter(s), dataname: { private$dataname }")
|
| 150 |
# remove state on subjects |
|
| 151 | 1x |
subject_state <- Filter(function(x) is.null(x$experiment), state) |
| 152 | 1x |
private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state) |
| 153 | ||
| 154 |
# remove state on experiments |
|
| 155 |
# determine target experiments (defined in teal_slices) |
|
| 156 | 1x |
experiments <- unique(unlist(lapply(state, "[[", "experiment"))) |
| 157 | 1x |
available_experiments <- setdiff(names(private$get_filter_states()), "subjects") |
| 158 | 1x |
excluded_filters <- setdiff(experiments, available_experiments) |
| 159 | 1x |
if (length(excluded_filters)) {
|
| 160 | ! |
stop(sprintf( |
| 161 | ! |
"%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s", |
| 162 | ! |
private$dataname, |
| 163 | ! |
toString(excluded_filters), |
| 164 | ! |
toString(available_experiments) |
| 165 |
)) |
|
| 166 |
} |
|
| 167 |
# remove states on state_lists with corresponding experiments |
|
| 168 | 1x |
lapply(experiments, function(experiment) {
|
| 169 | ! |
slices <- Filter(function(x) identical(x$experiment, experiment), state) |
| 170 | ! |
private$get_filter_states()[[experiment]]$remove_filter_state(slices) |
| 171 |
}) |
|
| 172 |
}) |
|
| 173 | ||
| 174 | 1x |
invisible(NULL) |
| 175 |
}, |
|
| 176 | ||
| 177 |
#' @description |
|
| 178 |
#' UI module to add filter variable for this dataset. |
|
| 179 |
#' @param id (`character(1)`) |
|
| 180 |
#' `shiny` module instance id. |
|
| 181 |
#' |
|
| 182 |
#' @return `shiny.tag` |
|
| 183 |
#' |
|
| 184 |
ui_add = function(id) {
|
|
| 185 | 1x |
ns <- NS(id) |
| 186 | 1x |
data <- self$get_dataset() |
| 187 | 1x |
experiment_names <- names(data) |
| 188 | ||
| 189 | 1x |
tags$div( |
| 190 | 1x |
tags$label("Add", tags$code(self$get_dataname()), "filter"),
|
| 191 | 1x |
tags$br(), |
| 192 | 1x |
HTML("►"),
|
| 193 | 1x |
tags$label("Add subjects filter"),
|
| 194 | 1x |
private$get_filter_states()[["subjects"]]$ui_add(id = ns("subjects")),
|
| 195 | 1x |
tagList( |
| 196 | 1x |
lapply( |
| 197 | 1x |
experiment_names, |
| 198 | 1x |
function(experiment_name) {
|
| 199 | 5x |
tagList( |
| 200 | 5x |
HTML("►"),
|
| 201 | 5x |
tags$label("Add", tags$code(experiment_name), "filter"),
|
| 202 | 5x |
private$get_filter_states()[[experiment_name]]$ui_add(id = ns(experiment_name)) |
| 203 |
) |
|
| 204 |
} |
|
| 205 |
) |
|
| 206 |
) |
|
| 207 |
) |
|
| 208 |
}, |
|
| 209 | ||
| 210 |
#' @description |
|
| 211 |
#' Creates row for filter overview in the form of \cr |
|
| 212 |
#' `dataname -- observations (remaining/total) -- subjects (remaining/total)` - MAE |
|
| 213 |
#' @return A `data.frame`. |
|
| 214 |
get_filter_overview = function() {
|
|
| 215 | 2x |
data <- self$get_dataset() |
| 216 | 2x |
data_filtered <- self$get_dataset(TRUE) |
| 217 | 2x |
experiment_names <- names(data) |
| 218 | ||
| 219 | 2x |
mae_info <- data.frame( |
| 220 | 2x |
dataname = private$dataname, |
| 221 | 2x |
subjects = nrow(SummarizedExperiment::colData(data)), |
| 222 | 2x |
subjects_filtered = nrow(SummarizedExperiment::colData(data_filtered())) |
| 223 |
) |
|
| 224 | ||
| 225 | 2x |
experiment_obs_info <- do.call("rbind", lapply(
|
| 226 | 2x |
experiment_names, |
| 227 | 2x |
function(experiment_name) {
|
| 228 | 10x |
data.frame( |
| 229 | 10x |
dataname = sprintf("- %s", experiment_name),
|
| 230 | 10x |
obs = nrow(data[[experiment_name]]), |
| 231 | 10x |
obs_filtered = nrow(data_filtered()[[experiment_name]]) |
| 232 |
) |
|
| 233 |
} |
|
| 234 |
)) |
|
| 235 | ||
| 236 | 2x |
get_experiment_keys <- function(mae, experiment) {
|
| 237 | 20x |
sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment)) |
| 238 | 20x |
length(unique(sample_subset$primary)) |
| 239 |
} |
|
| 240 | ||
| 241 | 2x |
experiment_subjects_info <- do.call("rbind", lapply(
|
| 242 | 2x |
experiment_names, |
| 243 | 2x |
function(experiment_name) {
|
| 244 | 10x |
data.frame( |
| 245 | 10x |
subjects = get_experiment_keys(data, data[[experiment_name]]), |
| 246 | 10x |
subjects_filtered = get_experiment_keys(data_filtered(), data_filtered()[[experiment_name]]) |
| 247 |
) |
|
| 248 |
} |
|
| 249 |
)) |
|
| 250 | ||
| 251 | 2x |
experiment_info <- cbind(experiment_obs_info, experiment_subjects_info) |
| 252 | 2x |
dplyr::bind_rows(mae_info, experiment_info) |
| 253 |
} |
|
| 254 |
) |
|
| 255 |
) |
| 1 |
#' Progress bars with labels |
|
| 2 |
#' |
|
| 3 |
#' `shiny` element displaying a series of progress bars and observation counts. |
|
| 4 |
#' |
|
| 5 |
#' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input). |
|
| 6 |
#' @param choices (`vector`) Available values. Used to determine label text. |
|
| 7 |
#' @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 |
#' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`. |
|
| 10 |
#' |
|
| 11 |
#' @return List of `shiny.tag`s. |
|
| 12 |
#' |
|
| 13 |
#' Creates a number of progress bar elements, one for each value of `choices`. |
|
| 14 |
#' The widths of all progress bars add up to the full width of the container. |
|
| 15 |
#' Each progress bar has a text label that contains the name of the value and the number of counts. |
|
| 16 |
#' |
|
| 17 |
#' If the filter panel is used with `count_type = "all"`, the progress bars will be filled |
|
| 18 |
#' according to the number of counts remaining in the current selection and the label will show |
|
| 19 |
#' both the current and the total number of counts. |
|
| 20 |
#' |
|
| 21 |
#' Each child element can have a unique `id` attribute to be used independently. |
|
| 22 |
#' |
|
| 23 |
#' @examples |
|
| 24 |
#' # use non-exported function from teal.slice |
|
| 25 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 26 |
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 27 |
#' countBars <- getFromNamespace("countBars", "teal.slice")
|
|
| 28 |
#' updateCountBars <- getFromNamespace("updateCountBars", "teal.slice")
|
|
| 29 |
#' |
|
| 30 |
#' library(shiny) |
|
| 31 |
#' |
|
| 32 |
#' choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE)
|
|
| 33 |
#' counts <- table(choices) |
|
| 34 |
#' labels <- countBars( |
|
| 35 |
#' inputId = "counts", |
|
| 36 |
#' choices = c("a", "b", "c"),
|
|
| 37 |
#' countsmax = counts, |
|
| 38 |
#' countsnow = unname(counts) |
|
| 39 |
#' ) |
|
| 40 |
#' |
|
| 41 |
#' ui <- bslib::page_fluid( |
|
| 42 |
#' tags$div( |
|
| 43 |
#' class = "teal-slice choices-state", |
|
| 44 |
#' include_js_files("count-bar-labels.js"),
|
|
| 45 |
#' include_css_files(pattern = "filter-panel"), |
|
| 46 |
#' checkboxGroupInput( |
|
| 47 |
#' inputId = "choices", |
|
| 48 |
#' selected = levels(choices), |
|
| 49 |
#' choiceNames = labels, |
|
| 50 |
#' choiceValues = levels(choices), |
|
| 51 |
#' label = NULL |
|
| 52 |
#' ) |
|
| 53 |
#' ) |
|
| 54 |
#' ) |
|
| 55 |
#' server <- function(input, output, session) {
|
|
| 56 |
#' observeEvent(input$choices, {
|
|
| 57 |
#' new_counts <- counts |
|
| 58 |
#' new_counts[!names(new_counts) %in% input$choices] <- 0 |
|
| 59 |
#' updateCountBars( |
|
| 60 |
#' inputId = "counts", |
|
| 61 |
#' choices = levels(choices), |
|
| 62 |
#' countsmax = counts, |
|
| 63 |
#' countsnow = unname(new_counts) |
|
| 64 |
#' ) |
|
| 65 |
#' }) |
|
| 66 |
#' } |
|
| 67 |
#' |
|
| 68 |
#' if (interactive()) {
|
|
| 69 |
#' shinyApp(ui, server) |
|
| 70 |
#' } |
|
| 71 |
#' |
|
| 72 |
#' @keywords internal |
|
| 73 |
#' |
|
| 74 |
countBars <- function(inputId, choices, countsmax, countsnow = NULL) { # nolint
|
|
| 75 | 36x |
checkmate::assert_string(inputId) |
| 76 | 32x |
checkmate::assert_vector(choices) |
| 77 | 31x |
checkmate::assert_numeric(countsmax, len = length(choices)) |
| 78 | 28x |
checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE) |
| 79 | 26x |
if (!is.null(countsnow)) {
|
| 80 | 8x |
checkmate::assert_true(all(countsnow <= countsmax)) |
| 81 |
} |
|
| 82 | ||
| 83 | 25x |
ns <- NS(inputId) |
| 84 | ||
| 85 | 25x |
mapply( |
| 86 | 25x |
countBar, |
| 87 | 25x |
inputId = ns(seq_along(choices)), |
| 88 | 25x |
label = as.character(choices), |
| 89 | 25x |
countmax = countsmax, |
| 90 | 25x |
countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow, |
| 91 | 25x |
MoreArgs = list( |
| 92 | 25x |
counttotal = sum(countsmax) |
| 93 |
), |
|
| 94 | 25x |
SIMPLIFY = FALSE, USE.NAMES = FALSE |
| 95 |
) |
|
| 96 |
} |
|
| 97 | ||
| 98 |
#' Progress bar with label |
|
| 99 |
#' |
|
| 100 |
#' `shiny` element displaying a progress bar and observation count. |
|
| 101 |
#' |
|
| 102 |
#' A progress bar is created to visualize the number of counts in a variable, with filling and a text label. |
|
| 103 |
#' - progress bar width is derived as a fraction of the container width equal to `<countmax> / <counttotal>%"`, |
|
| 104 |
#' - progress bar is filled up to the fraction `<countnow> / <countmax>`, |
|
| 105 |
#' - text label is obtained by `<label> (<countnow> / <countmax>)`. |
|
| 106 |
#' |
|
| 107 |
#' @param inputId (`character(1)`) `shiny` id of the parent element (e.g. a check-box group input). |
|
| 108 |
#' @param label (`character(1)`) Text to display followed by counts. |
|
| 109 |
#' @param countmax (`numeric(1)`) Maximum count for a single element. |
|
| 110 |
#' @param countnow (`numeric(1)`) Current count for a single element. |
|
| 111 |
#' @param counttotal (`numeric(1)`) Sum total of maximum counts of all elements, see `Details`. |
|
| 112 |
#' @param session (`session`) `shiny` `session` object passed to function given to `shinyServer`. |
|
| 113 |
#' |
|
| 114 |
#' @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 | 96x |
checkmate::assert_string(inputId) |
| 120 | 92x |
checkmate::assert_string(label) |
| 121 | 89x |
checkmate::assert_number(countmax) |
| 122 | 87x |
checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax) |
| 123 | 85x |
checkmate::assert_number(counttotal, lower = countmax) |
| 124 | ||
| 125 | 83x |
label <- make_count_text(label, countmax = countmax, countnow = countnow) |
| 126 | 83x |
ns <- NS(inputId) |
| 127 | 56x |
if (is.null(countnow)) countnow <- 0 |
| 128 | 83x |
tags$div( |
| 129 | 83x |
class = "teal-slice state-count-container", |
| 130 | 83x |
style = "margin-bottom: 5px; padding: 0; margin: 0;", |
| 131 | 83x |
`data-bar-id` = inputId, |
| 132 | 83x |
tags$svg( |
| 133 | 83x |
width = "100%", |
| 134 | 83x |
height = "20", |
| 135 | 83x |
style = c( |
| 136 | 83x |
"display: block;", |
| 137 | 83x |
"margin: 0;", |
| 138 | 83x |
"padding: 0;", |
| 139 | 83x |
"background: white;", |
| 140 | 83x |
"box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.1);" |
| 141 |
), |
|
| 142 | 83x |
tags$rect( |
| 143 | 83x |
id = ns("count_bar_unfiltered"),
|
| 144 | 83x |
x = sprintf("%.2f", countnow / counttotal * 100),
|
| 145 | 83x |
y = "0", |
| 146 | 83x |
width = sprintf("%.2f", (countmax - countnow) / counttotal * 100),
|
| 147 | 83x |
height = "20", |
| 148 | 83x |
fill = "#add8e670" |
| 149 |
), |
|
| 150 | 83x |
tags$rect( |
| 151 | 83x |
id = ns("count_bar_filtered"),
|
| 152 | 83x |
x = "0", |
| 153 | 83x |
y = "0", |
| 154 | 83x |
width = sprintf("%.2f", countnow / counttotal * 100),
|
| 155 | 83x |
height = "20", |
| 156 | 83x |
fill = "#add8e6" |
| 157 |
), |
|
| 158 | 83x |
tags$text( |
| 159 | 83x |
id = ns("count_bar_label"),
|
| 160 | 83x |
x = "2", |
| 161 | 83x |
y = "14", |
| 162 | 83x |
fill = "#333", |
| 163 | 83x |
`font-size` = "12", |
| 164 | 83x |
label |
| 165 |
) |
|
| 166 |
) |
|
| 167 |
) |
|
| 168 |
} |
|
| 169 | ||
| 170 |
#' @rdname countBars |
|
| 171 |
updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, countsmax, countsnow = NULL) { # nolint
|
|
| 172 | 16x |
checkmate::assert_string(inputId) |
| 173 | 16x |
checkmate::assert_vector(choices) |
| 174 | 16x |
checkmate::assert_numeric(countsmax, len = length(choices)) |
| 175 | 16x |
checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE) |
| 176 | ||
| 177 | 16x |
ns <- NS(inputId) |
| 178 | 16x |
mapply( |
| 179 | 16x |
updateCountBar, |
| 180 | 16x |
inputId = ns(seq_along(choices)), |
| 181 | 16x |
label = choices, |
| 182 | 16x |
countmax = countsmax, |
| 183 | 16x |
countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow, |
| 184 | 16x |
MoreArgs = list( |
| 185 | 16x |
counttotal = sum(countsmax) |
| 186 |
) |
|
| 187 |
) |
|
| 188 | 16x |
invisible(NULL) |
| 189 |
} |
|
| 190 | ||
| 191 |
#' @rdname countBar |
|
| 192 |
updateCountBar <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow = NULL, counttotal) { # nolint
|
|
| 193 | 45x |
checkmate::assert_string(inputId) |
| 194 | 45x |
checkmate::assert_string(label) |
| 195 | 45x |
checkmate::assert_number(countmax) |
| 196 | 45x |
checkmate::assert_number(countnow, null.ok = TRUE) |
| 197 | 45x |
checkmate::assert_number(counttotal) |
| 198 | ||
| 199 | 45x |
label <- make_count_text(label, countmax = countmax, countnow = countnow) |
| 200 | 45x |
if (is.null(countnow)) countnow <- countmax |
| 201 | 45x |
session$sendCustomMessage( |
| 202 | 45x |
type = "updateCountBar", |
| 203 | 45x |
message = list( |
| 204 | 45x |
id = session$ns(inputId), |
| 205 | 45x |
label = label, |
| 206 | 45x |
countmax = countmax, |
| 207 | 45x |
countnow = countnow, |
| 208 | 45x |
counttotal = counttotal |
| 209 |
) |
|
| 210 |
) |
|
| 211 | ||
| 212 | 45x |
invisible(NULL) |
| 213 |
} |
|
| 214 | ||
| 215 |
#' @rdname countBar |
|
| 216 |
updateCountText <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow) { # nolint
|
|
| 217 | 33x |
checkmate::assert_string(inputId) |
| 218 | 33x |
checkmate::assert_string(label) |
| 219 | 33x |
checkmate::assert_number(countmax) |
| 220 | 33x |
checkmate::assert_number(countnow, null.ok = TRUE) |
| 221 | 33x |
label <- make_count_text(label, countmax = countmax, countnow = countnow) |
| 222 | 33x |
session$sendCustomMessage( |
| 223 | 33x |
type = "updateCountText", |
| 224 | 33x |
message = list( |
| 225 | 33x |
id = session$ns(inputId), |
| 226 | 33x |
label = label |
| 227 |
) |
|
| 228 |
) |
|
| 229 |
} |
|
| 230 | ||
| 231 |
#' Build count text |
|
| 232 |
#' |
|
| 233 |
#' Returns a text label describing filtered counts. The text is composed in the following way: |
|
| 234 |
#' - when `countnow` is not `NULL`: `<label> (<countnow>/<countmax>)` |
|
| 235 |
#' - when `countnow` is `NULL`: `<label> (<countmax>)` |
|
| 236 |
#' |
|
| 237 |
#' @param label (`character(1)`) Text displayed before counts. |
|
| 238 |
#' @param countnow (`numeric(1)`) Number of filtered counts. |
|
| 239 |
#' @param countmax (`numeric(1)`) Number of unfiltered counts. |
|
| 240 |
#' |
|
| 241 |
#' @return A character string. |
|
| 242 |
#' |
|
| 243 |
#' @keywords internal |
|
| 244 |
#' |
|
| 245 |
make_count_text <- function(label, countmax, countnow = NULL) {
|
|
| 246 | 250x |
checkmate::assert_string(label) |
| 247 | 248x |
checkmate::assert_number(countmax) |
| 248 | 246x |
checkmate::assert_number(countnow, null.ok = TRUE) |
| 249 | 244x |
sprintf( |
| 250 | 244x |
"%s (%s%s)", |
| 251 | 244x |
label, |
| 252 | 244x |
if (is.null(countnow)) "" else sprintf("%s/", countnow),
|
| 253 | 244x |
countmax |
| 254 |
) |
|
| 255 |
} |
|
| 256 | ||
| 257 | ||
| 258 |
#' Adjust counts to match choices |
|
| 259 |
#' |
|
| 260 |
#' @param choices (`character`) Choices to match. |
|
| 261 |
#' @param counts (`named numeric`) Counts to adjust. |
|
| 262 |
#' @keywords internal |
|
| 263 |
pair_counts <- function(choices, counts) {
|
|
| 264 | 177x |
checkmate::assert_numeric(counts) |
| 265 | 177x |
counts <- counts[match(choices, names(counts))] |
| 266 | 177x |
counts[is.na(counts)] <- 0 |
| 267 | 177x |
names(counts) <- choices |
| 268 | 177x |
counts |
| 269 |
} |
| 1 |
# EmptyFilterState ------ |
|
| 2 | ||
| 3 |
#' @name EmptyFilterState |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterState` object for empty variables |
|
| 7 |
#' |
|
| 8 |
#' @description `FilterState` subclass representing an empty variable. |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' # use non-exported function from teal.slice |
|
| 12 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 13 |
#' EmptyFilterState <- getFromNamespace("EmptyFilterState", "teal.slice")
|
|
| 14 |
#' |
|
| 15 |
#' library(shiny) |
|
| 16 |
#' |
|
| 17 |
#' filter_state <- EmptyFilterState$new( |
|
| 18 |
#' x = NA, |
|
| 19 |
#' slice = teal_slice(varname = "x", dataname = "data"), |
|
| 20 |
#' extract_type = character(0) |
|
| 21 |
#' ) |
|
| 22 |
#' isolate(filter_state$get_call()) |
|
| 23 |
#' filter_state$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
|
| 24 |
#' isolate(filter_state$get_call()) |
|
| 25 |
#' |
|
| 26 |
#' @keywords internal |
|
| 27 |
#' |
|
| 28 |
EmptyFilterState <- R6::R6Class( # nolint |
|
| 29 |
"EmptyFilterState", |
|
| 30 |
inherit = FilterState, |
|
| 31 | ||
| 32 |
# public methods ---- |
|
| 33 |
public = list( |
|
| 34 | ||
| 35 |
#' @description |
|
| 36 |
#' Initialize `EmptyFilterState` object. |
|
| 37 |
#' |
|
| 38 |
#' @param x (`vector`) |
|
| 39 |
#' variable to be filtered, |
|
| 40 |
#' @param x_reactive (`reactive`) |
|
| 41 |
#' returning vector of the same type as `x`. Is used to update |
|
| 42 |
#' counts following the change in values of the filtered dataset. |
|
| 43 |
#' If it is set to `reactive(NULL)` then counts based on filtered |
|
| 44 |
#' dataset are not shown. |
|
| 45 |
#' @param slice (`teal_slice`) |
|
| 46 |
#' specification of this filter state. |
|
| 47 |
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 48 |
#' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 49 |
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|
| 50 |
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 51 |
#' @param extract_type (`character`) |
|
| 52 |
#' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 53 |
#' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 54 |
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 55 |
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 56 |
#' |
|
| 57 |
#' @return Object of class `EmptyFilterState`, invisibly. |
|
| 58 |
#' |
|
| 59 |
initialize = function(x, |
|
| 60 |
x_reactive = reactive(NULL), |
|
| 61 |
extract_type = character(0), |
|
| 62 |
slice) {
|
|
| 63 | 6x |
isolate({
|
| 64 | 6x |
super$initialize( |
| 65 | 6x |
x = x, |
| 66 | 6x |
x_reactive = x_reactive, |
| 67 | 6x |
slice = slice, |
| 68 | 6x |
extract_type = extract_type |
| 69 |
) |
|
| 70 | 6x |
private$set_choices(slice$choices) |
| 71 | 6x |
private$set_selected(slice$selected) |
| 72 |
}) |
|
| 73 | ||
| 74 | 6x |
invisible(self) |
| 75 |
}, |
|
| 76 | ||
| 77 |
#' @description |
|
| 78 |
#' Returns reproducible condition call for current selection relevant for selected variable type. |
|
| 79 |
#' Uses internal reactive values, hence must be called in reactive or isolated context. |
|
| 80 |
#' @param dataname name of data set; defaults to `private$get_dataname()` |
|
| 81 |
#' @return `logical(1)` |
|
| 82 |
#' |
|
| 83 |
get_call = function(dataname) {
|
|
| 84 | 2x |
if (isFALSE(private$is_any_filtered())) {
|
| 85 | 1x |
return(NULL) |
| 86 |
} |
|
| 87 | 1x |
if (missing(dataname)) dataname <- private$get_dataname() |
| 88 | 1x |
filter_call <- if (isTRUE(private$get_keep_na())) {
|
| 89 | ! |
call("is.na", private$get_varname_prefixed(dataname))
|
| 90 |
} else {
|
|
| 91 | 1x |
substitute(!is.na(varname), list(varname = private$get_varname_prefixed(dataname))) |
| 92 |
} |
|
| 93 |
} |
|
| 94 |
), |
|
| 95 | ||
| 96 |
# private members ---- |
|
| 97 |
private = list( |
|
| 98 |
cache_state = function() {
|
|
| 99 | ! |
private$cache <- private$get_state() |
| 100 | ! |
self$set_state( |
| 101 | ! |
list( |
| 102 | ! |
keep_na = NULL |
| 103 |
) |
|
| 104 |
) |
|
| 105 |
}, |
|
| 106 |
set_choices = function(choices) {
|
|
| 107 | 6x |
private$teal_slice$choices <- choices |
| 108 | 6x |
invisible(NULL) |
| 109 |
}, |
|
| 110 | ||
| 111 | ||
| 112 |
# Reports whether the current state filters out any values.(?) |
|
| 113 |
# @return `logical(1)` |
|
| 114 |
# |
|
| 115 |
is_any_filtered = function() {
|
|
| 116 | 2x |
if (private$is_choice_limited) {
|
| 117 | ! |
TRUE |
| 118 |
} else {
|
|
| 119 | 2x |
!isTRUE(private$get_keep_na()) |
| 120 |
} |
|
| 121 |
}, |
|
| 122 | ||
| 123 |
# @description |
|
| 124 |
# UI Module for `EmptyFilterState`. |
|
| 125 |
# This UI element contains a checkbox input to filter or keep missing values. |
|
| 126 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 127 |
# |
|
| 128 |
ui_inputs = function(id) {
|
|
| 129 | ! |
ns <- NS(id) |
| 130 | ! |
isolate({
|
| 131 | ! |
tags$div( |
| 132 | ! |
tags$span("Variable contains missing values only"),
|
| 133 | ! |
private$keep_na_ui(ns("keep_na"))
|
| 134 |
) |
|
| 135 |
}) |
|
| 136 |
}, |
|
| 137 | ||
| 138 |
# @description |
|
| 139 |
# Controls state of the `keep_na` checkbox input. |
|
| 140 |
# |
|
| 141 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 142 |
# |
|
| 143 |
# @return `NULL`. |
|
| 144 |
# |
|
| 145 |
server_inputs = function(id) {
|
|
| 146 | ! |
moduleServer( |
| 147 | ! |
id = id, |
| 148 | ! |
function(input, output, session) {
|
| 149 | ! |
private$keep_na_srv("keep_na")
|
| 150 |
} |
|
| 151 |
) |
|
| 152 |
}, |
|
| 153 |
server_inputs_fixed = function(id) {
|
|
| 154 | ! |
moduleServer( |
| 155 | ! |
id = id, |
| 156 | ! |
function(input, output, session) {
|
| 157 | ! |
output$selection <- renderUI({
|
| 158 | ! |
tags$span("Variable contains missing values only")
|
| 159 |
}) |
|
| 160 | ! |
NULL |
| 161 |
} |
|
| 162 |
) |
|
| 163 |
}, |
|
| 164 | ||
| 165 |
# @description |
|
| 166 |
# Server module to display filter summary |
|
| 167 |
# Doesn't render anything |
|
| 168 |
content_summary = function(id) {
|
|
| 169 | ! |
tags$span("All empty")
|
| 170 |
} |
|
| 171 |
) |
|
| 172 |
) |
| 1 |
#' Initialize `FilterState` |
|
| 2 |
#' |
|
| 3 |
#' Initializes a `FilterState` object corresponding to the class of the filtered variable. |
|
| 4 |
#' |
|
| 5 |
#' @param x (`vector`) |
|
| 6 |
#' variable to be filtered. |
|
| 7 |
#' @param x_reactive (`reactive`) |
|
| 8 |
#' returning vector of the same type as `x`. Is used to update |
|
| 9 |
#' counts following the change in values of the filtered dataset. |
|
| 10 |
#' If it is set to `reactive(NULL)` then counts based on filtered |
|
| 11 |
#' dataset are not shown. |
|
| 12 |
#' @param slice (`teal_slice`) |
|
| 13 |
#' specification of this filter state. |
|
| 14 |
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 15 |
#' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 16 |
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|
| 17 |
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 18 |
#' @param extract_type (`character`) |
|
| 19 |
#' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 20 |
#' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 21 |
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 22 |
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 23 |
#' |
|
| 24 |
#' @examples |
|
| 25 |
#' # use non-exported function from teal.slice |
|
| 26 |
#' init_filter_state <- getFromNamespace("init_filter_state", "teal.slice")
|
|
| 27 |
#' |
|
| 28 |
#' library(shiny) |
|
| 29 |
#' |
|
| 30 |
#' filter_state <- init_filter_state( |
|
| 31 |
#' x = c(1:10, NA, Inf), |
|
| 32 |
#' x_reactive = reactive(c(1:10, NA, Inf)), |
|
| 33 |
#' slice = teal_slice( |
|
| 34 |
#' varname = "varname", |
|
| 35 |
#' dataname = "dataname" |
|
| 36 |
#' ), |
|
| 37 |
#' extract_type = "matrix" |
|
| 38 |
#' ) |
|
| 39 |
#' |
|
| 40 |
#' isolate(filter_state$get_call()) |
|
| 41 |
#' |
|
| 42 |
#' # working filter in an app |
|
| 43 |
#' |
|
| 44 |
#' ui <- bslib::page_fluid( |
|
| 45 |
#' filter_state$ui(id = "app"), |
|
| 46 |
#' verbatimTextOutput("call")
|
|
| 47 |
#' ) |
|
| 48 |
#' server <- function(input, output, session) {
|
|
| 49 |
#' filter_state$server("app")
|
|
| 50 |
#' |
|
| 51 |
#' output$call <- renderText( |
|
| 52 |
#' deparse1(filter_state$get_call(), collapse = "\n") |
|
| 53 |
#' ) |
|
| 54 |
#' } |
|
| 55 |
#' |
|
| 56 |
#' if (interactive()) {
|
|
| 57 |
#' shinyApp(ui, server) |
|
| 58 |
#' } |
|
| 59 |
#' |
|
| 60 |
#' @return `FilterState` object |
|
| 61 |
#' @keywords internal |
|
| 62 |
init_filter_state <- function(x, |
|
| 63 |
x_reactive = reactive(NULL), |
|
| 64 |
slice, |
|
| 65 |
extract_type = character(0)) {
|
|
| 66 | 208x |
checkmate::assert_class(x_reactive, "reactive") |
| 67 | 207x |
checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE) |
| 68 | 207x |
checkmate::assert_class(slice, "teal_slice") |
| 69 | 206x |
if (length(extract_type) == 1) {
|
| 70 | 40x |
checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
|
| 71 |
} |
|
| 72 | ||
| 73 | 205x |
if (all(is.na(x))) {
|
| 74 | 1x |
EmptyFilterState$new( |
| 75 | 1x |
x = x, |
| 76 | 1x |
x_reactive = x_reactive, |
| 77 | 1x |
slice = slice, |
| 78 | 1x |
extract_type = extract_type |
| 79 |
) |
|
| 80 |
} else {
|
|
| 81 | 204x |
UseMethod("init_filter_state")
|
| 82 |
} |
|
| 83 |
} |
|
| 84 | ||
| 85 |
#' @keywords internal |
|
| 86 |
#' @export |
|
| 87 |
init_filter_state.default <- function(x, |
|
| 88 |
x_reactive = reactive(NULL), |
|
| 89 |
slice, |
|
| 90 |
extract_type = character(0)) {
|
|
| 91 | 1x |
args <- list( |
| 92 | 1x |
x = x, |
| 93 | 1x |
x_reactive = x_reactive, |
| 94 | 1x |
extract_type = extract_type, |
| 95 | 1x |
slice |
| 96 |
) |
|
| 97 | ||
| 98 | 1x |
do.call(FilterState$new, args) |
| 99 |
} |
|
| 100 | ||
| 101 |
#' @keywords internal |
|
| 102 |
#' @export |
|
| 103 |
init_filter_state.logical <- function(x, |
|
| 104 |
x_reactive = reactive(NULL), |
|
| 105 |
slice, |
|
| 106 |
extract_type = character(0)) {
|
|
| 107 | 1x |
LogicalFilterState$new( |
| 108 | 1x |
x = x, |
| 109 | 1x |
x_reactive = x_reactive, |
| 110 | 1x |
slice = slice, |
| 111 | 1x |
extract_type = extract_type |
| 112 |
) |
|
| 113 |
} |
|
| 114 | ||
| 115 |
#' @keywords internal |
|
| 116 |
#' @export |
|
| 117 |
init_filter_state.numeric <- function(x, |
|
| 118 |
x_reactive = reactive(NULL), |
|
| 119 |
slice, |
|
| 120 |
extract_type = character(0)) {
|
|
| 121 | 118x |
args <- list( |
| 122 | 118x |
x = x, |
| 123 | 118x |
x_reactive = x_reactive, |
| 124 | 118x |
slice = slice, |
| 125 | 118x |
extract_type = extract_type |
| 126 |
) |
|
| 127 | ||
| 128 | 118x |
if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
|
| 129 | 28x |
do.call(ChoicesFilterState$new, args) |
| 130 |
} else {
|
|
| 131 | 90x |
do.call(RangeFilterState$new, args) |
| 132 |
} |
|
| 133 |
} |
|
| 134 | ||
| 135 |
#' @keywords internal |
|
| 136 |
#' @export |
|
| 137 |
init_filter_state.factor <- function(x, |
|
| 138 |
x_reactive = reactive(NULL), |
|
| 139 |
slice, |
|
| 140 |
extract_type = character(0)) {
|
|
| 141 | 44x |
ChoicesFilterState$new( |
| 142 | 44x |
x = x, |
| 143 | 44x |
x_reactive = x_reactive, |
| 144 | 44x |
slice = slice, |
| 145 | 44x |
extract_type = extract_type |
| 146 |
) |
|
| 147 |
} |
|
| 148 | ||
| 149 |
#' @keywords internal |
|
| 150 |
#' @export |
|
| 151 |
init_filter_state.character <- function(x, |
|
| 152 |
x_reactive = reactive(NULL), |
|
| 153 |
slice, |
|
| 154 |
extract_type = character(0)) {
|
|
| 155 | 32x |
ChoicesFilterState$new( |
| 156 | 32x |
x = x, |
| 157 | 32x |
x_reactive = x_reactive, |
| 158 | 32x |
slice = slice, |
| 159 | 32x |
extract_type = extract_type |
| 160 |
) |
|
| 161 |
} |
|
| 162 | ||
| 163 |
#' @keywords internal |
|
| 164 |
#' @export |
|
| 165 |
init_filter_state.Date <- function(x, |
|
| 166 |
x_reactive = reactive(NULL), |
|
| 167 |
slice, |
|
| 168 |
extract_type = character(0)) {
|
|
| 169 | 4x |
args <- list( |
| 170 | 4x |
x = x, |
| 171 | 4x |
x_reactive = x_reactive, |
| 172 | 4x |
slice = slice, |
| 173 | 4x |
extract_type = extract_type |
| 174 |
) |
|
| 175 | ||
| 176 | 4x |
if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
|
| 177 | 1x |
do.call(ChoicesFilterState$new, args) |
| 178 |
} else {
|
|
| 179 | 3x |
do.call(DateFilterState$new, args) |
| 180 |
} |
|
| 181 |
} |
|
| 182 | ||
| 183 |
#' @keywords internal |
|
| 184 |
#' @export |
|
| 185 |
init_filter_state.POSIXct <- function(x, |
|
| 186 |
x_reactive = reactive(NULL), |
|
| 187 |
slice, |
|
| 188 |
extract_type = character(0)) {
|
|
| 189 | 2x |
args <- list( |
| 190 | 2x |
x = x, |
| 191 | 2x |
x_reactive = x_reactive, |
| 192 | 2x |
slice = slice, |
| 193 | 2x |
extract_type = extract_type |
| 194 |
) |
|
| 195 | ||
| 196 | 2x |
if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
|
| 197 | 1x |
do.call(ChoicesFilterState$new, args) |
| 198 |
} else {
|
|
| 199 | 1x |
do.call(DatetimeFilterState$new, args) |
| 200 |
} |
|
| 201 |
} |
|
| 202 | ||
| 203 |
#' @keywords internal |
|
| 204 |
#' @export |
|
| 205 |
init_filter_state.POSIXlt <- function(x, |
|
| 206 |
x_reactive = reactive(NULL), |
|
| 207 |
slice, |
|
| 208 |
extract_type = character(0)) {
|
|
| 209 | 2x |
args <- list( |
| 210 | 2x |
x = x, |
| 211 | 2x |
x_reactive = x_reactive, |
| 212 | 2x |
slice = slice, |
| 213 | 2x |
extract_type = extract_type |
| 214 |
) |
|
| 215 | ||
| 216 | 2x |
if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
|
| 217 | 1x |
do.call(ChoicesFilterState$new, args) |
| 218 |
} else {
|
|
| 219 | 1x |
do.call(DatetimeFilterState$new, args) |
| 220 |
} |
|
| 221 |
} |
|
| 222 | ||
| 223 | ||
| 224 |
#' Initialize a `FilterStateExpr` object |
|
| 225 |
#' |
|
| 226 |
#' @param slice (`teal_slice_expr`) |
|
| 227 |
#' specifying this filter state. |
|
| 228 |
#' |
|
| 229 |
#' @return `FilterStateExpr` object |
|
| 230 |
#' @keywords internal |
|
| 231 |
init_filter_state_expr <- function(slice) {
|
|
| 232 | 13x |
FilterStateExpr$new(slice) |
| 233 |
} |
|
| 234 | ||
| 235 | ||
| 236 |
#' Get hex code of the current Bootstrap theme color. |
|
| 237 |
#' |
|
| 238 |
#' Determines the color specification for the currently active Bootstrap color theme and returns one queried color. |
|
| 239 |
#' |
|
| 240 |
#' @param color (`character(1)`) naming one of the available theme colors |
|
| 241 |
#' @param alpha either a `numeric(1)` or `character(1)` specifying transparency |
|
| 242 |
#' in the range of `0-1` or a hexadecimal value `00-ff`, respectively; |
|
| 243 |
#' set to NULL to omit adding the alpha channel |
|
| 244 |
#' |
|
| 245 |
#' @return Named `character(1)` containing a hexadecimal color representation. |
|
| 246 |
#' |
|
| 247 |
#' @examples |
|
| 248 |
#' fetch_bs_color <- getFromNamespace("fetch_bs_color", "teal.slice")
|
|
| 249 |
#' fetch_bs_color("primary")
|
|
| 250 |
#' fetch_bs_color("danger", 0.35)
|
|
| 251 |
#' fetch_bs_color("danger", "80")
|
|
| 252 |
#' |
|
| 253 |
#' @keywords internal |
|
| 254 |
#' |
|
| 255 |
fetch_bs_color <- function(color, alpha = NULL) {
|
|
| 256 | 118x |
checkmate::assert_string(color) |
| 257 | 118x |
checkmate::assert( |
| 258 | 118x |
checkmate::check_number(alpha, lower = 0, upper = 1, null.ok = TRUE), |
| 259 | 118x |
checkmate::check_string(alpha, pattern = "[0-9a-f]{2}", null.ok = TRUE)
|
| 260 |
) |
|
| 261 | ||
| 262 |
# locate file that describes the current theme |
|
| 263 | 118x |
sass_file <- if (utils::packageVersion("bslib") < as.package_version("0.5.1.9000")) {
|
| 264 | ! |
bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]] |
| 265 |
} else {
|
|
| 266 | 118x |
bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]][[1]] |
| 267 |
} |
|
| 268 | 118x |
sass_file <- attr(sass_file, "sass_file_path") |
| 269 | ||
| 270 |
# load scss file that encodes variables |
|
| 271 | 118x |
variables_file <- readLines(sass_file) |
| 272 |
# locate theme color variables |
|
| 273 | 118x |
ind <- grep("// scss-docs-(start|end) theme-color-variables", variables_file)
|
| 274 | 118x |
color_definitions <- variables_file[(ind[1] + 1L):(ind[2] - 1L)] |
| 275 | ||
| 276 |
# extract colors names |
|
| 277 | 118x |
color_names <- sub("(\\$)(\\w.+)(:.+)", "\\2", color_definitions)
|
| 278 | ||
| 279 |
# verify that an available color was requested |
|
| 280 | 118x |
checkmate::assert_choice(color, color_names) |
| 281 | ||
| 282 |
# extract color references |
|
| 283 | 118x |
color_references <- sub("(\\$)(\\w.+)(:\\s.+\\$)(\\w.+)(\\s.+)", "\\4", color_definitions)
|
| 284 | ||
| 285 |
# translate references to color codes |
|
| 286 | 118x |
color_specification <- structure(color_references, names = color_names) |
| 287 | 118x |
color_specification <- vapply(color_specification, function(x) {
|
| 288 | 944x |
line <- grep(sprintf("^\\$%s:\\s+#\\w{6}\\s+!default", x), variables_file, value = TRUE)
|
| 289 | 944x |
code <- sub("(.+)(#\\w{6})(\\s+.+)", "\\2", line)
|
| 290 | 944x |
code |
| 291 | 118x |
}, character(1L)) |
| 292 | ||
| 293 | 118x |
if (!is.null(alpha)) {
|
| 294 | ! |
if (is.numeric(alpha)) alpha <- as.hexmode(ceiling(255 * alpha)) |
| 295 |
} |
|
| 296 | ||
| 297 | 118x |
paste0(color_specification[color], alpha) |
| 298 |
} |
| 1 |
# FilterState ------ |
|
| 2 | ||
| 3 |
#' @name FilterState |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterState` abstract class |
|
| 7 |
#' |
|
| 8 |
#' @description Abstract class to encapsulate single filter state. |
|
| 9 |
#' |
|
| 10 |
#' @details |
|
| 11 |
#' This class is responsible for managing a single filter item within a `FilteredData` object |
|
| 12 |
#' and outputs a condition call (logical predicate) for subsetting one variable. |
|
| 13 |
#' Filter states depend on the variable type: |
|
| 14 |
#' (`logical`, `integer`, `numeric`, `character`, `factor`, `Date`, `POSIXct`, `POSIXlt`) |
|
| 15 |
#' and `FilterState` subclasses exist that correspond to those types. |
|
| 16 |
#' - `logical`: `class = LogicalFilterState` |
|
| 17 |
#' - `integer`: `class = RangeFilterState` |
|
| 18 |
#' - `numeric`: `class = RangeFilterState` |
|
| 19 |
#' - `character`: `class = ChoicesFilterState` |
|
| 20 |
#' - `factor`: `class = ChoicesFilterState` |
|
| 21 |
#' - `Date`: `class = DateFilterState` |
|
| 22 |
#' - `POSIXct`, `POSIXlt`: `class = DatetimeFilterState` |
|
| 23 |
#' - all `NA` entries: `class: FilterState`, cannot be filtered |
|
| 24 |
#' - default: `FilterState`, cannot be filtered |
|
| 25 |
#' |
|
| 26 |
#' Each variable's filter state is an `R6` object keeps the variable that is filtered, |
|
| 27 |
#' a `teal_slice` object that describes the filter state, as well as a `shiny` module (UI and server) |
|
| 28 |
#' that allows the user to alter the filter state. |
|
| 29 |
#' Changes to the filter state that cause some observations to be omitted |
|
| 30 |
#' trigger the `get_call` method and every `R` function call up in the reactive chain. |
|
| 31 |
#' |
|
| 32 |
#' @section Modifying state: |
|
| 33 |
#' Modifying a `FilterState` object is possible in three scenarios: |
|
| 34 |
#' - In an interactive session, by passing an appropriate `teal_slice` to the `set_state` method. |
|
| 35 |
#' - In a running application, by changing appropriate inputs. |
|
| 36 |
#' - In a running application, by using [filter_state_api] which directly uses |
|
| 37 |
#' `set_state` method of the `FilterState` object. |
|
| 38 |
#' |
|
| 39 |
#' @keywords internal |
|
| 40 |
#' |
|
| 41 |
FilterState <- R6::R6Class( # nolint |
|
| 42 |
"FilterState", |
|
| 43 | ||
| 44 |
# public methods ---- |
|
| 45 |
public = list( |
|
| 46 | ||
| 47 |
#' @description |
|
| 48 |
#' Initialize a `FilterState` object. |
|
| 49 |
#' |
|
| 50 |
#' @param x (`vector`) |
|
| 51 |
#' variable to be filtered. |
|
| 52 |
#' @param x_reactive (`reactive`) |
|
| 53 |
#' returning vector of the same type as `x`. Is used to update |
|
| 54 |
#' counts following the change in values of the filtered dataset. |
|
| 55 |
#' If it is set to `reactive(NULL)` then counts based on filtered |
|
| 56 |
#' dataset are not shown. |
|
| 57 |
#' @param slice (`teal_slice`) |
|
| 58 |
#' specification of this filter state. |
|
| 59 |
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 60 |
#' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 61 |
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|
| 62 |
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 63 |
#' @param extract_type (`character`) |
|
| 64 |
#' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 65 |
#' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 66 |
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 67 |
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 68 |
#' |
|
| 69 |
#' @return Object of class `FilterState`, invisibly. |
|
| 70 |
#' |
|
| 71 |
initialize = function(x, |
|
| 72 |
x_reactive = reactive(NULL), |
|
| 73 |
slice, |
|
| 74 |
extract_type = character(0)) {
|
|
| 75 | 385x |
isolate({
|
| 76 | 385x |
checkmate::assert_class(x_reactive, "reactive") |
| 77 | 384x |
checkmate::assert_class(slice, "teal_slice") |
| 78 | 382x |
checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE) |
| 79 | 382x |
if (length(extract_type) == 1) {
|
| 80 | 50x |
checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
|
| 81 |
} |
|
| 82 | 381x |
logger::log_debug("{ class(self)[1] } initializing for slice: { slice$id }")
|
| 83 | ||
| 84 |
# Set data properties. |
|
| 85 | 381x |
private$x <- x |
| 86 | 381x |
private$x_reactive <- x_reactive |
| 87 |
# Set derived data properties. |
|
| 88 | 381x |
private$na_count <- sum(is.na(x)) |
| 89 | 381x |
private$filtered_na_count <- reactive( |
| 90 | 381x |
if (!is.null(private$x_reactive())) {
|
| 91 | ! |
sum(is.na(private$x_reactive())) |
| 92 |
} |
|
| 93 |
) |
|
| 94 |
# Set extract type. |
|
| 95 | 381x |
private$extract_type <- extract_type |
| 96 | ||
| 97 |
# Set state properties. |
|
| 98 | 19x |
if (is.null(isolate(slice$keep_na)) && anyNA(x)) slice$keep_na <- TRUE |
| 99 | 381x |
private$teal_slice <- slice |
| 100 |
# Obtain variable label. |
|
| 101 | 381x |
varlabel <- attr(x, "label", exact = TRUE) |
| 102 |
# Display only when different from varname. |
|
| 103 | 381x |
private$varlabel <- |
| 104 | 381x |
if (is.null(varlabel) || identical(varlabel, private$get_varname())) {
|
| 105 | 380x |
character(0) |
| 106 |
} else {
|
|
| 107 | 1x |
varlabel |
| 108 |
} |
|
| 109 | ||
| 110 | 381x |
private$state_history <- reactiveVal(list()) |
| 111 | ||
| 112 | 381x |
invisible(self) |
| 113 |
}) |
|
| 114 |
}, |
|
| 115 | ||
| 116 |
#' @description Destroys a `FilterState` object. |
|
| 117 | 87x |
destroy = function() private$finalize(), |
| 118 | ||
| 119 |
#' @description |
|
| 120 |
#' Returns a formatted string representing this `FilterState` object. |
|
| 121 |
#' |
|
| 122 |
#' @param show_all (`logical(1)`) passed to `format.teal_slice` |
|
| 123 |
#' @param trim_lines (`logical(1)`) passed to `format.teal_slice` |
|
| 124 |
#' |
|
| 125 |
#' @return `character(1)` the formatted string |
|
| 126 |
#' |
|
| 127 |
format = function(show_all = FALSE, trim_lines = TRUE) {
|
|
| 128 | 68x |
sprintf( |
| 129 | 68x |
"%s:\n%s", |
| 130 | 68x |
class(self)[1], |
| 131 | 68x |
format(self$get_state(), show_all = show_all, trim_lines = trim_lines) |
| 132 |
) |
|
| 133 |
}, |
|
| 134 | ||
| 135 |
#' @description |
|
| 136 |
#' Prints this `FilterState` object. |
|
| 137 |
#' |
|
| 138 |
#' @param ... additional arguments |
|
| 139 |
#' |
|
| 140 |
print = function(...) {
|
|
| 141 | 14x |
cat(isolate(self$format(...))) |
| 142 |
}, |
|
| 143 | ||
| 144 |
#' @description |
|
| 145 |
#' Sets mutable parameters of the filter state. |
|
| 146 |
#' - `fixed` state is prevented from changing state |
|
| 147 |
#' - `anchored` state is prevented from removing state |
|
| 148 |
#' |
|
| 149 |
#' @param state (`teal_slice`) |
|
| 150 |
#' |
|
| 151 |
#' @return `self` invisibly |
|
| 152 |
#' |
|
| 153 |
set_state = function(state) {
|
|
| 154 | 94x |
if (identical(state, private$slice)) {
|
| 155 | ! |
return(self) |
| 156 |
} |
|
| 157 | 93x |
isolate({
|
| 158 | 93x |
checkmate::assert_class(state, "teal_slice") |
| 159 | 93x |
if (private$is_fixed()) {
|
| 160 | 1x |
warning("attempt to set state on fixed filter aborted id: ", private$get_id())
|
| 161 |
} else {
|
|
| 162 | 92x |
logger::log_debug("{ class(self)[1] }$set_state setting state of filter id: { private$get_id() }")
|
| 163 | 92x |
if (!is.null(state$selected)) {
|
| 164 | 83x |
private$set_selected(state$selected) |
| 165 |
} |
|
| 166 | 80x |
if (!is.null(state$keep_na)) {
|
| 167 | 16x |
private$set_keep_na(state$keep_na) |
| 168 |
} |
|
| 169 | 80x |
if (!is.null(state$keep_inf)) {
|
| 170 | 9x |
private$set_keep_inf(state$keep_inf) |
| 171 |
} |
|
| 172 | 80x |
current_state <- sprintf( |
| 173 | 80x |
"selected: %s; keep_na: %s; keep_inf: %s", |
| 174 | 80x |
toString(private$get_selected()), |
| 175 | 80x |
private$get_keep_na(), |
| 176 | 80x |
private$get_keep_inf() |
| 177 |
) |
|
| 178 |
} |
|
| 179 | ||
| 180 | 81x |
invisible(self) |
| 181 |
}) |
|
| 182 |
}, |
|
| 183 | ||
| 184 | ||
| 185 |
#' @description |
|
| 186 |
#' Returns a complete description of the filter state. |
|
| 187 |
#' |
|
| 188 |
#' @return A `teal_slice` object. |
|
| 189 |
#' |
|
| 190 |
get_state = function() {
|
|
| 191 | 1093x |
private$teal_slice |
| 192 |
}, |
|
| 193 | ||
| 194 |
#' @description |
|
| 195 |
#' Returns reproducible condition call for current selection relevant |
|
| 196 |
#' for selected variable type. |
|
| 197 |
#' Method is using internal reactive values which makes it reactive |
|
| 198 |
#' and must be executed in reactive or isolated context. |
|
| 199 |
#' |
|
| 200 |
get_call = function() {
|
|
| 201 | 1x |
stop("this is a virtual method")
|
| 202 |
}, |
|
| 203 | ||
| 204 |
#' @description |
|
| 205 |
#' `shiny` module server. |
|
| 206 |
#' |
|
| 207 |
#' @param id (`character(1)`) |
|
| 208 |
#' `shiny` module instance id. |
|
| 209 |
#' |
|
| 210 |
#' @param remove_callback (`function`) |
|
| 211 |
#' callback to handle removal of this `FilterState` object from `state_list` |
|
| 212 |
#' |
|
| 213 |
#' @return Reactive expression signaling that remove button has been clicked. |
|
| 214 |
#' |
|
| 215 |
server = function(id, remove_callback) {
|
|
| 216 | 28x |
moduleServer( |
| 217 | 28x |
id = id, |
| 218 | 28x |
function(input, output, session) {
|
| 219 | 28x |
logger::log_debug("{ class(self)[1] }$server initializing module for slice: { private$get_id() } ")
|
| 220 | 28x |
private$server_summary("summary")
|
| 221 | 28x |
if (private$is_fixed()) {
|
| 222 | 1x |
private$server_inputs_fixed("inputs")
|
| 223 |
} else {
|
|
| 224 | 27x |
private$server_inputs("inputs")
|
| 225 |
} |
|
| 226 | ||
| 227 | 28x |
private$session_bindings[[session$ns("state")]] <- observeEvent(
|
| 228 | 28x |
eventExpr = list(private$get_selected(), private$get_keep_na(), private$get_keep_inf()), |
| 229 | 28x |
handlerExpr = {
|
| 230 | 28x |
current_state <- as.list(self$get_state()) |
| 231 | 28x |
history <- private$state_history() |
| 232 | 28x |
history_update <- c(history, list(current_state)) |
| 233 | 28x |
private$state_history(history_update) |
| 234 |
} |
|
| 235 |
) |
|
| 236 | ||
| 237 | 28x |
private$session_bindings[[session$ns("back")]] <- observeEvent(
|
| 238 | 28x |
eventExpr = input$back, |
| 239 | 28x |
handlerExpr = {
|
| 240 | 1x |
history <- rev(private$state_history()) |
| 241 | 1x |
slice <- history[[2L]] |
| 242 | 1x |
history_update <- rev(history[-(1:2)]) |
| 243 | 1x |
private$state_history(history_update) |
| 244 | 1x |
self$set_state(as.teal_slice(slice)) |
| 245 |
} |
|
| 246 |
) |
|
| 247 | ||
| 248 | 28x |
private$session_bindings[[session$ns("reset")]] <- observeEvent(
|
| 249 | 28x |
eventExpr = input$reset, |
| 250 | 28x |
handlerExpr = {
|
| 251 | 1x |
slice <- private$state_history()[[1L]] |
| 252 | 1x |
self$set_state(as.teal_slice(slice)) |
| 253 |
} |
|
| 254 |
) |
|
| 255 | ||
| 256 |
# Buttons for rewind/reset are disabled upon change in history to prevent double-clicking. |
|
| 257 |
# Re-enabling occurs after 100 ms, after they are potentially hidden when no history is present. |
|
| 258 | 28x |
private$session_bindings[[session$ns("state_history")]] <- observeEvent(
|
| 259 | 28x |
eventExpr = private$state_history(), |
| 260 | 28x |
handlerExpr = {
|
| 261 | 29x |
shinyjs::disable(id = "back") |
| 262 | 29x |
shinyjs::disable(id = "reset") |
| 263 | 29x |
shinyjs::delay( |
| 264 | 29x |
ms = 100, |
| 265 | 29x |
expr = {
|
| 266 | ! |
shinyjs::toggleElement(id = "back", condition = length(private$state_history()) > 1L) |
| 267 | ! |
shinyjs::enable(id = "back") |
| 268 |
} |
|
| 269 |
) |
|
| 270 | 29x |
shinyjs::delay( |
| 271 | 29x |
ms = 100, |
| 272 | 29x |
expr = {
|
| 273 | ! |
shinyjs::toggleElement(id = "reset", condition = length(private$state_history()) > 1L) |
| 274 | ! |
shinyjs::enable(id = "reset") |
| 275 |
} |
|
| 276 |
) |
|
| 277 |
} |
|
| 278 |
) |
|
| 279 | ||
| 280 | 28x |
private$session_bindings[[session$ns("remove")]] <- observeEvent(
|
| 281 | 28x |
once = TRUE, # remove button can be called once, should be destroyed afterwards |
| 282 | 28x |
ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI |
| 283 | 28x |
eventExpr = input$remove, # when remove button is clicked in the FilterState ui |
| 284 | 28x |
handlerExpr = remove_callback() |
| 285 |
) |
|
| 286 | ||
| 287 | 28x |
private$session_bindings[[session$ns("inputs")]] <- list(
|
| 288 | 28x |
destroy = function() {
|
| 289 | 50x |
logger::log_debug("Destroying { class(self)[1] } inputs and observers; id: { private$get_id() }")
|
| 290 | 50x |
lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) |
| 291 |
} |
|
| 292 |
) |
|
| 293 | ||
| 294 | 28x |
private$state_history <- reactiveVal(list()) |
| 295 | ||
| 296 | 28x |
NULL |
| 297 |
} |
|
| 298 |
) |
|
| 299 |
}, |
|
| 300 | ||
| 301 |
#' @description |
|
| 302 |
#' `shiny` UI module. |
|
| 303 |
#' The UI for this class contains simple message stating that it is not supported. |
|
| 304 |
#' @param id (`character(1)`) |
|
| 305 |
#' `shiny` module instance id. |
|
| 306 |
#' @param parent_id (`character(1)`) id of the `FilterStates` card container |
|
| 307 |
ui = function(id, parent_id = "cards") {
|
|
| 308 | 28x |
ns <- NS(id) |
| 309 | ||
| 310 |
# Filter card consists of header and body, arranged in a single column. |
|
| 311 |
# Body is hidden and is toggled by clicking on header. |
|
| 312 |
## Header consists of title and summary, arranged in a column. |
|
| 313 |
### Title consists of conditional icon, varname, conditional varlabel, and controls, arranged in a row. |
|
| 314 |
### Summary consists of value and controls, arranged in a row. |
|
| 315 | ||
| 316 | 28x |
tags$div( |
| 317 | 28x |
id = id, |
| 318 | 28x |
class = "teal-slice filter-card", |
| 319 | 28x |
include_js_files("count-bar-labels.js"),
|
| 320 | 28x |
tags$div( |
| 321 | 28x |
class = "filter-card-header", |
| 322 | 28x |
`data-toggle` = "collapse", |
| 323 | 28x |
`data-bs-toggle` = "collapse", |
| 324 | 28x |
href = paste0("#", ns("body")),
|
| 325 | 28x |
tags$div( |
| 326 | 28x |
class = "teal-slice filter-card-title", |
| 327 | 28x |
if (private$is_anchored() && private$is_fixed()) {
|
| 328 | ! |
icon("anchor-lock", class = "teal-slice filter-card-icon")
|
| 329 | 28x |
} else if (private$is_anchored() && !private$is_fixed()) {
|
| 330 | ! |
icon("anchor", class = "teal-slice filter-card-icon")
|
| 331 | 28x |
} else if (!private$is_anchored() && private$is_fixed()) {
|
| 332 | 1x |
icon("lock", class = "teal-slice filter-card-icon")
|
| 333 |
}, |
|
| 334 | 28x |
tags$div(class = "teal-slice filter-card-varname", tags$strong(private$get_varname())), |
| 335 | 28x |
tags$div(class = "teal-slice filter-card-varlabel", private$get_varlabel()), |
| 336 | 28x |
tags$div( |
| 337 | 28x |
class = "teal-slice filter-card-controls", |
| 338 |
# Suppress toggling body when clicking on this div. |
|
| 339 |
# This is for bootstrap 3 and 4. Causes page to scroll to top, prevented by setting href on buttons. |
|
| 340 | 28x |
onclick = "event.stopPropagation();event.preventDefault();", |
| 341 |
# This is for bootstrap 5. |
|
| 342 | 28x |
`data-bs-toggle` = "collapse", |
| 343 | 28x |
`data-bs-target` = NULL, |
| 344 | 28x |
if (isFALSE(private$is_fixed())) {
|
| 345 | 27x |
actionLink( |
| 346 | 27x |
inputId = ns("back"),
|
| 347 | 27x |
label = NULL, |
| 348 | 27x |
icon = icon("far fa-circle-arrow-left"),
|
| 349 | 27x |
title = "Rewind state", |
| 350 | 27x |
class = "filter-card-back", |
| 351 | 27x |
style = "display: none" |
| 352 |
) |
|
| 353 |
}, |
|
| 354 | 28x |
if (isFALSE(private$is_fixed())) {
|
| 355 | 27x |
actionLink( |
| 356 | 27x |
inputId = ns("reset"),
|
| 357 | 27x |
label = NULL, |
| 358 | 27x |
icon = icon("far fa-circle-arrow-up"),
|
| 359 | 27x |
title = "Restore original state", |
| 360 | 27x |
class = "filter-card-back", |
| 361 | 27x |
style = "display: none" |
| 362 |
) |
|
| 363 |
}, |
|
| 364 | 28x |
if (isFALSE(private$is_anchored())) {
|
| 365 | 28x |
actionLink( |
| 366 | 28x |
inputId = ns("remove"),
|
| 367 | 28x |
label = icon("far fa-circle-xmark"),
|
| 368 | 28x |
title = "Remove filter", |
| 369 | 28x |
class = "teal-slice filter-icon" |
| 370 |
) |
|
| 371 |
} |
|
| 372 |
) |
|
| 373 |
), |
|
| 374 | 28x |
tags$div(class = "teal-slice filter-card-summary", private$ui_summary(ns("summary")))
|
| 375 |
), |
|
| 376 | 28x |
tags$div( |
| 377 | 28x |
id = ns("body"),
|
| 378 | 28x |
class = "collapse out", |
| 379 | 28x |
`data-parent` = paste0("#", parent_id),
|
| 380 | 28x |
`data-bs-parent` = paste0("#", parent_id),
|
| 381 | 28x |
tags$div( |
| 382 | 28x |
class = "teal-slice filter-card-body", |
| 383 | 28x |
if (private$is_fixed()) {
|
| 384 | 1x |
private$ui_inputs_fixed(ns("inputs"))
|
| 385 |
} else {
|
|
| 386 | 27x |
private$ui_inputs(ns("inputs"))
|
| 387 |
} |
|
| 388 |
) |
|
| 389 |
) |
|
| 390 |
) |
|
| 391 |
} |
|
| 392 |
), |
|
| 393 | ||
| 394 |
# private members ---- |
|
| 395 |
private = list( |
|
| 396 |
# set by constructor |
|
| 397 |
x = NULL, # the filtered variable |
|
| 398 |
x_reactive = NULL, # reactive containing the filtered variable, used for updating counts and histograms |
|
| 399 |
teal_slice = NULL, # stores all transferable properties of this filter state |
|
| 400 |
extract_type = character(0), # used by private$get_varname_prefixed |
|
| 401 |
na_count = integer(0), |
|
| 402 |
filtered_na_count = NULL, # reactive containing the count of NA in the filtered dataset |
|
| 403 |
varlabel = character(0), # taken from variable labels in data; displayed in filter cards |
|
| 404 |
# other |
|
| 405 |
is_choice_limited = FALSE, # flag whether number of possible choices was limited when specifying filter |
|
| 406 |
session_bindings = list(), # stores observers and inputs to destroy afterwards |
|
| 407 |
state_history = NULL, # reactiveVal holding a list storing states this FilterState has had since instantiation |
|
| 408 | ||
| 409 |
# private methods ---- |
|
| 410 | ||
| 411 |
# setters for state features ---- |
|
| 412 | ||
| 413 |
# @description |
|
| 414 |
# Set values that can be selected from. |
|
| 415 |
set_choices = function(choices) {
|
|
| 416 | ! |
stop("this is a virtual method")
|
| 417 |
}, |
|
| 418 | ||
| 419 |
# @description |
|
| 420 |
# Set selection. |
|
| 421 |
# |
|
| 422 |
# @param value (`vector`) |
|
| 423 |
# value(s) that come from filter selection; values are set in the |
|
| 424 |
# module server after a selection is made in the app interface; |
|
| 425 |
# values are stored in `teal_slice$selected` which is reactive; |
|
| 426 |
# value types have to be the same as `private$get_choices()` |
|
| 427 |
# |
|
| 428 |
# @return `NULL`, invisibly. |
|
| 429 |
set_selected = function(value) {
|
|
| 430 | 447x |
isolate({
|
| 431 | 447x |
value <- private$cast_and_validate(value) |
| 432 | 436x |
value <- private$check_length(value) |
| 433 | 430x |
value <- private$remove_out_of_bounds_values(value) |
| 434 | 430x |
if (!identical(value, private$teal_slice$selected)) {
|
| 435 | 73x |
logger::log_debug("{ class(self)[1] }$set_selected setting selection for id: { private$get_id() }")
|
| 436 | 73x |
private$teal_slice$selected <- value |
| 437 |
} |
|
| 438 | 430x |
invisible(NULL) |
| 439 |
}) |
|
| 440 |
}, |
|
| 441 | ||
| 442 |
# @description |
|
| 443 |
# Sets `value` in `private$teal_slice$keep_na`. |
|
| 444 |
# |
|
| 445 |
# @param value (`logical(1)`) |
|
| 446 |
# corresponding to the state of a checkbox input in the `shiny` interface. |
|
| 447 |
# |
|
| 448 |
# @return `NULL`, invisibly. |
|
| 449 |
# |
|
| 450 |
set_keep_na = function(value) {
|
|
| 451 | 17x |
isolate({
|
| 452 | 17x |
checkmate::assert_flag(value) |
| 453 | 17x |
logger::log_debug("{ class(self)[1] }$set_keep_na sets for filter { private$get_id() } to { value }.")
|
| 454 | 17x |
if (!identical(value, private$teal_slice$keep_na)) {
|
| 455 | 6x |
private$teal_slice$keep_na <- value |
| 456 |
} |
|
| 457 | 17x |
invisible(NULL) |
| 458 |
}) |
|
| 459 |
}, |
|
| 460 | ||
| 461 |
# @description |
|
| 462 |
# Sets `value` in `private$teal_slice$keep_inf`. |
|
| 463 |
# |
|
| 464 |
# @param value (`logical(1)`) |
|
| 465 |
# corresponding to the state of a checkbox input in the `shiny` interface. |
|
| 466 |
# |
|
| 467 |
# @return `NULL`, invisibly. |
|
| 468 |
# |
|
| 469 |
set_keep_inf = function(value) {
|
|
| 470 | 9x |
isolate({
|
| 471 | 9x |
if (!identical(value, private$teal_slice$keep_inf)) {
|
| 472 | 4x |
checkmate::assert_flag(value) |
| 473 | 4x |
logger::log_debug( |
| 474 | 4x |
sprintf( |
| 475 | 4x |
"%s$set_keep_inf of filter %s set to %s", |
| 476 | 4x |
class(self)[1], |
| 477 | 4x |
private$get_id(), |
| 478 | 4x |
value |
| 479 |
) |
|
| 480 |
) |
|
| 481 | 4x |
private$teal_slice$keep_inf <- value |
| 482 |
} |
|
| 483 | 9x |
invisible(NULL) |
| 484 |
}) |
|
| 485 |
}, |
|
| 486 | ||
| 487 |
# getters for state features ---- |
|
| 488 | ||
| 489 |
# @description |
|
| 490 |
# Returns dataname. |
|
| 491 |
# @return `character(1)` |
|
| 492 |
get_dataname = function() {
|
|
| 493 | 88x |
isolate(private$teal_slice$dataname) |
| 494 |
}, |
|
| 495 | ||
| 496 |
# @description |
|
| 497 |
# Get variable name. |
|
| 498 |
# @return `character(1)` |
|
| 499 |
get_varname = function() {
|
|
| 500 | 185x |
isolate(private$teal_slice$varname) |
| 501 |
}, |
|
| 502 | ||
| 503 |
# @description |
|
| 504 |
# Get id of the teal_slice. |
|
| 505 |
# @return `character(1)` |
|
| 506 |
get_id = function() {
|
|
| 507 | 4x |
isolate(private$teal_slice$id) |
| 508 |
}, |
|
| 509 | ||
| 510 |
# @description |
|
| 511 |
# Get allowed values from `FilterState`. |
|
| 512 |
# @return |
|
| 513 |
# Vector describing the available choices. Return type depends on the `FilterState` subclass. |
|
| 514 |
get_choices = function() {
|
|
| 515 | 924x |
isolate(private$teal_slice$choices) |
| 516 |
}, |
|
| 517 | ||
| 518 |
# @description |
|
| 519 |
# Get selected values from `FilterState`. |
|
| 520 |
# @return |
|
| 521 |
# Vector describing the current selection. Return type depends on the `FilterState` subclass. |
|
| 522 |
get_selected = function() {
|
|
| 523 | 512x |
private$teal_slice$selected |
| 524 |
}, |
|
| 525 | ||
| 526 |
# @description |
|
| 527 |
# Returns current `keep_na` selection. |
|
| 528 |
# @return `logical(1)` |
|
| 529 |
get_keep_na = function() {
|
|
| 530 | 175x |
private$teal_slice$keep_na |
| 531 |
}, |
|
| 532 | ||
| 533 |
# @description |
|
| 534 |
# Returns current `keep_inf` selection. |
|
| 535 |
# @return (`logical(1)`) |
|
| 536 |
get_keep_inf = function() {
|
|
| 537 | 147x |
private$teal_slice$keep_inf |
| 538 |
}, |
|
| 539 | ||
| 540 |
# Check whether this filter is fixed (cannot be changed). |
|
| 541 |
# @return `logical(1)` |
|
| 542 |
is_fixed = function() {
|
|
| 543 | 233x |
isolate(isTRUE(private$teal_slice$fixed)) |
| 544 |
}, |
|
| 545 | ||
| 546 |
# Check whether this filter is anchored (cannot be removed). |
|
| 547 |
# @return `logical(1)` |
|
| 548 |
is_anchored = function() {
|
|
| 549 | 112x |
isolate(isTRUE(private$teal_slice$anchored)) |
| 550 |
}, |
|
| 551 | ||
| 552 |
# Check whether this filter is capable of selecting multiple values. |
|
| 553 |
# @return `logical(1)` |
|
| 554 |
is_multiple = function() {
|
|
| 555 | 271x |
isolate(isTRUE(private$teal_slice$multiple)) |
| 556 |
}, |
|
| 557 | ||
| 558 |
# other ---- |
|
| 559 | ||
| 560 |
# @description |
|
| 561 |
# Returns variable label. |
|
| 562 |
# @return `character(1)` |
|
| 563 |
get_varlabel = function() {
|
|
| 564 | 28x |
private$varlabel |
| 565 |
}, |
|
| 566 | ||
| 567 |
# @description |
|
| 568 |
# Return variable name prefixed by `dataname` to be evaluated as extracted object, for example `data$var` |
|
| 569 |
# @return Call that extracts the variable from the dataset. |
|
| 570 |
get_varname_prefixed = function(dataname) {
|
|
| 571 | 112x |
varname <- private$get_varname() |
| 572 | 112x |
varname_backticked <- sprintf("`%s`", varname)
|
| 573 | 112x |
ans <- |
| 574 | 112x |
if (isTRUE(private$extract_type == "list")) {
|
| 575 | 16x |
sprintf("%s$%s", dataname, varname_backticked)
|
| 576 | 112x |
} else if (isTRUE(private$extract_type == "matrix")) {
|
| 577 | 7x |
sprintf("%s[, \"%s\"]", dataname, varname)
|
| 578 |
} else {
|
|
| 579 | 89x |
varname_backticked |
| 580 |
} |
|
| 581 | 112x |
str2lang(ans) |
| 582 |
}, |
|
| 583 | ||
| 584 |
# @description |
|
| 585 |
# Adds `is.na(varname)` moiety to the existing condition call, according to `keep_na` status. |
|
| 586 |
# @param filter_call `call` raw filter call, as defined by selection |
|
| 587 |
# @param varname `character(1)` name of a variable |
|
| 588 |
# @return `call` |
|
| 589 |
add_keep_na_call = function(filter_call, varname) {
|
|
| 590 |
# No need to deal with NAs. |
|
| 591 | 111x |
if (private$na_count == 0L) {
|
| 592 | 90x |
return(filter_call) |
| 593 |
} |
|
| 594 | ||
| 595 | 21x |
if (is.null(filter_call) && isFALSE(private$get_keep_na())) {
|
| 596 | 2x |
call("!", call("is.na", varname))
|
| 597 | 19x |
} else if (!is.null(filter_call) && isTRUE(private$get_keep_na())) {
|
| 598 | 12x |
call("|", call("is.na", varname), filter_call)
|
| 599 | 7x |
} else if (!is.null(filter_call) && isFALSE(private$get_keep_na())) {
|
| 600 | 7x |
call("&", call("!", call("is.na", varname)), filter_call)
|
| 601 |
} |
|
| 602 |
}, |
|
| 603 | ||
| 604 |
# Converts values to the type fitting this `FilterState` and validates the conversion. |
|
| 605 |
# Raises error if casting does not execute successfully. |
|
| 606 |
# |
|
| 607 |
# @param values vector of values |
|
| 608 |
# |
|
| 609 |
# @return vector converted to appropriate class |
|
| 610 |
cast_and_validate = function(values) {
|
|
| 611 | 11x |
values |
| 612 |
}, |
|
| 613 | ||
| 614 |
# Checks length of selection. |
|
| 615 |
check_length = function(values) {
|
|
| 616 | 11x |
values |
| 617 |
}, |
|
| 618 | ||
| 619 |
# Filters out erroneous values from vector. |
|
| 620 |
# |
|
| 621 |
# @param values vector of values |
|
| 622 |
# |
|
| 623 |
# @return vector in which values that cannot be set in this FilterState have been dropped |
|
| 624 |
remove_out_of_bounds_values = function(values) {
|
|
| 625 | 31x |
values |
| 626 |
}, |
|
| 627 | ||
| 628 |
# Checks if the selection is valid in terms of class and length. |
|
| 629 |
# It should not return anything but raise an error if selection |
|
| 630 |
# has a wrong class or is outside of possible choices |
|
| 631 |
validate_selection = function(value) {
|
|
| 632 | ! |
invisible(NULL) |
| 633 |
}, |
|
| 634 | ||
| 635 |
# @description |
|
| 636 |
# Checks whether the current settings actually cause any values to be omitted. |
|
| 637 |
# @return logical scalar |
|
| 638 |
is_any_filtered = function() {
|
|
| 639 | 78x |
if (private$is_choice_limited) {
|
| 640 | 3x |
TRUE |
| 641 | 75x |
} else if (!setequal(private$get_selected(), private$get_choices())) {
|
| 642 | 62x |
TRUE |
| 643 | 13x |
} else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
|
| 644 | 4x |
TRUE |
| 645 |
} else {
|
|
| 646 | 9x |
FALSE |
| 647 |
} |
|
| 648 |
}, |
|
| 649 | ||
| 650 |
# shiny modules ----- |
|
| 651 | ||
| 652 |
# @description |
|
| 653 |
# Server module to display filter summary |
|
| 654 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 655 |
ui_summary = function(id) {
|
|
| 656 | 28x |
ns <- NS(id) |
| 657 | 28x |
uiOutput(ns("summary"), class = "teal-slice filter-card-summary")
|
| 658 |
}, |
|
| 659 | ||
| 660 |
# @description |
|
| 661 |
# UI module to display filter summary |
|
| 662 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 663 |
# @return Nothing. Renders the UI. |
|
| 664 |
server_summary = function(id) {
|
|
| 665 | 28x |
moduleServer( |
| 666 | 28x |
id = id, |
| 667 | 28x |
function(input, output, session) {
|
| 668 | 28x |
output$summary <- renderUI(private$content_summary()) |
| 669 |
} |
|
| 670 |
) |
|
| 671 |
}, |
|
| 672 | ||
| 673 |
# module with inputs |
|
| 674 |
ui_inputs = function(id) {
|
|
| 675 | ! |
stop("abstract class")
|
| 676 |
}, |
|
| 677 |
# module with inputs |
|
| 678 |
server_inputs = function(id) {
|
|
| 679 | ! |
stop("abstract class")
|
| 680 |
}, |
|
| 681 | ||
| 682 |
# @description |
|
| 683 |
# Module displaying inputs in a fixed filter state. |
|
| 684 |
# There are no input widgets, only selection visualizations. |
|
| 685 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 686 |
ui_inputs_fixed = function(id) {
|
|
| 687 | 1x |
ns <- NS(id) |
| 688 | 1x |
tags$div( |
| 689 | 1x |
class = "teal-slice choices-state", |
| 690 | 1x |
uiOutput(ns("selection"))
|
| 691 |
) |
|
| 692 |
}, |
|
| 693 | ||
| 694 |
# @description |
|
| 695 |
# Module creating the display of a fixed filter state. |
|
| 696 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 697 |
server_inputs_fixed = function(id) {
|
|
| 698 | ! |
stop("abstract class")
|
| 699 |
}, |
|
| 700 | ||
| 701 |
# @description |
|
| 702 |
# Module UI function displaying input to keep or remove NA in the `FilterState` call. |
|
| 703 |
# Renders a checkbox input only when variable with which `FilterState` has been created contains NAs. |
|
| 704 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 705 |
keep_na_ui = function(id) {
|
|
| 706 | 28x |
ns <- NS(id) |
| 707 | 28x |
if (private$na_count > 0) {
|
| 708 | 1x |
isolate({
|
| 709 | 1x |
countmax <- private$na_count |
| 710 | 1x |
countnow <- private$filtered_na_count() |
| 711 | 1x |
ui_input <- checkboxInput( |
| 712 | 1x |
inputId = ns("value"),
|
| 713 | 1x |
label = tags$span( |
| 714 | 1x |
id = ns("count_label"),
|
| 715 | 1x |
make_count_text( |
| 716 | 1x |
label = "Keep NA", |
| 717 | 1x |
countmax = countmax, |
| 718 | 1x |
countnow = countnow |
| 719 |
) |
|
| 720 |
), |
|
| 721 | 1x |
value = private$get_keep_na() |
| 722 |
) |
|
| 723 | 1x |
tags$div( |
| 724 | 1x |
uiOutput(ns("trigger_visible"), inline = TRUE),
|
| 725 | 1x |
ui_input |
| 726 |
) |
|
| 727 |
}) |
|
| 728 |
} else {
|
|
| 729 | 27x |
NULL |
| 730 |
} |
|
| 731 |
}, |
|
| 732 | ||
| 733 |
# @description |
|
| 734 |
# Module server function to handle NA values in the `FilterState`. |
|
| 735 |
# Sets `private$slice$keep_na` according to the selection |
|
| 736 |
# and updates the relevant UI element if `private$slice$keep_na` has been changed by the api. |
|
| 737 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 738 |
# @return `NULL`, invisibly. |
|
| 739 |
keep_na_srv = function(id) {
|
|
| 740 | 27x |
moduleServer(id, function(input, output, session) {
|
| 741 |
# 1. renderUI is used here as an observer which triggers only if output is visible |
|
| 742 |
# and if the reactive changes - reactive triggers only if the output is visible. |
|
| 743 |
# 2. We want to trigger change of the labels only if reactive count changes (not underlying data) |
|
| 744 | 27x |
output$trigger_visible <- renderUI({
|
| 745 | 27x |
updateCountText( |
| 746 | 27x |
inputId = "count_label", |
| 747 | 27x |
label = "Keep NA", |
| 748 | 27x |
countmax = private$na_count, |
| 749 | 27x |
countnow = private$filtered_na_count() |
| 750 |
) |
|
| 751 | 27x |
NULL |
| 752 |
}) |
|
| 753 | ||
| 754 |
# this observer is needed in the situation when private$keep_inf has been |
|
| 755 |
# changed directly by the api - then it's needed to rerender UI element |
|
| 756 |
# to show relevant values |
|
| 757 | 27x |
private$session_bindings[[session$ns("keep_na_api")]] <- observeEvent(
|
| 758 | 27x |
ignoreNULL = FALSE, # nothing selected is possible for NA |
| 759 | 27x |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 760 | 27x |
eventExpr = private$get_keep_na(), |
| 761 | 27x |
handlerExpr = {
|
| 762 | ! |
if (!setequal(private$get_keep_na(), input$value)) {
|
| 763 | ! |
logger::log_debug("{ class(self)[1] }$keep_na_srv@1 changed reactive value, id: { private$get_id() }")
|
| 764 | ! |
updateCheckboxInput( |
| 765 | ! |
inputId = "value", |
| 766 | ! |
label = sprintf("Keep NA (%s/%s)", private$filtered_na_count(), private$na_count),
|
| 767 | ! |
value = private$get_keep_na() |
| 768 |
) |
|
| 769 |
} |
|
| 770 |
} |
|
| 771 |
) |
|
| 772 | 27x |
private$session_bindings[[session$ns("keep_na")]] <- observeEvent(
|
| 773 | 27x |
ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput` |
| 774 | 27x |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 775 | 27x |
eventExpr = input$value, |
| 776 | 27x |
handlerExpr = {
|
| 777 | 1x |
logger::log_debug("{ class(self)[1] }$keep_na_srv@2 changed input, id: { private$get_id() }")
|
| 778 | 1x |
keep_na <- if (is.null(input$value)) {
|
| 779 | ! |
FALSE |
| 780 |
} else {
|
|
| 781 | 1x |
input$value |
| 782 |
} |
|
| 783 | 1x |
private$set_keep_na(keep_na) |
| 784 |
} |
|
| 785 |
) |
|
| 786 | 27x |
invisible(NULL) |
| 787 |
}) |
|
| 788 |
}, |
|
| 789 | ||
| 790 |
# @description |
|
| 791 |
# Destroy inputs and observers stored in `private$session_bindings`. |
|
| 792 |
# |
|
| 793 |
# |
|
| 794 |
# @return `NULL`, invisibly. |
|
| 795 |
# |
|
| 796 |
finalize = function() {
|
|
| 797 | 460x |
.finalize_session_bindings(self, private) |
| 798 |
} |
|
| 799 |
) |
|
| 800 |
) |
| 1 |
# RangeFilterState ------ |
|
| 2 | ||
| 3 |
#' @name RangeFilterState |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterState` object for numeric data |
|
| 7 |
#' |
|
| 8 |
#' @description Manages choosing a numeric range. |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' # use non-exported function from teal.slice |
|
| 12 |
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 13 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 14 |
#' RangeFilterState <- getFromNamespace("RangeFilterState", "teal.slice")
|
|
| 15 |
#' |
|
| 16 |
#' library(shiny) |
|
| 17 |
#' |
|
| 18 |
#' filter_state <- RangeFilterState$new( |
|
| 19 |
#' x = c(NA, Inf, seq(1:10)), |
|
| 20 |
#' slice = teal_slice(varname = "x", dataname = "data") |
|
| 21 |
#' ) |
|
| 22 |
#' isolate(filter_state$get_call()) |
|
| 23 |
#' filter_state$set_state( |
|
| 24 |
#' teal_slice( |
|
| 25 |
#' dataname = "data", |
|
| 26 |
#' varname = "x", |
|
| 27 |
#' selected = c(3L, 8L), |
|
| 28 |
#' keep_na = TRUE, |
|
| 29 |
#' keep_inf = TRUE |
|
| 30 |
#' ) |
|
| 31 |
#' ) |
|
| 32 |
#' isolate(filter_state$get_call()) |
|
| 33 |
#' |
|
| 34 |
#' # working filter in an app |
|
| 35 |
#' library(shinyjs) |
|
| 36 |
#' |
|
| 37 |
#' data_range <- c(runif(100, 0, 1), NA, Inf) |
|
| 38 |
#' fs <- RangeFilterState$new( |
|
| 39 |
#' x = data_range, |
|
| 40 |
#' slice = teal_slice( |
|
| 41 |
#' dataname = "data", |
|
| 42 |
#' varname = "x", |
|
| 43 |
#' selected = c(0.15, 0.93), |
|
| 44 |
#' keep_na = TRUE, |
|
| 45 |
#' keep_inf = TRUE |
|
| 46 |
#' ) |
|
| 47 |
#' ) |
|
| 48 |
#' |
|
| 49 |
#' ui <- bslib::page_fluid( |
|
| 50 |
#' useShinyjs(), |
|
| 51 |
#' include_css_files(pattern = "filter-panel"), |
|
| 52 |
#' include_js_files(pattern = "count-bar-labels"), |
|
| 53 |
#' bslib::layout_column_wrap( |
|
| 54 |
#' width = 1 / 3, |
|
| 55 |
#' tags$div( |
|
| 56 |
#' tags$h4("RangeFilterState"),
|
|
| 57 |
#' fs$ui("fs")
|
|
| 58 |
#' ), |
|
| 59 |
#' tags$div( |
|
| 60 |
#' id = "outputs", # div id is needed for toggling the element |
|
| 61 |
#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|
| 62 |
#' textOutput("condition_range"), tags$br(),
|
|
| 63 |
#' tags$h4("Unformatted state"), # display raw filter state
|
|
| 64 |
#' textOutput("unformatted_range"), tags$br(),
|
|
| 65 |
#' tags$h4("Formatted state"), # display human readable filter state
|
|
| 66 |
#' textOutput("formatted_range"), tags$br()
|
|
| 67 |
#' ), |
|
| 68 |
#' tags$div( |
|
| 69 |
#' tags$h4("Programmatic filter control"),
|
|
| 70 |
#' actionButton("button1_range", "set drop NA", width = "100%"), tags$br(),
|
|
| 71 |
#' actionButton("button2_range", "set keep NA", width = "100%"), tags$br(),
|
|
| 72 |
#' actionButton("button3_range", "set drop Inf", width = "100%"), tags$br(),
|
|
| 73 |
#' actionButton("button4_range", "set keep Inf", width = "100%"), tags$br(),
|
|
| 74 |
#' actionButton("button5_range", "set a range", width = "100%"), tags$br(),
|
|
| 75 |
#' actionButton("button6_range", "set full range", width = "100%"), tags$br(),
|
|
| 76 |
#' actionButton("button0_range", "set initial state", width = "100%"), tags$br()
|
|
| 77 |
#' ) |
|
| 78 |
#' ) |
|
| 79 |
#' ) |
|
| 80 |
#' |
|
| 81 |
#' server <- function(input, output, session) {
|
|
| 82 |
#' fs$server("fs")
|
|
| 83 |
#' output$condition_range <- renderPrint(fs$get_call()) |
|
| 84 |
#' output$formatted_range <- renderText(fs$format()) |
|
| 85 |
#' output$unformatted_range <- renderPrint(fs$get_state()) |
|
| 86 |
#' # modify filter state programmatically |
|
| 87 |
#' observeEvent( |
|
| 88 |
#' input$button1_range, |
|
| 89 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) |
|
| 90 |
#' ) |
|
| 91 |
#' observeEvent( |
|
| 92 |
#' input$button2_range, |
|
| 93 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
|
| 94 |
#' ) |
|
| 95 |
#' observeEvent( |
|
| 96 |
#' input$button3_range, |
|
| 97 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = FALSE)) |
|
| 98 |
#' ) |
|
| 99 |
#' observeEvent( |
|
| 100 |
#' input$button4_range, |
|
| 101 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = TRUE)) |
|
| 102 |
#' ) |
|
| 103 |
#' observeEvent( |
|
| 104 |
#' input$button5_range, |
|
| 105 |
#' fs$set_state( |
|
| 106 |
#' teal_slice(dataname = "data", varname = "x", selected = c(0.2, 0.74)) |
|
| 107 |
#' ) |
|
| 108 |
#' ) |
|
| 109 |
#' observeEvent( |
|
| 110 |
#' input$button6_range, |
|
| 111 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = c(0, 1))) |
|
| 112 |
#' ) |
|
| 113 |
#' observeEvent( |
|
| 114 |
#' input$button0_range, |
|
| 115 |
#' fs$set_state( |
|
| 116 |
#' teal_slice("data", "variable", selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)
|
|
| 117 |
#' ) |
|
| 118 |
#' ) |
|
| 119 |
#' } |
|
| 120 |
#' |
|
| 121 |
#' if (interactive()) {
|
|
| 122 |
#' shinyApp(ui, server) |
|
| 123 |
#' } |
|
| 124 |
#' @keywords internal |
|
| 125 |
#' |
|
| 126 |
RangeFilterState <- R6::R6Class( # nolint |
|
| 127 |
"RangeFilterState", |
|
| 128 |
inherit = FilterState, |
|
| 129 | ||
| 130 |
# public methods ---- |
|
| 131 |
public = list( |
|
| 132 | ||
| 133 |
#' @description |
|
| 134 |
#' Initialize a `FilterState` object for range selection. |
|
| 135 |
#' @param x (`numeric`) |
|
| 136 |
#' variable to be filtered. |
|
| 137 |
#' @param x_reactive (`reactive`) |
|
| 138 |
#' returning vector of the same type as `x`. Is used to update |
|
| 139 |
#' counts following the change in values of the filtered dataset. |
|
| 140 |
#' If it is set to `reactive(NULL)` then counts based on filtered |
|
| 141 |
#' dataset are not shown. |
|
| 142 |
#' @param slice (`teal_slice`) |
|
| 143 |
#' specification of this filter state. |
|
| 144 |
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 145 |
#' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 146 |
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|
| 147 |
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 148 |
#' @param extract_type (`character`) |
|
| 149 |
#' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 150 |
#' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 151 |
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 152 |
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 153 |
#' |
|
| 154 |
#' @return Object of class `RangeFilterState`, invisibly. |
|
| 155 |
#' |
|
| 156 |
initialize = function(x, |
|
| 157 |
x_reactive = reactive(NULL), |
|
| 158 |
extract_type = character(0), |
|
| 159 |
slice) {
|
|
| 160 | 119x |
isolate({
|
| 161 | 119x |
checkmate::assert_numeric(x, all.missing = FALSE) |
| 162 | 2x |
if (!any(is.finite(x))) stop("\"x\" contains no finite values")
|
| 163 | 116x |
super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type) |
| 164 | 116x |
private$is_integer <- checkmate::test_integerish(x) |
| 165 | 116x |
private$inf_count <- sum(is.infinite(x)) |
| 166 | 116x |
private$inf_filtered_count <- reactive( |
| 167 | 116x |
if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive())) |
| 168 |
) |
|
| 169 | ||
| 170 | 116x |
checkmate::assert_numeric(slice$choices, null.ok = TRUE) |
| 171 | 3x |
if (is.null(slice$keep_inf) && any(is.infinite(x))) slice$keep_inf <- TRUE |
| 172 | ||
| 173 | 115x |
private$set_choices(slice$choices) |
| 174 | 41x |
if (is.null(slice$selected)) slice$selected <- slice$choices |
| 175 | 115x |
private$set_selected(slice$selected) |
| 176 | ||
| 177 | 112x |
private$is_integer <- checkmate::test_integerish(x) |
| 178 | 112x |
private$inf_filtered_count <- reactive( |
| 179 | 112x |
if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive())) |
| 180 |
) |
|
| 181 | 112x |
private$inf_count <- sum(is.infinite(x)) |
| 182 | ||
| 183 | 112x |
private$plot_data <- list( |
| 184 | 112x |
type = "histogram", |
| 185 | 112x |
nbinsx = 50, |
| 186 | 112x |
x = Filter(Negate(is.na), Filter(is.finite, private$x)), |
| 187 | 112x |
color = I(fetch_bs_color("secondary")),
|
| 188 | 112x |
alpha = 0.2, |
| 189 | 112x |
bingroup = 1, |
| 190 | 112x |
showlegend = FALSE, |
| 191 | 112x |
hoverinfo = "none" |
| 192 |
) |
|
| 193 | 112x |
private$plot_mask <- list(list( |
| 194 | 112x |
type = "rect", fillcolor = rgb(1, 1, 1, .65), line = list(width = 0), |
| 195 | 112x |
x0 = -0.5, x1 = 1.5, y0 = -0.5, y1 = 1.5, xref = "paper", yref = "paper" |
| 196 |
)) |
|
| 197 | 112x |
private$plot_layout <- reactive({
|
| 198 | 6x |
shapes <- private$get_shape_properties(private$get_selected()) |
| 199 | 6x |
list( |
| 200 | 6x |
barmode = "overlay", |
| 201 | 6x |
xaxis = list( |
| 202 | 6x |
range = private$get_choices() * c(0.995, 1.005), |
| 203 | 6x |
rangeslider = list(thickness = 0), |
| 204 | 6x |
showticklabels = TRUE, |
| 205 | 6x |
ticks = "outside", |
| 206 | 6x |
ticklen = 1.5, |
| 207 | 6x |
tickmode = "auto", |
| 208 | 6x |
nticks = 10 |
| 209 |
), |
|
| 210 | 6x |
yaxis = list(showgrid = FALSE, showticklabels = FALSE), |
| 211 | 6x |
margin = list(b = 17, l = 0, r = 0, t = 0, autoexpand = FALSE), |
| 212 | 6x |
plot_bgcolor = "#FFFFFF00", |
| 213 | 6x |
paper_bgcolor = "#FFFFFF00", |
| 214 | 6x |
shapes = shapes |
| 215 |
) |
|
| 216 |
}) |
|
| 217 | 112x |
private$plot_config <- reactive({
|
| 218 | 6x |
list( |
| 219 | 6x |
doubleClick = "reset", |
| 220 | 6x |
displayModeBar = FALSE, |
| 221 | 6x |
edits = list(shapePosition = TRUE) |
| 222 |
) |
|
| 223 |
}) |
|
| 224 | 112x |
private$plot_filtered <- reactive({
|
| 225 | 6x |
finite_values <- Filter(is.finite, private$x_reactive()) |
| 226 | 6x |
if (!identical(finite_values, numeric(0))) {
|
| 227 | 6x |
list( |
| 228 | 6x |
x = finite_values, |
| 229 | 6x |
bingroup = 1, |
| 230 | 6x |
color = I(fetch_bs_color("primary"))
|
| 231 |
) |
|
| 232 |
} |
|
| 233 |
}) |
|
| 234 | 112x |
invisible(self) |
| 235 |
}) |
|
| 236 |
}, |
|
| 237 | ||
| 238 |
#' @description |
|
| 239 |
#' Returns reproducible condition call for current selection. |
|
| 240 |
#' For this class returned call looks like |
|
| 241 |
#' `<varname> >= <min value> & <varname> <= <max value>` with |
|
| 242 |
#' optional `is.na(<varname>)` and `is.finite(<varname>)`. |
|
| 243 |
#' @param dataname name of data set; defaults to `private$get_dataname()` |
|
| 244 |
#' @return `call` |
|
| 245 |
#' |
|
| 246 |
get_call = function(dataname) {
|
|
| 247 | 35x |
if (isFALSE(private$is_any_filtered())) {
|
| 248 | 1x |
return(NULL) |
| 249 |
} |
|
| 250 | 4x |
if (missing(dataname)) dataname <- private$get_dataname() |
| 251 | 34x |
varname <- private$get_varname_prefixed(dataname) |
| 252 | 34x |
filter_call <- |
| 253 | 34x |
call( |
| 254 |
"&", |
|
| 255 | 34x |
call(">=", varname, private$get_selected()[1L]),
|
| 256 | 34x |
call("<=", varname, private$get_selected()[2L])
|
| 257 |
) |
|
| 258 | 34x |
private$add_keep_na_call(private$add_keep_inf_call(filter_call, varname), varname) |
| 259 |
}, |
|
| 260 | ||
| 261 |
#' @description |
|
| 262 |
#' Returns current `keep_inf` selection. |
|
| 263 |
#' @return `logical(1)` |
|
| 264 |
get_keep_inf = function() {
|
|
| 265 | ! |
private$teal_slice$keep_inf |
| 266 |
} |
|
| 267 |
), |
|
| 268 | ||
| 269 |
# private fields---- |
|
| 270 |
private = list( |
|
| 271 |
inf_count = integer(0), |
|
| 272 |
inf_filtered_count = NULL, |
|
| 273 |
is_integer = logical(0), |
|
| 274 |
numeric_step = numeric(0), # step for the slider input widget, calculated from input data (x) |
|
| 275 |
plot_data = NULL, |
|
| 276 |
plot_mask = list(), |
|
| 277 |
plot_layout = NULL, |
|
| 278 |
plot_config = NULL, |
|
| 279 |
plot_filtered = NULL, |
|
| 280 | ||
| 281 |
# private methods ---- |
|
| 282 | ||
| 283 |
set_choices = function(choices) {
|
|
| 284 | 115x |
x <- private$x[is.finite(private$x)] |
| 285 | 115x |
if (is.null(choices)) {
|
| 286 | 103x |
choices <- range(x) |
| 287 |
} else {
|
|
| 288 | 12x |
choices_adjusted <- c(max(choices[1L], min(x)), min(choices[2L], max(x))) |
| 289 | 12x |
if (any(choices != choices_adjusted)) {
|
| 290 | 1x |
warning(sprintf( |
| 291 | 1x |
"Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", |
| 292 | 1x |
private$get_varname(), private$get_dataname() |
| 293 |
)) |
|
| 294 | 1x |
choices <- choices_adjusted |
| 295 |
} |
|
| 296 | 12x |
if (choices[1L] > choices[2L]) {
|
| 297 | 1x |
warning(sprintf( |
| 298 | 1x |
"Invalid choices: lower is higher / equal to upper, or not in range of variable values. |
| 299 | 1x |
Setting defaults. Varname: %s, dataname: %s.", |
| 300 | 1x |
private$get_varname(), private$get_dataname() |
| 301 |
)) |
|
| 302 | 1x |
choices <- range(x) |
| 303 |
} |
|
| 304 |
} |
|
| 305 | ||
| 306 | 115x |
private$set_is_choice_limited(private$x, choices) |
| 307 | 115x |
private$x <- private$x[ |
| 308 | 115x |
(private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x) | !is.finite(private$x) |
| 309 |
] |
|
| 310 | ||
| 311 | 115x |
x_range <- range(private$x, finite = TRUE) |
| 312 | ||
| 313 |
# Required for displaying ticks on the slider, can modify choices! |
|
| 314 | 115x |
if (identical(diff(x_range), 0)) {
|
| 315 | 2x |
choices <- x_range |
| 316 |
} else {
|
|
| 317 | 113x |
x_pretty <- pretty(x_range, 100L) |
| 318 | 113x |
choices <- range(x_pretty) |
| 319 | 113x |
private$numeric_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10) |
| 320 |
} |
|
| 321 | 115x |
private$teal_slice$choices <- choices |
| 322 | 115x |
invisible(NULL) |
| 323 |
}, |
|
| 324 | ||
| 325 |
# @description |
|
| 326 |
# Check whether the initial choices filter out some values of x and set the flag in case. |
|
| 327 |
set_is_choice_limited = function(xl, choices) {
|
|
| 328 | 115x |
xl <- xl[!is.na(xl)] |
| 329 | 115x |
xl <- xl[is.finite(xl)] |
| 330 | 115x |
private$is_choice_limited <- (any(xl < choices[1L]) | any(xl > choices[2L])) |
| 331 | 115x |
invisible(NULL) |
| 332 |
}, |
|
| 333 | ||
| 334 |
# Adds is.infinite(varname) before existing condition calls if keep_inf is selected |
|
| 335 |
# returns a call |
|
| 336 |
add_keep_inf_call = function(filter_call, varname) {
|
|
| 337 | 34x |
if (isTRUE(private$get_keep_inf())) {
|
| 338 | 2x |
call("|", call("is.infinite", varname), filter_call)
|
| 339 |
} else {
|
|
| 340 | 32x |
filter_call |
| 341 |
} |
|
| 342 |
}, |
|
| 343 | ||
| 344 |
# @description gets pretty step size for range slider |
|
| 345 |
# adaptation of shiny's method (see shiny/R/input-slider.R function findStepSize) |
|
| 346 |
# @param pretty_range (numeric(n)) vector of pretty values |
|
| 347 |
# @return numeric(1) pretty step size for the sliderInput |
|
| 348 |
get_pretty_range_step = function(pretty_range) {
|
|
| 349 | 115x |
if (private$is_integer && diff(range(pretty_range) > 2)) {
|
| 350 | 46x |
1L |
| 351 |
} else {
|
|
| 352 | 69x |
n_steps <- length(pretty_range) - 1 |
| 353 | 69x |
signif(digits = 10, (max(pretty_range) - min(pretty_range)) / n_steps) |
| 354 |
} |
|
| 355 |
}, |
|
| 356 |
cast_and_validate = function(values) {
|
|
| 357 | 131x |
tryCatch( |
| 358 | 131x |
expr = {
|
| 359 | 131x |
values <- as.numeric(values) |
| 360 | 4x |
if (anyNA(values)) stop() |
| 361 | 127x |
values |
| 362 |
}, |
|
| 363 | 131x |
error = function(e) stop("Vector of set values must contain values coercible to numeric")
|
| 364 |
) |
|
| 365 |
}, |
|
| 366 |
# Also validates that selection is sorted. |
|
| 367 |
check_length = function(values) {
|
|
| 368 | 2x |
if (length(values) != 2L) stop("Vector of set values must have length two.")
|
| 369 | 2x |
if (values[1L] > values[2L]) stop("Vector of set values must be sorted.")
|
| 370 | 123x |
values |
| 371 |
}, |
|
| 372 |
# Trim selection to limits imposed by private$get_choices() |
|
| 373 |
remove_out_of_bounds_values = function(values) {
|
|
| 374 | 2x |
if (values[1L] < private$get_choices()[1L]) values[1L] <- private$get_choices()[1L] |
| 375 | 2x |
if (values[2L] > private$get_choices()[2L]) values[2L] <- private$get_choices()[2L] |
| 376 | 123x |
values |
| 377 |
}, |
|
| 378 | ||
| 379 |
# Answers the question of whether the current settings and values selected actually filters out any values. |
|
| 380 |
# @return logical scalar |
|
| 381 |
is_any_filtered = function() {
|
|
| 382 | 35x |
if (private$is_choice_limited) {
|
| 383 | 1x |
TRUE |
| 384 | 34x |
} else if (!isTRUE(all.equal(private$get_selected(), private$get_choices()))) {
|
| 385 | 32x |
TRUE |
| 386 | 2x |
} else if (!isTRUE(private$get_keep_inf()) && private$inf_count > 0) {
|
| 387 | ! |
TRUE |
| 388 | 2x |
} else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
|
| 389 | 1x |
TRUE |
| 390 |
} else {
|
|
| 391 | 1x |
FALSE |
| 392 |
} |
|
| 393 |
}, |
|
| 394 | ||
| 395 |
# obtain shape determination for histogram |
|
| 396 |
# returns a list that is passed to plotly's layout.shapes property |
|
| 397 |
get_shape_properties = function(values) {
|
|
| 398 | 6x |
list( |
| 399 | 6x |
list(type = "line", x0 = values[1], x1 = values[1], y0 = -100, y1 = 100, yref = "paper"), |
| 400 | 6x |
list(type = "line", x0 = values[2], x1 = values[2], y0 = -100, y1 = 100, yref = "paper") |
| 401 |
) |
|
| 402 |
}, |
|
| 403 | ||
| 404 |
# shiny modules ---- |
|
| 405 | ||
| 406 |
# UI Module for `RangeFilterState`. |
|
| 407 |
# This UI element contains two values for `min` and `max` |
|
| 408 |
# of the range and two checkboxes whether to keep the `NA` or `Inf` values. |
|
| 409 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 410 |
ui_inputs = function(id) {
|
|
| 411 | 6x |
ns <- NS(id) |
| 412 | 6x |
isolate({
|
| 413 | 6x |
ui_input <- shinyWidgets::numericRangeInput( |
| 414 | 6x |
inputId = ns("selection_manual"),
|
| 415 | 6x |
label = NULL, |
| 416 | 6x |
min = private$get_choices()[1L], |
| 417 | 6x |
max = private$get_choices()[2L], |
| 418 | 6x |
value = private$get_selected(), |
| 419 | 6x |
step = private$numeric_step, |
| 420 | 6x |
width = "100%" |
| 421 |
) |
|
| 422 | 6x |
tagList( |
| 423 | 6x |
tags$div( |
| 424 | 6x |
class = "teal-slice choices-state", |
| 425 | 6x |
tags$div( |
| 426 | 6x |
bslib::tooltip( |
| 427 | 6x |
trigger = actionLink( |
| 428 | 6x |
ns("plotly_info"),
|
| 429 | 6x |
label = NULL, |
| 430 | 6x |
icon = icon("question-circle")
|
| 431 |
), |
|
| 432 | 6x |
HTML( |
| 433 | 6x |
"<p> |
| 434 | 6x |
Drag vertical lines to set selection.<br> |
| 435 | 6x |
Drag across plot to zoom in.<br> |
| 436 | 6x |
Drag axis to pan.<br> |
| 437 | 6x |
Double click to zoom out." |
| 438 |
) |
|
| 439 |
), |
|
| 440 | 6x |
style = "text-align: right; font-size: 0.7em; margin-bottom: -1em; position: relative; z-index: 9;" |
| 441 |
), |
|
| 442 | 6x |
shinycssloaders::withSpinner( |
| 443 | 6x |
plotly::plotlyOutput(ns("plot"), height = "50px"),
|
| 444 | 6x |
type = 4, |
| 445 | 6x |
size = 0.25, |
| 446 | 6x |
hide.ui = FALSE |
| 447 |
), |
|
| 448 | 6x |
ui_input |
| 449 |
), |
|
| 450 | 6x |
tags$div( |
| 451 | 6x |
style = "display: flex; justify-content: space-evenly;", |
| 452 | 6x |
private$keep_inf_ui(ns("keep_inf")),
|
| 453 | 6x |
private$keep_na_ui(ns("keep_na"))
|
| 454 |
) |
|
| 455 |
) |
|
| 456 |
}) |
|
| 457 |
}, |
|
| 458 | ||
| 459 |
# @description |
|
| 460 |
# Server module |
|
| 461 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 462 |
# return `NULL`. |
|
| 463 |
server_inputs = function(id) {
|
|
| 464 | 6x |
moduleServer( |
| 465 | 6x |
id = id, |
| 466 | 6x |
function(input, output, session) {
|
| 467 | 6x |
logger::log_debug("RangeFilterState$server initializing, id: { private$get_id() }")
|
| 468 | ||
| 469 |
# Capture manual input with debounce. |
|
| 470 | 6x |
selection_manual <- debounce(reactive(input$selection_manual), 200) |
| 471 | ||
| 472 |
# Prepare for histogram construction. |
|
| 473 | 6x |
plot_data <- c(private$plot_data, source = session$ns("histogram_plot"))
|
| 474 | ||
| 475 | 6x |
trigger_event_data <- reactiveVal(NULL) |
| 476 | ||
| 477 |
# Display histogram, adding a second trace that contains filtered data. |
|
| 478 | 6x |
output$plot <- plotly::renderPlotly({
|
| 479 | 6x |
histogram <- do.call(plotly::plot_ly, plot_data) |
| 480 | 6x |
histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout())) |
| 481 | 6x |
histogram <- do.call(plotly::config, c(list(p = histogram), private$plot_config())) |
| 482 | 6x |
histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered())) |
| 483 | 6x |
trigger_event_data(TRUE) |
| 484 | 6x |
histogram |
| 485 |
}) |
|
| 486 | ||
| 487 | 6x |
relayout_data <- reactive({
|
| 488 | 3x |
req(trigger_event_data()) |
| 489 | 3x |
plotly::event_data("plotly_relayout", source = session$ns("histogram_plot"))
|
| 490 |
}) |
|
| 491 | ||
| 492 |
# Dragging shapes (lines) on plot updates selection. |
|
| 493 | 6x |
private$session_bindings[[session$ns("relayout")]] <- observeEvent(
|
| 494 | 6x |
ignoreNULL = FALSE, |
| 495 | 6x |
ignoreInit = TRUE, |
| 496 | 6x |
eventExpr = relayout_data(), |
| 497 | 6x |
handlerExpr = {
|
| 498 | ! |
logger::log_debug("RangeFilterState$server@1 selection changed, id: { private$get_id() }")
|
| 499 | ! |
event <- relayout_data() |
| 500 | ! |
if (any(grepl("shapes", names(event)))) {
|
| 501 | ! |
line_positions <- private$get_selected() |
| 502 | ! |
if (any(grepl("shapes[0]", names(event), fixed = TRUE))) {
|
| 503 | ! |
line_positions[1] <- event[["shapes[0].x0"]] |
| 504 | ! |
} else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) {
|
| 505 | ! |
line_positions[2] <- event[["shapes[1].x0"]] |
| 506 |
} |
|
| 507 |
# If one line was dragged past the other, abort action and reset lines. |
|
| 508 | ! |
if (line_positions[1] > line_positions[2]) {
|
| 509 | ! |
showNotification( |
| 510 | ! |
"Numeric range start value must be less than end value.", |
| 511 | ! |
type = "warning" |
| 512 |
) |
|
| 513 | ! |
plotly::plotlyProxyInvoke( |
| 514 | ! |
plotly::plotlyProxy("plot"),
|
| 515 | ! |
"relayout", |
| 516 | ! |
shapes = private$get_shape_properties(private$get_selected()) |
| 517 |
) |
|
| 518 | ! |
return(NULL) |
| 519 |
} |
|
| 520 | ||
| 521 | ! |
private$set_selected(signif(line_positions, digits = 4L)) |
| 522 |
} |
|
| 523 |
} |
|
| 524 |
) |
|
| 525 | ||
| 526 |
# Change in selection updates shapes (lines) on plot and numeric input. |
|
| 527 | 6x |
private$session_bindings[[session$ns("selection_api")]] <- observeEvent(
|
| 528 | 6x |
ignoreNULL = FALSE, |
| 529 | 6x |
ignoreInit = TRUE, |
| 530 | 6x |
eventExpr = private$get_selected(), |
| 531 | 6x |
handlerExpr = {
|
| 532 | ! |
if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) {
|
| 533 | ! |
logger::log_debug("RangeFilterState$server@2 state changed, id: {private$get_id() }")
|
| 534 | ! |
shinyWidgets::updateNumericRangeInput( |
| 535 | ! |
session = session, |
| 536 | ! |
inputId = "selection_manual", |
| 537 | ! |
value = private$get_selected() |
| 538 |
) |
|
| 539 |
} |
|
| 540 |
} |
|
| 541 |
) |
|
| 542 | ||
| 543 |
# Manual input updates selection. |
|
| 544 | 6x |
private$session_bindings[[session$ns("selection_manual")]] <- observeEvent(
|
| 545 | 6x |
ignoreNULL = FALSE, |
| 546 | 6x |
ignoreInit = TRUE, |
| 547 | 6x |
eventExpr = selection_manual(), |
| 548 | 6x |
handlerExpr = {
|
| 549 | ! |
selection <- selection_manual() |
| 550 |
# Abort and reset if non-numeric values is entered. |
|
| 551 | ! |
if (any(is.na(selection))) {
|
| 552 | ! |
showNotification( |
| 553 | ! |
"Numeric range values must be numbers.", |
| 554 | ! |
type = "warning" |
| 555 |
) |
|
| 556 | ! |
shinyWidgets::updateNumericRangeInput( |
| 557 | ! |
session = session, |
| 558 | ! |
inputId = "selection_manual", |
| 559 | ! |
value = private$get_selected() |
| 560 |
) |
|
| 561 | ! |
return(NULL) |
| 562 |
} |
|
| 563 | ||
| 564 |
# Abort and reset if reversed choices are specified. |
|
| 565 | ! |
if (selection[1] > selection[2]) {
|
| 566 | ! |
showNotification( |
| 567 | ! |
"Numeric range start value must be less than end value.", |
| 568 | ! |
type = "warning" |
| 569 |
) |
|
| 570 | ! |
shinyWidgets::updateNumericRangeInput( |
| 571 | ! |
session = session, |
| 572 | ! |
inputId = "selection_manual", |
| 573 | ! |
value = private$get_selected() |
| 574 |
) |
|
| 575 | ! |
return(NULL) |
| 576 |
} |
|
| 577 | ||
| 578 | ||
| 579 | ! |
if (!isTRUE(all.equal(selection, private$get_selected()))) {
|
| 580 | ! |
logger::log_debug("RangeFilterState$server@3 manual selection changed, id: { private$get_id() }")
|
| 581 | ! |
private$set_selected(selection) |
| 582 |
} |
|
| 583 |
} |
|
| 584 |
) |
|
| 585 | ||
| 586 | 6x |
private$keep_inf_srv("keep_inf")
|
| 587 | 6x |
private$keep_na_srv("keep_na")
|
| 588 | ||
| 589 | 6x |
NULL |
| 590 |
} |
|
| 591 |
) |
|
| 592 |
}, |
|
| 593 |
server_inputs_fixed = function(id) {
|
|
| 594 | ! |
moduleServer( |
| 595 | ! |
id = id, |
| 596 | ! |
function(input, output, session) {
|
| 597 | ! |
logger::log_debug("RangeFilterState$server initializing, id: { private$get_id() }")
|
| 598 | ||
| 599 | ! |
plot_config <- private$plot_config() |
| 600 | ! |
plot_config$staticPlot <- TRUE |
| 601 | ||
| 602 | ! |
output$plot <- plotly::renderPlotly({
|
| 603 | ! |
histogram <- do.call(plotly::plot_ly, private$plot_data) |
| 604 | ! |
histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout())) |
| 605 | ! |
histogram <- do.call(plotly::config, c(list(p = histogram), plot_config)) |
| 606 | ! |
histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered())) |
| 607 | ! |
histogram |
| 608 |
}) |
|
| 609 | ||
| 610 | ! |
output$selection <- renderUI({
|
| 611 | ! |
shinycssloaders::withSpinner( |
| 612 | ! |
plotly::plotlyOutput(session$ns("plot"), height = "50px"),
|
| 613 | ! |
type = 4, |
| 614 | ! |
size = 0.25 |
| 615 |
) |
|
| 616 |
}) |
|
| 617 | ||
| 618 | ! |
NULL |
| 619 |
} |
|
| 620 |
) |
|
| 621 |
}, |
|
| 622 | ||
| 623 |
# @description |
|
| 624 |
# Server module to display filter summary |
|
| 625 |
# renders text describing selected range and |
|
| 626 |
# if NA or Inf are included also |
|
| 627 |
# @return `shiny.tag` to include in the `ui_summary` |
|
| 628 |
content_summary = function() {
|
|
| 629 | 6x |
selection <- private$get_selected() |
| 630 | 6x |
tagList( |
| 631 | 6x |
tags$span(HTML(selection[1], "–", selection[2]), class = "teal-slice filter-card-summary-value"), |
| 632 | 6x |
tags$span( |
| 633 | 6x |
class = "teal-slice filter-card-summary-controls", |
| 634 | 6x |
if (private$na_count > 0) {
|
| 635 | ! |
tags$span( |
| 636 | ! |
"NA", |
| 637 | ! |
if (isTRUE(private$get_keep_na())) {
|
| 638 | ! |
icon("check", class = "text-success")
|
| 639 |
} else {
|
|
| 640 | ! |
icon("xmark", class = "text-danger")
|
| 641 |
} |
|
| 642 |
) |
|
| 643 |
}, |
|
| 644 | 6x |
if (private$inf_count > 0) {
|
| 645 | ! |
tags$span( |
| 646 | ! |
"Inf", |
| 647 | ! |
if (isTRUE(private$get_keep_inf())) {
|
| 648 | ! |
icon("check", class = "text-success")
|
| 649 |
} else {
|
|
| 650 | ! |
icon("xmark", class = "text-danger")
|
| 651 |
} |
|
| 652 |
) |
|
| 653 |
} |
|
| 654 |
) |
|
| 655 |
) |
|
| 656 |
}, |
|
| 657 | ||
| 658 |
# @description |
|
| 659 |
# Module displaying input to keep or remove NA in the `FilterState` call. |
|
| 660 |
# Renders a checkbox input only when variable with which the `FilterState` has been created contains Infs. |
|
| 661 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 662 |
keep_inf_ui = function(id) {
|
|
| 663 | 6x |
ns <- NS(id) |
| 664 | ||
| 665 | 6x |
if (private$inf_count > 0) {
|
| 666 | ! |
countmax <- private$na_count |
| 667 | ! |
countnow <- isolate(private$filtered_na_count()) |
| 668 | ! |
ui_input <- checkboxInput( |
| 669 | ! |
inputId = ns("value"),
|
| 670 | ! |
label = tags$span( |
| 671 | ! |
id = ns("count_label"),
|
| 672 | ! |
make_count_text( |
| 673 | ! |
label = "Keep Inf", |
| 674 | ! |
countmax = countmax, |
| 675 | ! |
countnow = countnow |
| 676 |
) |
|
| 677 |
), |
|
| 678 | ! |
value = isolate(private$get_keep_inf()) |
| 679 |
) |
|
| 680 | ! |
tags$div( |
| 681 | ! |
uiOutput(ns("trigger_visible"), inline = TRUE),
|
| 682 | ! |
ui_input |
| 683 |
) |
|
| 684 |
} else {
|
|
| 685 | 6x |
NULL |
| 686 |
} |
|
| 687 |
}, |
|
| 688 | ||
| 689 |
# @description |
|
| 690 |
# Module to handle Inf values in the FilterState |
|
| 691 |
# Sets `private$slice$keep_inf` according to the selection |
|
| 692 |
# and updates the relevant UI element if `private$slice$keep_inf` has been changed by the api. |
|
| 693 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 694 |
# @return `NULL`. |
|
| 695 |
keep_inf_srv = function(id) {
|
|
| 696 | 6x |
moduleServer(id, function(input, output, session) {
|
| 697 |
# 1. renderUI is used here as an observer which triggers only if output is visible |
|
| 698 |
# and if the reactive changes - reactive triggers only if the output is visible. |
|
| 699 |
# 2. We want to trigger change of the labels only if reactive count changes (not underlying data) |
|
| 700 | 6x |
output$trigger_visible <- renderUI({
|
| 701 | 6x |
updateCountText( |
| 702 | 6x |
inputId = "count_label", |
| 703 | 6x |
label = "Keep Inf", |
| 704 | 6x |
countmax = private$inf_count, |
| 705 | 6x |
countnow = private$inf_filtered_count() |
| 706 |
) |
|
| 707 | 6x |
NULL |
| 708 |
}) |
|
| 709 | ||
| 710 |
# this observer is needed in the situation when private$teal_slice$keep_inf has been |
|
| 711 |
# changed directly by the api - then it's needed to rerender UI element |
|
| 712 |
# to show relevant values |
|
| 713 | 6x |
private$session_bindings[[session$ns("keep_inf_api")]] <- observeEvent(
|
| 714 | 6x |
ignoreNULL = TRUE, # its not possible for range that NULL is selected |
| 715 | 6x |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 716 | 6x |
eventExpr = private$get_keep_inf(), |
| 717 | 6x |
handlerExpr = {
|
| 718 | ! |
if (!setequal(private$get_keep_inf(), input$value)) {
|
| 719 | ! |
logger::log_debug("RangeFilterState$keep_inf_srv@1 changed reactive value, id: { private$get_id() }")
|
| 720 | ! |
updateCheckboxInput( |
| 721 | ! |
inputId = "value", |
| 722 | ! |
value = private$get_keep_inf() |
| 723 |
) |
|
| 724 |
} |
|
| 725 |
} |
|
| 726 |
) |
|
| 727 | ||
| 728 | 6x |
private$session_bindings[[session$ns("keep_inf")]] <- observeEvent(
|
| 729 | 6x |
ignoreNULL = TRUE, # it's not possible for range that NULL is selected |
| 730 | 6x |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 731 | 6x |
eventExpr = input$value, |
| 732 | 6x |
handlerExpr = {
|
| 733 | ! |
logger::log_debug("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
|
| 734 | ! |
keep_inf <- input$value |
| 735 | ! |
private$set_keep_inf(keep_inf) |
| 736 |
} |
|
| 737 |
) |
|
| 738 | ||
| 739 | 6x |
invisible(NULL) |
| 740 |
}) |
|
| 741 |
} |
|
| 742 |
) |
|
| 743 |
) |
| 1 |
#' Include `JS` files from `/inst/js/` package directory to application header |
|
| 2 |
#' |
|
| 3 |
#' `system.file` should not be used to access files in other packages, it does |
|
| 4 |
#' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 5 |
#' as needed. Thus, we do not export this method. |
|
| 6 |
#' |
|
| 7 |
#' @param pattern (`character`) pattern of files to be included, passed to `system.file` |
|
| 8 |
#' |
|
| 9 |
#' @return HTML code that includes `JS` files |
|
| 10 |
#' @keywords internal |
|
| 11 |
include_js_files <- function(pattern) {
|
|
| 12 | 61x |
checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE) |
| 13 | 61x |
js_files <- list.files( |
| 14 | 61x |
system.file("js", package = "teal.slice", mustWork = TRUE),
|
| 15 | 61x |
pattern = pattern, |
| 16 | 61x |
full.names = TRUE |
| 17 |
) |
|
| 18 | 61x |
singleton(lapply(js_files, includeScript)) |
| 19 |
} |
|
| 20 | ||
| 21 |
#' Build concatenating call |
|
| 22 |
#' |
|
| 23 |
#' This function takes a vector of values and returns a `c` call. If the vector |
|
| 24 |
#' has only one element, the element is returned directly. |
|
| 25 |
#' |
|
| 26 |
#' @param choices A vector of values. |
|
| 27 |
#' |
|
| 28 |
#' @return A `c` call. |
|
| 29 |
#' |
|
| 30 |
#' @examples |
|
| 31 |
#' # use non-exported function from teal.slice |
|
| 32 |
#' make_c_call <- getFromNamespace("make_c_call", "teal.slice")
|
|
| 33 |
#' make_c_call(1:3) |
|
| 34 |
#' make_c_call(1) |
|
| 35 |
#' |
|
| 36 |
#' @keywords internal |
|
| 37 |
make_c_call <- function(choices) {
|
|
| 38 | 58x |
if (length(choices) > 1) {
|
| 39 | 29x |
do.call("call", append(list("c"), choices))
|
| 40 |
} else {
|
|
| 41 | 29x |
choices |
| 42 |
} |
|
| 43 |
} |
|
| 44 | ||
| 45 |
#' Destroys inputs and observers stored in `private$session_bindings` |
|
| 46 |
#' |
|
| 47 |
#' @description |
|
| 48 |
#' Call a `destroy` method to remove `observer` and `input` from obsolete session which happens |
|
| 49 |
#' when `filter_panel_srv` is called again in new `FilteredData` object. |
|
| 50 |
#' Inputs are not stored directly in a field as they don't have `destroy` method. Instead, we |
|
| 51 |
#' store callback `destroy` function for inputs which removes bindings from a `session`. |
|
| 52 |
#' @param self,private slots of a `R6` class |
|
| 53 |
#' @return `NULL` invisibly |
|
| 54 |
#' @keywords internal |
|
| 55 |
.finalize_session_bindings <- function(self, private) {
|
|
| 56 |
# Only finalize shiny session binding when there is an active session |
|
| 57 | 1527x |
shiny::isolate({
|
| 58 | 1527x |
rd <- getDefaultReactiveDomain() |
| 59 | 1527x |
if (!is.null(rd) && !rd$isEnded()) {
|
| 60 | 366x |
lapply(private$session_bindings, function(x) x$destroy()) |
| 61 |
} |
|
| 62 |
}) |
|
| 63 | 1527x |
invisible(NULL) |
| 64 |
} |
|
| 65 | ||
| 66 | ||
| 67 | ||
| 68 |
#' Encodes ids to be used in JavaScript and Shiny |
|
| 69 |
#' |
|
| 70 |
#' @description |
|
| 71 |
#' Replaces non-ASCII characters into a format that can be used in HTML, |
|
| 72 |
#' JavaScript and Shiny. |
|
| 73 |
#' |
|
| 74 |
#' When the id has a character that is not allowed, it is replaced with `"_"` |
|
| 75 |
#' and a 4 character hash of the original id is added to the start of the |
|
| 76 |
#' resulting id. |
|
| 77 |
#' |
|
| 78 |
#' |
|
| 79 |
#' @param id (`character(1)`) The id string. |
|
| 80 |
#' |
|
| 81 |
#' @return Sanitized string that removes special characters and spaces. |
|
| 82 |
#' |
|
| 83 |
#' @keywords internal |
|
| 84 |
sanitize_id <- function(id) {
|
|
| 85 | 1065x |
pattern_escape <- "[^0-9A-Za-z_]" |
| 86 | ||
| 87 | 1065x |
id_new <- gsub(pattern_escape, "_", id, perl = TRUE) |
| 88 | 1065x |
hashes <- vapply(id[id != id_new], rlang::hash, character(1), USE.NAMES = FALSE) |
| 89 | ||
| 90 | 1065x |
id[id != id_new] <- paste0("h", substr(hashes, 1, 4), "_", id_new[id != id_new])
|
| 91 | 1065x |
id |
| 92 |
} |
|
| 93 | ||
| 94 |
#' `NS` wrapper to sanitize ids for shiny |
|
| 95 |
#' |
|
| 96 |
#' Special characters and spaces are not allowed in shiny ids (in JS) |
|
| 97 |
#' |
|
| 98 |
#' @noRd |
|
| 99 |
NS <- function(namespace, id = NULL) { # nolint: object_name.
|
|
| 100 | 356x |
if (!missing(id)) {
|
| 101 | 3x |
return(shiny::NS(namespace, sanitize_id(id))) |
| 102 |
} |
|
| 103 | ||
| 104 | 353x |
function(id) {
|
| 105 | 747x |
shiny::NS(namespace, sanitize_id(id)) |
| 106 |
} |
|
| 107 |
} |
|
| 108 | ||
| 109 |
#' `moduleServer` wrapper to sanitize ids for shiny |
|
| 110 |
#' |
|
| 111 |
#' Special characters and spaces are not allowed in shiny ids (in JS) |
|
| 112 |
#' |
|
| 113 |
#' @noRd |
|
| 114 |
moduleServer <- function(id, module, session = getDefaultReactiveDomain()) { # nolint: object_name.
|
|
| 115 | 315x |
id <- sanitize_id(id) |
| 116 | 315x |
shiny::moduleServer(id, module, session) |
| 117 |
} |
| 1 |
# LogicalFilterState ------ |
|
| 2 | ||
| 3 |
#' @name LogicalFilterState |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterState` object for logical data |
|
| 7 |
#' |
|
| 8 |
#' @description Manages choosing a logical state. |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' # use non-exported function from teal.slice |
|
| 12 |
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 13 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 14 |
#' LogicalFilterState <- getFromNamespace("LogicalFilterState", "teal.slice")
|
|
| 15 |
#' |
|
| 16 |
#' library(shiny) |
|
| 17 |
#' |
|
| 18 |
#' filter_state <- LogicalFilterState$new( |
|
| 19 |
#' x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE), |
|
| 20 |
#' slice = teal_slice(varname = "x", dataname = "data") |
|
| 21 |
#' ) |
|
| 22 |
#' isolate(filter_state$get_call()) |
|
| 23 |
#' filter_state$set_state( |
|
| 24 |
#' teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE) |
|
| 25 |
#' ) |
|
| 26 |
#' isolate(filter_state$get_call()) |
|
| 27 |
#' |
|
| 28 |
#' # working filter in an app |
|
| 29 |
#' library(shinyjs) |
|
| 30 |
#' |
|
| 31 |
#' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA) |
|
| 32 |
#' fs <- LogicalFilterState$new( |
|
| 33 |
#' x = data_logical, |
|
| 34 |
#' slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE) |
|
| 35 |
#' ) |
|
| 36 |
#' |
|
| 37 |
#' ui <- bslib::page_fluid( |
|
| 38 |
#' useShinyjs(), |
|
| 39 |
#' include_css_files(pattern = "filter-panel"), |
|
| 40 |
#' include_js_files(pattern = "count-bar-labels"), |
|
| 41 |
#' bslib::layout_column_wrap( |
|
| 42 |
#' width = 1 / 3, |
|
| 43 |
#' tags$div( |
|
| 44 |
#' tags$h4("LogicalFilterState"),
|
|
| 45 |
#' fs$ui("fs")
|
|
| 46 |
#' ), |
|
| 47 |
#' tags$div( |
|
| 48 |
#' id = "outputs", # div id is needed for toggling the element |
|
| 49 |
#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|
| 50 |
#' textOutput("condition_logical"), tags$br(),
|
|
| 51 |
#' tags$h4("Unformatted state"), # display raw filter state
|
|
| 52 |
#' textOutput("unformatted_logical"), tags$br(),
|
|
| 53 |
#' tags$h4("Formatted state"), # display human readable filter state
|
|
| 54 |
#' textOutput("formatted_logical"), tags$br()
|
|
| 55 |
#' ), |
|
| 56 |
#' tags$div( |
|
| 57 |
#' tags$h4("Programmatic filter control"),
|
|
| 58 |
#' actionButton("button1_logical", "set drop NA", width = "100%"), tags$br(),
|
|
| 59 |
#' actionButton("button2_logical", "set keep NA", width = "100%"), tags$br(),
|
|
| 60 |
#' actionButton("button3_logical", "set a selection", width = "100%"), tags$br(),
|
|
| 61 |
#' actionButton("button0_logical", "set initial state", width = "100%"), tags$br()
|
|
| 62 |
#' ) |
|
| 63 |
#' ) |
|
| 64 |
#' ) |
|
| 65 |
#' |
|
| 66 |
#' server <- function(input, output, session) {
|
|
| 67 |
#' fs$server("fs")
|
|
| 68 |
#' output$condition_logical <- renderPrint(fs$get_call()) |
|
| 69 |
#' output$formatted_logical <- renderText(fs$format()) |
|
| 70 |
#' output$unformatted_logical <- renderPrint(fs$get_state()) |
|
| 71 |
#' # modify filter state programmatically |
|
| 72 |
#' observeEvent( |
|
| 73 |
#' input$button1_logical, |
|
| 74 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) |
|
| 75 |
#' ) |
|
| 76 |
#' observeEvent( |
|
| 77 |
#' input$button2_logical, |
|
| 78 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
|
| 79 |
#' ) |
|
| 80 |
#' observeEvent( |
|
| 81 |
#' input$button3_logical, |
|
| 82 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE)) |
|
| 83 |
#' ) |
|
| 84 |
#' observeEvent( |
|
| 85 |
#' input$button0_logical, |
|
| 86 |
#' fs$set_state( |
|
| 87 |
#' teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE) |
|
| 88 |
#' ) |
|
| 89 |
#' ) |
|
| 90 |
#' } |
|
| 91 |
#' |
|
| 92 |
#' if (interactive()) {
|
|
| 93 |
#' shinyApp(ui, server) |
|
| 94 |
#' } |
|
| 95 |
#' |
|
| 96 |
#' @keywords internal |
|
| 97 |
#' |
|
| 98 |
LogicalFilterState <- R6::R6Class( # nolint |
|
| 99 |
"LogicalFilterState", |
|
| 100 |
inherit = FilterState, |
|
| 101 | ||
| 102 |
# public methods ---- |
|
| 103 |
public = list( |
|
| 104 | ||
| 105 |
#' @description |
|
| 106 |
#' Initialize a `FilterState` object. |
|
| 107 |
#' |
|
| 108 |
#' @param x (`logical`) |
|
| 109 |
#' variable to be filtered. |
|
| 110 |
#' @param x_reactive (`reactive`) |
|
| 111 |
#' returning vector of the same type as `x`. Is used to update |
|
| 112 |
#' counts following the change in values of the filtered dataset. |
|
| 113 |
#' If it is set to `reactive(NULL)` then counts based on filtered |
|
| 114 |
#' dataset are not shown. |
|
| 115 |
#' @param slice (`teal_slice`) |
|
| 116 |
#' specification of this filter state. |
|
| 117 |
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 118 |
#' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 119 |
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|
| 120 |
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 121 |
#' @param extract_type (`character`) |
|
| 122 |
#' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 123 |
#' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 124 |
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 125 |
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 126 |
#' |
|
| 127 |
#' @return Object of class `LogicalFilterState`, invisibly. |
|
| 128 |
#' |
|
| 129 |
initialize = function(x, |
|
| 130 |
x_reactive = reactive(NULL), |
|
| 131 |
extract_type = character(0), |
|
| 132 |
slice) {
|
|
| 133 | 16x |
isolate({
|
| 134 | 16x |
checkmate::assert_logical(x) |
| 135 | 15x |
checkmate::assert_logical(slice$selected, null.ok = TRUE) |
| 136 | 14x |
super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type) |
| 137 | ||
| 138 | 14x |
private$set_choices(slice$choices) |
| 139 | ! |
if (is.null(slice$multiple)) slice$multiple <- FALSE |
| 140 | 14x |
if (is.null(slice$selected) && slice$multiple) {
|
| 141 | 7x |
slice$selected <- private$get_choices() |
| 142 | 7x |
} else if (length(slice$selected) != 1 && !slice$multiple) {
|
| 143 | 3x |
slice$selected <- TRUE |
| 144 |
} |
|
| 145 | 14x |
private$set_selected(slice$selected) |
| 146 | 14x |
df <- factor(x, levels = c(TRUE, FALSE)) |
| 147 | 14x |
tbl <- table(df) |
| 148 | 14x |
private$set_choices_counts(tbl) |
| 149 |
}) |
|
| 150 | 14x |
invisible(self) |
| 151 |
}, |
|
| 152 | ||
| 153 |
#' @description |
|
| 154 |
#' Returns reproducible condition call for current selection. |
|
| 155 |
#' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally `is.na(<varname>)` |
|
| 156 |
#' @param dataname name of data set; defaults to `private$get_dataname()` |
|
| 157 |
#' @return `call` |
|
| 158 |
#' |
|
| 159 |
get_call = function(dataname) {
|
|
| 160 | 6x |
if (isFALSE(private$is_any_filtered())) {
|
| 161 | ! |
return(NULL) |
| 162 |
} |
|
| 163 | 4x |
if (missing(dataname)) dataname <- private$get_dataname() |
| 164 | 6x |
varname <- private$get_varname_prefixed(dataname) |
| 165 | 6x |
choices <- private$get_selected() |
| 166 | 6x |
n_choices <- length(choices) |
| 167 | ||
| 168 | 6x |
filter_call <- |
| 169 | 6x |
if (n_choices == 1 && choices) {
|
| 170 | 1x |
varname |
| 171 | 6x |
} else if (n_choices == 1 && !choices) {
|
| 172 | 4x |
call("!", varname)
|
| 173 |
} else {
|
|
| 174 | 1x |
call("%in%", varname, make_c_call(choices))
|
| 175 |
} |
|
| 176 | 6x |
private$add_keep_na_call(filter_call, varname) |
| 177 |
} |
|
| 178 |
), |
|
| 179 | ||
| 180 |
# private members ---- |
|
| 181 |
private = list( |
|
| 182 |
choices_counts = integer(0), |
|
| 183 | ||
| 184 |
# private methods ---- |
|
| 185 |
set_choices = function(choices) {
|
|
| 186 | 14x |
private$teal_slice$choices <- c(TRUE, FALSE) |
| 187 | 14x |
invisible(NULL) |
| 188 |
}, |
|
| 189 |
# @description |
|
| 190 |
# Sets choices_counts private field |
|
| 191 |
set_choices_counts = function(choices_counts) {
|
|
| 192 | 14x |
private$choices_counts <- choices_counts |
| 193 | 14x |
invisible(NULL) |
| 194 |
}, |
|
| 195 |
cast_and_validate = function(values) {
|
|
| 196 | 21x |
tryCatch( |
| 197 | 21x |
expr = {
|
| 198 | 21x |
values <- as.logical(values) |
| 199 | 1x |
if (anyNA(values)) stop() |
| 200 | 20x |
values |
| 201 |
}, |
|
| 202 | 21x |
error = function(e) stop("Vector of set values must contain values coercible to logical.")
|
| 203 |
) |
|
| 204 |
}, |
|
| 205 |
# If multiple forbidden but selected, restores previous selection with warning. |
|
| 206 |
check_length = function(values) {
|
|
| 207 | 20x |
if (!private$is_multiple() && length(values) > 1) {
|
| 208 | 1x |
warning( |
| 209 | 1x |
sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
|
| 210 | 1x |
"Maintaining previous selection." |
| 211 |
) |
|
| 212 | 1x |
values <- isolate(private$get_selected()) |
| 213 |
} |
|
| 214 | 20x |
values |
| 215 |
}, |
|
| 216 | ||
| 217 |
# Answers the question of whether the current settings and values selected actually filters out any values. |
|
| 218 |
# @return logical scalar |
|
| 219 |
is_any_filtered = function() {
|
|
| 220 | 6x |
if (private$is_choice_limited) {
|
| 221 | ! |
TRUE |
| 222 | 6x |
} else if (all(private$choices_counts > 0)) {
|
| 223 | 6x |
TRUE |
| 224 |
} else if ( |
|
| 225 | ! |
setequal(private$get_selected(), private$get_choices()) && |
| 226 | ! |
!anyNA(private$get_selected(), private$get_choices()) |
| 227 |
) {
|
|
| 228 | ! |
TRUE |
| 229 | ! |
} else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
|
| 230 | ! |
TRUE |
| 231 |
} else {
|
|
| 232 | ! |
FALSE |
| 233 |
} |
|
| 234 |
}, |
|
| 235 | ||
| 236 |
# shiny modules ---- |
|
| 237 | ||
| 238 |
# @description |
|
| 239 |
# UI Module for `EmptyFilterState`. |
|
| 240 |
# This UI element contains available choices selection and |
|
| 241 |
# checkbox whether to keep or not keep the `NA` values. |
|
| 242 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 243 |
ui_inputs = function(id) {
|
|
| 244 | ! |
ns <- NS(id) |
| 245 | ! |
isolate({
|
| 246 | ! |
countsmax <- private$choices_counts |
| 247 | ! |
countsnow <- if (!is.null(private$x_reactive())) {
|
| 248 | ! |
unname(table(factor(private$x_reactive(), levels = private$get_choices()))) |
| 249 |
} else {
|
|
| 250 | ! |
NULL |
| 251 |
} |
|
| 252 | ||
| 253 | ! |
labels <- countBars( |
| 254 | ! |
inputId = ns("labels"),
|
| 255 | ! |
choices = as.character(private$get_choices()), |
| 256 | ! |
countsnow = countsnow, |
| 257 | ! |
countsmax = countsmax |
| 258 |
) |
|
| 259 | ! |
ui_input <- if (private$is_multiple()) {
|
| 260 | ! |
checkboxGroupInput( |
| 261 | ! |
inputId = ns("selection"),
|
| 262 | ! |
label = NULL, |
| 263 | ! |
selected = isolate(as.character(private$get_selected())), |
| 264 | ! |
choiceNames = labels, |
| 265 | ! |
choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
|
| 266 | ! |
width = "100%" |
| 267 |
) |
|
| 268 |
} else {
|
|
| 269 | ! |
radioButtons( |
| 270 | ! |
inputId = ns("selection"),
|
| 271 | ! |
label = NULL, |
| 272 | ! |
selected = isolate(as.character(private$get_selected())), |
| 273 | ! |
choiceNames = labels, |
| 274 | ! |
choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
|
| 275 | ! |
width = "100%" |
| 276 |
) |
|
| 277 |
} |
|
| 278 | ! |
tags$div( |
| 279 | ! |
tags$div( |
| 280 | ! |
class = "teal-slice choices-state", |
| 281 | ! |
uiOutput(ns("trigger_visible"), inline = TRUE),
|
| 282 | ! |
ui_input |
| 283 |
), |
|
| 284 | ! |
private$keep_na_ui(ns("keep_na"))
|
| 285 |
) |
|
| 286 |
}) |
|
| 287 |
}, |
|
| 288 | ||
| 289 |
# @description |
|
| 290 |
# Server module |
|
| 291 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 292 |
# @return `NULL`. |
|
| 293 |
server_inputs = function(id) {
|
|
| 294 | ! |
moduleServer( |
| 295 | ! |
id = id, |
| 296 | ! |
function(input, output, session) {
|
| 297 |
# this observer is needed in the situation when teal_slice$selected has been |
|
| 298 |
# changed directly by the api - then it's needed to rerender UI element |
|
| 299 |
# to show relevant values |
|
| 300 | ! |
non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive())) |
| 301 | ! |
output$trigger_visible <- renderUI({
|
| 302 | ! |
logger::log_debug("LogicalFilterState$server@1 updating count labels, id: { private$get_id() }")
|
| 303 | ||
| 304 | ! |
countsnow <- if (!is.null(private$x_reactive())) {
|
| 305 | ! |
unname(table(factor(non_missing_values(), levels = private$get_choices()))) |
| 306 |
} else {
|
|
| 307 | ! |
NULL |
| 308 |
} |
|
| 309 | ||
| 310 | ! |
updateCountBars( |
| 311 | ! |
inputId = "labels", |
| 312 | ! |
choices = as.character(private$get_choices()), |
| 313 | ! |
countsmax = private$choices_counts, |
| 314 | ! |
countsnow = countsnow |
| 315 |
) |
|
| 316 | ! |
NULL |
| 317 |
}) |
|
| 318 | ||
| 319 | ! |
private$session_bindings[[session$ns("selected_api")]] <- observeEvent(
|
| 320 | ! |
ignoreNULL = !private$is_multiple(), |
| 321 | ! |
ignoreInit = TRUE, |
| 322 | ! |
eventExpr = private$get_selected(), |
| 323 | ! |
handlerExpr = {
|
| 324 | ! |
if (!setequal(private$get_selected(), input$selection)) {
|
| 325 | ! |
logger::log_debug("LogicalFilterState$server@1 state changed, id: { private$get_id() }")
|
| 326 | ! |
if (private$is_multiple()) {
|
| 327 | ! |
updateCheckboxGroupInput( |
| 328 | ! |
inputId = "selection", |
| 329 | ! |
selected = private$get_selected() |
| 330 |
) |
|
| 331 |
} else {
|
|
| 332 | ! |
updateRadioButtons( |
| 333 | ! |
inputId = "selection", |
| 334 | ! |
selected = private$get_selected() |
| 335 |
) |
|
| 336 |
} |
|
| 337 |
} |
|
| 338 |
} |
|
| 339 |
) |
|
| 340 | ||
| 341 | ! |
private$session_bindings[[session$ns("selection")]] <- observeEvent(
|
| 342 | ! |
ignoreNULL = FALSE, |
| 343 | ! |
ignoreInit = TRUE, |
| 344 | ! |
eventExpr = input$selection, |
| 345 | ! |
handlerExpr = {
|
| 346 | ! |
logger::log_debug("LogicalFilterState$server@2 selection changed, id: { private$get_id() }")
|
| 347 |
# for private$is_multiple() == TRUE input$selection will always have value |
|
| 348 | ! |
if (is.null(input$selection) && isFALSE(private$is_multiple())) {
|
| 349 | ! |
selection_state <- private$get_selected() |
| 350 |
} else {
|
|
| 351 | ! |
selection_state <- as.logical(input$selection) |
| 352 |
} |
|
| 353 | ||
| 354 | ! |
if (is.null(selection_state)) {
|
| 355 | ! |
selection_state <- logical(0) |
| 356 |
} |
|
| 357 | ! |
private$set_selected(selection_state) |
| 358 |
} |
|
| 359 |
) |
|
| 360 | ||
| 361 | ! |
private$keep_na_srv("keep_na")
|
| 362 | ||
| 363 | ! |
NULL |
| 364 |
} |
|
| 365 |
) |
|
| 366 |
}, |
|
| 367 |
server_inputs_fixed = function(id) {
|
|
| 368 | ! |
moduleServer( |
| 369 | ! |
id = id, |
| 370 | ! |
function(input, output, session) {
|
| 371 | ! |
logger::log_debug("LogicalFilterState$server initializing, id: { private$get_id() }")
|
| 372 | ||
| 373 | ! |
output$selection <- renderUI({
|
| 374 | ! |
countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices()))) |
| 375 | ! |
countsmax <- private$choices_counts |
| 376 | ||
| 377 | ! |
ind <- private$get_choices() %in% private$get_selected() |
| 378 | ! |
countBars( |
| 379 | ! |
inputId = session$ns("labels"),
|
| 380 | ! |
choices = private$get_selected(), |
| 381 | ! |
countsnow = countsnow[ind], |
| 382 | ! |
countsmax = countsmax[ind] |
| 383 |
) |
|
| 384 |
}) |
|
| 385 | ||
| 386 | ! |
NULL |
| 387 |
} |
|
| 388 |
) |
|
| 389 |
}, |
|
| 390 | ||
| 391 |
# @description |
|
| 392 |
# Server module to display filter summary |
|
| 393 |
# renders text describing whether TRUE or FALSE is selected |
|
| 394 |
# and if NA are included also |
|
| 395 |
content_summary = function(id) {
|
|
| 396 | ! |
tagList( |
| 397 | ! |
tags$span( |
| 398 | ! |
class = "teal-slice filter-card-summary-value", |
| 399 | ! |
toString(private$get_selected()) |
| 400 |
), |
|
| 401 | ! |
tags$span( |
| 402 | ! |
class = "teal-slice filter-card-summary-controls", |
| 403 | ! |
if (private$na_count > 0) {
|
| 404 | ! |
tags$span( |
| 405 | ! |
"NA", |
| 406 | ! |
if (isTRUE(private$get_keep_na())) {
|
| 407 | ! |
icon("check", class = "text-success")
|
| 408 |
} else {
|
|
| 409 | ! |
icon("xmark", class = "text-danger")
|
| 410 |
} |
|
| 411 |
) |
|
| 412 |
} |
|
| 413 |
) |
|
| 414 |
) |
|
| 415 |
} |
|
| 416 |
) |
|
| 417 |
) |
| 1 |
# FilteredData ------ |
|
| 2 | ||
| 3 |
#' @name FilteredData |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title Class to encapsulate filtered datasets |
|
| 7 |
#' |
|
| 8 |
#' @description |
|
| 9 |
#' Manages filtering of all datasets in the application or module. |
|
| 10 |
#' |
|
| 11 |
#' @details |
|
| 12 |
#' 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 |
#' |
|
| 15 |
#' For each dataset, `get_filter_expr` returns the call to filter the dataset according |
|
| 16 |
#' to the filter state. The data itself can be obtained through `get_data`. |
|
| 17 |
#' |
|
| 18 |
#' The datasets are filtered lazily, i.e. only when requested / needed in a `shiny` app. |
|
| 19 |
#' |
|
| 20 |
#' 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 |
#' data can be set to `NULL`. |
|
| 23 |
#' |
|
| 24 |
#' The class currently supports variables of the following types within datasets: |
|
| 25 |
#' - `choices`: variable of type `factor`, e.g. `ADSL$COUNTRY`, `iris$Species` |
|
| 26 |
#' zero or more options can be selected, when the variable is a factor |
|
| 27 |
#' - `logical`: variable of type `logical`, e.g. `ADSL$TRT_FLAG` |
|
| 28 |
#' exactly one option must be selected, `TRUE` or `FALSE` |
|
| 29 |
#' - `ranges`: variable of type `numeric`, e.g. `ADSL$AGE`, `iris$Sepal.Length` |
|
| 30 |
#' numerical range, a range within this range can be selected |
|
| 31 |
#' - `dates`: variable of type `Date`, `POSIXlt` |
|
| 32 |
#' Other variables cannot be used for filtering the data in this class. |
|
| 33 |
#' |
|
| 34 |
#' Common arguments are: |
|
| 35 |
#' 1. `filtered`: whether to return a filtered result or not |
|
| 36 |
#' 2. `dataname`: the name of one of the datasets in this `FilteredData` object |
|
| 37 |
#' 3. `varname`: one of the columns in a dataset |
|
| 38 |
#' |
|
| 39 |
#' @examples |
|
| 40 |
#' # use non-exported function from teal.slice |
|
| 41 |
#' FilteredData <- getFromNamespace("FilteredData", "teal.slice")
|
|
| 42 |
#' |
|
| 43 |
#' library(shiny) |
|
| 44 |
#' |
|
| 45 |
#' datasets <- FilteredData$new(list(iris = iris, mtcars = mtcars)) |
|
| 46 |
#' |
|
| 47 |
#' # get datanames |
|
| 48 |
#' datasets$datanames() |
|
| 49 |
#' |
|
| 50 |
#' datasets$set_filter_state( |
|
| 51 |
#' teal_slices(teal_slice(dataname = "iris", varname = "Species", selected = "virginica")) |
|
| 52 |
#' ) |
|
| 53 |
#' |
|
| 54 |
#' datasets$set_filter_state( |
|
| 55 |
#' teal_slices(teal_slice(dataname = "mtcars", varname = "mpg", selected = c(15, 20))) |
|
| 56 |
#' ) |
|
| 57 |
#' |
|
| 58 |
#' isolate(datasets$get_filter_state()) |
|
| 59 |
#' isolate(datasets$get_call("iris"))
|
|
| 60 |
#' isolate(datasets$get_call("mtcars"))
|
|
| 61 |
#' |
|
| 62 |
#' @examplesIf requireNamespace("MultiAssayExperiment")
|
|
| 63 |
#' ### set_filter_state |
|
| 64 |
#' library(shiny) |
|
| 65 |
#' |
|
| 66 |
#' data(miniACC, package = "MultiAssayExperiment") |
|
| 67 |
#' datasets <- FilteredData$new(list(iris = iris, mae = miniACC)) |
|
| 68 |
#' fs <- teal_slices( |
|
| 69 |
#' teal_slice( |
|
| 70 |
#' dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4), |
|
| 71 |
#' keep_na = TRUE, keep_inf = FALSE |
|
| 72 |
#' ), |
|
| 73 |
#' teal_slice( |
|
| 74 |
#' dataname = "iris", varname = "Species", selected = c("setosa", "versicolor"),
|
|
| 75 |
#' keep_na = FALSE |
|
| 76 |
#' ), |
|
| 77 |
#' teal_slice( |
|
| 78 |
#' dataname = "mae", varname = "years_to_birth", selected = c(30, 50), |
|
| 79 |
#' keep_na = TRUE, keep_inf = FALSE |
|
| 80 |
#' ), |
|
| 81 |
#' teal_slice(dataname = "mae", varname = "vital_status", selected = "1", keep_na = FALSE), |
|
| 82 |
#' teal_slice(dataname = "mae", varname = "gender", selected = "female", keep_na = TRUE), |
|
| 83 |
#' teal_slice( |
|
| 84 |
#' dataname = "mae", varname = "ARRAY_TYPE", |
|
| 85 |
#' selected = "", keep_na = TRUE, experiment = "RPPAArray", arg = "subset" |
|
| 86 |
#' ) |
|
| 87 |
#' ) |
|
| 88 |
#' datasets$set_filter_state(state = fs) |
|
| 89 |
#' isolate(datasets$get_filter_state()) |
|
| 90 |
#' |
|
| 91 |
#' @keywords internal |
|
| 92 |
#' |
|
| 93 |
FilteredData <- R6::R6Class( # nolint |
|
| 94 |
"FilteredData", |
|
| 95 |
# public methods ---- |
|
| 96 |
public = list( |
|
| 97 |
#' @description |
|
| 98 |
#' Initialize a `FilteredData` object. |
|
| 99 |
#' @param data_objects (`named list`) |
|
| 100 |
#' List of data objects. |
|
| 101 |
#' Names of the list will be used as `dataname` for respective datasets. |
|
| 102 |
#' @param join_keys (`join_keys`) optional joining keys, see [`teal.data::join_keys()`]. |
|
| 103 |
#' |
|
| 104 |
initialize = function(data_objects, join_keys = teal.data::join_keys()) {
|
|
| 105 | 90x |
checkmate::assert_list(data_objects, any.missing = FALSE, min.len = 0, names = "unique") |
| 106 |
# unpack data.object from the nested list |
|
| 107 | 90x |
data_objects <- lapply(data_objects, function(dataset) {
|
| 108 | 124x |
if (is.list(dataset) && "dataset" %in% names(dataset)) {
|
| 109 | ! |
dataset$dataset |
| 110 |
} else {
|
|
| 111 | 124x |
dataset |
| 112 |
} |
|
| 113 |
}) |
|
| 114 | ||
| 115 |
# Note the internals of data_objects are checked in set_dataset |
|
| 116 | 90x |
checkmate::assert_class(join_keys, "join_keys") |
| 117 | 89x |
self$set_join_keys(join_keys) |
| 118 | 89x |
child_parent <- sapply( |
| 119 | 89x |
names(data_objects), |
| 120 | 89x |
function(i) teal.data::parent(join_keys, i), |
| 121 | 89x |
USE.NAMES = TRUE, |
| 122 | 89x |
simplify = FALSE |
| 123 |
) |
|
| 124 | 89x |
ordered_datanames <- topological_sort(child_parent) |
| 125 | 89x |
ordered_datanames <- intersect(ordered_datanames, names(data_objects)) |
| 126 | ||
| 127 | 89x |
for (dataname in ordered_datanames) {
|
| 128 | 123x |
ds_object <- data_objects[[dataname]] |
| 129 | 123x |
self$set_dataset(data = ds_object, dataname = dataname) |
| 130 |
} |
|
| 131 | ||
| 132 | 89x |
self$set_available_teal_slices(x = reactive(NULL)) |
| 133 | ||
| 134 | 89x |
invisible(self) |
| 135 |
}, |
|
| 136 | ||
| 137 |
#' @description Destroys a `FilteredData` object. |
|
| 138 | ! |
destroy = function() private$finalize(), |
| 139 | ||
| 140 |
#' @description |
|
| 141 |
#' Gets `datanames`. |
|
| 142 |
#' @details |
|
| 143 |
#' The `datanames` are returned in the order in which they must be evaluated (in case of dependencies). |
|
| 144 |
#' @return Character vector. |
|
| 145 |
datanames = function() {
|
|
| 146 | 187x |
names(private$filtered_datasets) |
| 147 |
}, |
|
| 148 | ||
| 149 |
#' @description |
|
| 150 |
#' Gets data label for the dataset. |
|
| 151 |
#' Useful to display in `Show R Code`. |
|
| 152 |
#' |
|
| 153 |
#' @param dataname (`character(1)`) name of the dataset |
|
| 154 |
#' @return Character string. |
|
| 155 |
get_datalabel = function(dataname) {
|
|
| 156 | 1x |
private$get_filtered_dataset(dataname)$get_dataset_label() |
| 157 |
}, |
|
| 158 | ||
| 159 |
#' @description |
|
| 160 |
#' Set list of external filter states available for activation. |
|
| 161 |
#' @details |
|
| 162 |
#' Unlike adding new filter from the column, these filters can come with some prespecified settings. |
|
| 163 |
#' `teal_slices` are wrapped in a `reactive` so they can be updated from elsewhere in the app. |
|
| 164 |
#' Filters passed in `x` are limited to those that can be set for this `FilteredData` object, |
|
| 165 |
#' i.e. they have the correct `dataname` and `varname` (waived `teal_slice_fixed` as they do not have `varname`). |
|
| 166 |
#' List is accessible in `ui/srv_active` through `ui/srv_available_filters`. |
|
| 167 |
#' @param x (`reactive`) |
|
| 168 |
#' should return `teal_slices` |
|
| 169 |
#' @return `NULL`, invisibly. |
|
| 170 |
set_available_teal_slices = function(x) {
|
|
| 171 | 90x |
checkmate::assert_class(x, "reactive") |
| 172 | 90x |
private$available_teal_slices <- reactive({
|
| 173 |
# Available filters should be limited to the ones relevant for this FilteredData. |
|
| 174 | 25x |
current_state <- isolate(self$get_filter_state()) |
| 175 | 25x |
allowed <- attr(current_state, "include_varnames") |
| 176 | 25x |
forbidden <- attr(current_state, "exclude_varnames") |
| 177 | 25x |
foo <- function(slice) {
|
| 178 | 13x |
if (slice$dataname %in% self$datanames()) {
|
| 179 | 13x |
if (slice$fixed) {
|
| 180 | 4x |
TRUE |
| 181 |
} else {
|
|
| 182 | 9x |
isTRUE(slice$varname %in% allowed[[slice$dataname]]) || |
| 183 | 9x |
isFALSE(slice$varname %in% forbidden[[slice$dataname]]) |
| 184 |
} |
|
| 185 |
} else {
|
|
| 186 | ! |
FALSE |
| 187 |
} |
|
| 188 |
} |
|
| 189 | 25x |
Filter(foo, x()) |
| 190 |
}) |
|
| 191 | 90x |
invisible(NULL) |
| 192 |
}, |
|
| 193 | ||
| 194 |
#' @description |
|
| 195 |
#' Get list of filter states available for this object. |
|
| 196 |
#' @details |
|
| 197 |
#' All `teal_slice` objects that have been created since the beginning of the app session |
|
| 198 |
#' are stored in one `teal_slices` object. This returns a subset of that `teal_slices`, |
|
| 199 |
#' describing filter states that can be set for this object. |
|
| 200 |
#' @return `reactive` that returns `teal_slices`. |
|
| 201 |
get_available_teal_slices = function() {
|
|
| 202 | 25x |
private$available_teal_slices |
| 203 |
}, |
|
| 204 | ||
| 205 |
# datasets methods ---- |
|
| 206 | ||
| 207 |
#' @description |
|
| 208 |
#' Gets a `call` to filter the dataset according to the filter state. |
|
| 209 |
#' @details |
|
| 210 |
#' It returns a `call` to filter the dataset only, assuming the |
|
| 211 |
#' other (filtered) datasets it depends on are available. |
|
| 212 |
#' |
|
| 213 |
#' Together with `self$datanames()` which returns the datasets in the correct |
|
| 214 |
#' evaluation order, this generates the whole filter code, see the function |
|
| 215 |
#' `FilteredData$get_filter_code`. |
|
| 216 |
#' |
|
| 217 |
#' For the return type, note that `rlang::is_expression` returns `TRUE` on the |
|
| 218 |
#' return type, both for base `R` expressions and calls (single expression, |
|
| 219 |
#' capturing a function call). |
|
| 220 |
#' |
|
| 221 |
#' The filtered dataset has the name given by `self$filtered_dataname(dataname)` |
|
| 222 |
#' |
|
| 223 |
#' This can be used for the `Show R Code` generation. |
|
| 224 |
#' |
|
| 225 |
#' @param dataname (`character(1)`) name of the dataset |
|
| 226 |
#' |
|
| 227 |
#' @return A list of `call`s. |
|
| 228 |
#' |
|
| 229 |
get_call = function(dataname) {
|
|
| 230 | 10x |
checkmate::assert_subset(dataname, self$datanames()) |
| 231 | 9x |
private$get_filtered_dataset(dataname)$get_call() |
| 232 |
}, |
|
| 233 | ||
| 234 |
#' @description |
|
| 235 |
#' Gets filtered or unfiltered dataset. |
|
| 236 |
#' |
|
| 237 |
#' For `filtered = FALSE`, the original data set with `set_data` is returned including all attributes. |
|
| 238 |
#' |
|
| 239 |
#' @param dataname (`character(1)`) name of the dataset. |
|
| 240 |
#' @param filtered (`logical(1)`) whether to return a filtered or unfiltered dataset. |
|
| 241 |
#' |
|
| 242 |
#' @return A data object, a `data.frame` or a `MultiAssayExperiment`. |
|
| 243 |
#' |
|
| 244 |
get_data = function(dataname, filtered = TRUE) {
|
|
| 245 | 27x |
checkmate::assert_subset(dataname, self$datanames()) |
| 246 | 26x |
checkmate::assert_flag(filtered) |
| 247 | 25x |
data <- private$get_filtered_dataset(dataname)$get_dataset(filtered) |
| 248 | 3x |
if (filtered) data() else data |
| 249 |
}, |
|
| 250 | ||
| 251 |
#' @description |
|
| 252 |
#' Get join keys between two datasets. |
|
| 253 |
#' |
|
| 254 |
#' @return `join_keys` |
|
| 255 |
#' |
|
| 256 |
get_join_keys = function() {
|
|
| 257 | 2x |
private$join_keys |
| 258 |
}, |
|
| 259 | ||
| 260 |
#' @description |
|
| 261 |
#' Creates filter overview table to be displayed in the application. |
|
| 262 |
#' One row is created per dataset, according to the `get_filter_overview` methods |
|
| 263 |
#' of the contained `FilteredDataset` objects. |
|
| 264 |
#' |
|
| 265 |
#' @param datanames (`character`) vector of dataset names. |
|
| 266 |
#' |
|
| 267 |
#' @return A `data.frame` listing the numbers of observations in all datasets. |
|
| 268 |
#' |
|
| 269 |
get_filter_overview = function(datanames) {
|
|
| 270 | 12x |
rows <- lapply( |
| 271 | 12x |
datanames, |
| 272 | 12x |
function(dataname) {
|
| 273 | 17x |
private$get_filtered_dataset(dataname)$get_filter_overview() |
| 274 |
} |
|
| 275 |
) |
|
| 276 | 8x |
unssuported_idx <- vapply(rows, function(x) all(is.na(x[-1])), logical(1)) |
| 277 | 8x |
dplyr::bind_rows(c(rows[!unssuported_idx], rows[unssuported_idx])) |
| 278 |
}, |
|
| 279 | ||
| 280 |
#' @description |
|
| 281 |
#' Get keys for the dataset. |
|
| 282 |
#' |
|
| 283 |
#' @param dataname (`character(1)`) name of the dataset. |
|
| 284 |
#' |
|
| 285 |
#' @return Character vector of key column names. |
|
| 286 |
#' |
|
| 287 |
get_keys = function(dataname) {
|
|
| 288 | 1x |
private$get_filtered_dataset(dataname)$get_keys() |
| 289 |
}, |
|
| 290 | ||
| 291 |
#' @description |
|
| 292 |
#' Adds a dataset to this `FilteredData`. |
|
| 293 |
#' |
|
| 294 |
#' @details |
|
| 295 |
#' `set_dataset` creates a `FilteredDataset` object which keeps `dataset` for the filtering purpose. |
|
| 296 |
#' If this data has a parent specified in the `join_keys` object stored in `private$join_keys` |
|
| 297 |
#' then created `FilteredDataset` (child) gets linked with other `FilteredDataset` (parent). |
|
| 298 |
#' "Child" dataset return filtered data then dependent on the reactive filtered data of the |
|
| 299 |
#' "parent". See more in documentation of `parent` argument in `DataframeFilteredDataset` constructor. |
|
| 300 |
#' |
|
| 301 |
#' @param data (`data.frame` or `MultiAssayExperiment`) |
|
| 302 |
#' data to be filtered. |
|
| 303 |
#' |
|
| 304 |
#' @param dataname (`character(1)`) |
|
| 305 |
#' the name of the `dataset` to be added to this object. |
|
| 306 |
#' |
|
| 307 |
#' @return `self`, invisibly. |
|
| 308 |
#' |
|
| 309 |
set_dataset = function(data, dataname) {
|
|
| 310 | 128x |
checkmate::assert_string(dataname) |
| 311 | 128x |
logger::log_debug("FilteredData$set_dataset setting dataset, name: { dataname }")
|
| 312 | ||
| 313 | 128x |
parent_dataname <- teal.data::parent(private$join_keys, dataname) |
| 314 | 128x |
keys <- private$join_keys[dataname, dataname] |
| 315 | 125x |
if (is.null(keys)) keys <- character(0) |
| 316 | ||
| 317 | 128x |
if (length(parent_dataname) == 0) {
|
| 318 | 117x |
private$filtered_datasets[[dataname]] <- init_filtered_dataset( |
| 319 | 117x |
dataset = data, |
| 320 | 117x |
dataname = dataname, |
| 321 | 117x |
keys = keys |
| 322 |
) |
|
| 323 |
} else {
|
|
| 324 | 11x |
join_keys <- private$join_keys[dataname, parent_dataname] |
| 325 | ! |
if (is.null(join_keys)) join_keys <- character(0) |
| 326 | 11x |
private$filtered_datasets[[dataname]] <- init_filtered_dataset( |
| 327 | 11x |
dataset = data, |
| 328 | 11x |
dataname = dataname, |
| 329 | 11x |
keys = keys, |
| 330 | 11x |
parent_name = parent_dataname, |
| 331 | 11x |
parent = reactive(self$get_data(parent_dataname, filtered = TRUE)), |
| 332 | 11x |
join_keys = join_keys |
| 333 |
) |
|
| 334 |
} |
|
| 335 | ||
| 336 | 128x |
invisible(self) |
| 337 |
}, |
|
| 338 | ||
| 339 |
#' @description |
|
| 340 |
#' Set the `join_keys`. |
|
| 341 |
#' |
|
| 342 |
#' @param join_keys (`join_keys`), see [`teal.data::join_keys()`]. |
|
| 343 |
#' |
|
| 344 |
#' @return `self`, invisibly. |
|
| 345 |
#' |
|
| 346 |
set_join_keys = function(join_keys) {
|
|
| 347 | 89x |
checkmate::assert_class(join_keys, "join_keys") |
| 348 | 89x |
private$join_keys <- join_keys |
| 349 | 89x |
invisible(self) |
| 350 |
}, |
|
| 351 | ||
| 352 |
# Functions useful for restoring from another dataset ---- |
|
| 353 | ||
| 354 |
#' @description |
|
| 355 |
#' Gets states of all contained `FilterState` objects. |
|
| 356 |
#' |
|
| 357 |
#' @return A `teal_slices` object. |
|
| 358 |
#' |
|
| 359 |
get_filter_state = function() {
|
|
| 360 | 157x |
states <- unname(lapply(private$filtered_datasets, function(x) x$get_filter_state())) |
| 361 | 157x |
slices <- Filter(Negate(is.null), states) |
| 362 | 157x |
slices <- do.call(c, slices) |
| 363 | 157x |
if (!is.null(slices)) {
|
| 364 | 157x |
attr(slices, "allow_add") <- private$allow_add |
| 365 |
} |
|
| 366 | 157x |
slices |
| 367 |
}, |
|
| 368 | ||
| 369 |
#' @description |
|
| 370 |
#' Returns a formatted string representing this `FilteredData` object. |
|
| 371 |
#' |
|
| 372 |
#' @param show_all (`logical(1)`) passed to `format.teal_slice`. |
|
| 373 |
#' @param trim_lines (`logical(1)`) passed to `format.teal_slice`. |
|
| 374 |
#' |
|
| 375 |
#' @return `character(1)` the formatted string. |
|
| 376 |
#' |
|
| 377 |
format = function(show_all = FALSE, trim_lines = TRUE) {
|
|
| 378 | 5x |
datasets <- lapply(self$datanames(), private$get_filtered_dataset) |
| 379 | 5x |
ind <- vapply(datasets, inherits, logical(1L), what = "DefaultFilteredDataset") |
| 380 | 5x |
states <- do.call(c, lapply(datasets[!ind], function(ds) ds$get_filter_state())) |
| 381 | 5x |
states_fmt <- format(states, show_all = show_all, trim_lines = trim_lines) |
| 382 | 5x |
holders_fmt <- vapply(datasets[ind], format, character(1L), show_all = show_all, trim_lines = trim_lines) |
| 383 | ||
| 384 | 5x |
sprintf( |
| 385 | 5x |
"%s:\n%s", |
| 386 | 5x |
class(self)[1], |
| 387 | 5x |
paste(c(states_fmt, holders_fmt), collapse = "\n") |
| 388 |
) |
|
| 389 |
}, |
|
| 390 | ||
| 391 |
#' @description |
|
| 392 |
#' Prints this `FilteredData` object. |
|
| 393 |
#' |
|
| 394 |
#' @param ... additional arguments passed to `format`. |
|
| 395 |
#' |
|
| 396 |
print = function(...) {
|
|
| 397 | ! |
cat(isolate(self$format(...)), "\n") |
| 398 |
}, |
|
| 399 | ||
| 400 |
#' @description |
|
| 401 |
#' Sets active filter states. |
|
| 402 |
#' |
|
| 403 |
#' @param state (`teal_slices`) |
|
| 404 |
#' |
|
| 405 |
#' @return `NULL`, invisibly. |
|
| 406 |
set_filter_state = function(state) {
|
|
| 407 | 56x |
isolate({
|
| 408 | 56x |
logger::log_debug("{ class(self)[1] }$set_filter_state initializing")
|
| 409 | 56x |
checkmate::assert_class(state, "teal_slices") |
| 410 | 56x |
allow_add <- attr(state, "allow_add") |
| 411 | 56x |
if (!is.null(allow_add)) {
|
| 412 | 56x |
private$allow_add <- allow_add |
| 413 |
} |
|
| 414 | ||
| 415 | 56x |
lapply(self$datanames(), function(dataname) {
|
| 416 | 87x |
states <- Filter(function(x) identical(x$dataname, dataname), state) |
| 417 | 87x |
private$get_filtered_dataset(dataname)$set_filter_state(states) |
| 418 |
}) |
|
| 419 | ||
| 420 | 56x |
invisible(NULL) |
| 421 |
}) |
|
| 422 | ||
| 423 | 56x |
invisible(NULL) |
| 424 |
}, |
|
| 425 | ||
| 426 |
#' @description |
|
| 427 |
#' Removes one or more `FilterState` from a `FilteredData` object. |
|
| 428 |
#' |
|
| 429 |
#' @param state (`teal_slices`) |
|
| 430 |
#' specifying `FilterState` objects to remove; |
|
| 431 |
#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored. |
|
| 432 |
#' |
|
| 433 |
#' @return `NULL`, invisibly. |
|
| 434 |
#' |
|
| 435 |
remove_filter_state = function(state) {
|
|
| 436 | 8x |
isolate({
|
| 437 | 8x |
checkmate::assert_class(state, "teal_slices") |
| 438 | 8x |
state_ids <- unique(vapply(state, "[[", character(1L), "id")) |
| 439 | 8x |
logger::log_debug("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { state_ids }")
|
| 440 | 8x |
datanames <- unique(vapply(state, "[[", character(1L), "dataname")) |
| 441 | 8x |
checkmate::assert_subset(datanames, self$datanames()) |
| 442 | 8x |
lapply(datanames, function(dataname) {
|
| 443 | 9x |
slices <- Filter(function(x) identical(x$dataname, dataname), state) |
| 444 | 9x |
private$get_filtered_dataset(dataname)$remove_filter_state(slices) |
| 445 |
}) |
|
| 446 |
}) |
|
| 447 | ||
| 448 | 8x |
invisible(NULL) |
| 449 |
}, |
|
| 450 | ||
| 451 |
#' @description |
|
| 452 |
#' Remove all `FilterStates` of a `FilteredDataset` or all `FilterStates` of a `FilteredData` object. |
|
| 453 |
#' |
|
| 454 |
#' @param datanames (`character`) |
|
| 455 |
#' names of datasets for which to remove all filter states. |
|
| 456 |
#' Defaults to all datasets in this `FilteredData` object. |
|
| 457 |
#' @param force (`logical(1)`) |
|
| 458 |
#' flag specifying whether to include anchored filter states. |
|
| 459 |
#' |
|
| 460 |
#' @return `NULL`, invisibly. |
|
| 461 |
#' |
|
| 462 |
clear_filter_states = function(datanames = self$datanames(), force = FALSE) {
|
|
| 463 | 7x |
logger::log_debug("FilteredData$clear_filter_states called, datanames: { toString(datanames) }")
|
| 464 | 7x |
for (dataname in datanames) {
|
| 465 | 12x |
fdataset <- private$get_filtered_dataset(dataname = dataname) |
| 466 | 12x |
fdataset$clear_filter_states(force) |
| 467 |
} |
|
| 468 | 7x |
invisible(NULL) |
| 469 |
}, |
|
| 470 | ||
| 471 | ||
| 472 |
# shiny modules ----- |
|
| 473 | ||
| 474 |
#' @description |
|
| 475 |
#' top-level `shiny` module for the filter panel in the `teal` app. |
|
| 476 |
#' Contains 1) filter overview panel, 2) filter active panel, and 3) add filters panel. |
|
| 477 |
#' |
|
| 478 |
#' @param id (`character(1)`) |
|
| 479 |
#' `shiny` module instance id. |
|
| 480 |
#' @param active_datanames (`reactive`) |
|
| 481 |
#' defining subset of `self$datanames()` to be displayed. |
|
| 482 |
#' @return `shiny.tag` |
|
| 483 |
ui_filter_panel = function(id, active_datanames = self$datanames) {
|
|
| 484 | ! |
ns <- NS(id) |
| 485 | ! |
bslib::page_fluid( |
| 486 | ! |
id = ns(NULL), # used for hiding / showing |
| 487 | ! |
class = "teal-slice filter-panel", |
| 488 | ! |
include_css_files(pattern = "filter-panel"), |
| 489 | ! |
include_js_files(pattern = "togglePanelItems"), |
| 490 | ! |
shinyjs::useShinyjs(), |
| 491 | ! |
self$ui_overview(ns("overview")),
|
| 492 | ! |
self$ui_active(ns("active"), active_datanames = active_datanames)
|
| 493 |
) |
|
| 494 |
}, |
|
| 495 | ||
| 496 |
#' @description |
|
| 497 |
#' Server function for filter panel. |
|
| 498 |
#' |
|
| 499 |
#' @param id (`character(1)`) |
|
| 500 |
#' `shiny` module instance id. |
|
| 501 |
#' @param active_datanames (`function` or `reactive`) |
|
| 502 |
#' returning `datanames` that should be shown on the filter panel. |
|
| 503 |
#' Must be a subset of the `datanames` in this `FilteredData`. |
|
| 504 |
#' If the function returns `NULL` (as opposed to `character(0)`), |
|
| 505 |
#' the filter panel will be hidden. |
|
| 506 |
#' @return `NULL`. |
|
| 507 |
srv_filter_panel = function(id, active_datanames = self$datanames) {
|
|
| 508 | 1x |
checkmate::assert_function(active_datanames) |
| 509 | 1x |
moduleServer(id = id, function(input, output, session) {
|
| 510 | 1x |
logger::log_debug("FilteredData$srv_filter_panel initializing")
|
| 511 | ||
| 512 | 1x |
active_datanames_resolved <- reactive({
|
| 513 | 1x |
checkmate::assert_subset(active_datanames(), self$datanames()) |
| 514 | ! |
active_datanames() |
| 515 |
}) |
|
| 516 | ||
| 517 | 1x |
self$srv_overview("overview", active_datanames_resolved)
|
| 518 | 1x |
self$srv_active("active", active_datanames_resolved)
|
| 519 | ||
| 520 | 1x |
NULL |
| 521 |
}) |
|
| 522 |
}, |
|
| 523 | ||
| 524 |
#' @description |
|
| 525 |
#' Server module responsible for displaying active filters. |
|
| 526 |
#' @param id (`character(1)`) |
|
| 527 |
#' `shiny` module instance id. |
|
| 528 |
#' @param active_datanames (`reactive`) |
|
| 529 |
#' defining subset of `self$datanames()` to be displayed. |
|
| 530 |
#' @return `shiny.tag` |
|
| 531 |
ui_active = function(id, active_datanames = self$datanames) {
|
|
| 532 | ! |
ns <- NS(id) |
| 533 | ! |
tags$div( |
| 534 | ! |
id = id, # not used, can be used to customize CSS behavior |
| 535 | ! |
include_js_files(pattern = "togglePanelItems"), |
| 536 | ! |
class = "teal-slice", |
| 537 | ! |
bslib::accordion( |
| 538 | ! |
id = ns("main_filter_accordion"),
|
| 539 | ! |
bslib::accordion_panel( |
| 540 | ! |
"Filter Data", |
| 541 | ! |
tags$div( |
| 542 | ! |
div( |
| 543 | ! |
id = ns("additional_filter_helpers"),
|
| 544 | ! |
class = "teal-slice available-filters", |
| 545 | ! |
private$ui_available_filters(ns("available_filters")),
|
| 546 | ! |
uiOutput(ns("remove_all_filters_ui"))
|
| 547 |
), |
|
| 548 | ! |
tags$div( |
| 549 | ! |
id = ns("filter_active_vars_contents"),
|
| 550 | ! |
tagList( |
| 551 | ! |
lapply( |
| 552 | ! |
isolate(active_datanames()), |
| 553 | ! |
function(dataname) {
|
| 554 | ! |
fdataset <- private$get_filtered_dataset(dataname) |
| 555 | ! |
fdataset$ui_active(id = ns(dataname)) |
| 556 |
} |
|
| 557 |
) |
|
| 558 |
) |
|
| 559 |
), |
|
| 560 | ! |
tags$div( |
| 561 | ! |
id = ns("filters_active_count"),
|
| 562 | ! |
style = "display: none;", |
| 563 | ! |
textOutput(ns("teal_filters_count"))
|
| 564 |
) |
|
| 565 |
) |
|
| 566 |
) |
|
| 567 |
), |
|
| 568 | ! |
tags$script( |
| 569 | ! |
HTML( |
| 570 | ! |
sprintf( |
| 571 |
" |
|
| 572 | ! |
$(document).ready(function() {
|
| 573 | ! |
$('#%s').appendTo('#%s > .accordion-item > .accordion-header');
|
| 574 | ! |
$('#%s > .accordion-item > .accordion-header').css({
|
| 575 | ! |
'display': 'flex' |
| 576 |
}); |
|
| 577 | ! |
$('#%s i').css({
|
| 578 | ! |
'color': 'var(--bs-accordion-color)', |
| 579 | ! |
'font-size': '1rem' |
| 580 |
}); |
|
| 581 |
}); |
|
| 582 |
", |
|
| 583 | ! |
ns("additional_filter_helpers"),
|
| 584 | ! |
ns("main_filter_accordion"),
|
| 585 | ! |
ns("main_filter_accordion"),
|
| 586 | ! |
ns("additional_filter_helpers")
|
| 587 |
) |
|
| 588 |
) |
|
| 589 |
) |
|
| 590 |
) |
|
| 591 |
}, |
|
| 592 | ||
| 593 |
#' @description |
|
| 594 |
#' Server module responsible for displaying active filters. |
|
| 595 |
#' @param id (`character(1)`) |
|
| 596 |
#' `shiny` module instance id. |
|
| 597 |
#' @param active_datanames (`reactive`) |
|
| 598 |
#' defining subset of `self$datanames()` to be displayed. |
|
| 599 |
#' @return `NULL`. |
|
| 600 |
srv_active = function(id, active_datanames = self$datanames) {
|
|
| 601 | 24x |
checkmate::assert_function(active_datanames) |
| 602 | 24x |
moduleServer(id, function(input, output, session) {
|
| 603 | 24x |
logger::log_debug("FilteredData$srv_active initializing")
|
| 604 | ||
| 605 | 24x |
private$srv_available_filters("available_filters")
|
| 606 | ||
| 607 | 24x |
private$session_bindings[[session$ns("minimise_filter_active")]] <- observeEvent(
|
| 608 | 24x |
eventExpr = input$minimise_filter_active, |
| 609 | 24x |
handlerExpr = {
|
| 610 | ! |
shinyjs::toggle("filter_active_vars_contents")
|
| 611 | ! |
shinyjs::toggle("filters_active_count")
|
| 612 | ! |
toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"))
|
| 613 | ! |
toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"))
|
| 614 |
} |
|
| 615 |
) |
|
| 616 | ||
| 617 | 24x |
filter_count <- reactive({
|
| 618 | 26x |
length(self$get_filter_state()) |
| 619 |
}) |
|
| 620 | ||
| 621 | 24x |
is_filter_removable <- reactive({
|
| 622 | 26x |
non_anchored <- Filter(function(x) !x$anchored, self$get_filter_state()) |
| 623 | 26x |
isTRUE(length(non_anchored) > 0) |
| 624 |
}) |
|
| 625 | ||
| 626 | 24x |
output$remove_all_filters_ui <- renderUI({
|
| 627 | 26x |
req(is_filter_removable()) |
| 628 | 22x |
tags$div( |
| 629 | 22x |
style = "display: flex;", |
| 630 | 22x |
actionLink( |
| 631 | 22x |
inputId = session$ns("remove_all_filters"),
|
| 632 | 22x |
label = "", |
| 633 | 22x |
title = "Remove active filters", |
| 634 | 22x |
icon = icon("far fa-circle-xmark"),
|
| 635 | 22x |
class = "teal-slice filter-icon remove-all" |
| 636 |
) |
|
| 637 |
) |
|
| 638 |
}) |
|
| 639 | ||
| 640 | 24x |
private$session_bindings[[session$ns("is_filter_removable")]] <- observeEvent(
|
| 641 | 24x |
eventExpr = is_filter_removable(), |
| 642 | 24x |
handlerExpr = {
|
| 643 | 26x |
shinyjs::toggle("remove_all_filters", condition = is_filter_removable())
|
| 644 | 26x |
shinyjs::show("filter_active_vars_contents")
|
| 645 | 26x |
shinyjs::hide("filters_active_count")
|
| 646 | 26x |
toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"), TRUE)
|
| 647 | 26x |
toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"), TRUE)
|
| 648 |
} |
|
| 649 |
) |
|
| 650 | ||
| 651 | 24x |
private$session_bindings[[session$ns("active_datanames")]] <- observeEvent(
|
| 652 | 24x |
eventExpr = active_datanames(), |
| 653 | 24x |
handlerExpr = lapply(self$datanames(), function(dataname) {
|
| 654 | 25x |
if (dataname %in% active_datanames()) {
|
| 655 | 25x |
shinyjs::show(dataname) |
| 656 |
} else {
|
|
| 657 | ! |
shinyjs::hide(dataname) |
| 658 |
} |
|
| 659 |
}) |
|
| 660 |
) |
|
| 661 | ||
| 662 |
# should not use for-loop as variables are otherwise only bound by reference |
|
| 663 |
# and last dataname would be used |
|
| 664 | 24x |
lapply( |
| 665 | 24x |
self$datanames(), |
| 666 | 24x |
function(dataname) {
|
| 667 | 27x |
fdataset <- private$get_filtered_dataset(dataname) |
| 668 | 27x |
fdataset$srv_active(id = dataname) |
| 669 |
} |
|
| 670 |
) |
|
| 671 | ||
| 672 | 24x |
output$teal_filters_count <- renderText({
|
| 673 | 26x |
n_filters_active <- filter_count() |
| 674 | 26x |
req(n_filters_active > 0L) |
| 675 | 23x |
sprintf( |
| 676 | 23x |
"%s filter%s applied across datasets", |
| 677 | 23x |
n_filters_active, |
| 678 | 23x |
ifelse(n_filters_active == 1, "", "s") |
| 679 |
) |
|
| 680 |
}) |
|
| 681 | ||
| 682 | 24x |
private$session_bindings[[session$ns("remove_all_filters")]] <- observeEvent(
|
| 683 | 24x |
eventExpr = input$remove_all_filters, |
| 684 | 24x |
handlerExpr = {
|
| 685 | 1x |
logger::log_debug("FilteredData$srv_filter_panel@1 removing all non-anchored filters")
|
| 686 | 1x |
self$clear_filter_states() |
| 687 |
} |
|
| 688 |
) |
|
| 689 | ||
| 690 | 24x |
private$session_bindings[[session$ns("inputs")]] <- list(
|
| 691 | 24x |
destroy = function() {
|
| 692 | 21x |
lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) |
| 693 |
} |
|
| 694 |
) |
|
| 695 | ||
| 696 | 24x |
NULL |
| 697 |
}) |
|
| 698 |
}, |
|
| 699 | ||
| 700 |
#' @description |
|
| 701 |
#' Creates the UI definition for the module showing counts for each dataset |
|
| 702 |
#' contrasting the filtered to the full unfiltered dataset. |
|
| 703 |
#' |
|
| 704 |
#' Per dataset, it displays |
|
| 705 |
#' the number of rows/observations in each dataset, |
|
| 706 |
#' the number of unique subjects. |
|
| 707 |
#' |
|
| 708 |
#' @param id (`character(1)`) |
|
| 709 |
#' `shiny` module instance id. |
|
| 710 |
#' |
|
| 711 |
ui_overview = function(id) {
|
|
| 712 | ! |
ns <- NS(id) |
| 713 | ! |
tags$div( |
| 714 | ! |
class = "teal-slice", |
| 715 | ! |
bslib::accordion( |
| 716 | ! |
id = ns("main_filter_accordion"),
|
| 717 | ! |
bslib::accordion_panel( |
| 718 | ! |
title = "Active Filter Summary", |
| 719 | ! |
tags$div( |
| 720 | ! |
id = ns("filters_overview_contents"),
|
| 721 | ! |
tags$div( |
| 722 | ! |
style = "overflow-x: auto;", |
| 723 | ! |
tableOutput(ns("table"))
|
| 724 |
) |
|
| 725 |
) |
|
| 726 |
) |
|
| 727 |
) |
|
| 728 |
) |
|
| 729 |
}, |
|
| 730 | ||
| 731 |
#' @description |
|
| 732 |
#' Server function to display the number of records in the filtered and unfiltered |
|
| 733 |
#' data. |
|
| 734 |
#' |
|
| 735 |
#' @param id (`character(1)`) |
|
| 736 |
#' `shiny` module instance id. |
|
| 737 |
#' @param active_datanames (`reactive`) |
|
| 738 |
#' returning `datanames` that should be shown on the filter panel, |
|
| 739 |
#' must be a subset of the `datanames` argument provided to `ui_filter_panel`; |
|
| 740 |
#' if the function returns `NULL` (as opposed to `character(0)`), the filter |
|
| 741 |
#' panel will be hidden. |
|
| 742 |
#' @return `NULL`. |
|
| 743 |
srv_overview = function(id, active_datanames = self$datanames) {
|
|
| 744 | 5x |
checkmate::assert_function(active_datanames) |
| 745 | 5x |
moduleServer( |
| 746 | 5x |
id = id, |
| 747 | 5x |
function(input, output, session) {
|
| 748 | 5x |
logger::log_debug("FilteredData$srv_filter_overview initializing")
|
| 749 | ||
| 750 | 5x |
output$table <- renderUI({
|
| 751 | 4x |
logger::log_debug("FilteredData$srv_filter_overview@1 updating counts")
|
| 752 | 4x |
if (length(active_datanames()) == 0) {
|
| 753 | 1x |
return(NULL) |
| 754 |
} |
|
| 755 | ||
| 756 | 3x |
datasets_df <- self$get_filter_overview(datanames = active_datanames()) |
| 757 | ||
| 758 | 3x |
attr(datasets_df$dataname, "label") <- "Data Name" |
| 759 | ||
| 760 | 3x |
if (!is.null(datasets_df$obs)) {
|
| 761 |
# some datasets (MAE colData) doesn't return obs column |
|
| 762 | 3x |
datasets_df <- transform( |
| 763 | 3x |
datasets_df, |
| 764 | 3x |
obs_str_summary = ifelse( |
| 765 | 3x |
!is.na(obs), |
| 766 | 3x |
sprintf("%s/%s", obs_filtered, obs),
|
| 767 |
"" |
|
| 768 |
) |
|
| 769 |
) |
|
| 770 | 3x |
attr(datasets_df$obs_str_summary, "label") <- "Obs" |
| 771 |
} |
|
| 772 | ||
| 773 | ||
| 774 | 3x |
if (!is.null(datasets_df$subjects)) {
|
| 775 |
# some datasets (without keys) doesn't return subjects |
|
| 776 | 1x |
datasets_df <- transform( |
| 777 | 1x |
datasets_df, |
| 778 | 1x |
subjects_summary = ifelse( |
| 779 | 1x |
!is.na(subjects), |
| 780 | 1x |
sprintf("%s/%s", subjects_filtered, subjects),
|
| 781 |
"" |
|
| 782 |
) |
|
| 783 |
) |
|
| 784 | 1x |
attr(datasets_df$subjects_summary, "label") <- "Subjects" |
| 785 |
} |
|
| 786 | ||
| 787 | 3x |
all_names <- c("dataname", "obs_str_summary", "subjects_summary")
|
| 788 | 3x |
datasets_df <- datasets_df[, colnames(datasets_df) %in% all_names] |
| 789 | ||
| 790 | 3x |
body_html <- apply( |
| 791 | 3x |
datasets_df, |
| 792 | 3x |
1, |
| 793 | 3x |
function(x) {
|
| 794 | 6x |
tags$tr( |
| 795 | 6x |
tagList( |
| 796 | 6x |
tags$td( |
| 797 | 6x |
if (all(x[-1] == "")) {
|
| 798 | 1x |
icon( |
| 799 | 1x |
name = "exclamation-triangle", |
| 800 | 1x |
title = "Unsupported dataset", |
| 801 | 1x |
`data-container` = "body", |
| 802 | 1x |
`data-toggle` = "popover", |
| 803 | 1x |
`data-content` = "object not supported by the filter panel" |
| 804 |
) |
|
| 805 |
}, |
|
| 806 | 6x |
x[1] |
| 807 |
), |
|
| 808 | 6x |
lapply(x[-1], tags$td) |
| 809 |
) |
|
| 810 |
) |
|
| 811 |
} |
|
| 812 |
) |
|
| 813 | ||
| 814 | 3x |
header_labels <- vapply( |
| 815 | 3x |
seq_along(datasets_df), |
| 816 | 3x |
function(i) {
|
| 817 | 7x |
label <- attr(datasets_df[[i]], "label") |
| 818 | 7x |
ifelse(!is.null(label), label, names(datasets_df)[[i]]) |
| 819 |
}, |
|
| 820 | 3x |
character(1) |
| 821 |
) |
|
| 822 | 3x |
header_html <- tags$tr(tagList(lapply(header_labels, tags$td))) |
| 823 | ||
| 824 | 3x |
table_html <- tags$table( |
| 825 | 3x |
class = "teal-slice table custom-table", |
| 826 | 3x |
tags$thead(header_html), |
| 827 | 3x |
tags$tbody(body_html) |
| 828 |
) |
|
| 829 | 3x |
table_html |
| 830 |
}) |
|
| 831 | ||
| 832 | 5x |
NULL |
| 833 |
} |
|
| 834 |
) |
|
| 835 |
} |
|
| 836 |
), |
|
| 837 | ||
| 838 |
# private members ---- |
|
| 839 |
private = list( |
|
| 840 |
# selectively hide / show to only show `active_datanames` out of all datanames |
|
| 841 | ||
| 842 |
# private attributes ---- |
|
| 843 |
filtered_datasets = list(), |
|
| 844 | ||
| 845 |
# activate/deactivate filter panel |
|
| 846 |
filter_panel_active = TRUE, |
|
| 847 | ||
| 848 |
# `reactive` containing teal_slices that can be selected; only active in module-specific mode |
|
| 849 |
available_teal_slices = NULL, |
|
| 850 | ||
| 851 |
# keys used for joining/filtering data a join_keys object (see teal.data) |
|
| 852 |
join_keys = NULL, |
|
| 853 | ||
| 854 |
# flag specifying whether the user may add filters |
|
| 855 |
allow_add = TRUE, |
|
| 856 | ||
| 857 |
# observers and inputs list |
|
| 858 |
session_bindings = list(), |
|
| 859 | ||
| 860 |
# private methods ---- |
|
| 861 | ||
| 862 |
# @description |
|
| 863 |
# Gets `FilteredDataset` object which contains all information |
|
| 864 |
# pertaining to the specified dataset. |
|
| 865 |
# |
|
| 866 |
# @param dataname (`character(1)`) |
|
| 867 |
# name of the dataset |
|
| 868 |
# |
|
| 869 |
# @return `FilteredDataset` object or list of `FilteredDataset`s |
|
| 870 |
# |
|
| 871 |
get_filtered_dataset = function(dataname = character(0)) {
|
|
| 872 | 199x |
if (length(dataname) == 0) {
|
| 873 | ! |
private$filtered_datasets |
| 874 |
} else {
|
|
| 875 | 199x |
private$filtered_datasets[[dataname]] |
| 876 |
} |
|
| 877 |
}, |
|
| 878 | ||
| 879 |
# @description |
|
| 880 |
# Activate available filters. |
|
| 881 |
# Module is composed from plus button and dropdown menu. Menu is shown when |
|
| 882 |
# the button is clicked. Menu contains available/active filters list |
|
| 883 |
# passed via `set_available_teal_slice`. |
|
| 884 |
ui_available_filters = function(id) {
|
|
| 885 | ! |
ns <- NS(id) |
| 886 | ||
| 887 | ! |
active_slices_id <- isolate(vapply(self$get_filter_state(), `[[`, character(1), "id")) |
| 888 | ! |
tags$div( |
| 889 | ! |
id = ns("available_menu"),
|
| 890 | ! |
shinyWidgets::dropMenu( |
| 891 | ! |
tags$a( |
| 892 | ! |
id = ns("show"),
|
| 893 | ! |
class = "available-menu", |
| 894 | ! |
bsicons::bs_icon("plus-square", size = "1.4rem", class = "teal-slice filter-icon", fill = "#fff"),
|
| 895 |
), |
|
| 896 | ! |
tags$div( |
| 897 | ! |
style = "min-width: 15em;", |
| 898 | ! |
shinycssloaders::withSpinner( |
| 899 | ! |
uiOutput(ns("checkbox")),
|
| 900 | ! |
type = 4, |
| 901 | ! |
size = 0.25 |
| 902 |
) |
|
| 903 |
) |
|
| 904 |
) |
|
| 905 |
) |
|
| 906 |
}, |
|
| 907 |
# @description |
|
| 908 |
# Activate available filters. When a filter is selected or removed, |
|
| 909 |
# `set_filter_state` or `remove_filter_state` is executed for |
|
| 910 |
# the appropriate filter state id. |
|
| 911 |
srv_available_filters = function(id) {
|
|
| 912 | 25x |
moduleServer(id, function(input, output, session) {
|
| 913 | 25x |
slices_available <- self$get_available_teal_slices() |
| 914 | 25x |
slices_interactive <- reactive( |
| 915 | 25x |
Filter(function(slice) isFALSE(slice$fixed), slices_available()) |
| 916 |
) |
|
| 917 | 25x |
slices_fixed <- reactive( |
| 918 | 25x |
Filter(function(slice) isTRUE(slice$fixed), slices_available()) |
| 919 |
) |
|
| 920 | 25x |
available_slices_id <- reactive(vapply(slices_available(), `[[`, character(1), "id")) |
| 921 | 25x |
active_slices_id <- reactive(vapply(self$get_filter_state(), `[[`, character(1), "id")) |
| 922 | 25x |
duplicated_slice_references <- reactive({
|
| 923 |
# slice refers to a particular column |
|
| 924 | 31x |
slice_reference <- vapply(slices_available(), get_default_slice_id, character(1)) |
| 925 | 31x |
is_duplicated_reference <- duplicated(slice_reference) | duplicated(slice_reference, fromLast = TRUE) |
| 926 | 31x |
is_active <- available_slices_id() %in% active_slices_id() |
| 927 | 31x |
is_not_expr <- !vapply(slices_available(), inherits, logical(1), "teal_slice_expr") |
| 928 | 31x |
slice_reference[is_duplicated_reference & is_active & is_not_expr] |
| 929 |
}) |
|
| 930 | ||
| 931 | 25x |
checkbox_group_element <- function(name, value, label, checked, disabled = FALSE) {
|
| 932 | 35x |
tags$div( |
| 933 | 35x |
class = "checkbox available-filters", |
| 934 | 35x |
tags$label( |
| 935 | 35x |
tags$input( |
| 936 | 35x |
type = "checkbox", |
| 937 | 35x |
name = name, |
| 938 | 35x |
value = value, |
| 939 | 35x |
checked = checked, |
| 940 | 35x |
disabled = if (disabled) "disabled" |
| 941 |
), |
|
| 942 | 35x |
tags$span(label, disabled = if (disabled) disabled) |
| 943 |
) |
|
| 944 |
) |
|
| 945 |
} |
|
| 946 | ||
| 947 | 25x |
output$checkbox <- renderUI({
|
| 948 | 31x |
checkbox <- checkboxGroupInput( |
| 949 | 31x |
session$ns("available_slices_id"),
|
| 950 | 31x |
label = NULL, |
| 951 | 31x |
choices = NULL, |
| 952 | 31x |
selected = NULL |
| 953 |
) |
|
| 954 | 31x |
active_slices_ids <- active_slices_id() |
| 955 | 31x |
duplicated_slice_refs <- duplicated_slice_references() |
| 956 | ||
| 957 | 31x |
checkbox_group_slice <- function(slice) {
|
| 958 |
# we need to isolate changes in the fields of the slice (teal_slice) |
|
| 959 | 35x |
isolate({
|
| 960 | 35x |
checkbox_group_element( |
| 961 | 35x |
name = session$ns("available_slices_id"),
|
| 962 | 35x |
value = slice$id, |
| 963 | 35x |
label = slice$id, |
| 964 | 35x |
checked = if (slice$id %in% active_slices_ids) "checked", |
| 965 | 35x |
disabled = slice$anchored || |
| 966 | 35x |
get_default_slice_id(slice) %in% duplicated_slice_refs && |
| 967 | 35x |
!slice$id %in% active_slices_ids |
| 968 |
) |
|
| 969 |
}) |
|
| 970 |
} |
|
| 971 | ||
| 972 | 31x |
interactive_choice_mock <- lapply(slices_interactive(), checkbox_group_slice) |
| 973 | 31x |
non_interactive_choice_mock <- lapply(slices_fixed(), checkbox_group_slice) |
| 974 | ||
| 975 | 31x |
htmltools::tagInsertChildren( |
| 976 | 31x |
checkbox, |
| 977 | 31x |
tags$br(), |
| 978 | 31x |
if (length(non_interactive_choice_mock)) tags$strong("Fixed filters"),
|
| 979 | 31x |
non_interactive_choice_mock, |
| 980 | 31x |
if (length(interactive_choice_mock)) tags$strong("Interactive filters"),
|
| 981 | 31x |
interactive_choice_mock, |
| 982 | 31x |
.cssSelector = "div.shiny-options-group", |
| 983 | 31x |
after = 0 |
| 984 |
) |
|
| 985 |
}) |
|
| 986 | ||
| 987 | 25x |
private$session_bindings[[session$ns("available_slices_id")]] <- observeEvent(
|
| 988 | 25x |
eventExpr = input$available_slices_id, |
| 989 | 25x |
ignoreNULL = FALSE, |
| 990 | 25x |
ignoreInit = TRUE, |
| 991 | 25x |
handlerExpr = {
|
| 992 | 5x |
new_slices_id <- setdiff(input$available_slices_id, active_slices_id()) |
| 993 | 5x |
removed_slices_id <- setdiff(active_slices_id(), input$available_slices_id) |
| 994 | 5x |
if (length(new_slices_id)) {
|
| 995 | 3x |
new_teal_slices <- Filter( |
| 996 | 3x |
function(slice) slice$id %in% new_slices_id, |
| 997 | 3x |
private$available_teal_slices() |
| 998 |
) |
|
| 999 | 3x |
self$set_filter_state(new_teal_slices) |
| 1000 |
} |
|
| 1001 | ||
| 1002 | 5x |
if (length(removed_slices_id)) {
|
| 1003 | 4x |
removed_teal_slices <- Filter( |
| 1004 | 4x |
function(slice) slice$id %in% removed_slices_id, |
| 1005 | 4x |
self$get_filter_state() |
| 1006 |
) |
|
| 1007 | 4x |
self$remove_filter_state(removed_teal_slices) |
| 1008 |
} |
|
| 1009 |
} |
|
| 1010 |
) |
|
| 1011 | ||
| 1012 | 25x |
private$session_bindings[[session$ns("available_teal_slices")]] <- observeEvent(
|
| 1013 | 25x |
eventExpr = private$available_teal_slices(), |
| 1014 | 25x |
ignoreNULL = FALSE, |
| 1015 | 25x |
handlerExpr = {
|
| 1016 | 24x |
if (length(private$available_teal_slices())) {
|
| 1017 | 1x |
shinyjs::show("available_menu")
|
| 1018 |
} else {
|
|
| 1019 | 23x |
shinyjs::hide("available_menu")
|
| 1020 |
} |
|
| 1021 |
} |
|
| 1022 |
) |
|
| 1023 |
}) |
|
| 1024 |
}, |
|
| 1025 | ||
| 1026 |
# @description |
|
| 1027 |
# Object and dependencies cleanup. |
|
| 1028 |
# |
|
| 1029 |
# - Destroy inputs and observers stored in `private$session_bindings` |
|
| 1030 |
# - Finalize `FilteredData` stored in `private$filtered_datasets` |
|
| 1031 |
# |
|
| 1032 |
# @return `NULL`, invisibly. |
|
| 1033 |
finalize = function() {
|
|
| 1034 | 89x |
.finalize_session_bindings(self, private) |
| 1035 | 89x |
lapply(private$filtered_datasets, function(x) x$destroy()) |
| 1036 | 89x |
invisible(NULL) |
| 1037 |
} |
|
| 1038 |
) |
|
| 1039 |
) |
| 1 |
# ChoicesFilterState ------ |
|
| 2 | ||
| 3 |
#' @name ChoicesFilterState |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterState` object for categorical data |
|
| 7 |
#' |
|
| 8 |
#' @description Manages choosing elements from a set. |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' # use non-exported function from teal.slice |
|
| 12 |
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 13 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 14 |
#' ChoicesFilterState <- getFromNamespace("ChoicesFilterState", "teal.slice")
|
|
| 15 |
#' |
|
| 16 |
#' library(shiny) |
|
| 17 |
#' |
|
| 18 |
#' filter_state <- ChoicesFilterState$new( |
|
| 19 |
#' x = c(LETTERS, NA), |
|
| 20 |
#' slice = teal_slice(varname = "var", dataname = "data") |
|
| 21 |
#' ) |
|
| 22 |
#' isolate(filter_state$get_call()) |
|
| 23 |
#' filter_state$set_state( |
|
| 24 |
#' teal_slice( |
|
| 25 |
#' dataname = "data", |
|
| 26 |
#' varname = "var", |
|
| 27 |
#' selected = "A", |
|
| 28 |
#' keep_na = TRUE |
|
| 29 |
#' ) |
|
| 30 |
#' ) |
|
| 31 |
#' isolate(filter_state$get_call()) |
|
| 32 |
#' |
|
| 33 |
#' # working filter in an app |
|
| 34 |
#' library(shinyjs) |
|
| 35 |
#' |
|
| 36 |
#' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA) |
|
| 37 |
#' attr(data_choices, "label") <- "lowercase letters" |
|
| 38 |
#' fs <- ChoicesFilterState$new( |
|
| 39 |
#' x = data_choices, |
|
| 40 |
#' slice = teal_slice( |
|
| 41 |
#' dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE
|
|
| 42 |
#' ) |
|
| 43 |
#' ) |
|
| 44 |
#' |
|
| 45 |
#' ui <- bslib::page_fluid( |
|
| 46 |
#' useShinyjs(), |
|
| 47 |
#' include_css_files(pattern = "filter-panel"), |
|
| 48 |
#' include_js_files(pattern = "count-bar-labels"), |
|
| 49 |
#' bslib::layout_column_wrap( |
|
| 50 |
#' width = 1 / 3, |
|
| 51 |
#' tags$div( |
|
| 52 |
#' tags$h4("ChoicesFilterState"),
|
|
| 53 |
#' fs$ui("fs")
|
|
| 54 |
#' ), |
|
| 55 |
#' tags$div( |
|
| 56 |
#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|
| 57 |
#' textOutput("condition_choices"), tags$br(),
|
|
| 58 |
#' tags$h4("Unformatted state"), # display raw filter state
|
|
| 59 |
#' textOutput("unformatted_choices"), tags$br(),
|
|
| 60 |
#' tags$h4("Formatted state"), # display human readable filter state
|
|
| 61 |
#' textOutput("formatted_choices"), tags$br()
|
|
| 62 |
#' ), |
|
| 63 |
#' tags$div( |
|
| 64 |
#' tags$h4("Programmatic filter control"),
|
|
| 65 |
#' actionButton("button1_choices", "set drop NA", width = "100%"), tags$br(),
|
|
| 66 |
#' actionButton("button2_choices", "set keep NA", width = "100%"), tags$br(),
|
|
| 67 |
#' actionButton("button3_choices", "set selection: a, b", width = "100%"), tags$br(),
|
|
| 68 |
#' actionButton("button4_choices", "deselect all", width = "100%"), tags$br(),
|
|
| 69 |
#' actionButton("button0_choices", "set initial state", width = "100%"), tags$br()
|
|
| 70 |
#' ) |
|
| 71 |
#' ) |
|
| 72 |
#' ) |
|
| 73 |
#' |
|
| 74 |
#' server <- function(input, output, session) {
|
|
| 75 |
#' fs$server("fs")
|
|
| 76 |
#' output$condition_choices <- renderPrint(fs$get_call()) |
|
| 77 |
#' output$formatted_choices <- renderText(fs$format()) |
|
| 78 |
#' output$unformatted_choices <- renderPrint(fs$get_state()) |
|
| 79 |
#' # modify filter state programmatically |
|
| 80 |
#' observeEvent( |
|
| 81 |
#' input$button1_choices, |
|
| 82 |
#' fs$set_state( |
|
| 83 |
#' teal_slice(dataname = "data", varname = "variable", keep_na = FALSE) |
|
| 84 |
#' ) |
|
| 85 |
#' ) |
|
| 86 |
#' observeEvent( |
|
| 87 |
#' input$button2_choices, |
|
| 88 |
#' fs$set_state( |
|
| 89 |
#' teal_slice(dataname = "data", varname = "variable", keep_na = TRUE) |
|
| 90 |
#' ) |
|
| 91 |
#' ) |
|
| 92 |
#' observeEvent( |
|
| 93 |
#' input$button3_choices, |
|
| 94 |
#' fs$set_state( |
|
| 95 |
#' teal_slice(dataname = "data", varname = "variable", selected = c("a", "b"))
|
|
| 96 |
#' ) |
|
| 97 |
#' ) |
|
| 98 |
#' observeEvent( |
|
| 99 |
#' input$button4_choices, |
|
| 100 |
#' fs$set_state( |
|
| 101 |
#' teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE) |
|
| 102 |
#' ) |
|
| 103 |
#' ) |
|
| 104 |
#' observeEvent( |
|
| 105 |
#' input$button0_choices, |
|
| 106 |
#' fs$set_state( |
|
| 107 |
#' teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE)
|
|
| 108 |
#' ) |
|
| 109 |
#' ) |
|
| 110 |
#' } |
|
| 111 |
#' |
|
| 112 |
#' if (interactive()) {
|
|
| 113 |
#' shinyApp(ui, server) |
|
| 114 |
#' } |
|
| 115 |
#' |
|
| 116 |
#' @keywords internal |
|
| 117 |
#' |
|
| 118 |
ChoicesFilterState <- R6::R6Class( # nolint |
|
| 119 |
"ChoicesFilterState", |
|
| 120 |
inherit = FilterState, |
|
| 121 | ||
| 122 |
# public methods ---- |
|
| 123 | ||
| 124 |
public = list( |
|
| 125 |
#' @description |
|
| 126 |
#' Initialize a `FilterState` object. |
|
| 127 |
#' |
|
| 128 |
#' @param x (`character`) |
|
| 129 |
#' variable to be filtered. |
|
| 130 |
#' @param x_reactive (`reactive`) |
|
| 131 |
#' returning vector of the same type as `x`. Is used to update |
|
| 132 |
#' counts following the change in values of the filtered dataset. |
|
| 133 |
#' If it is set to `reactive(NULL)` then counts based on filtered |
|
| 134 |
#' dataset are not shown. |
|
| 135 |
#' @param slice (`teal_slice`) |
|
| 136 |
#' specification of this filter state. |
|
| 137 |
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 138 |
#' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 139 |
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|
| 140 |
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 141 |
#' @param extract_type (`character`) |
|
| 142 |
#' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 143 |
#' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 144 |
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 145 |
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 146 |
#' |
|
| 147 |
#' @return Object of class `ChoicesFilterState`, invisibly. |
|
| 148 |
#' |
|
| 149 |
initialize = function(x, |
|
| 150 |
x_reactive = reactive(NULL), |
|
| 151 |
slice, |
|
| 152 |
extract_type = character(0)) {
|
|
| 153 | 176x |
isolate({
|
| 154 | 176x |
checkmate::assert( |
| 155 | 176x |
is.character(x), |
| 156 | 176x |
is.factor(x), |
| 157 | 176x |
length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
|
| 158 | 176x |
combine = "or" |
| 159 |
) |
|
| 160 | 176x |
if (is.factor(x)) {
|
| 161 | 51x |
x <- droplevels(x) |
| 162 |
} |
|
| 163 | 176x |
super$initialize( |
| 164 | 176x |
x = x, |
| 165 | 176x |
x_reactive = x_reactive, |
| 166 | 176x |
slice = slice, |
| 167 | 176x |
extract_type = extract_type |
| 168 |
) |
|
| 169 | 176x |
private$set_choices(slice$choices) |
| 170 | 176x |
if (is.null(slice$selected) && slice$multiple) {
|
| 171 | 51x |
slice$selected <- private$get_choices() |
| 172 | 125x |
} else if (is.null(slice$selected)) {
|
| 173 | 1x |
slice$selected <- private$get_choices()[1] |
| 174 | 124x |
} else if (length(slice$selected) > 1 && !slice$multiple) {
|
| 175 | 1x |
warning( |
| 176 | 1x |
"ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ", |
| 177 | 1x |
"Only the first value will be used." |
| 178 |
) |
|
| 179 | 1x |
slice$selected <- slice$selected[1] |
| 180 |
} |
|
| 181 | 176x |
private$set_selected(slice$selected) |
| 182 | 176x |
if (inherits(x, "POSIXt")) {
|
| 183 | 9x |
private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone")) |
| 184 |
} |
|
| 185 |
}) |
|
| 186 | 176x |
invisible(self) |
| 187 |
}, |
|
| 188 | ||
| 189 |
#' @description |
|
| 190 |
#' Returns reproducible condition call for current selection. |
|
| 191 |
#' For this class returned call looks like |
|
| 192 |
#' `<varname> %in% c(<values selected>)` with optional `is.na(<varname>)`. |
|
| 193 |
#' @param dataname (`character(1)`) name of data set; defaults to `private$get_dataname()` |
|
| 194 |
#' @return `call` or `NULL` |
|
| 195 |
#' |
|
| 196 |
get_call = function(dataname) {
|
|
| 197 | 64x |
if (isFALSE(private$is_any_filtered())) {
|
| 198 | 7x |
return(NULL) |
| 199 |
} |
|
| 200 | 30x |
if (missing(dataname)) dataname <- private$get_dataname() |
| 201 | 57x |
varname <- private$get_varname_prefixed(dataname) |
| 202 | 57x |
choices <- private$get_choices() |
| 203 | 57x |
selected <- private$get_selected() |
| 204 | 57x |
fun_compare <- if (length(selected) == 1L) "==" else "%in%" |
| 205 | 57x |
filter_call <- if (length(selected) == 0) {
|
| 206 | 6x |
call("!", call(fun_compare, varname, make_c_call(as.character(choices))))
|
| 207 |
} else {
|
|
| 208 | 51x |
if (setequal(selected, choices) && !private$is_choice_limited) {
|
| 209 | 2x |
NULL |
| 210 | 49x |
} else if (inherits(private$x, "Date")) {
|
| 211 | 1x |
call(fun_compare, varname, call("as.Date", make_c_call(as.character(selected))))
|
| 212 | 48x |
} else if (inherits(private$x, c("POSIXct", "POSIXlt"))) {
|
| 213 | 2x |
class <- class(private$x)[1L] |
| 214 | 2x |
date_fun <- as.name( |
| 215 | 2x |
switch(class, |
| 216 | 2x |
"POSIXct" = "as.POSIXct", |
| 217 | 2x |
"POSIXlt" = "as.POSIXlt" |
| 218 |
) |
|
| 219 |
) |
|
| 220 | 2x |
call( |
| 221 | 2x |
fun_compare, |
| 222 | 2x |
varname, |
| 223 | 2x |
as.call(list(date_fun, make_c_call(as.character(selected)), tz = private$tzone)) |
| 224 |
) |
|
| 225 | 46x |
} else if (is.numeric(private$x)) {
|
| 226 | 8x |
call(fun_compare, varname, make_c_call(as.numeric(selected))) |
| 227 |
} else {
|
|
| 228 |
# This handles numerics, characters, and factors. |
|
| 229 | 38x |
call(fun_compare, varname, make_c_call(selected)) |
| 230 |
} |
|
| 231 |
} |
|
| 232 | 57x |
private$add_keep_na_call(filter_call, varname) |
| 233 |
} |
|
| 234 |
), |
|
| 235 | ||
| 236 |
# private members ---- |
|
| 237 |
private = list( |
|
| 238 |
x = NULL, |
|
| 239 |
choices_counts = integer(0), |
|
| 240 |
tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call |
|
| 241 | ||
| 242 |
# private methods ---- |
|
| 243 | ||
| 244 |
# @description |
|
| 245 |
# Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices |
|
| 246 |
# are limited by default from the start. |
|
| 247 |
set_choices = function(choices) {
|
|
| 248 | 176x |
named_counts <- .table(private$x) |
| 249 | 176x |
possible_choices <- names(named_counts) |
| 250 | 176x |
if (is.null(choices)) {
|
| 251 | 161x |
choices <- possible_choices |
| 252 |
} else {
|
|
| 253 | 15x |
choices <- as.character(choices) |
| 254 | 15x |
choices_adjusted <- choices[choices %in% possible_choices] |
| 255 | 15x |
if (length(setdiff(choices, choices_adjusted)) > 0L) {
|
| 256 | 2x |
warning( |
| 257 | 2x |
sprintf( |
| 258 | 2x |
"Some choices not found in data. Adjusting. Filter id: %s.", |
| 259 | 2x |
private$get_id() |
| 260 |
) |
|
| 261 |
) |
|
| 262 | 2x |
choices <- choices_adjusted |
| 263 |
} |
|
| 264 | 15x |
if (length(choices) == 0) {
|
| 265 | 1x |
warning( |
| 266 | 1x |
sprintf( |
| 267 | 1x |
"None of the choices were found in data. Setting defaults. Filter id: %s.", |
| 268 | 1x |
private$get_id() |
| 269 |
) |
|
| 270 |
) |
|
| 271 | 1x |
choices <- possible_choices |
| 272 |
} |
|
| 273 |
} |
|
| 274 | 176x |
private$set_choices_counts( |
| 275 | 176x |
pair_counts(choices, named_counts) |
| 276 |
) |
|
| 277 | 176x |
private$set_is_choice_limited(possible_choices, choices) |
| 278 | 176x |
private$teal_slice$choices <- choices |
| 279 | 176x |
invisible(NULL) |
| 280 |
}, |
|
| 281 |
# @description |
|
| 282 |
# Check whether the initial choices filter out some values of x and set the flag in case. |
|
| 283 |
set_is_choice_limited = function(x, choices) {
|
|
| 284 | 176x |
xl <- x[!is.na(x)] |
| 285 | 176x |
private$is_choice_limited <- length(setdiff(xl, choices)) > 0L |
| 286 | 176x |
invisible(NULL) |
| 287 |
}, |
|
| 288 |
# @description |
|
| 289 |
# Sets choices_counts private field. |
|
| 290 |
set_choices_counts = function(choices_counts) {
|
|
| 291 | 176x |
private$choices_counts <- choices_counts |
| 292 | 176x |
invisible(NULL) |
| 293 |
}, |
|
| 294 |
# @description |
|
| 295 |
# Checks whether the input should be rendered as a checkboxgroup/radiobutton or a drop-down. |
|
| 296 |
is_checkboxgroup = function() {
|
|
| 297 | 76x |
length(private$get_choices()) <= getOption("teal.threshold_slider_vs_checkboxgroup")
|
| 298 |
}, |
|
| 299 |
cast_and_validate = function(values) {
|
|
| 300 | 214x |
tryCatch( |
| 301 | 214x |
expr = {
|
| 302 | 214x |
values <- as.character(values) |
| 303 | ! |
if (anyNA(values)) stop() |
| 304 |
}, |
|
| 305 | 214x |
error = function(e) stop("The vector of set values must contain values coercible to character.")
|
| 306 |
) |
|
| 307 | 214x |
values |
| 308 |
}, |
|
| 309 |
# If multiple forbidden but selected, restores previous selection with warning. |
|
| 310 |
check_length = function(values) {
|
|
| 311 | 214x |
if (!private$is_multiple() && length(values) != 1) {
|
| 312 | 3x |
warning( |
| 313 | 3x |
sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
|
| 314 | 3x |
"Maintaining previous selection." |
| 315 |
) |
|
| 316 | 3x |
isolate(private$get_selected()) |
| 317 |
} else {
|
|
| 318 | 211x |
values |
| 319 |
} |
|
| 320 |
}, |
|
| 321 |
remove_out_of_bounds_values = function(values) {
|
|
| 322 | 214x |
in_choices_mask <- values %in% private$get_choices() |
| 323 | 214x |
if (length(values[!in_choices_mask]) > 0) {
|
| 324 | 17x |
warning(paste( |
| 325 | 17x |
"Values:", toString(values[!in_choices_mask], width = 360), |
| 326 | 17x |
"are not in choices of column", private$get_varname(), "in dataset", private$get_dataname(), "." |
| 327 |
)) |
|
| 328 |
} |
|
| 329 | 214x |
values[in_choices_mask] |
| 330 |
}, |
|
| 331 | ||
| 332 |
# shiny modules ---- |
|
| 333 | ||
| 334 |
# @description |
|
| 335 |
# UI Module for `ChoicesFilterState`. |
|
| 336 |
# This UI element contains available choices selection and |
|
| 337 |
# checkbox whether to keep or not keep the `NA` values. |
|
| 338 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 339 |
ui_inputs = function(id) {
|
|
| 340 | 20x |
ns <- NS(id) |
| 341 | ||
| 342 |
# we need to isolate UI to not retrigger renderUI |
|
| 343 | 20x |
isolate({
|
| 344 | 20x |
countsmax <- private$choices_counts |
| 345 | 20x |
countsnow <- if (!is.null(private$x_reactive())) {
|
| 346 | 1x |
pair_counts( |
| 347 | 1x |
private$get_choices(), |
| 348 | 1x |
.table(private$x_reactive()) |
| 349 |
) |
|
| 350 |
} |
|
| 351 | ||
| 352 | 20x |
ui_input <- if (private$is_checkboxgroup()) {
|
| 353 | 17x |
labels <- countBars( |
| 354 | 17x |
inputId = ns("labels"),
|
| 355 | 17x |
choices = private$get_choices(), |
| 356 | 17x |
countsnow = countsnow, |
| 357 | 17x |
countsmax = countsmax |
| 358 |
) |
|
| 359 | 17x |
tags$div( |
| 360 | 17x |
class = "teal-slice choices-state", |
| 361 | 17x |
if (private$is_multiple()) {
|
| 362 | 16x |
checkboxGroupInput( |
| 363 | 16x |
inputId = ns("selection"),
|
| 364 | 16x |
label = NULL, |
| 365 | 16x |
selected = private$get_selected(), |
| 366 | 16x |
choiceNames = labels, |
| 367 | 16x |
choiceValues = private$get_choices(), |
| 368 | 16x |
width = "100%" |
| 369 |
) |
|
| 370 |
} else {
|
|
| 371 | 1x |
radioButtons( |
| 372 | 1x |
inputId = ns("selection"),
|
| 373 | 1x |
label = NULL, |
| 374 | 1x |
selected = private$get_selected(), |
| 375 | 1x |
choiceNames = labels, |
| 376 | 1x |
choiceValues = private$get_choices(), |
| 377 | 1x |
width = "100%" |
| 378 |
) |
|
| 379 |
} |
|
| 380 |
) |
|
| 381 |
} else {
|
|
| 382 | 3x |
labels <- mapply( |
| 383 | 3x |
FUN = make_count_text, |
| 384 | 3x |
label = private$get_choices(), |
| 385 | 3x |
countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow, |
| 386 | 3x |
countmax = countsmax |
| 387 |
) |
|
| 388 | ||
| 389 | 3x |
teal.widgets::optionalSelectInput( |
| 390 | 3x |
inputId = ns("selection"),
|
| 391 | 3x |
choices = stats::setNames(private$get_choices(), labels), |
| 392 | 3x |
selected = private$get_selected(), |
| 393 | 3x |
multiple = private$is_multiple(), |
| 394 | 3x |
options = shinyWidgets::pickerOptions( |
| 395 | 3x |
actionsBox = TRUE, |
| 396 | 3x |
liveSearch = (length(private$get_choices()) > 10), |
| 397 | 3x |
noneSelectedText = "Select a value" |
| 398 |
) |
|
| 399 |
) |
|
| 400 |
} |
|
| 401 | 20x |
tags$div( |
| 402 | 20x |
uiOutput(ns("trigger_visible")),
|
| 403 | 20x |
ui_input, |
| 404 | 20x |
private$keep_na_ui(ns("keep_na"))
|
| 405 |
) |
|
| 406 |
}) |
|
| 407 |
}, |
|
| 408 | ||
| 409 |
# @description |
|
| 410 |
# Server module |
|
| 411 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 412 |
# @return `NULL`. |
|
| 413 |
server_inputs = function(id) {
|
|
| 414 | 19x |
moduleServer( |
| 415 | 19x |
id = id, |
| 416 | 19x |
function(input, output, session) {
|
| 417 | 19x |
logger::log_debug("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }")
|
| 418 |
# 1. renderUI is used here as an observer which triggers only if output is visible |
|
| 419 |
# and if the reactive changes - reactive triggers only if the output is visible. |
|
| 420 |
# 2. We want to trigger change of the labels only if reactive count changes (not underlying data) |
|
| 421 | 19x |
non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive())) |
| 422 | 19x |
output$trigger_visible <- renderUI({
|
| 423 | 19x |
logger::log_debug("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")
|
| 424 | ||
| 425 | 19x |
countsnow <- if (!is.null(private$x_reactive())) {
|
| 426 | ! |
pair_counts( |
| 427 | ! |
private$get_choices(), |
| 428 | ! |
.table(non_missing_values()) |
| 429 |
) |
|
| 430 |
} |
|
| 431 | ||
| 432 |
# update should be based on a change of counts only |
|
| 433 | 19x |
isolate({
|
| 434 | 19x |
if (private$is_checkboxgroup()) {
|
| 435 | 16x |
updateCountBars( |
| 436 | 16x |
inputId = "labels", |
| 437 | 16x |
choices = private$get_choices(), |
| 438 | 16x |
countsmax = private$choices_counts, |
| 439 | 16x |
countsnow = countsnow |
| 440 |
) |
|
| 441 |
} else {
|
|
| 442 | 3x |
labels <- mapply( |
| 443 | 3x |
FUN = make_count_text, |
| 444 | 3x |
label = private$get_choices(), |
| 445 | 3x |
countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow, |
| 446 | 3x |
countmax = private$choices_counts |
| 447 |
) |
|
| 448 | 3x |
teal.widgets::updateOptionalSelectInput( |
| 449 | 3x |
session = session, |
| 450 | 3x |
inputId = "selection", |
| 451 | 3x |
choices = stats::setNames(private$get_choices(), labels), |
| 452 | 3x |
selected = private$get_selected() |
| 453 |
) |
|
| 454 |
} |
|
| 455 | 19x |
NULL |
| 456 |
}) |
|
| 457 |
}) |
|
| 458 | ||
| 459 | 19x |
private$session_bindings[[session$ns("selection")]] <- if (private$is_checkboxgroup()) {
|
| 460 | 16x |
observeEvent( |
| 461 | 16x |
ignoreNULL = FALSE, |
| 462 | 16x |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 463 | 16x |
eventExpr = input$selection, |
| 464 | 16x |
handlerExpr = {
|
| 465 | 2x |
logger::log_debug("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
|
| 466 | 2x |
private$set_selected(input$selection) |
| 467 |
} |
|
| 468 |
) |
|
| 469 |
} else {
|
|
| 470 | 3x |
observeEvent( |
| 471 | 3x |
ignoreNULL = FALSE, |
| 472 | 3x |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 473 | 3x |
eventExpr = input$selection_open, # observe click on a dropdown |
| 474 | 3x |
handlerExpr = {
|
| 475 | 2x |
if (!isTRUE(input$selection_open)) { # only when the dropdown got closed
|
| 476 | 2x |
logger::log_debug("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
|
| 477 | ||
| 478 | 2x |
if (length(input$selection) != 1 && !private$is_multiple()) {
|
| 479 |
# In optionalSelectInput user is able to select mutliple options. |
|
| 480 |
# But if FilterState is not multiple we should prevent this selection to be processed further. |
|
| 481 |
# This is why notification is thrown and dropdown is changed back to latest selected. |
|
| 482 | 1x |
showNotification(paste( |
| 483 | 1x |
"This filter exclusively supports single selection.", |
| 484 | 1x |
"Any additional choices made will be disregarded." |
| 485 |
)) |
|
| 486 | 1x |
teal.widgets::updateOptionalSelectInput( |
| 487 | 1x |
session, "selection", |
| 488 | 1x |
selected = private$get_selected() |
| 489 |
) |
|
| 490 |
} |
|
| 491 | ||
| 492 | 2x |
private$set_selected(input$selection) |
| 493 |
} |
|
| 494 |
} |
|
| 495 |
) |
|
| 496 |
} |
|
| 497 | ||
| 498 | 19x |
private$keep_na_srv("keep_na")
|
| 499 | ||
| 500 |
# this observer is needed in the situation when teal_slice$selected has been |
|
| 501 |
# changed directly by the api - then it's needed to rerender UI element |
|
| 502 |
# to show relevant values |
|
| 503 | 19x |
private$session_bindings[[session$ns("selection_api")]] <- observeEvent(private$get_selected(), {
|
| 504 |
# it's important to not retrigger when the input$selection is the same as reactive values |
|
| 505 |
# kept in the teal_slice$selected |
|
| 506 | 21x |
if (!setequal(input$selection, private$get_selected())) {
|
| 507 | 18x |
logger::log_debug("ChoicesFilterState$server@1 state changed, id: { private$get_id() }")
|
| 508 | 18x |
if (private$is_checkboxgroup()) {
|
| 509 | 15x |
if (private$is_multiple()) {
|
| 510 | 14x |
updateCheckboxGroupInput( |
| 511 | 14x |
inputId = "selection", |
| 512 | 14x |
selected = private$get_selected() |
| 513 |
) |
|
| 514 |
} else {
|
|
| 515 | 1x |
updateRadioButtons( |
| 516 | 1x |
inputId = "selection", |
| 517 | 1x |
selected = private$get_selected() |
| 518 |
) |
|
| 519 |
} |
|
| 520 |
} else {
|
|
| 521 | 3x |
teal.widgets::updateOptionalSelectInput( |
| 522 | 3x |
session, "selection", |
| 523 | 3x |
selected = private$get_selected() |
| 524 |
) |
|
| 525 |
} |
|
| 526 |
} |
|
| 527 |
}) |
|
| 528 | ||
| 529 | 19x |
NULL |
| 530 |
} |
|
| 531 |
) |
|
| 532 |
}, |
|
| 533 |
server_inputs_fixed = function(id) {
|
|
| 534 | 1x |
moduleServer( |
| 535 | 1x |
id = id, |
| 536 | 1x |
function(input, output, session) {
|
| 537 | 1x |
logger::log_debug("ChoicesFilterState$server_inputs_fixed initializing, id: { private$get_id() }")
|
| 538 | ||
| 539 | 1x |
output$selection <- renderUI({
|
| 540 | 1x |
countsnow <- if (!is.null(private$x_reactive())) {
|
| 541 | ! |
pair_counts( |
| 542 | ! |
private$get_choices(), |
| 543 | ! |
.table(private$x_reactive()) |
| 544 |
) |
|
| 545 |
} |
|
| 546 | 1x |
countsmax <- private$choices_counts |
| 547 | ||
| 548 | 1x |
ind <- private$get_choices() %in% isolate(private$get_selected()) |
| 549 | 1x |
countBars( |
| 550 | 1x |
inputId = session$ns("labels"),
|
| 551 | 1x |
choices = isolate(private$get_selected()), |
| 552 | 1x |
countsnow = countsnow[ind], |
| 553 | 1x |
countsmax = countsmax[ind] |
| 554 |
) |
|
| 555 |
}) |
|
| 556 | ||
| 557 | 1x |
NULL |
| 558 |
} |
|
| 559 |
) |
|
| 560 |
}, |
|
| 561 | ||
| 562 |
# @description |
|
| 563 |
# UI module to display filter summary |
|
| 564 |
# renders text describing number of selected levels |
|
| 565 |
# and if NA are included also |
|
| 566 |
content_summary = function(id) {
|
|
| 567 | 27x |
selected <- private$get_selected() |
| 568 | 27x |
selected_text <- |
| 569 | 27x |
if (length(selected) == 0L) {
|
| 570 | 1x |
"no selection" |
| 571 |
} else {
|
|
| 572 | 26x |
if (sum(nchar(selected)) <= 40L) {
|
| 573 | 25x |
paste(selected, collapse = ", ") |
| 574 |
} else {
|
|
| 575 | 1x |
paste(length(selected), "levels selected") |
| 576 |
} |
|
| 577 |
} |
|
| 578 | 27x |
tagList( |
| 579 | 27x |
tags$span( |
| 580 | 27x |
class = "teal-slice filter-card-summary-value", |
| 581 | 27x |
selected_text |
| 582 |
), |
|
| 583 | 27x |
tags$span( |
| 584 | 27x |
class = "teal-slice filter-card-summary-controls", |
| 585 | 27x |
if (private$na_count > 0) {
|
| 586 | 1x |
tags$span( |
| 587 | 1x |
"NA", |
| 588 | 1x |
if (isTRUE(private$get_keep_na())) {
|
| 589 | ! |
icon("check", class = "text-success")
|
| 590 |
} else {
|
|
| 591 | 1x |
icon("xmark", class = "text-danger")
|
| 592 |
} |
|
| 593 |
) |
|
| 594 |
} |
|
| 595 |
) |
|
| 596 |
) |
|
| 597 |
} |
|
| 598 |
) |
|
| 599 |
) |
|
| 600 | ||
| 601 |
#' `table` handling `POSIXlt` |
|
| 602 |
#' |
|
| 603 |
#' @param x (`vector`) variable to get counts from. |
|
| 604 |
#' @return vector of counts named by unique values of `x`. |
|
| 605 |
#' |
|
| 606 |
#' @keywords internal |
|
| 607 |
.table <- function(x) {
|
|
| 608 | 177x |
tbl <- table( |
| 609 | 177x |
if (is.factor(x)) {
|
| 610 | 51x |
x |
| 611 |
} else {
|
|
| 612 | 126x |
as.character(x) |
| 613 |
} |
|
| 614 |
) |
|
| 615 |
# tbl returns an array with dimnames instead of a simple vector |
|
| 616 |
# we need to convert it to a vector so the object is simpler to handle |
|
| 617 | 177x |
stats::setNames( |
| 618 | 177x |
as.vector(tbl), |
| 619 | 177x |
names(tbl) |
| 620 |
) |
|
| 621 |
} |
| 1 |
# FilterStates ------ |
|
| 2 | ||
| 3 |
#' @name FilterStates |
|
| 4 |
#' @docType class |
|
| 5 |
#' @title `FilterStates` `R6` class |
|
| 6 |
#' |
|
| 7 |
#' @description |
|
| 8 |
#' Abstract class that manages adding and removing `FilterState` objects |
|
| 9 |
#' and builds a *subset expression*. |
|
| 10 |
#' |
|
| 11 |
#' A `FilterStates` object tracks all condition calls |
|
| 12 |
#' (logical predicates that limit observations) associated with a given dataset |
|
| 13 |
#' and composes them into a single reproducible `R` expression |
|
| 14 |
#' that will assign a subset of the original data to a new variable. |
|
| 15 |
#' This expression is hereafter referred to as *subset expression*. |
|
| 16 |
#' |
|
| 17 |
#' The *subset expression* is constructed differently for different |
|
| 18 |
#' classes of the underlying data object and `FilterStates` sub-classes. |
|
| 19 |
#' Currently implemented for `data.frame`, `matrix`, |
|
| 20 |
#' `SummarizedExperiment`, and `MultiAssayExperiment`. |
|
| 21 |
#' |
|
| 22 |
#' @keywords internal |
|
| 23 |
#' |
|
| 24 |
FilterStates <- R6::R6Class( # nolint |
|
| 25 |
classname = "FilterStates", |
|
| 26 | ||
| 27 |
# public members ---- |
|
| 28 |
public = list( |
|
| 29 |
#' @description |
|
| 30 |
#' Initializes `FilterStates` object by setting |
|
| 31 |
#' `dataname`, and `datalabel`. |
|
| 32 |
#' |
|
| 33 |
#' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`) |
|
| 34 |
#' the `R` object which `subset` function is applied on. |
|
| 35 |
#' @param data_reactive (`function(sid)`) |
|
| 36 |
#' should return an object of the same type as `data` object or `NULL`. |
|
| 37 |
#' This object is needed for the `FilterState` counts being updated |
|
| 38 |
#' on a change in filters. If function returns `NULL` then filtered counts are not shown. |
|
| 39 |
#' Function has to have `sid` argument being a character. |
|
| 40 |
#' @param dataname (`character(1)`) |
|
| 41 |
#' name of the dataset, used in the subset expression. |
|
| 42 |
#' Passed to the function argument attached to this `FilterStates`. |
|
| 43 |
#' @param datalabel (`character(1)`) optional |
|
| 44 |
#' text label. |
|
| 45 |
#' |
|
| 46 |
#' @return |
|
| 47 |
#' Object of class `FilterStates`, invisibly. |
|
| 48 |
#' |
|
| 49 |
initialize = function(data, |
|
| 50 |
data_reactive = function(sid = "") NULL, |
|
| 51 |
dataname, |
|
| 52 |
datalabel = NULL) {
|
|
| 53 | 286x |
checkmate::assert_string(dataname) |
| 54 | 284x |
logger::log_debug("Instantiating { class(self)[1] }, dataname: { dataname }")
|
| 55 | 284x |
checkmate::assert_function(data_reactive, args = "sid") |
| 56 | 284x |
checkmate::assert_string(datalabel, null.ok = TRUE) |
| 57 | ||
| 58 | 284x |
private$dataname <- dataname |
| 59 | 284x |
private$datalabel <- datalabel |
| 60 | 284x |
private$dataname_prefixed <- if (identical(dataname, make.names(dataname))) {
|
| 61 | 284x |
dataname |
| 62 |
} else {
|
|
| 63 | ! |
sprintf("`%s`", dataname)
|
| 64 |
} |
|
| 65 | 284x |
private$data <- data |
| 66 | 284x |
private$data_reactive <- data_reactive |
| 67 | 284x |
private$state_list <- reactiveVal() |
| 68 | ||
| 69 |
# Clears state list when finalizing the object |
|
| 70 | 284x |
private$session_bindings[["clear_state_list"]] <- list( |
| 71 | 284x |
destroy = function() {
|
| 72 | 141x |
private$state_list_empty(force = TRUE) |
| 73 | 141x |
isolate(private$state_list(NULL)) |
| 74 |
} |
|
| 75 |
) |
|
| 76 | ||
| 77 | 284x |
invisible(self) |
| 78 |
}, |
|
| 79 | ||
| 80 |
#' @description Destroys a `FilterStates` object. |
|
| 81 | 367x |
destroy = function() private$finalize(), |
| 82 | ||
| 83 |
#' @description |
|
| 84 |
#' Returns a formatted string representing this `FilterStates` object. |
|
| 85 |
#' |
|
| 86 |
#' @param show_all (`logical(1)`) passed to `format.teal_slices` |
|
| 87 |
#' @param trim_lines (`logical(1)`) passed to `format.teal_slices` |
|
| 88 |
#' |
|
| 89 |
#' @return `character(1)` the formatted string |
|
| 90 |
#' |
|
| 91 |
format = function(show_all = FALSE, trim_lines = TRUE) {
|
|
| 92 | ! |
sprintf( |
| 93 | ! |
"%s:\n%s", |
| 94 | ! |
class(self)[1], |
| 95 | ! |
format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines) |
| 96 |
) |
|
| 97 |
}, |
|
| 98 | ||
| 99 |
#' @description |
|
| 100 |
#' Filter call |
|
| 101 |
#' |
|
| 102 |
#' Builds *subset expression* from condition calls generated by `FilterState`. |
|
| 103 |
#' The `lhs` of the expression is a `dataname_prefixed`, where word prefixed refers to |
|
| 104 |
#' situation when call is evaluated on elements of the original data, for example `dataname[[x]]`. |
|
| 105 |
#' By default `dataname_prefixed = dataname` and it's not alterable through class methods. |
|
| 106 |
#' Customization of `private$dataname_prefixed` is done through inheriting classes. |
|
| 107 |
#' |
|
| 108 |
#' The `rhs` is a call to `private$fun` with following arguments: |
|
| 109 |
#' - `dataname_prefixed` |
|
| 110 |
#' - list of logical expressions generated by `FilterState` objects |
|
| 111 |
#' stored in `private$state_list`. Each logical predicate is combined with `&` operator. |
|
| 112 |
#' Variables in these logical expressions by default are not prefixed but this can be changed |
|
| 113 |
#' by setting `private$extract_type` (change in the similar way as `dataname_prefixed`) |
|
| 114 |
#' Possible call outputs depending on a custom fields/options: |
|
| 115 |
#' ``` |
|
| 116 |
#' # default |
|
| 117 |
#' dataname <- subset(dataname, col == "x") |
|
| 118 |
#' |
|
| 119 |
#' # fun = dplyr::filter |
|
| 120 |
#' dataname <- dplyr::filter(dataname, col == "x") |
|
| 121 |
#' |
|
| 122 |
#' # fun = MultiAssayExperiment::subsetByColData; extract_type = "list" |
|
| 123 |
#' dataname <- MultiAssayExperiment::subsetByColData(dataname, dataname$col == "x") |
|
| 124 |
#' |
|
| 125 |
#' # teal_slice objects having `arg = "subset"` and `arg = "select"` |
|
| 126 |
#' dataname <- subset(dataname, subset = row_col == "x", select = col_col == "x") |
|
| 127 |
#' |
|
| 128 |
#' # dataname = dataname[[element]] |
|
| 129 |
#' dataname[[element]] <- subset(dataname[[element]], subset = col == "x") |
|
| 130 |
#' ``` |
|
| 131 |
#' |
|
| 132 |
#' If no filters are applied, `NULL` is returned to avoid no-op calls such as `dataname <- dataname`. |
|
| 133 |
#' |
|
| 134 |
#' @param sid (`character`) |
|
| 135 |
#' when specified then method returns code containing condition calls (logical predicates) of |
|
| 136 |
#' `FilterState` objects which `"sid"` attribute is different than this `sid` argument. |
|
| 137 |
#' |
|
| 138 |
#' @return `call` or `NULL` |
|
| 139 |
#' |
|
| 140 |
get_call = function(sid = "") {
|
|
| 141 |
# `arg` must be the same as argument of the function where |
|
| 142 |
# predicate is passed to. |
|
| 143 |
# For unnamed arguments state_list should have `arg = NULL` |
|
| 144 | 95x |
states_list <- private$state_list_get() |
| 145 | 95x |
if (length(states_list) == 0) {
|
| 146 | 55x |
return(NULL) |
| 147 |
} |
|
| 148 | 40x |
args <- vapply( |
| 149 | 40x |
states_list, |
| 150 | 40x |
function(x) {
|
| 151 | 61x |
arg <- x$get_state()$arg |
| 152 | 7x |
`if`(is.null(arg), "", arg) # converting NULL -> "" to enable tapply. |
| 153 |
}, |
|
| 154 | 40x |
character(1) |
| 155 |
) |
|
| 156 | ||
| 157 | 40x |
filter_items <- tapply( |
| 158 | 40x |
X = states_list, |
| 159 | 40x |
INDEX = args, |
| 160 | 40x |
simplify = FALSE, |
| 161 | 40x |
function(items) {
|
| 162 |
# removing filters identified by sid |
|
| 163 | 42x |
other_filter_idx <- !names(items) %in% sid |
| 164 | 42x |
filtered_items <- items[other_filter_idx] |
| 165 | ||
| 166 | 42x |
calls <- Filter( |
| 167 | 42x |
Negate(is.null), |
| 168 | 42x |
lapply( |
| 169 | 42x |
filtered_items, |
| 170 | 42x |
function(state) {
|
| 171 | 55x |
state$get_call(dataname = private$dataname_prefixed) |
| 172 |
} |
|
| 173 |
) |
|
| 174 |
) |
|
| 175 | 42x |
calls_combine_by(calls, operator = "&") |
| 176 |
} |
|
| 177 |
) |
|
| 178 | 40x |
filter_items <- Filter( |
| 179 | 40x |
x = filter_items, |
| 180 | 40x |
f = Negate(is.null) |
| 181 |
) |
|
| 182 | 40x |
if (length(filter_items) > 0L) {
|
| 183 | 39x |
filter_function <- private$fun |
| 184 | 39x |
data_name <- tryCatch( |
| 185 |
{
|
|
| 186 | 39x |
str2lang(private$dataname_prefixed) |
| 187 |
}, |
|
| 188 | 39x |
error = function(e) str2lang(paste0("`", private$dataname_prefixed, "`"))
|
| 189 |
) |
|
| 190 | 39x |
substitute( |
| 191 | 39x |
env = list( |
| 192 | 39x |
lhs = data_name, |
| 193 | 39x |
rhs = as.call(c(filter_function, c(list(data_name), filter_items))) |
| 194 |
), |
|
| 195 | 39x |
expr = lhs <- rhs |
| 196 |
) |
|
| 197 |
} else {
|
|
| 198 |
# return NULL to avoid no-op call |
|
| 199 | 1x |
NULL |
| 200 |
} |
|
| 201 |
}, |
|
| 202 | ||
| 203 |
#' @description |
|
| 204 |
#' Prints this `FilterStates` object. |
|
| 205 |
#' |
|
| 206 |
#' @param ... additional arguments passed to `format`. |
|
| 207 |
print = function(...) {
|
|
| 208 | ! |
cat(isolate(self$format(...)), "\n") |
| 209 |
}, |
|
| 210 | ||
| 211 |
#' @description |
|
| 212 |
#' Remove one or more `FilterState`s from the `state_list` along with their UI elements. |
|
| 213 |
#' |
|
| 214 |
#' @param state (`teal_slices`) |
|
| 215 |
#' specifying `FilterState` objects to remove; |
|
| 216 |
#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored |
|
| 217 |
#' |
|
| 218 |
#' @return `NULL`, invisibly. |
|
| 219 |
#' |
|
| 220 |
remove_filter_state = function(state) {
|
|
| 221 | 17x |
isolate({
|
| 222 | 17x |
logger::log_debug("{ class(self)[1] }$remove_filter_state removing filters, state_id: { private$dataname }")
|
| 223 | 17x |
checkmate::assert_class(state, "teal_slices") |
| 224 | 17x |
state_ids <- vapply(state, `[[`, character(1L), "id") |
| 225 | 17x |
private$state_list_remove(state_ids) |
| 226 |
}) |
|
| 227 | 17x |
invisible(NULL) |
| 228 |
}, |
|
| 229 | ||
| 230 |
#' @description |
|
| 231 |
#' Gets reactive values from active `FilterState` objects. |
|
| 232 |
#' |
|
| 233 |
#' Get active filter state from `FilterState` objects stored in `state_list`(s). |
|
| 234 |
#' The output is a list compatible with input to `self$set_filter_state`. |
|
| 235 |
#' |
|
| 236 |
#' @return Object of class `teal_slices`. |
|
| 237 |
#' |
|
| 238 |
get_filter_state = function() {
|
|
| 239 | 509x |
slices <- unname(lapply(private$state_list(), function(x) x$get_state())) |
| 240 | 509x |
fs <- do.call(teal_slices, c(slices, list(count_type = private$count_type))) |
| 241 | ||
| 242 | 509x |
include_varnames <- private$include_varnames |
| 243 | 509x |
if (length(include_varnames)) {
|
| 244 | 383x |
attr(fs, "include_varnames") <- structure( |
| 245 | 383x |
list(include_varnames), |
| 246 | 383x |
names = private$dataname |
| 247 |
) |
|
| 248 |
} |
|
| 249 | ||
| 250 | 509x |
exclude_varnames <- private$exclude_varnames |
| 251 | 509x |
if (length(exclude_varnames)) {
|
| 252 | 9x |
attr(fs, "exclude_varnames") <- structure( |
| 253 | 9x |
list(exclude_varnames), |
| 254 | 9x |
names = private$dataname |
| 255 |
) |
|
| 256 |
} |
|
| 257 | ||
| 258 | 509x |
fs |
| 259 |
}, |
|
| 260 | ||
| 261 |
#' @description |
|
| 262 |
#' Sets active `FilterState` objects. |
|
| 263 |
#' @param state (`teal_slices`) |
|
| 264 |
#' @return Function that raises an error. |
|
| 265 |
set_filter_state = function(state) {
|
|
| 266 | 158x |
isolate({
|
| 267 | 158x |
logger::log_debug("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
|
| 268 | 158x |
checkmate::assert_class(state, "teal_slices") |
| 269 | 158x |
lapply(state, function(x) {
|
| 270 | 201x |
checkmate::assert_true( |
| 271 | 201x |
x$dataname == private$dataname, |
| 272 | 201x |
.var.name = "dataname matches private$dataname" |
| 273 |
) |
|
| 274 |
}) |
|
| 275 | ||
| 276 | 158x |
private$set_filterable_varnames( |
| 277 | 158x |
include_varnames = attr(state, "include_varnames")[[private$dataname]], |
| 278 | 158x |
exclude_varnames = attr(state, "exclude_varnames")[[private$dataname]] |
| 279 |
) |
|
| 280 | 158x |
count_type <- attr(state, "count_type") |
| 281 | 158x |
if (length(count_type)) {
|
| 282 | 21x |
private$count_type <- count_type |
| 283 |
} |
|
| 284 | ||
| 285 |
# Drop teal_slices that refer to excluded variables. |
|
| 286 | 158x |
varnames <- unique(unlist(lapply(state, "[[", "varname"))) |
| 287 | 158x |
excluded_varnames <- setdiff(varnames, private$get_filterable_varnames()) |
| 288 | 158x |
if (length(excluded_varnames)) {
|
| 289 | 3x |
state <- Filter(function(x) !isTRUE(x$varname %in% excluded_varnames), state) |
| 290 | 3x |
warning(sprintf("filters for columns: %s excluded from %s", toString(excluded_varnames), private$dataname))
|
| 291 |
} |
|
| 292 | ||
| 293 | 158x |
if (length(state) > 0) {
|
| 294 | 119x |
private$set_filter_state_impl( |
| 295 | 119x |
state = state, |
| 296 | 119x |
data = private$data, |
| 297 | 119x |
data_reactive = private$data_reactive |
| 298 |
) |
|
| 299 |
} |
|
| 300 |
}) |
|
| 301 | ||
| 302 | 158x |
invisible(NULL) |
| 303 |
}, |
|
| 304 | ||
| 305 |
#' @description |
|
| 306 |
#' Remove all `FilterState` objects from this `FilterStates` object. |
|
| 307 |
#' |
|
| 308 |
#' @param force (`logical(1)`) |
|
| 309 |
#' flag specifying whether to include anchored filter states. |
|
| 310 |
#' |
|
| 311 |
#' @return `NULL`, invisibly. |
|
| 312 |
#' |
|
| 313 |
clear_filter_states = function(force = FALSE) {
|
|
| 314 | 25x |
private$state_list_empty(force) |
| 315 | 25x |
invisible(NULL) |
| 316 |
}, |
|
| 317 | ||
| 318 |
# shiny modules ---- |
|
| 319 | ||
| 320 |
#' @description |
|
| 321 |
#' `shiny` UI definition that stores `FilterState` UI elements. |
|
| 322 |
#' Populated with elements created with `renderUI` in the module server. |
|
| 323 |
#' |
|
| 324 |
#' @param id (`character(1)`) |
|
| 325 |
#' `shiny` module instance id. |
|
| 326 |
#' |
|
| 327 |
#' @return `shiny.tag` |
|
| 328 |
#' |
|
| 329 |
ui_active = function(id) {
|
|
| 330 | 31x |
ns <- NS(id) |
| 331 | 31x |
tagList( |
| 332 | 31x |
include_css_files(pattern = "filter-panel"), |
| 333 | 31x |
uiOutput(ns("trigger_visible_state_change"), inline = TRUE),
|
| 334 | 31x |
uiOutput( |
| 335 | 31x |
ns("cards"),
|
| 336 | 31x |
class = "accordion", |
| 337 | 31x |
`data-label` = ifelse(length(private$datalabel), paste0("> ", private$datalabel), ""),
|
| 338 |
) |
|
| 339 |
) |
|
| 340 |
}, |
|
| 341 | ||
| 342 |
#' @description |
|
| 343 |
#' `shiny` server module. |
|
| 344 |
#' |
|
| 345 |
#' @param id (`character(1)`) |
|
| 346 |
#' `shiny` module instance id. |
|
| 347 |
#' |
|
| 348 |
#' @return `NULL`. |
|
| 349 |
#' |
|
| 350 |
srv_active = function(id) {
|
|
| 351 | 33x |
moduleServer( |
| 352 | 33x |
id = id, |
| 353 | 33x |
function(input, output, session) {
|
| 354 | 33x |
logger::log_debug("{ class(self)[1] }$srv_active initializing, dataname: { private$dataname }")
|
| 355 | 33x |
current_state <- reactive(private$state_list_get()) |
| 356 | 33x |
previous_state <- reactiveVal(NULL) # FilterState list |
| 357 | 33x |
added_states <- reactiveVal(NULL) # FilterState list |
| 358 | ||
| 359 |
# gives a valid shiny ns based on a default slice id |
|
| 360 | 33x |
fs_to_shiny_ns <- function(x) {
|
| 361 | 70x |
checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
|
| 362 | 70x |
gsub("[^[:alnum:]]+", "_", get_default_slice_id(x$get_state()))
|
| 363 |
} |
|
| 364 | ||
| 365 | 33x |
output$trigger_visible_state_change <- renderUI({
|
| 366 | 37x |
current_state() |
| 367 | 37x |
isolate({
|
| 368 | 37x |
logger::log_debug("{ class(self)[1] }$srv_active@1 determining added and removed filter states")
|
| 369 |
# Be aware this returns a list because `current_state` is a list and not `teal_slices`. |
|
| 370 | 37x |
added_states(setdiff_teal_slices(current_state(), previous_state())) |
| 371 | 37x |
previous_state(current_state()) |
| 372 | 37x |
NULL |
| 373 |
}) |
|
| 374 |
}) |
|
| 375 | ||
| 376 | 33x |
output[["cards"]] <- renderUI({
|
| 377 | 37x |
lapply( |
| 378 | 37x |
current_state(), # observes only if added/removed |
| 379 | 37x |
function(state) {
|
| 380 | 35x |
isolate( # isolates when existing state changes |
| 381 | 35x |
state$ui(id = session$ns(fs_to_shiny_ns(state)), parent_id = session$ns("cards"))
|
| 382 |
) |
|
| 383 |
} |
|
| 384 |
) |
|
| 385 |
}) |
|
| 386 | ||
| 387 | 33x |
private$session_bindings[[session$ns("added_states")]] <- observeEvent(
|
| 388 | 33x |
added_states(), # we want to call FilterState module only once when it's added |
| 389 | 33x |
ignoreNULL = TRUE, |
| 390 |
{
|
|
| 391 | 33x |
added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L)) |
| 392 | 33x |
logger::log_debug( |
| 393 | 33x |
"{ class(self)[1] }$srv_active@2 triggered by added states: { toString(added_state_names) }"
|
| 394 |
) |
|
| 395 | 33x |
lapply(added_states(), function(state) {
|
| 396 | 35x |
state$server( |
| 397 | 35x |
id = fs_to_shiny_ns(state), |
| 398 | 35x |
remove_callback = function() private$state_list_remove(state$get_state()$id) |
| 399 |
) |
|
| 400 |
}) |
|
| 401 | 33x |
added_states(NULL) |
| 402 |
} |
|
| 403 |
) |
|
| 404 | ||
| 405 | 33x |
NULL |
| 406 |
} |
|
| 407 |
) |
|
| 408 |
}, |
|
| 409 | ||
| 410 |
#' @description |
|
| 411 |
#' `shiny` UI module to add filter variable. |
|
| 412 |
#' |
|
| 413 |
#' @param id (`character(1)`) |
|
| 414 |
#' `shiny` module instance id. |
|
| 415 |
#' |
|
| 416 |
#' @return `shiny.tag` |
|
| 417 |
#' |
|
| 418 |
ui_add = function(id) {
|
|
| 419 | 28x |
checkmate::assert_string(id) |
| 420 | 28x |
data <- private$data |
| 421 | 28x |
ns <- NS(id) |
| 422 | 28x |
if (ncol(data) == 0) {
|
| 423 | 1x |
tags$div("dataset has no columns")
|
| 424 | 27x |
} else if (nrow(data) == 0) {
|
| 425 | ! |
tags$div("dataset has now rows")
|
| 426 |
} else {
|
|
| 427 | 27x |
uiOutput(ns("var_to_add_container"))
|
| 428 |
} |
|
| 429 |
}, |
|
| 430 | ||
| 431 |
#' @description |
|
| 432 |
#' `shiny` server module to add filter variable. |
|
| 433 |
#' |
|
| 434 |
#' This module controls available choices to select as a filter variable. |
|
| 435 |
#' Once selected, a variable is removed from available choices. |
|
| 436 |
#' Removing a filter variable adds it back to available choices. |
|
| 437 |
#' |
|
| 438 |
#' @param id (`character(1)`) |
|
| 439 |
#' `shiny` module instance id. |
|
| 440 |
#' |
|
| 441 |
#' @return `NULL`. |
|
| 442 |
srv_add = function(id) {
|
|
| 443 | 35x |
moduleServer( |
| 444 | 35x |
id = id, |
| 445 | 35x |
function(input, output, session) {
|
| 446 | 35x |
logger::log_debug("{ class(self)[1] }$srv_add initializing, dataname: { private$dataname }")
|
| 447 | ||
| 448 |
# available choices to display |
|
| 449 | 35x |
avail_column_choices <- reactive({
|
| 450 | 40x |
data <- private$data |
| 451 | 40x |
vars_include <- private$get_filterable_varnames() |
| 452 | 40x |
active_filter_vars <- unique(unlist(lapply(self$get_filter_state(), "[[", "varname"))) |
| 453 | 40x |
choices <- setdiff(vars_include, active_filter_vars) |
| 454 | 40x |
varlabels <- get_varlabels(data) |
| 455 | ||
| 456 | 40x |
data_choices_labeled( |
| 457 | 40x |
data = data, |
| 458 | 40x |
choices = choices, |
| 459 | 40x |
varlabels = varlabels, |
| 460 | 40x |
keys = private$keys |
| 461 |
) |
|
| 462 |
}) |
|
| 463 | ||
| 464 | 35x |
output$var_to_add_container <- renderUI({
|
| 465 | 37x |
logger::log_debug( |
| 466 | 37x |
"{ class(self)[1] }$srv_add@1 updating available column choices, dataname: { private$dataname }"
|
| 467 |
) |
|
| 468 | 37x |
if (length(avail_column_choices()) == 0) {
|
| 469 |
# because input UI is not rendered on this condition but shiny still holds latest selected value |
|
| 470 | ! |
tags$span("No available columns to add.")
|
| 471 |
} else {
|
|
| 472 | 36x |
tags$div( |
| 473 | 36x |
teal.widgets::optionalSelectInput( |
| 474 | 36x |
session$ns("var_to_add"),
|
| 475 | 36x |
choices = avail_column_choices(), |
| 476 | 36x |
selected = NULL, |
| 477 | 36x |
options = shinyWidgets::pickerOptions( |
| 478 | 36x |
liveSearch = TRUE, |
| 479 | 36x |
noneSelectedText = "Select variable to filter" |
| 480 |
) |
|
| 481 |
) |
|
| 482 |
) |
|
| 483 |
} |
|
| 484 |
}) |
|
| 485 | ||
| 486 | 35x |
private$session_bindings[[session$ns("var_to_add")]] <- observeEvent(
|
| 487 | 35x |
eventExpr = input$var_to_add, |
| 488 | 35x |
handlerExpr = {
|
| 489 |
# We have to close the picker selection dropdown because it is re-rendered with new choices |
|
| 490 |
# and if the old dropdown is still open, it gets unbinded and cannot be closed. |
|
| 491 | 3x |
shinyjs::runjs( |
| 492 | 3x |
sprintf( |
| 493 | 3x |
"document.querySelector('#%s .dropdown').click()",
|
| 494 | 3x |
session$ns("var_to_add_input")
|
| 495 |
) |
|
| 496 |
) |
|
| 497 | 3x |
logger::log_debug( |
| 498 | 3x |
"{ class(self)[1] }$srv_add@2 adding FilterState for variable { input$var_to_add }, ",
|
| 499 | 3x |
"dataname {private$dataname}"
|
| 500 |
) |
|
| 501 | 3x |
self$set_filter_state( |
| 502 | 3x |
teal_slices( |
| 503 | 3x |
teal_slice(dataname = private$dataname, varname = input$var_to_add) |
| 504 |
) |
|
| 505 |
) |
|
| 506 |
} |
|
| 507 |
) |
|
| 508 | ||
| 509 |
# Extra observer that clears all input values in session |
|
| 510 | 35x |
private$session_bindings[[session$ns("inputs")]] <- list(
|
| 511 | 35x |
destroy = function() {
|
| 512 | 72x |
lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) |
| 513 |
} |
|
| 514 |
) |
|
| 515 | ||
| 516 | 35x |
NULL |
| 517 |
} |
|
| 518 |
) |
|
| 519 |
} |
|
| 520 |
), |
|
| 521 |
private = list( |
|
| 522 |
# private fields ---- |
|
| 523 |
count_type = "none", # specifies how observation numbers are displayed in filter cards, |
|
| 524 |
data = NULL, # data.frame, MAE, SE or matrix |
|
| 525 |
data_reactive = NULL, # reactive |
|
| 526 |
datalabel = NULL, # to follow default `experiment = NULL` in `teal_slice` |
|
| 527 |
dataname = NULL, # because it holds object of class name |
|
| 528 |
dataname_prefixed = character(0), # name used in call returned from get_call |
|
| 529 |
exclude_varnames = character(0), # holds column names |
|
| 530 |
include_varnames = character(0), # holds column names |
|
| 531 |
extract_type = character(0), # type of the prefix in a subset call (eg. "list": x$var; "matrix": x[["var"]]) |
|
| 532 |
fun = quote(subset), # function used to generate subset call |
|
| 533 |
keys = character(0), |
|
| 534 |
ns = NULL, # shiny ns() |
|
| 535 |
session_bindings = list(), # inputs and observers |
|
| 536 |
state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes, |
|
| 537 | ||
| 538 |
# private methods ---- |
|
| 539 | ||
| 540 |
# @description |
|
| 541 |
# Set the allowed filterable variables |
|
| 542 |
# @param include_varnames (`character`) Names of variables included in filtering. |
|
| 543 |
# @param exclude_varnames (`character`) Names of variables excluded from filtering. |
|
| 544 |
# |
|
| 545 |
# @details When retrieving the filtered variables only |
|
| 546 |
# those which have filtering supported (i.e. are of the permitted types). |
|
| 547 |
# Only one from `include_varnames` and `exclude_varnames` can be used in one call. When `exclude_varnames` |
|
| 548 |
# is called `include_varnames` is cleared - same otherwise. |
|
| 549 |
# are included. |
|
| 550 |
# |
|
| 551 |
# @return `NULL`, invisibly. |
|
| 552 |
set_filterable_varnames = function(include_varnames = character(0), exclude_varnames = character(0)) {
|
|
| 553 | 331x |
if ((length(include_varnames) + length(exclude_varnames)) == 0L) {
|
| 554 | 135x |
return(invisible(NULL)) |
| 555 |
} |
|
| 556 | 196x |
checkmate::assert_character(include_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE) |
| 557 | 196x |
checkmate::assert_character(exclude_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE) |
| 558 | 196x |
if (length(include_varnames) && length(exclude_varnames)) {
|
| 559 | ! |
stop( |
| 560 | ! |
"`include_varnames` and `exclude_varnames` has been both specified for", |
| 561 | ! |
private$dataname, |
| 562 | ! |
". Only one per dataset is allowed.", |
| 563 |
) |
|
| 564 |
} |
|
| 565 | 196x |
supported_vars <- get_supported_filter_varnames(private$data) |
| 566 | 196x |
if (length(include_varnames)) {
|
| 567 | 181x |
private$include_varnames <- intersect(include_varnames, supported_vars) |
| 568 | 181x |
private$exclude_varnames <- character(0) |
| 569 |
} else {
|
|
| 570 | 15x |
private$exclude_varnames <- exclude_varnames |
| 571 | 15x |
private$include_varnames <- character(0) |
| 572 |
} |
|
| 573 | 196x |
invisible(NULL) |
| 574 |
}, |
|
| 575 | ||
| 576 |
# @description |
|
| 577 |
# Get vector of filterable varnames |
|
| 578 |
# |
|
| 579 |
# @details |
|
| 580 |
# These are the only columns which can be used in the filter panel |
|
| 581 |
# |
|
| 582 |
# @return character vector with names of the columns |
|
| 583 |
get_filterable_varnames = function() {
|
|
| 584 | 154x |
if (length(private$include_varnames)) {
|
| 585 | 126x |
private$include_varnames |
| 586 |
} else {
|
|
| 587 | 28x |
supported_varnames <- get_supported_filter_varnames(private$data) |
| 588 | 28x |
setdiff(supported_varnames, private$exclude_varnames) |
| 589 |
} |
|
| 590 |
}, |
|
| 591 | ||
| 592 |
# state_list methods ---- |
|
| 593 | ||
| 594 |
# @description |
|
| 595 |
# Returns a list of `FilterState` objects stored in this `FilterStates`. |
|
| 596 |
# |
|
| 597 |
# @param state_id (`character(1)`) |
|
| 598 |
# name of element in a filter state (which is a `reactiveVal` containing a list) |
|
| 599 |
# |
|
| 600 |
# @return `list` of `FilterState` objects |
|
| 601 |
# |
|
| 602 |
state_list_get = function(state_id = NULL) {
|
|
| 603 | 267x |
checkmate::assert_string(state_id, null.ok = TRUE) |
| 604 | ||
| 605 | 267x |
if (is.null(state_id)) {
|
| 606 | 267x |
private$state_list() |
| 607 |
} else {
|
|
| 608 | ! |
private$state_list()[[state_id]] |
| 609 |
} |
|
| 610 |
}, |
|
| 611 | ||
| 612 |
# @description |
|
| 613 |
# Adds a new `FilterState` object to this `FilterStates`. |
|
| 614 |
# Raises error if the length of `x` does not match the length of `state_id`. |
|
| 615 |
# |
|
| 616 |
# @param x (`FilterState`) |
|
| 617 |
# object to be added to filter state list |
|
| 618 |
# @param state_id (`character(1)`) |
|
| 619 |
# name of element in a filter state (which is a `reactiveVal` containing a list) |
|
| 620 |
# |
|
| 621 |
# @return `NULL`. |
|
| 622 |
# |
|
| 623 |
state_list_push = function(x, state_id) {
|
|
| 624 | 203x |
isolate({
|
| 625 | 203x |
logger::log_debug("{ class(self)[1] }$state_list_push pushing into state_list, state_id: { state_id }")
|
| 626 | 203x |
checkmate::assert_string(state_id) |
| 627 | 203x |
checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
|
| 628 | 203x |
state <- stats::setNames(list(x), state_id) |
| 629 | 203x |
new_state_list <- c(private$state_list(), state) |
| 630 | 203x |
private$state_list(new_state_list) |
| 631 | 203x |
invisible(NULL) |
| 632 |
}) |
|
| 633 |
}, |
|
| 634 | ||
| 635 |
# @description |
|
| 636 |
# Removes a single filter state with all associated shiny elements: |
|
| 637 |
# * specified `FilterState` from `private$state_list` |
|
| 638 |
# * UI card created for this filter |
|
| 639 |
# * observers tracking the selection and remove button |
|
| 640 |
# |
|
| 641 |
# @param state_id (`character`) |
|
| 642 |
# identifiers of elements in a filter state (which is a `reactiveVal` containing a list). |
|
| 643 |
# @param force (`logical(1)`) |
|
| 644 |
# flag specifying whether to include anchored filter states. |
|
| 645 |
# |
|
| 646 |
# @return `NULL`, invisibly. |
|
| 647 |
# |
|
| 648 |
state_list_remove = function(state_id, force = FALSE) {
|
|
| 649 | 68x |
isolate({
|
| 650 | 68x |
checkmate::assert_character(state_id) |
| 651 | 68x |
logger::log_debug("{ class(self)[1] }$state_list_remove removing a filter, state_id: { toString(state_id) }")
|
| 652 | 68x |
current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1)) |
| 653 | 68x |
to_remove <- state_id %in% current_state_ids |
| 654 | 68x |
if (any(to_remove)) {
|
| 655 | 67x |
new_state_list <- Filter( |
| 656 | 67x |
function(state) {
|
| 657 | 112x |
if (state$get_state()$id %in% state_id) {
|
| 658 | 98x |
if (state$get_state()$anchored && !force) {
|
| 659 | 7x |
TRUE |
| 660 |
} else {
|
|
| 661 | 91x |
state$destroy() |
| 662 | 91x |
FALSE |
| 663 |
} |
|
| 664 |
} else {
|
|
| 665 | 14x |
TRUE |
| 666 |
} |
|
| 667 |
}, |
|
| 668 | 67x |
private$state_list() |
| 669 |
) |
|
| 670 | 67x |
private$state_list(new_state_list) |
| 671 |
} else {
|
|
| 672 | 1x |
warning(sprintf("\"%s\" not found in state list", state_id))
|
| 673 |
} |
|
| 674 |
}) |
|
| 675 | ||
| 676 | 68x |
invisible(NULL) |
| 677 |
}, |
|
| 678 | ||
| 679 |
# @description |
|
| 680 |
# Remove all `FilterState` objects from this `FilterStates` object. |
|
| 681 |
# @param force (`logical(1)`) |
|
| 682 |
# flag specifying whether to include anchored filter states. |
|
| 683 |
# @return `NULL`, invisibly. |
|
| 684 |
# |
|
| 685 |
state_list_empty = function(force = FALSE) {
|
|
| 686 | 166x |
isolate({
|
| 687 | 166x |
logger::log_debug( |
| 688 | 166x |
"{ class(self)[1] }$state_list_empty removing all non-anchored filters for dataname: { private$dataname }"
|
| 689 |
) |
|
| 690 | ||
| 691 | 166x |
state_list <- private$state_list() |
| 692 | 166x |
if (length(state_list)) {
|
| 693 | 49x |
state_ids <- vapply(state_list, function(x) x$get_state()$id, character(1L)) |
| 694 | 49x |
private$state_list_remove(state_ids, force) |
| 695 |
} |
|
| 696 |
}) |
|
| 697 | ||
| 698 | 166x |
invisible(NULL) |
| 699 |
}, |
|
| 700 | ||
| 701 |
# @description |
|
| 702 |
# Set filter state |
|
| 703 |
# |
|
| 704 |
# Utility method for `set_filter_state` to create or modify `FilterState` using a single |
|
| 705 |
# `teal_slice`. |
|
| 706 |
# @param state (`teal_slices`) |
|
| 707 |
# @param data (`data.frame`, `matrix` or `DataFrame`) |
|
| 708 |
# @param data_reactive (`function`) |
|
| 709 |
# function having `sid` as argument. |
|
| 710 |
# |
|
| 711 |
# @return `NULL`, invisibly. |
|
| 712 |
# |
|
| 713 |
set_filter_state_impl = function(state, |
|
| 714 |
data, |
|
| 715 |
data_reactive) {
|
|
| 716 | 221x |
isolate({
|
| 717 | 221x |
checkmate::assert_class(state, "teal_slices") |
| 718 | 221x |
checkmate::assert_multi_class(data, c("data.frame", "matrix", "DataFrame", "HermesData"))
|
| 719 | 221x |
checkmate::assert_function(data_reactive, args = "sid") |
| 720 | 221x |
if (length(state) == 0L) {
|
| 721 | 86x |
return(invisible(NULL)) |
| 722 |
} |
|
| 723 | ||
| 724 | 135x |
slices_hashed <- vapply(state, `[[`, character(1L), "id") |
| 725 | 135x |
if (any(duplicated(slices_hashed))) {
|
| 726 | ! |
stop( |
| 727 | ! |
"Some of the teal_slice objects refer to the same filter. ", |
| 728 | ! |
"Please specify different 'id' when calling teal_slice" |
| 729 |
) |
|
| 730 |
} |
|
| 731 | ||
| 732 | 135x |
state_list <- private$state_list_get() |
| 733 | 135x |
lapply(state, function(slice) {
|
| 734 | 214x |
state_id <- slice$id |
| 735 | 214x |
if (state_id %in% names(state_list)) {
|
| 736 |
# Modify existing filter states. |
|
| 737 | 11x |
state_list[[state_id]]$set_state(slice) |
| 738 |
} else {
|
|
| 739 | 203x |
if (inherits(slice, "teal_slice_expr")) {
|
| 740 |
# create a new FilterStateExpr |
|
| 741 | 13x |
fstate <- init_filter_state_expr(slice) |
| 742 |
} else {
|
|
| 743 |
# create a new FilterState |
|
| 744 | 190x |
fstate <- init_filter_state( |
| 745 | 190x |
x = data[, slice$varname, drop = TRUE], |
| 746 |
# data_reactive is a function which eventually calls get_call(sid). |
|
| 747 |
# This chain of calls returns column from the data filtered by everything |
|
| 748 |
# but filter identified by the sid argument. FilterState then get x_reactive |
|
| 749 |
# and this no longer needs to be a function to pass sid. reactive in the FilterState |
|
| 750 |
# is also beneficial as it can be cached and retriger filter counts only if |
|
| 751 |
# returned vector is different. |
|
| 752 | 190x |
x_reactive = if (private$count_type == "none") {
|
| 753 | 184x |
reactive(NULL) |
| 754 |
} else {
|
|
| 755 | 6x |
reactive(data_reactive(state_id)[, slice$varname, drop = TRUE]) |
| 756 |
}, |
|
| 757 | 190x |
slice = slice, |
| 758 | 190x |
extract_type = private$extract_type |
| 759 |
) |
|
| 760 |
} |
|
| 761 | 203x |
private$state_list_push(x = fstate, state_id = state_id) |
| 762 |
} |
|
| 763 |
}) |
|
| 764 | ||
| 765 | 135x |
invisible(NULL) |
| 766 |
}) |
|
| 767 |
}, |
|
| 768 | ||
| 769 |
# @description |
|
| 770 |
# Object cleanup. |
|
| 771 |
# |
|
| 772 |
# - Destroy inputs and observers stored in `private$session_bindings` |
|
| 773 |
# - Clean `state_list` |
|
| 774 |
# |
|
| 775 |
# @return `NULL`, invisibly. |
|
| 776 |
# |
|
| 777 |
finalize = function() {
|
|
| 778 | 651x |
.finalize_session_bindings(self, private) |
| 779 |
} |
|
| 780 |
) |
|
| 781 |
) |
| 1 |
#' Complete filter specification |
|
| 2 |
#' |
|
| 3 |
#' Create `teal_slices` object to package multiple filters and additional settings. |
|
| 4 |
#' Check out [`teal_slices-utilities`] functions for working with `teal_slices` object. |
|
| 5 |
#' |
|
| 6 |
#' `teal_slices()` collates multiple `teal_slice` objects into a `teal_slices` object, |
|
| 7 |
#' a complete filter specification. This is used by all classes above `FilterState` |
|
| 8 |
#' as well as `filter_panel_api` wrapper functions. |
|
| 9 |
#' `teal_slices` has attributes that modify the behavior of the filter panel, which are resolved by different classes. |
|
| 10 |
#' |
|
| 11 |
#' `include_varnames` and `exclude_varnames` determine which variables can have filters assigned. |
|
| 12 |
#' The former enumerates allowed variables, the latter enumerates forbidden values. |
|
| 13 |
#' Since these could be mutually exclusive, it is impossible to set both allowed and forbidden |
|
| 14 |
#' variables for one data set in one `teal_slices`. |
|
| 15 |
#' |
|
| 16 |
#' @param ... any number of `teal_slice` objects. |
|
| 17 |
#' @param include_varnames,exclude_varnames (`named list`s of `character`) where list names |
|
| 18 |
#' match names of data sets and vector elements match variable names in respective data sets; |
|
| 19 |
#' specify which variables are allowed to be filtered; see `Details`. |
|
| 20 |
#' @param count_type |
|
| 21 |
#' _This is a new feature. Do kindly share your opinions on |
|
| 22 |
#' [`teal.slice`'s GitHub repository](https://github.com/insightsengineering/teal.slice/)._ |
|
| 23 |
#' |
|
| 24 |
#' (`character(1)`) string specifying how observations are tallied by these filter states. |
|
| 25 |
#' Possible options: |
|
| 26 |
#' - `"none"` (default) to have counts of single `FilterState` to show unfiltered number only. |
|
| 27 |
#' - `"all"` to have counts of single `FilterState` to show number of observation in filtered |
|
| 28 |
#' and unfiltered dataset. Note, that issues were reported when using this option with `MultiAssayExperiment`. |
|
| 29 |
#' Please make sure that adding new filters doesn't fail on target platform before deploying for production. |
|
| 30 |
#' @param allow_add (`logical(1)`) logical flag specifying whether the user will be able to add new filters |
|
| 31 |
#' |
|
| 32 |
#' @return |
|
| 33 |
#' `teal_slices`, which is an unnamed list of `teal_slice` objects. |
|
| 34 |
#' |
|
| 35 |
#' @examples |
|
| 36 |
#' filter_1 <- teal_slice( |
|
| 37 |
#' dataname = "dataname1", |
|
| 38 |
#' varname = "varname1", |
|
| 39 |
#' choices = letters, |
|
| 40 |
#' selected = "b", |
|
| 41 |
#' keep_na = TRUE, |
|
| 42 |
#' fixed = FALSE, |
|
| 43 |
#' extra1 = "extraone" |
|
| 44 |
#' ) |
|
| 45 |
#' filter_2 <- teal_slice( |
|
| 46 |
#' dataname = "dataname1", |
|
| 47 |
#' varname = "varname2", |
|
| 48 |
#' choices = 1:10, |
|
| 49 |
#' keep_na = TRUE, |
|
| 50 |
#' selected = 2, |
|
| 51 |
#' fixed = TRUE, |
|
| 52 |
#' anchored = FALSE, |
|
| 53 |
#' extra2 = "extratwo" |
|
| 54 |
#' ) |
|
| 55 |
#' filter_3 <- teal_slice( |
|
| 56 |
#' dataname = "dataname2", |
|
| 57 |
#' varname = "varname3", |
|
| 58 |
#' choices = 1:10 / 10, |
|
| 59 |
#' keep_na = TRUE, |
|
| 60 |
#' selected = 0.2, |
|
| 61 |
#' fixed = TRUE, |
|
| 62 |
#' anchored = FALSE, |
|
| 63 |
#' extra1 = "extraone", |
|
| 64 |
#' extra2 = "extratwo" |
|
| 65 |
#' ) |
|
| 66 |
#' |
|
| 67 |
#' all_filters <- teal_slices( |
|
| 68 |
#' filter_1, |
|
| 69 |
#' filter_2, |
|
| 70 |
#' filter_3, |
|
| 71 |
#' exclude_varnames = list( |
|
| 72 |
#' "dataname1" = "varname2" |
|
| 73 |
#' ) |
|
| 74 |
#' ) |
|
| 75 |
#' |
|
| 76 |
#' is.teal_slices(all_filters) |
|
| 77 |
#' all_filters[1:2] |
|
| 78 |
#' c(all_filters[1], all_filters[2]) |
|
| 79 |
#' print(all_filters) |
|
| 80 |
#' print(all_filters, trim_lines = FALSE) |
|
| 81 |
#' |
|
| 82 |
#' @seealso |
|
| 83 |
#' - [`teal_slice`] for creating constituent elements of `teal_slices` |
|
| 84 |
#' - `teal::slices_store` for robust utilities for saving and loading `teal_slices` in `JSON` format |
|
| 85 |
#' - [`is.teal_slices`], [`as.teal_slices`], [`as.list.teal_slices`], [`[.teal_slices`], [`c.teal_slices`] |
|
| 86 |
#' [`print.teal_slices`], [`format.teal_slices`] |
|
| 87 |
#' |
|
| 88 |
#' @export |
|
| 89 |
#' |
|
| 90 |
teal_slices <- function(..., |
|
| 91 |
exclude_varnames = NULL, |
|
| 92 |
include_varnames = NULL, |
|
| 93 |
count_type = NULL, |
|
| 94 |
allow_add = TRUE) {
|
|
| 95 | 1186x |
slices <- list(...) |
| 96 | 1186x |
checkmate::assert_list(slices, types = "teal_slice", any.missing = FALSE) |
| 97 | 1185x |
slices_id <- isolate(vapply(slices, `[[`, character(1L), "id")) |
| 98 | 1185x |
if (any(duplicated(slices_id))) {
|
| 99 | 1x |
stop( |
| 100 | 1x |
"Some teal_slice objects have the same id:\n", |
| 101 | 1x |
toString(unique(slices_id[duplicated(slices_id)])) |
| 102 |
) |
|
| 103 |
} |
|
| 104 | 1184x |
checkmate::assert_list(exclude_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1) |
| 105 | 1183x |
checkmate::assert_list(include_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1) |
| 106 | 1182x |
checkmate::assert_character(count_type, len = 1, null.ok = TRUE) |
| 107 | 1180x |
checkmate::assert_subset(count_type, choices = c("all", "none"), empty.ok = TRUE)
|
| 108 | 1179x |
checkmate::assert_logical(allow_add) |
| 109 | ||
| 110 | 1178x |
duplicated_datasets <- intersect(names(include_varnames), names(exclude_varnames)) |
| 111 | 1178x |
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) |
| 115 |
) |
|
| 116 |
} |
|
| 117 | ||
| 118 | 1177x |
structure( |
| 119 | 1177x |
slices, |
| 120 | 1177x |
exclude_varnames = exclude_varnames, |
| 121 | 1177x |
include_varnames = include_varnames, |
| 122 | 1177x |
count_type = count_type, |
| 123 | 1177x |
allow_add = allow_add, |
| 124 | 1177x |
class = c("teal_slices", class(slices))
|
| 125 |
) |
|
| 126 |
} |
|
| 127 | ||
| 128 |
#' `teal_slices` utility functions |
|
| 129 |
#' |
|
| 130 |
#' Helper functions for working with [`teal_slices`] object. |
|
| 131 |
#' @param x object to test for `teal_slices`, object to convert to `teal_slices` or a `teal_slices` object |
|
| 132 |
#' @param i (`character` or `numeric` or `logical`) indicating which elements to extract |
|
| 133 |
#' @param recursive (`logical(1)`) flag specifying whether to also convert to list the elements of this `teal_slices` |
|
| 134 |
#' @param ... additional arguments passed to other functions. |
|
| 135 |
#' @name teal_slices-utilities |
|
| 136 |
#' @inherit teal_slices examples |
|
| 137 |
#' @keywords internal |
|
| 138 | ||
| 139 |
#' @rdname teal_slices-utilities |
|
| 140 |
#' @export |
|
| 141 |
#' |
|
| 142 |
is.teal_slices <- function(x) { # nolint
|
|
| 143 | 664x |
inherits(x, "teal_slices") |
| 144 |
} |
|
| 145 | ||
| 146 |
#' @rdname teal_slices-utilities |
|
| 147 |
#' @export |
|
| 148 |
#' |
|
| 149 |
as.teal_slices <- function(x) { # nolint
|
|
| 150 | ! |
checkmate::assert_list(x) |
| 151 | ! |
lapply(x, checkmate::assert_list, names = "named", .var.name = "list element") |
| 152 | ||
| 153 | ! |
attrs <- attributes(unclass(x)) |
| 154 | ! |
ans <- lapply(x, function(x) if (is.teal_slice(x)) x else as.teal_slice(x)) |
| 155 | ! |
do.call(teal_slices, c(ans, attrs)) |
| 156 |
} |
|
| 157 | ||
| 158 | ||
| 159 |
#' @rdname teal_slices-utilities |
|
| 160 |
#' @export |
|
| 161 |
#' |
|
| 162 |
as.list.teal_slices <- function(x, recursive = FALSE, ...) { # nolint
|
|
| 163 | 1320x |
ans <- unclass(x) |
| 164 | 46x |
if (recursive) ans[] <- lapply(ans, as.list) |
| 165 | 1320x |
ans |
| 166 |
} |
|
| 167 | ||
| 168 | ||
| 169 |
#' @rdname teal_slices-utilities |
|
| 170 |
#' @export |
|
| 171 |
#' |
|
| 172 |
`[.teal_slices` <- function(x, i) {
|
|
| 173 | 3x |
if (missing(i)) i <- seq_along(x) |
| 174 | 558x |
if (length(i) == 0L) {
|
| 175 | 169x |
return(x[0]) |
| 176 |
} |
|
| 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 | 387x |
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 |
} |
|
| 183 | ||
| 184 | 386x |
y <- NextMethod("[")
|
| 185 | 386x |
attrs <- attributes(x) |
| 186 | 386x |
attrs$names <- attrs$names[i] |
| 187 | 386x |
attributes(y) <- attrs |
| 188 | 386x |
y |
| 189 |
} |
|
| 190 | ||
| 191 | ||
| 192 |
#' @rdname teal_slices-utilities |
|
| 193 |
#' @export |
|
| 194 |
#' |
|
| 195 |
c.teal_slices <- function(...) {
|
|
| 196 | 502x |
x <- list(...) |
| 197 | 502x |
checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices") |
| 198 | ||
| 199 | 501x |
all_attributes <- lapply(x, attributes) |
| 200 | 501x |
all_attributes <- coalesce_r(all_attributes) |
| 201 | 501x |
all_attributes <- all_attributes[names(all_attributes) != "class"] |
| 202 | ||
| 203 | 501x |
do.call( |
| 204 | 501x |
teal_slices, |
| 205 | 501x |
c( |
| 206 | 501x |
unique(unlist(x, recursive = FALSE)), |
| 207 | 501x |
all_attributes |
| 208 |
) |
|
| 209 |
) |
|
| 210 |
} |
|
| 211 | ||
| 212 | ||
| 213 |
#' @rdname teal_slices-utilities |
|
| 214 |
#' @param show_all (`logical(1)`) whether to display non-null elements of constituent `teal_slice` objects |
|
| 215 |
#' @param trim_lines (`logical(1)`) whether to trim lines |
|
| 216 |
#' @export |
|
| 217 |
#' |
|
| 218 |
format.teal_slices <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
|
|
| 219 | 46x |
checkmate::assert_flag(show_all) |
| 220 | 46x |
checkmate::assert_flag(trim_lines) |
| 221 | ||
| 222 | 46x |
x <- as.list(x, recursive = TRUE) |
| 223 | 46x |
attrs <- attributes(x) |
| 224 | 46x |
attributes(x) <- NULL |
| 225 | 46x |
slices_list <- list(slices = x, attributes = attrs) |
| 226 | 46x |
slices_list <- Filter(Negate(is.null), slices_list) # drop attributes if empty |
| 227 | ||
| 228 | 21x |
if (!show_all) slices_list$slices <- lapply(slices_list$slices, function(slice) Filter(Negate(is.null), slice)) |
| 229 | ||
| 230 | 46x |
jsonify(slices_list, trim_lines) |
| 231 |
} |
|
| 232 | ||
| 233 |
#' @rdname teal_slices-utilities |
|
| 234 |
#' @export |
|
| 235 |
#' |
|
| 236 |
print.teal_slices <- function(x, ...) {
|
|
| 237 | 3x |
cat(format(x, ...), "\n") |
| 238 | 3x |
invisible(x) |
| 239 |
} |
|
| 240 | ||
| 241 | ||
| 242 |
#' `setdiff` method for `teal_slices` |
|
| 243 |
#' |
|
| 244 |
#' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`. |
|
| 245 |
#' @param x,y (`teal_slices`) |
|
| 246 |
#' @return `teal_slices` |
|
| 247 |
#' @keywords internal |
|
| 248 |
#' |
|
| 249 |
setdiff_teal_slices <- function(x, y) {
|
|
| 250 | 37x |
Filter( |
| 251 | 37x |
function(xx) {
|
| 252 | 35x |
!any(vapply(y, function(yy) identical(yy, xx), logical(1))) |
| 253 |
}, |
|
| 254 | 37x |
x |
| 255 |
) |
|
| 256 |
} |
|
| 257 | ||
| 258 |
#' Recursively coalesce list elements. |
|
| 259 |
#' |
|
| 260 |
#' Returns first element of list that it not `NULL`, recursively. |
|
| 261 |
#' |
|
| 262 |
#' Given a list of atomic vectors, the first non-null element is returned. |
|
| 263 |
#' Given a list of lists, for all `names` found in all elements of the list |
|
| 264 |
#' the first non-null element of a given name is returned. |
|
| 265 |
#' |
|
| 266 |
#' This function is used internally in `c.teal_slices` to manage `teal_slices` attributes. |
|
| 267 |
#' |
|
| 268 |
#' @param x (`list`), either of atomic vectors or of named lists |
|
| 269 |
#' @return |
|
| 270 |
#' Either an atomic vector of length 1 or a (potentially nested) list. |
|
| 271 |
#' |
|
| 272 |
#' @keywords internal |
|
| 273 |
#' |
|
| 274 |
coalesce_r <- function(x) {
|
|
| 275 | 3058x |
checkmate::assert_list(x) |
| 276 | 3057x |
xnn <- Filter(Negate(is.null), x) |
| 277 | 3057x |
if (all(vapply(xnn, is.atomic, logical(1L)))) {
|
| 278 | 2048x |
return(xnn[[1L]]) |
| 279 |
} |
|
| 280 | 1009x |
lapply(x, checkmate::assert_list, names = "named", null.ok = TRUE, .var.name = "list element") |
| 281 | 1008x |
all_names <- unique(unlist(lapply(x, names))) |
| 282 | 1008x |
sapply(all_names, function(nm) coalesce_r(lapply(x, `[[`, nm)), simplify = FALSE) |
| 283 |
} |
| 1 |
# SEFilterStates ------ |
|
| 2 | ||
| 3 |
#' @name SEFilterStates |
|
| 4 |
#' @docType class |
|
| 5 |
#' @title `FilterStates` subclass for `SummarizedExperiment`s |
|
| 6 |
#' @description Handles filter states in a `SummaryExperiment`. |
|
| 7 |
#' @keywords internal |
|
| 8 |
#' |
|
| 9 |
SEFilterStates <- R6::R6Class( # nolint |
|
| 10 |
classname = "SEFilterStates", |
|
| 11 |
inherit = FilterStates, |
|
| 12 | ||
| 13 |
# public methods ---- |
|
| 14 |
public = list( |
|
| 15 |
#' @description |
|
| 16 |
#' Initialize `SEFilterStates` object. |
|
| 17 |
#' |
|
| 18 |
#' @param data (`SummarizedExperiment`) |
|
| 19 |
#' the `R` object which `subset` function is applied on. |
|
| 20 |
#' @param data_reactive (`function(sid)`) |
|
| 21 |
#' should return a `SummarizedExperiment` object or `NULL`. |
|
| 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. |
|
| 24 |
#' Function has to have `sid` argument being a character. |
|
| 25 |
#' @param dataname (`character(1)`) |
|
| 26 |
#' name of the data used in the expression |
|
| 27 |
#' specified to the function argument attached to this `FilterStates`. |
|
| 28 |
#' @param datalabel (`character(1)`) optional |
|
| 29 |
#' text label. Should be the name of experiment. |
|
| 30 |
#' |
|
| 31 |
initialize = function(data, |
|
| 32 |
data_reactive = function(sid = "") NULL, |
|
| 33 |
dataname, |
|
| 34 |
datalabel = NULL) {
|
|
| 35 | 84x |
if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
|
| 36 | ! |
stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
|
| 37 |
} |
|
| 38 | 84x |
checkmate::assert_function(data_reactive, args = "sid") |
| 39 | 84x |
checkmate::assert_class(data, "SummarizedExperiment") |
| 40 | 83x |
super$initialize(data, data_reactive, dataname, datalabel) |
| 41 | 83x |
if (!is.null(datalabel)) {
|
| 42 | 76x |
private$dataname_prefixed <- sprintf( |
| 43 | 76x |
"%s[['%s']]", private$dataname_prefixed, datalabel |
| 44 |
) |
|
| 45 |
} |
|
| 46 |
}, |
|
| 47 | ||
| 48 |
#' @description |
|
| 49 |
#' Set filter state. |
|
| 50 |
#' |
|
| 51 |
#' @param state (`teal_slices`) |
|
| 52 |
#' `teal_slice` objects should contain the field `arg %in% c("subset", "select")`
|
|
| 53 |
#' |
|
| 54 |
#' @return `NULL`, invisibly. |
|
| 55 |
#' |
|
| 56 |
set_filter_state = function(state) {
|
|
| 57 | 53x |
isolate({
|
| 58 | 53x |
logger::log_debug("SEFilterState$set_filter_state initializing, dataname: { private$dataname }")
|
| 59 | 53x |
checkmate::assert_class(state, "teal_slices") |
| 60 | 51x |
lapply(state, function(x) {
|
| 61 | 16x |
checkmate::assert_choice(x$arg, choices = c("subset", "select"), null.ok = TRUE, .var.name = "teal_slice$arg")
|
| 62 |
}) |
|
| 63 | 51x |
count_type <- attr(state, "count_type") |
| 64 | 51x |
if (length(count_type)) {
|
| 65 | 8x |
private$count_type <- count_type |
| 66 |
} |
|
| 67 | ||
| 68 | 51x |
subset_states <- Filter(function(x) x$arg == "subset", state) |
| 69 | 51x |
private$set_filter_state_impl( |
| 70 | 51x |
state = subset_states, |
| 71 | 51x |
data = SummarizedExperiment::rowData(private$data), |
| 72 | 51x |
data_reactive = function(sid = "") {
|
| 73 | ! |
data <- private$data_reactive() |
| 74 | ! |
if (!is.null(data)) {
|
| 75 | ! |
SummarizedExperiment::rowData(data) |
| 76 |
} |
|
| 77 |
} |
|
| 78 |
) |
|
| 79 | ||
| 80 | 51x |
select_states <- Filter(function(x) x$arg == "select", state) |
| 81 | 51x |
private$set_filter_state_impl( |
| 82 | 51x |
state = select_states, |
| 83 | 51x |
data = SummarizedExperiment::colData(private$data), |
| 84 | 51x |
data_reactive = function(sid = "") {
|
| 85 | ! |
data <- private$data_reactive() |
| 86 | ! |
if (!is.null(data)) {
|
| 87 | ! |
SummarizedExperiment::colData(data) |
| 88 |
} |
|
| 89 |
} |
|
| 90 |
) |
|
| 91 | ||
| 92 | 51x |
invisible(NULL) |
| 93 |
}) |
|
| 94 |
}, |
|
| 95 | ||
| 96 |
#' @description |
|
| 97 |
#' `shiny` UI module to add filter variable. |
|
| 98 |
#' @param id (`character(1)`) |
|
| 99 |
#' `shiny` module instance id. |
|
| 100 |
#' @return `shiny.tag` |
|
| 101 |
ui_add = function(id) {
|
|
| 102 | 6x |
data <- private$data |
| 103 | 6x |
checkmate::assert_string(id) |
| 104 | 6x |
ns <- NS(id) |
| 105 | ||
| 106 | 6x |
row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
|
| 107 | 3x |
tags$div("no gene variables available")
|
| 108 | 6x |
} else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
|
| 109 | 1x |
tags$div("no genes available")
|
| 110 |
} else {
|
|
| 111 | 2x |
uiOutput(ns("row_to_add_container"))
|
| 112 |
} |
|
| 113 | ||
| 114 | 6x |
col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
|
| 115 | 5x |
tags$div("no sample variables available")
|
| 116 | 6x |
} else if (nrow(SummarizedExperiment::colData(data)) == 0) {
|
| 117 | 1x |
tags$div("no samples available")
|
| 118 |
} else {
|
|
| 119 | ! |
uiOutput(ns("col_to_add_container"))
|
| 120 |
} |
|
| 121 | ||
| 122 | 6x |
tags$div(row_input, col_input) |
| 123 |
}, |
|
| 124 | ||
| 125 |
#' @description |
|
| 126 |
#' `shiny` server module to add filter variable. |
|
| 127 |
#' |
|
| 128 |
#' Module controls available choices to select as a filter variable. |
|
| 129 |
#' Selected filter variable is being removed from available choices. |
|
| 130 |
#' Removed filter variable gets back to available choices. |
|
| 131 |
#' This module unlike other `FilterStates` classes manages two |
|
| 132 |
#' sets of filter variables - one for `colData` and another for |
|
| 133 |
#' `rowData`. |
|
| 134 |
#' |
|
| 135 |
#' @param id (`character(1)`) |
|
| 136 |
#' `shiny` module instance id. |
|
| 137 |
#' @return `NULL` |
|
| 138 |
srv_add = function(id) {
|
|
| 139 | 4x |
data <- private$data |
| 140 | 4x |
data_reactive <- private$data_reactive |
| 141 | 4x |
moduleServer( |
| 142 | 4x |
id = id, |
| 143 | 4x |
function(input, output, session) {
|
| 144 | 4x |
logger::log_debug("SEFilterState$srv_add initializing, dataname: { private$dataname }")
|
| 145 | ||
| 146 | 4x |
row_data <- SummarizedExperiment::rowData(data) |
| 147 | 4x |
col_data <- SummarizedExperiment::colData(data) |
| 148 | ||
| 149 | 4x |
avail_row_data_choices <- reactive({
|
| 150 | 4x |
slices_for_subset <- Filter(function(x) x$arg == "subset", self$get_filter_state()) |
| 151 | 4x |
active_filter_row_vars <- unique(unlist(lapply(slices_for_subset, "[[", "varname"))) |
| 152 | ||
| 153 | 4x |
choices <- setdiff( |
| 154 | 4x |
get_supported_filter_varnames(data = row_data), |
| 155 | 4x |
active_filter_row_vars |
| 156 |
) |
|
| 157 | ||
| 158 | 4x |
data_choices_labeled( |
| 159 | 4x |
data = row_data, |
| 160 | 4x |
choices = choices, |
| 161 | 4x |
varlabels = character(0), |
| 162 | 4x |
keys = NULL |
| 163 |
) |
|
| 164 |
}) |
|
| 165 | ||
| 166 | 4x |
avail_col_data_choices <- reactive({
|
| 167 | 4x |
slices_for_select <- Filter(function(x) x$arg == "select", self$get_filter_state()) |
| 168 | 4x |
active_filter_col_vars <- unique(unlist(lapply(slices_for_select, "[[", "varname"))) |
| 169 | ||
| 170 | 4x |
choices <- setdiff( |
| 171 | 4x |
get_supported_filter_varnames(data = col_data), |
| 172 | 4x |
active_filter_col_vars |
| 173 |
) |
|
| 174 | ||
| 175 | 4x |
data_choices_labeled( |
| 176 | 4x |
data = col_data, |
| 177 | 4x |
choices = choices, |
| 178 | 4x |
varlabels = character(0), |
| 179 | 4x |
keys = NULL |
| 180 |
) |
|
| 181 |
}) |
|
| 182 | ||
| 183 | 4x |
output$row_to_add_container <- renderUI({
|
| 184 | 4x |
logger::log_debug( |
| 185 | 4x |
"{ class(self)[1] }$srv_add@1 updating available row data choices, dataname: { private$dataname }"
|
| 186 |
) |
|
| 187 | 4x |
if (length(avail_row_data_choices()) == 0) {
|
| 188 |
# because input UI is not rendered on this condition but shiny still holds latest selected value |
|
| 189 | 2x |
tags$div("no gene variables available")
|
| 190 |
} else {
|
|
| 191 | ! |
tags$div( |
| 192 | ! |
teal.widgets::optionalSelectInput( |
| 193 | ! |
session$ns("row_to_add"),
|
| 194 | ! |
choices = avail_row_data_choices(), |
| 195 | ! |
selected = NULL, |
| 196 | ! |
options = shinyWidgets::pickerOptions( |
| 197 | ! |
liveSearch = TRUE, |
| 198 | ! |
noneSelectedText = "Select gene variable" |
| 199 |
) |
|
| 200 |
) |
|
| 201 |
) |
|
| 202 |
} |
|
| 203 |
}) |
|
| 204 | ||
| 205 | 4x |
output$col_to_add_container <- renderUI({
|
| 206 | 4x |
logger::log_debug( |
| 207 | 4x |
"{ class(self)[1] }$srv_add@1 updating available col data choices, dataname: { private$dataname }"
|
| 208 |
) |
|
| 209 | 4x |
if (length(avail_col_data_choices()) == 0) {
|
| 210 |
# because input UI is not rendered on this condition but shiny still holds latest selected value |
|
| 211 | 4x |
tags$div("no sample variables available")
|
| 212 |
} else {
|
|
| 213 | ! |
tags$div( |
| 214 | ! |
teal.widgets::optionalSelectInput( |
| 215 | ! |
session$ns("col_to_add"),
|
| 216 | ! |
choices = avail_col_data_choices(), |
| 217 | ! |
selected = NULL, |
| 218 | ! |
options = shinyWidgets::pickerOptions( |
| 219 | ! |
liveSearch = TRUE, |
| 220 | ! |
noneSelectedText = "Select sample variable" |
| 221 |
) |
|
| 222 |
) |
|
| 223 |
) |
|
| 224 |
} |
|
| 225 |
}) |
|
| 226 | ||
| 227 | 4x |
private$session_bindings[[session$ns("col_to_add")]] <- observeEvent(
|
| 228 | 4x |
eventExpr = input$col_to_add, |
| 229 | 4x |
handlerExpr = {
|
| 230 | ! |
logger::log_debug( |
| 231 | ! |
"SEFilterStates$srv_add@3 adding FilterState of column { input$col_to_add }",
|
| 232 | ! |
" to col data, dataname: { private$dataname }"
|
| 233 |
) |
|
| 234 | ! |
varname <- input$col_to_add |
| 235 | ! |
self$set_filter_state(teal_slices( |
| 236 | ! |
teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select") |
| 237 |
)) |
|
| 238 |
} |
|
| 239 |
) |
|
| 240 | ||
| 241 | ||
| 242 | 4x |
private$session_bindings[[session$ns("row_to_add")]] <- observeEvent(
|
| 243 | 4x |
eventExpr = input$row_to_add, |
| 244 | 4x |
handlerExpr = {
|
| 245 | ! |
logger::log_debug( |
| 246 | ! |
"SEFilterStates$srv_add@4 adding FilterState of variable { input$row_to_add }",
|
| 247 | ! |
" to row data, dataname: { private$dataname }"
|
| 248 |
) |
|
| 249 | ! |
varname <- input$row_to_add |
| 250 | ! |
self$set_filter_state(teal_slices( |
| 251 | ! |
teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset") |
| 252 |
)) |
|
| 253 |
} |
|
| 254 |
) |
|
| 255 | ||
| 256 |
# Extra observer that clears all input values in session |
|
| 257 | 4x |
private$session_bindings[[session$ns("inputs")]] <- list(
|
| 258 | 4x |
destroy = function() {
|
| 259 | ! |
lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) |
| 260 |
} |
|
| 261 |
) |
|
| 262 | ||
| 263 | 4x |
NULL |
| 264 |
} |
|
| 265 |
) |
|
| 266 |
} |
|
| 267 |
) |
|
| 268 |
) |
| 1 |
# DatetimeFilterState ------ |
|
| 2 | ||
| 3 |
#' @rdname DatetimeFilterState |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterState` object for date time data |
|
| 7 |
#' |
|
| 8 |
#' @description Manages choosing a range of date-times. |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' # use non-exported function from teal.slice |
|
| 12 |
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 13 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 14 |
#' DatetimeFilterState <- getFromNamespace("DatetimeFilterState", "teal.slice")
|
|
| 15 |
#' |
|
| 16 |
#' library(shiny) |
|
| 17 |
#' |
|
| 18 |
#' filter_state <- DatetimeFilterState$new( |
|
| 19 |
#' x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA), |
|
| 20 |
#' slice = teal_slice(varname = "x", dataname = "data"), |
|
| 21 |
#' extract_type = character(0) |
|
| 22 |
#' ) |
|
| 23 |
#' isolate(filter_state$get_call()) |
|
| 24 |
#' filter_state$set_state( |
|
| 25 |
#' teal_slice( |
|
| 26 |
#' dataname = "data", |
|
| 27 |
#' varname = "x", |
|
| 28 |
#' selected = c(Sys.time() + 3L, Sys.time() + 8L), |
|
| 29 |
#' keep_na = TRUE |
|
| 30 |
#' ) |
|
| 31 |
#' ) |
|
| 32 |
#' isolate(filter_state$get_call()) |
|
| 33 |
#' |
|
| 34 |
#' # working filter in an app |
|
| 35 |
#' library(shinyjs) |
|
| 36 |
#' |
|
| 37 |
#' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00"))
|
|
| 38 |
#' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA) |
|
| 39 |
#' fs <- DatetimeFilterState$new( |
|
| 40 |
#' x = data_datetime, |
|
| 41 |
#' slice = teal_slice( |
|
| 42 |
#' varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE |
|
| 43 |
#' ) |
|
| 44 |
#' ) |
|
| 45 |
#' |
|
| 46 |
#' ui <- bslib::page_fluid( |
|
| 47 |
#' useShinyjs(), |
|
| 48 |
#' include_css_files(pattern = "filter-panel"), |
|
| 49 |
#' include_js_files(pattern = "count-bar-labels"), |
|
| 50 |
#' bslib::layout_column_wrap( |
|
| 51 |
#' width = 1 / 3, |
|
| 52 |
#' tags$div( |
|
| 53 |
#' tags$h4("DatetimeFilterState"),
|
|
| 54 |
#' fs$ui("fs")
|
|
| 55 |
#' ), |
|
| 56 |
#' tags$div( |
|
| 57 |
#' id = "outputs", # div id is needed for toggling the element |
|
| 58 |
#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|
| 59 |
#' textOutput("condition_datetime"), tags$br(),
|
|
| 60 |
#' tags$h4("Unformatted state"), # display raw filter state
|
|
| 61 |
#' textOutput("unformatted_datetime"), tags$br(),
|
|
| 62 |
#' tags$h4("Formatted state"), # display human readable filter state
|
|
| 63 |
#' textOutput("formatted_datetime"), tags$br()
|
|
| 64 |
#' ), |
|
| 65 |
#' tags$div( |
|
| 66 |
#' tags$h4("Programmatic filter control"),
|
|
| 67 |
#' actionButton("button1_datetime", "set drop NA", width = "100%"), tags$br(),
|
|
| 68 |
#' actionButton("button2_datetime", "set keep NA", width = "100%"), tags$br(),
|
|
| 69 |
#' actionButton("button3_datetime", "set a range", width = "100%"), tags$br(),
|
|
| 70 |
#' actionButton("button4_datetime", "set full range", width = "100%"), tags$br(),
|
|
| 71 |
#' actionButton("button0_datetime", "set initial state", width = "100%"), tags$br()
|
|
| 72 |
#' ) |
|
| 73 |
#' ) |
|
| 74 |
#' ) |
|
| 75 |
#' |
|
| 76 |
#' server <- function(input, output, session) {
|
|
| 77 |
#' fs$server("fs")
|
|
| 78 |
#' output$condition_datetime <- renderPrint(fs$get_call()) |
|
| 79 |
#' output$formatted_datetime <- renderText(fs$format()) |
|
| 80 |
#' output$unformatted_datetime <- renderPrint(fs$get_state()) |
|
| 81 |
#' # modify filter state programmatically |
|
| 82 |
#' observeEvent( |
|
| 83 |
#' input$button1_datetime, |
|
| 84 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) |
|
| 85 |
#' ) |
|
| 86 |
#' observeEvent( |
|
| 87 |
#' input$button2_datetime, |
|
| 88 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
|
| 89 |
#' ) |
|
| 90 |
#' observeEvent( |
|
| 91 |
#' input$button3_datetime, |
|
| 92 |
#' fs$set_state( |
|
| 93 |
#' teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)]) |
|
| 94 |
#' ) |
|
| 95 |
#' ) |
|
| 96 |
#' observeEvent( |
|
| 97 |
#' input$button4_datetime, |
|
| 98 |
#' fs$set_state( |
|
| 99 |
#' teal_slice(dataname = "data", varname = "x", selected = datetimes) |
|
| 100 |
#' ) |
|
| 101 |
#' ) |
|
| 102 |
#' observeEvent( |
|
| 103 |
#' input$button0_datetime, |
|
| 104 |
#' fs$set_state( |
|
| 105 |
#' teal_slice( |
|
| 106 |
#' dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE |
|
| 107 |
#' ) |
|
| 108 |
#' ) |
|
| 109 |
#' ) |
|
| 110 |
#' } |
|
| 111 |
#' |
|
| 112 |
#' if (interactive()) {
|
|
| 113 |
#' shinyApp(ui, server) |
|
| 114 |
#' } |
|
| 115 |
#' |
|
| 116 |
#' @keywords internal |
|
| 117 |
#' |
|
| 118 |
DatetimeFilterState <- R6::R6Class( # nolint |
|
| 119 |
"DatetimeFilterState", |
|
| 120 |
inherit = FilterState, |
|
| 121 | ||
| 122 |
# public methods ---- |
|
| 123 | ||
| 124 |
public = list( |
|
| 125 | ||
| 126 |
#' @description |
|
| 127 |
#' Initialize a `FilterState` object. This class |
|
| 128 |
#' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by |
|
| 129 |
#' default. However, in case when using this module in `teal` app, one needs |
|
| 130 |
#' timezone of the app user. App user timezone is taken from `session$userData$timezone` |
|
| 131 |
#' and is set only if object is initialized in `shiny`. |
|
| 132 |
#' |
|
| 133 |
#' @param x (`POSIXct` or `POSIXlt`) |
|
| 134 |
#' variable to be filtered. |
|
| 135 |
#' @param x_reactive (`reactive`) |
|
| 136 |
#' returning vector of the same type as `x`. Is used to update |
|
| 137 |
#' counts following the change in values of the filtered dataset. |
|
| 138 |
#' If it is set to `reactive(NULL)` then counts based on filtered |
|
| 139 |
#' dataset are not shown. |
|
| 140 |
#' @param slice (`teal_slice`) |
|
| 141 |
#' specification of this filter state. |
|
| 142 |
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 143 |
#' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 144 |
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|
| 145 |
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 146 |
#' @param extract_type (`character`) |
|
| 147 |
#' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 148 |
#' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 149 |
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 150 |
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 151 |
#' |
|
| 152 |
#' @return Object of class `DatetimeFilterState`, invisibly. |
|
| 153 |
#' |
|
| 154 |
initialize = function(x, |
|
| 155 |
x_reactive = reactive(NULL), |
|
| 156 |
extract_type = character(0), |
|
| 157 |
slice) {
|
|
| 158 | 25x |
isolate({
|
| 159 | 25x |
checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
|
| 160 | 24x |
checkmate::assert_class(x_reactive, "reactive") |
| 161 | ||
| 162 | 24x |
super$initialize( |
| 163 | 24x |
x = x, |
| 164 | 24x |
x_reactive = x_reactive, |
| 165 | 24x |
slice = slice, |
| 166 | 24x |
extract_type = extract_type |
| 167 |
) |
|
| 168 | 24x |
checkmate::assert_multi_class(slice$choices, c("POSIXct", "POSIXlt"), null.ok = TRUE)
|
| 169 | 23x |
private$set_choices(slice$choices) |
| 170 | 15x |
if (is.null(slice$selected)) slice$selected <- slice$choices |
| 171 | 23x |
private$set_selected(slice$selected) |
| 172 |
}) |
|
| 173 | ||
| 174 | 22x |
invisible(self) |
| 175 |
}, |
|
| 176 | ||
| 177 |
#' @description |
|
| 178 |
#' Returns reproducible condition call for current selection. |
|
| 179 |
#' For this class returned call looks like |
|
| 180 |
#' `<varname> >= as.POSIXct(<min>) & <varname> <= <max>)` with optional `is.na(<varname>)`. |
|
| 181 |
#' @param dataname name of data set; defaults to `private$get_dataname()` |
|
| 182 |
#' @return `call` |
|
| 183 |
#' |
|
| 184 |
get_call = function(dataname) {
|
|
| 185 | 7x |
if (isFALSE(private$is_any_filtered())) {
|
| 186 | 1x |
return(NULL) |
| 187 |
} |
|
| 188 | 4x |
if (missing(dataname)) dataname <- private$get_dataname() |
| 189 | 6x |
varname <- private$get_varname_prefixed(dataname) |
| 190 | 6x |
choices <- private$get_selected() |
| 191 | 6x |
tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone")) |
| 192 | 6x |
class <- class(choices)[1L] |
| 193 | 6x |
date_fun <- as.name( |
| 194 | 6x |
switch(class, |
| 195 | 6x |
"POSIXct" = "as.POSIXct", |
| 196 | 6x |
"POSIXlt" = "as.POSIXlt" |
| 197 |
) |
|
| 198 |
) |
|
| 199 | 6x |
choices <- as.character(choices + c(0, 1)) |
| 200 | 6x |
filter_call <- |
| 201 | 6x |
call( |
| 202 |
"&", |
|
| 203 | 6x |
call( |
| 204 |
">=", |
|
| 205 | 6x |
varname, |
| 206 | 6x |
as.call(list(date_fun, choices[1L], tz = tzone)) |
| 207 |
), |
|
| 208 | 6x |
call( |
| 209 |
"<", |
|
| 210 | 6x |
varname, |
| 211 | 6x |
as.call(list(date_fun, choices[2L], tz = tzone)) |
| 212 |
) |
|
| 213 |
) |
|
| 214 | 6x |
private$add_keep_na_call(filter_call, varname) |
| 215 |
} |
|
| 216 |
), |
|
| 217 | ||
| 218 |
# private members ---- |
|
| 219 | ||
| 220 |
private = list( |
|
| 221 |
# private methods ---- |
|
| 222 |
set_choices = function(choices) {
|
|
| 223 | 23x |
if (is.null(choices)) {
|
| 224 | 20x |
choices <- as.POSIXct(trunc(range(private$x, na.rm = TRUE), units = "secs")) |
| 225 |
} else {
|
|
| 226 | 3x |
choices <- as.POSIXct(choices, units = "secs") |
| 227 | 3x |
choices_adjusted <- c( |
| 228 | 3x |
max(choices[1L], min(as.POSIXct(private$x), na.rm = TRUE)), |
| 229 | 3x |
min(choices[2L], max(as.POSIXct(private$x), na.rm = TRUE)) |
| 230 |
) |
|
| 231 | 3x |
if (any(choices != choices_adjusted)) {
|
| 232 | 1x |
warning(sprintf( |
| 233 | 1x |
"Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", |
| 234 | 1x |
private$get_varname(), private$get_dataname() |
| 235 |
)) |
|
| 236 | 1x |
choices <- choices_adjusted |
| 237 |
} |
|
| 238 | 3x |
if (choices[1L] >= choices[2L]) {
|
| 239 | 1x |
warning(sprintf( |
| 240 | 1x |
"Invalid choices: lower is higher / equal to upper, or not in range of variable values. |
| 241 | 1x |
Setting defaults. Varname: %s, dataname: %s.", |
| 242 | 1x |
private$get_varname(), private$get_dataname() |
| 243 |
)) |
|
| 244 | 1x |
choices <- range(private$x, na.rm = TRUE) |
| 245 |
} |
|
| 246 |
} |
|
| 247 | ||
| 248 | 23x |
private$set_is_choice_limited(private$x, choices) |
| 249 | 23x |
private$x <- private$x[ |
| 250 |
( |
|
| 251 | 23x |
as.POSIXct(trunc(private$x, units = "secs")) >= choices[1L] & |
| 252 | 23x |
as.POSIXct(trunc(private$x, units = "secs")) <= choices[2L] |
| 253 | 23x |
) | is.na(private$x) |
| 254 |
] |
|
| 255 | 23x |
private$teal_slice$choices <- choices |
| 256 | 23x |
invisible(NULL) |
| 257 |
}, |
|
| 258 | ||
| 259 |
# @description |
|
| 260 |
# Check whether the initial choices filter out some values of x and set the flag in case. |
|
| 261 |
set_is_choice_limited = function(xl, choices = NULL) {
|
|
| 262 | 23x |
private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE)) |
| 263 | 23x |
invisible(NULL) |
| 264 |
}, |
|
| 265 |
cast_and_validate = function(values) {
|
|
| 266 | 34x |
tryCatch( |
| 267 | 34x |
expr = {
|
| 268 | 34x |
values <- as.POSIXct(values, origin = "1970-01-01 00:00:00") |
| 269 | ! |
if (anyNA(values)) stop() |
| 270 | 31x |
values |
| 271 |
}, |
|
| 272 | 34x |
error = function(e) stop("Vector of set values must contain values coercible to POSIX.")
|
| 273 |
) |
|
| 274 |
}, |
|
| 275 |
check_length = function(values) {
|
|
| 276 | 1x |
if (length(values) != 2) stop("Vector of set values must have length two.")
|
| 277 | 30x |
if (values[1] > values[2]) {
|
| 278 | 1x |
warning( |
| 279 | 1x |
sprintf( |
| 280 | 1x |
"Start date '%s' is set after the end date '%s', the values will be replaced by a default datetime range.", |
| 281 | 1x |
values[1], values[2] |
| 282 |
) |
|
| 283 |
) |
|
| 284 | 1x |
values <- isolate(private$get_choices()) |
| 285 |
} |
|
| 286 | 30x |
values |
| 287 |
}, |
|
| 288 |
remove_out_of_bounds_values = function(values) {
|
|
| 289 | 30x |
choices <- private$get_choices() |
| 290 | 30x |
if (values[1] < choices[1L] || values[1] > choices[2L]) {
|
| 291 | 5x |
warning( |
| 292 | 5x |
sprintf( |
| 293 | 5x |
"Value: %s is outside of the range for the column '%s' in dataset '%s', setting minimum possible value.", |
| 294 | 5x |
values[1], private$get_varname(), toString(private$get_dataname()) |
| 295 |
) |
|
| 296 |
) |
|
| 297 | 5x |
values[1] <- choices[1L] |
| 298 |
} |
|
| 299 | ||
| 300 | 30x |
if (values[2] > choices[2L] | values[2] < choices[1L]) {
|
| 301 | 5x |
warning( |
| 302 | 5x |
sprintf( |
| 303 | 5x |
"Value: '%s' is outside of the range for the column '%s' in dataset '%s', setting maximum possible value.", |
| 304 | 5x |
values[2], private$get_varname(), toString(private$get_dataname()) |
| 305 |
) |
|
| 306 |
) |
|
| 307 | 5x |
values[2] <- choices[2L] |
| 308 |
} |
|
| 309 | ||
| 310 | 30x |
values |
| 311 |
}, |
|
| 312 | ||
| 313 |
# shiny modules ---- |
|
| 314 | ||
| 315 |
# @description |
|
| 316 |
# UI Module for `DatetimeFilterState`. |
|
| 317 |
# This UI element contains two date-time selections for `min` and `max` |
|
| 318 |
# of the range and a checkbox whether to keep the `NA` values. |
|
| 319 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 320 |
ui_inputs = function(id) {
|
|
| 321 | ! |
ns <- NS(id) |
| 322 | ||
| 323 | ! |
isolate({
|
| 324 | ! |
ui_input_1 <- shinyWidgets::airDatepickerInput( |
| 325 | ! |
inputId = ns("selection_start"),
|
| 326 | ! |
value = private$get_selected()[1], |
| 327 | ! |
startView = private$get_selected()[1], |
| 328 | ! |
timepicker = TRUE, |
| 329 | ! |
minDate = private$get_choices()[1L], |
| 330 | ! |
maxDate = private$get_choices()[2L], |
| 331 | ! |
update_on = "close", |
| 332 | ! |
addon = "none" |
| 333 |
) |
|
| 334 | ! |
ui_input_2 <- shinyWidgets::airDatepickerInput( |
| 335 | ! |
inputId = ns("selection_end"),
|
| 336 | ! |
value = private$get_selected()[2], |
| 337 | ! |
startView = private$get_selected()[2], |
| 338 | ! |
timepicker = TRUE, |
| 339 | ! |
minDate = private$get_choices()[1L], |
| 340 | ! |
maxDate = private$get_choices()[2L], |
| 341 | ! |
update_on = "close", |
| 342 | ! |
addon = "none" |
| 343 |
) |
|
| 344 | ! |
ui_reset_1 <- actionButton( |
| 345 | ! |
class = "teal-slice date-reset-button", |
| 346 | ! |
inputId = ns("start_date_reset"),
|
| 347 | ! |
label = NULL, |
| 348 | ! |
icon = icon("fas fa-undo")
|
| 349 |
) |
|
| 350 | ! |
ui_reset_2 <- actionButton( |
| 351 | ! |
class = "teal-slice date-reset-button", |
| 352 | ! |
inputId = ns("end_date_reset"),
|
| 353 | ! |
label = NULL, |
| 354 | ! |
icon = icon("fas fa-undo")
|
| 355 |
) |
|
| 356 | ! |
ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm")) |
| 357 | ! |
ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm")) |
| 358 | ||
| 359 | ! |
tags$div( |
| 360 | ! |
tags$div( |
| 361 | ! |
style = "display: flex;", |
| 362 | ! |
ui_reset_1, |
| 363 | ! |
tags$div( |
| 364 | ! |
class = "teal-slice filter_datelike_input", |
| 365 | ! |
style = "display: flex; width: 80%;", |
| 366 | ! |
tags$div(style = "width: 45%; text-align: center;", ui_input_1), |
| 367 | ! |
tags$span( |
| 368 | ! |
style = "width: 10%; height: 3rem !important;", |
| 369 | ! |
tags$span( |
| 370 | ! |
style = "height: 3rem; display: flex; justify-content: center; align-items: center;", |
| 371 | ! |
"to" |
| 372 |
), |
|
| 373 | ! |
title = "Times are displayed in the local timezone and are converted to UTC in the analysis" |
| 374 |
), |
|
| 375 | ! |
tags$div(style = "width: 45%; text-align: center;", ui_input_2) |
| 376 |
), |
|
| 377 | ! |
ui_reset_2 |
| 378 |
), |
|
| 379 | ! |
private$keep_na_ui(ns("keep_na"))
|
| 380 |
) |
|
| 381 |
}) |
|
| 382 |
}, |
|
| 383 | ||
| 384 |
# @description |
|
| 385 |
# Server module |
|
| 386 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 387 |
# @return `NULL`. |
|
| 388 |
server_inputs = function(id) {
|
|
| 389 | ! |
moduleServer( |
| 390 | ! |
id = id, |
| 391 | ! |
function(input, output, session) {
|
| 392 | ! |
logger::log_debug("DatetimeFilterState$server initializing, id: { private$get_id() }")
|
| 393 |
# this observer is needed in the situation when teal_slice$selected has been |
|
| 394 |
# changed directly by the api - then it's needed to rerender UI element |
|
| 395 |
# to show relevant values |
|
| 396 | ! |
private$session_bindings[[session$ns("selection_api")]] <- observeEvent(
|
| 397 | ! |
ignoreNULL = TRUE, # dates needs to be selected |
| 398 | ! |
ignoreInit = TRUE, # on init selected == default, so no need to trigger |
| 399 | ! |
eventExpr = private$get_selected(), |
| 400 | ! |
handlerExpr = {
|
| 401 | ! |
start_date <- input$selection_start |
| 402 | ! |
end_date <- input$selection_end |
| 403 | ! |
if (!all(private$get_selected() == c(start_date, end_date))) {
|
| 404 | ! |
logger::log_debug("DatetimeFilterState$server@1 state changed, id: { private$get_id() }")
|
| 405 | ! |
if (private$get_selected()[1] != start_date) {
|
| 406 | ! |
shinyWidgets::updateAirDateInput( |
| 407 | ! |
session = session, |
| 408 | ! |
inputId = "selection_start", |
| 409 | ! |
value = private$get_selected()[1] |
| 410 |
) |
|
| 411 |
} |
|
| 412 | ||
| 413 | ! |
if (private$get_selected()[2] != end_date) {
|
| 414 | ! |
shinyWidgets::updateAirDateInput( |
| 415 | ! |
session = session, |
| 416 | ! |
inputId = "selection_end", |
| 417 | ! |
value = private$get_selected()[2] |
| 418 |
) |
|
| 419 |
} |
|
| 420 |
} |
|
| 421 |
} |
|
| 422 |
) |
|
| 423 | ||
| 424 | ||
| 425 | ! |
private$session_bindings[[session$ns("selection_start")]] <- observeEvent(
|
| 426 | ! |
ignoreNULL = TRUE, # dates needs to be selected |
| 427 | ! |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 428 | ! |
eventExpr = input$selection_start, |
| 429 | ! |
handlerExpr = {
|
| 430 | ! |
logger::log_debug("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
|
| 431 | ! |
start_date <- input$selection_start |
| 432 | ! |
end_date <- private$get_selected()[[2]] |
| 433 | ! |
tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone")) |
| 434 | ! |
attr(start_date, "tzone") <- tzone |
| 435 | ||
| 436 | ! |
if (start_date > end_date) {
|
| 437 | ! |
showNotification( |
| 438 | ! |
"Start date must not be greater than the end date. Ignoring selection.", |
| 439 | ! |
type = "warning" |
| 440 |
) |
|
| 441 | ! |
shinyWidgets::updateAirDateInput( |
| 442 | ! |
session = session, |
| 443 | ! |
inputId = "selection_start", |
| 444 | ! |
value = private$get_selected()[1] # sets back to latest selected value |
| 445 |
) |
|
| 446 | ! |
return(NULL) |
| 447 |
} |
|
| 448 | ||
| 449 | ! |
private$set_selected(c(start_date, end_date)) |
| 450 |
} |
|
| 451 |
) |
|
| 452 | ||
| 453 | ! |
private$session_bindings[[session$ns("selection_end")]] <- observeEvent(
|
| 454 | ! |
ignoreNULL = TRUE, # dates needs to be selected |
| 455 | ! |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 456 | ! |
eventExpr = input$selection_end, |
| 457 | ! |
handlerExpr = {
|
| 458 | ! |
start_date <- private$get_selected()[1] |
| 459 | ! |
end_date <- input$selection_end |
| 460 | ! |
tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone")) |
| 461 | ! |
attr(end_date, "tzone") <- tzone |
| 462 | ||
| 463 | ! |
if (start_date > end_date) {
|
| 464 | ! |
showNotification( |
| 465 | ! |
"End date must not be lower than the start date. Ignoring selection.", |
| 466 | ! |
type = "warning" |
| 467 |
) |
|
| 468 | ! |
shinyWidgets::updateAirDateInput( |
| 469 | ! |
session = session, |
| 470 | ! |
inputId = "selection_end", |
| 471 | ! |
value = private$get_selected()[2] # sets back to latest selected value |
| 472 |
) |
|
| 473 | ! |
return(NULL) |
| 474 |
} |
|
| 475 | ||
| 476 | ! |
private$set_selected(c(start_date, end_date)) |
| 477 | ! |
logger::log_debug("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
|
| 478 |
} |
|
| 479 |
) |
|
| 480 | ||
| 481 | ! |
private$keep_na_srv("keep_na")
|
| 482 | ||
| 483 | ! |
private$session_bindings[[session$ns("reset1")]] <- observeEvent(
|
| 484 | ! |
ignoreInit = TRUE, # reset button shouldn't be trigger on init |
| 485 | ! |
ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL |
| 486 | ! |
input$start_date_reset, |
| 487 |
{
|
|
| 488 | ! |
shinyWidgets::updateAirDateInput( |
| 489 | ! |
session = session, |
| 490 | ! |
inputId = "selection_start", |
| 491 | ! |
value = private$get_choices()[1L] |
| 492 |
) |
|
| 493 | ! |
logger::log_debug("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
|
| 494 |
} |
|
| 495 |
) |
|
| 496 | ! |
private$session_bindings[[session$ns("reset2")]] <- observeEvent(
|
| 497 | ! |
ignoreInit = TRUE, # reset button shouldn't be trigger on init |
| 498 | ! |
ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL |
| 499 | ! |
input$end_date_reset, |
| 500 |
{
|
|
| 501 | ! |
shinyWidgets::updateAirDateInput( |
| 502 | ! |
session = session, |
| 503 | ! |
inputId = "selection_end", |
| 504 | ! |
value = private$get_choices()[2L] |
| 505 |
) |
|
| 506 | ! |
logger::log_debug("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
|
| 507 |
} |
|
| 508 |
) |
|
| 509 | ||
| 510 | ! |
NULL |
| 511 |
} |
|
| 512 |
) |
|
| 513 |
}, |
|
| 514 |
server_inputs_fixed = function(id) {
|
|
| 515 | ! |
moduleServer( |
| 516 | ! |
id = id, |
| 517 | ! |
function(input, output, session) {
|
| 518 | ! |
logger::log_debug("DatetimeFilterState$server initializing, id: { private$get_id() }")
|
| 519 | ||
| 520 | ! |
output$selection <- renderUI({
|
| 521 | ! |
vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3) |
| 522 | ! |
tags$div( |
| 523 | ! |
tags$div(icon("clock"), vals[1]),
|
| 524 | ! |
tags$div(span(" - "), icon("clock"), vals[2])
|
| 525 |
) |
|
| 526 |
}) |
|
| 527 | ||
| 528 | ! |
NULL |
| 529 |
} |
|
| 530 |
) |
|
| 531 |
}, |
|
| 532 | ||
| 533 |
# @description |
|
| 534 |
# UI module to display filter summary |
|
| 535 |
# renders text describing selected date range and |
|
| 536 |
# if NA are included also |
|
| 537 |
content_summary = function(id) {
|
|
| 538 | ! |
selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S") |
| 539 | ! |
min <- selected[1] |
| 540 | ! |
max <- selected[2] |
| 541 | ! |
tagList( |
| 542 | ! |
tags$span( |
| 543 | ! |
class = "teal-slice filter-card-summary-value", |
| 544 | ! |
HTML(min, "–", max) |
| 545 |
), |
|
| 546 | ! |
tags$span( |
| 547 | ! |
class = "teal-slice filter-card-summary-controls", |
| 548 | ! |
if (private$na_count > 0) {
|
| 549 | ! |
tags$span( |
| 550 | ! |
"NA", |
| 551 | ! |
if (isTRUE(private$get_keep_na())) {
|
| 552 | ! |
icon("check", class = "text-success")
|
| 553 |
} else {
|
|
| 554 | ! |
icon("xmark", class = "text-danger")
|
| 555 |
} |
|
| 556 |
) |
|
| 557 |
} |
|
| 558 |
) |
|
| 559 |
) |
|
| 560 |
} |
|
| 561 |
) |
|
| 562 |
) |
| 1 |
# This file contains helper functions used in unit tests. |
|
| 2 | ||
| 3 |
# compares specified fields between two `teal_slice` objects |
|
| 4 |
#' @noRd |
|
| 5 |
#' @keywords internal |
|
| 6 |
compare_slices <- function(ts1, ts2, fields) {
|
|
| 7 | 9x |
isolate( |
| 8 | 9x |
all(vapply(fields, function(x) identical(ts1[[x]], ts2[[x]]), logical(1L))) |
| 9 |
) |
|
| 10 |
} |
|
| 11 | ||
| 12 | ||
| 13 |
# compare two teal_slice |
|
| 14 |
#' @noRd |
|
| 15 |
#' @keywords internal |
|
| 16 |
expect_identical_slice <- function(x, y) {
|
|
| 17 | 34x |
isolate({
|
| 18 | 34x |
testthat::expect_true( |
| 19 | 34x |
setequal( |
| 20 | 34x |
reactiveValuesToList(x), |
| 21 | 34x |
reactiveValuesToList(y) |
| 22 |
) |
|
| 23 |
) |
|
| 24 |
}) |
|
| 25 |
} |
|
| 26 | ||
| 27 |
# compare two teal_slices |
|
| 28 |
#' @noRd |
|
| 29 |
#' @keywords internal |
|
| 30 |
expect_identical_slices <- function(x, y) {
|
|
| 31 | 12x |
isolate({
|
| 32 | 12x |
mapply( |
| 33 | 12x |
function(x, y) {
|
| 34 | 27x |
expect_identical_slice(x, y) |
| 35 |
}, |
|
| 36 | 12x |
x = x, |
| 37 | 12x |
y = y |
| 38 |
) |
|
| 39 | 12x |
testthat::expect_identical(attributes(x), attributes(y)) |
| 40 |
}) |
|
| 41 |
} |
| 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. |
|
| 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 | 127x |
checkmate::assert_data_frame(dataset) |
| 72 | 125x |
super$initialize(dataset, dataname, keys, label) |
| 73 | ||
| 74 |
# overwrite filtered_data if there is relationship with parent dataset |
|
| 75 | 123x |
if (!is.null(parent)) {
|
| 76 | 11x |
checkmate::assert_character(parent_name, len = 1) |
| 77 | 11x |
checkmate::assert_character(join_keys, min.len = 1) |
| 78 | ||
| 79 | 11x |
private$parent_name <- parent_name |
| 80 | 11x |
private$join_keys <- join_keys |
| 81 | ||
| 82 | 11x |
private$data_filtered_fun <- function(sid = "") {
|
| 83 | 9x |
checkmate::assert_character(sid) |
| 84 | 9x |
if (length(sid)) {
|
| 85 | 9x |
logger::log_debug("filtering data dataname: { dataname }, sid: { sid }")
|
| 86 |
} else {
|
|
| 87 | ! |
logger::log_debug("filtering data dataname: { dataname }")
|
| 88 |
} |
|
| 89 | 9x |
env <- new.env(parent = parent.env(globalenv())) |
| 90 | 9x |
env[[dataname]] <- private$dataset |
| 91 | 9x |
env[[parent_name]] <- parent() |
| 92 | 9x |
filter_call <- self$get_call(sid) |
| 93 | 9x |
eval_expr_with_msg(filter_call, env) |
| 94 | 9x |
get(x = dataname, envir = env) |
| 95 |
} |
|
| 96 |
} |
|
| 97 | ||
| 98 | 123x |
private$add_filter_states( |
| 99 | 123x |
filter_states = init_filter_states( |
| 100 | 123x |
data = dataset, |
| 101 | 123x |
data_reactive = private$data_filtered_fun, |
| 102 | 123x |
dataname = dataname, |
| 103 | 123x |
keys = self$get_keys() |
| 104 |
), |
|
| 105 | 123x |
id = "filter" |
| 106 |
) |
|
| 107 | ||
| 108 |
# todo: Should we make these defaults? It could be handled by the app developer |
|
| 109 | 123x |
if (!is.null(parent)) {
|
| 110 | 11x |
logger::log_debug("Excluding { parent_name } columns from possible teal_slices for dataname: { dataname }")
|
| 111 | 11x |
fs <- teal_slices( |
| 112 | 11x |
exclude_varnames = structure( |
| 113 | 11x |
list(intersect(colnames(dataset), colnames(isolate(parent())))), |
| 114 | 11x |
names = private$dataname |
| 115 |
) |
|
| 116 |
) |
|
| 117 | 11x |
self$set_filter_state(fs) |
| 118 |
} |
|
| 119 | ||
| 120 | 123x |
invisible(self) |
| 121 |
}, |
|
| 122 | ||
| 123 |
#' @description |
|
| 124 |
#' Gets the subset expression. |
|
| 125 |
#' |
|
| 126 |
#' This function returns subset expressions equivalent to selected items |
|
| 127 |
#' within each of `filter_states`. Configuration of the expressions is constant and |
|
| 128 |
#' depends on `filter_states` type and order which are set during initialization. |
|
| 129 |
#' This class contains single `FilterStates` which contains single `state_list` |
|
| 130 |
#' and all `FilterState` objects apply to one argument (`...`) in a `dplyr::filter` call. |
|
| 131 |
#' |
|
| 132 |
#' @param sid (`character`) |
|
| 133 |
#' when specified, the method returns code containing conditions calls of |
|
| 134 |
#' `FilterState` objects with `sid` different to that of this `sid` argument. |
|
| 135 |
#' |
|
| 136 |
#' @return Either a `list` of length 1 containing a filter `call`, or `NULL`. |
|
| 137 |
get_call = function(sid = "") {
|
|
| 138 | 49x |
filter_call <- super$get_call(sid) |
| 139 | 49x |
dataname <- private$dataname |
| 140 | 49x |
parent_dataname <- private$parent_name |
| 141 | ||
| 142 | 49x |
if (!identical(parent_dataname, character(0))) {
|
| 143 | 10x |
join_keys <- private$join_keys |
| 144 | 10x |
parent_keys <- unname(join_keys) |
| 145 | 10x |
dataset_keys <- names(join_keys) |
| 146 | ||
| 147 | 10x |
y_arg <- if (length(parent_keys) == 0L) {
|
| 148 | ! |
parent_dataname |
| 149 |
} else {
|
|
| 150 | 10x |
sprintf( |
| 151 | 10x |
"%s[, c(%s), drop = FALSE]", |
| 152 | 10x |
parent_dataname, |
| 153 | 10x |
toString(dQuote(parent_keys, q = FALSE)) |
| 154 |
) |
|
| 155 |
} |
|
| 156 | ||
| 157 | 10x |
more_args <- if (length(parent_keys) == 0 || length(dataset_keys) == 0) {
|
| 158 | ! |
list() |
| 159 | 10x |
} else if (identical(parent_keys, dataset_keys)) {
|
| 160 | 7x |
list(by = parent_keys) |
| 161 |
} else {
|
|
| 162 | 3x |
list(by = stats::setNames(parent_keys, dataset_keys)) |
| 163 |
} |
|
| 164 | ||
| 165 | 10x |
merge_call <- call( |
| 166 |
"<-", |
|
| 167 | 10x |
as.name(dataname), |
| 168 | 10x |
as.call( |
| 169 | 10x |
c( |
| 170 | 10x |
str2lang("dplyr::inner_join"),
|
| 171 | 10x |
x = as.name(dataname), |
| 172 | 10x |
y = str2lang(y_arg), |
| 173 | 10x |
more_args |
| 174 |
) |
|
| 175 |
) |
|
| 176 |
) |
|
| 177 | ||
| 178 | 10x |
filter_call <- c(filter_call, merge_call) |
| 179 |
} |
|
| 180 | 49x |
filter_call |
| 181 |
}, |
|
| 182 | ||
| 183 |
#' @description |
|
| 184 |
#' Set filter state. |
|
| 185 |
#' |
|
| 186 |
#' @param state (`teal_slices`) |
|
| 187 |
#' @return `NULL`, invisibly. |
|
| 188 |
#' |
|
| 189 |
set_filter_state = function(state) {
|
|
| 190 | 108x |
isolate({
|
| 191 | 108x |
logger::log_debug("FilteredDatasetDataframe$set_filter_state initializing, dataname: { private$dataname }")
|
| 192 | 108x |
checkmate::assert_class(state, "teal_slices") |
| 193 | 107x |
state_datanames <- unique(vapply(state, `[[`, character(1L), "dataname")) |
| 194 | 107x |
checkmate::assert_subset(state_datanames, private$dataname) |
| 195 | 107x |
super$set_filter_state(state = state) |
| 196 | 107x |
private$get_filter_states()[[1L]]$set_filter_state(state = state) |
| 197 | 107x |
invisible(NULL) |
| 198 |
}) |
|
| 199 |
}, |
|
| 200 | ||
| 201 |
#' @description |
|
| 202 |
#' Remove one or more `FilterState` form a `FilteredDataset`. |
|
| 203 |
#' |
|
| 204 |
#' @param state (`teal_slices`) |
|
| 205 |
#' specifying `FilterState` objects to remove; |
|
| 206 |
#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored |
|
| 207 |
#' |
|
| 208 |
#' @return `NULL`, invisibly. |
|
| 209 |
#' |
|
| 210 |
remove_filter_state = function(state) {
|
|
| 211 | 11x |
checkmate::assert_class(state, "teal_slices") |
| 212 | ||
| 213 | 11x |
isolate({
|
| 214 | 11x |
logger::log_debug( |
| 215 | 11x |
"FilteredDatasetDataframe$remove_filter_state removing filter(s), dataname: { private$dataname }"
|
| 216 |
) |
|
| 217 | ||
| 218 | 11x |
varnames <- unique(unlist(lapply(state, "[[", "varname"))) |
| 219 | 11x |
private$get_filter_states()[[1]]$remove_filter_state(state) |
| 220 |
}) |
|
| 221 | ||
| 222 | 11x |
invisible(NULL) |
| 223 |
}, |
|
| 224 | ||
| 225 |
#' @description |
|
| 226 |
#' UI module to add filter variable for this dataset. |
|
| 227 |
#' |
|
| 228 |
#' @param id (`character(1)`) |
|
| 229 |
#' `shiny` module instance id. |
|
| 230 |
#' |
|
| 231 |
#' @return `shiny.tag` |
|
| 232 |
ui_add = function(id) {
|
|
| 233 | 25x |
ns <- NS(id) |
| 234 | 25x |
tagList( |
| 235 | 25x |
tags$div( |
| 236 | 25x |
tags$label("Add", tags$code(self$get_dataname()), "filter")
|
| 237 |
), |
|
| 238 | 25x |
private$get_filter_states()[["filter"]]$ui_add(id = ns("filter"))
|
| 239 |
) |
|
| 240 |
}, |
|
| 241 | ||
| 242 |
#' @description |
|
| 243 |
#' Creates row for filter overview in the form of \cr |
|
| 244 |
#' `dataname -- observations (remaining/total)` - data.frame |
|
| 245 |
#' @return A `data.frame`. |
|
| 246 |
get_filter_overview = function() {
|
|
| 247 | 17x |
logger::log_debug("FilteredDataset$srv_filter_overview initializing for dataname: { private$dataname }")
|
| 248 |
# Gets filter overview subjects number and returns a list |
|
| 249 |
# of the number of subjects of filtered/non-filtered datasets |
|
| 250 | 17x |
subject_keys <- if (length(private$parent_name) > 0) {
|
| 251 | 2x |
names(private$join_keys) |
| 252 |
} else {
|
|
| 253 | 15x |
self$get_keys() |
| 254 |
} |
|
| 255 | 17x |
dataset <- self$get_dataset() |
| 256 | 17x |
data_filtered <- self$get_dataset(TRUE) |
| 257 | 17x |
if (length(subject_keys) == 0) {
|
| 258 | 13x |
data.frame( |
| 259 | 13x |
dataname = private$dataname, |
| 260 | 13x |
obs = nrow(dataset), |
| 261 | 13x |
obs_filtered = nrow(data_filtered()) |
| 262 |
) |
|
| 263 |
} else {
|
|
| 264 | 4x |
data.frame( |
| 265 | 4x |
dataname = private$dataname, |
| 266 | 4x |
obs = nrow(dataset), |
| 267 | 4x |
obs_filtered = nrow(data_filtered()), |
| 268 | 4x |
subjects = nrow(unique(dataset[subject_keys])), |
| 269 | 4x |
subjects_filtered = nrow(unique(data_filtered()[subject_keys])) |
| 270 |
) |
|
| 271 |
} |
|
| 272 |
} |
|
| 273 |
), |
|
| 274 | ||
| 275 |
# private fields ---- |
|
| 276 |
private = list( |
|
| 277 |
parent_name = character(0), |
|
| 278 |
join_keys = character(0) |
|
| 279 |
) |
|
| 280 |
) |
| 1 |
#' Managing `FilteredData` states |
|
| 2 |
#' |
|
| 3 |
#' @description |
|
| 4 |
#' |
|
| 5 |
#' Set, get and remove filter states of `FilteredData` object. |
|
| 6 |
#' |
|
| 7 |
#' @name filter_state_api |
|
| 8 |
#' |
|
| 9 |
#' @param datasets (`FilteredData`) |
|
| 10 |
#' object to store filter state and filtered datasets, shared across modules |
|
| 11 |
#' |
|
| 12 |
#' see [`FilteredData`] for details |
|
| 13 |
#' |
|
| 14 |
#' @param filter (`teal_slices`) |
|
| 15 |
#' specify filters in place on app start-up |
|
| 16 |
#' |
|
| 17 |
#' @param force (`logical(1)`) |
|
| 18 |
#' flag specifying whether to include anchored filter states. |
|
| 19 |
#' |
|
| 20 |
#' @return |
|
| 21 |
#' - `set_*`, `remove_*` and `clear_filter_state` return `NULL` invisibly |
|
| 22 |
#' - `get_filter_state` returns a named `teal_slices` object |
|
| 23 |
#' containing a `teal_slice` for every existing `FilterState` |
|
| 24 |
#' |
|
| 25 |
#' @seealso [`teal_slice`] |
|
| 26 |
#' |
|
| 27 |
#' @examples |
|
| 28 |
#' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars)) |
|
| 29 |
#' fs <- teal_slices( |
|
| 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)), |
|
| 32 |
#' teal_slice(dataname = "mtcars", varname = "gear", selected = c(4, 5)), |
|
| 33 |
#' teal_slice(dataname = "mtcars", varname = "carb", selected = c(4, 10)) |
|
| 34 |
#' ) |
|
| 35 |
#' |
|
| 36 |
#' # set initial filter state |
|
| 37 |
#' set_filter_state(datasets, filter = fs) |
|
| 38 |
#' |
|
| 39 |
#' # get filter state |
|
| 40 |
#' get_filter_state(datasets) |
|
| 41 |
#' |
|
| 42 |
#' # modify filter state |
|
| 43 |
#' set_filter_state( |
|
| 44 |
#' datasets, |
|
| 45 |
#' teal_slices( |
|
| 46 |
#' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE) |
|
| 47 |
#' ) |
|
| 48 |
#' ) |
|
| 49 |
#' |
|
| 50 |
#' # remove specific filters |
|
| 51 |
#' remove_filter_state( |
|
| 52 |
#' datasets, |
|
| 53 |
#' teal_slices( |
|
| 54 |
#' teal_slice(dataname = "iris", varname = "Species"), |
|
| 55 |
#' teal_slice(dataname = "mtcars", varname = "gear"), |
|
| 56 |
#' teal_slice(dataname = "mtcars", varname = "carb") |
|
| 57 |
#' ) |
|
| 58 |
#' ) |
|
| 59 |
#' |
|
| 60 |
#' # remove all states |
|
| 61 |
#' clear_filter_states(datasets) |
|
| 62 |
#' |
|
| 63 |
#' @examples |
|
| 64 |
#' \donttest{
|
|
| 65 |
#' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
|
| 66 |
#' # Requires MultiAssayExperiment from Bioconductor |
|
| 67 |
#' data(miniACC, package = "MultiAssayExperiment") |
|
| 68 |
#' |
|
| 69 |
#' datasets <- init_filtered_data(list(mae = miniACC)) |
|
| 70 |
#' fs <- teal_slices( |
|
| 71 |
#' teal_slice( |
|
| 72 |
#' dataname = "mae", varname = "years_to_birth", selected = c(30, 50), |
|
| 73 |
#' keep_na = TRUE, keep_inf = FALSE |
|
| 74 |
#' ), |
|
| 75 |
#' teal_slice( |
|
| 76 |
#' dataname = "mae", varname = "vital_status", selected = "1", |
|
| 77 |
#' keep_na = FALSE |
|
| 78 |
#' ), |
|
| 79 |
#' teal_slice( |
|
| 80 |
#' dataname = "mae", varname = "gender", selected = "female", |
|
| 81 |
#' keep_na = TRUE |
|
| 82 |
#' ), |
|
| 83 |
#' teal_slice( |
|
| 84 |
#' dataname = "mae", varname = "ARRAY_TYPE", selected = "", |
|
| 85 |
#' keep_na = TRUE, experiment = "RPPAArray", arg = "subset" |
|
| 86 |
#' ) |
|
| 87 |
#' ) |
|
| 88 |
#' |
|
| 89 |
#' # set initial filter state |
|
| 90 |
#' set_filter_state(datasets, filter = fs) |
|
| 91 |
#' |
|
| 92 |
#' # get filter state |
|
| 93 |
#' get_filter_state(datasets) |
|
| 94 |
#' |
|
| 95 |
#' # modify filter state |
|
| 96 |
#' set_filter_state( |
|
| 97 |
#' datasets, |
|
| 98 |
#' teal_slices( |
|
| 99 |
#' teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(40, 60)) |
|
| 100 |
#' ) |
|
| 101 |
#' ) |
|
| 102 |
#' |
|
| 103 |
#' # remove specific filters |
|
| 104 |
#' remove_filter_state( |
|
| 105 |
#' datasets, |
|
| 106 |
#' teal_slices( |
|
| 107 |
#' teal_slice(dataname = "mae", varname = "years_to_birth"), |
|
| 108 |
#' teal_slice(dataname = "mae", varname = "vital_status") |
|
| 109 |
#' ) |
|
| 110 |
#' ) |
|
| 111 |
#' |
|
| 112 |
#' # remove all states |
|
| 113 |
#' clear_filter_states(datasets) |
|
| 114 |
#' } |
|
| 115 |
#' } |
|
| 116 |
NULL |
|
| 117 | ||
| 118 |
#' @rdname filter_state_api |
|
| 119 |
#' @export |
|
| 120 |
set_filter_state <- function(datasets, filter) {
|
|
| 121 | 21x |
checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
|
| 122 | 21x |
checkmate::assert_class(filter, "teal_slices") |
| 123 | 21x |
datasets$set_filter_state(filter) |
| 124 | 21x |
invisible(NULL) |
| 125 |
} |
|
| 126 | ||
| 127 |
#' @rdname filter_state_api |
|
| 128 |
#' @export |
|
| 129 |
get_filter_state <- function(datasets) {
|
|
| 130 | 15x |
checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
|
| 131 | 15x |
if (isRunning()) {
|
| 132 | ! |
datasets$get_filter_state() |
| 133 |
} else {
|
|
| 134 | 15x |
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 | ||
| 156 |
#' Gets filter expression for multiple `datanames` taking into account its order. |
|
| 157 |
#' |
|
| 158 |
#' @description |
|
| 159 |
#' |
|
| 160 |
#' To be used in `Show R Code` button. |
|
| 161 |
#' |
|
| 162 |
#' @param datasets (`FilteredData`) |
|
| 163 |
#' @param datanames (`character`) vector of dataset names |
|
| 164 |
#' |
|
| 165 |
#' @return A character string containing all subset expressions. |
|
| 166 |
#' |
|
| 167 |
#' @export |
|
| 168 |
#' |
|
| 169 |
get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
|
|
| 170 | 2x |
checkmate::check_class(datasets, "FilteredData") |
| 171 | 2x |
checkmate::assert_character(datanames, any.missing = FALSE) |
| 172 | 2x |
checkmate::assert_subset(datanames, datasets$datanames()) |
| 173 | 2x |
paste( |
| 174 | 2x |
unlist(lapply( |
| 175 | 2x |
datanames, |
| 176 | 2x |
function(dataname) {
|
| 177 | 4x |
datasets$get_call(dataname) |
| 178 |
} |
|
| 179 |
)), |
|
| 180 | 2x |
collapse = "\n" |
| 181 |
) |
|
| 182 |
} |
| 1 |
# DateFilterState ------ |
|
| 2 | ||
| 3 |
#' @name DateFilterState |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterState` object for `Date` data |
|
| 7 |
#' |
|
| 8 |
#' @description Manages choosing a range of `Date`s. |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' # use non-exported function from teal.slice |
|
| 12 |
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 13 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 14 |
#' DateFilterState <- getFromNamespace("DateFilterState", "teal.slice")
|
|
| 15 |
#' |
|
| 16 |
#' library(shiny) |
|
| 17 |
#' |
|
| 18 |
#' filter_state <- DateFilterState$new( |
|
| 19 |
#' x = c(Sys.Date() + seq(1:10), NA), |
|
| 20 |
#' slice = teal_slice(varname = "x", dataname = "data"), |
|
| 21 |
#' extract_type = character(0) |
|
| 22 |
#' ) |
|
| 23 |
#' isolate(filter_state$get_call()) |
|
| 24 |
#' filter_state$set_state( |
|
| 25 |
#' teal_slice( |
|
| 26 |
#' dataname = "data", |
|
| 27 |
#' varname = "x", |
|
| 28 |
#' selected = c(Sys.Date() + 3L, Sys.Date() + 8L), |
|
| 29 |
#' keep_na = TRUE |
|
| 30 |
#' ) |
|
| 31 |
#' ) |
|
| 32 |
#' isolate(filter_state$get_call()) |
|
| 33 |
#' |
|
| 34 |
#' # working filter in an app |
|
| 35 |
#' library(shinyjs) |
|
| 36 |
#' |
|
| 37 |
#' dates <- c(Sys.Date() - 100, Sys.Date()) |
|
| 38 |
#' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA) |
|
| 39 |
#' fs <- DateFilterState$new( |
|
| 40 |
#' x = data_date, |
|
| 41 |
#' slice = teal_slice( |
|
| 42 |
#' dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE |
|
| 43 |
#' ) |
|
| 44 |
#' ) |
|
| 45 |
#' |
|
| 46 |
#' ui <- bslib::page_fluid( |
|
| 47 |
#' useShinyjs(), |
|
| 48 |
#' include_css_files(pattern = "filter-panel"), |
|
| 49 |
#' include_js_files(pattern = "count-bar-labels"), |
|
| 50 |
#' bslib::layout_column_wrap( |
|
| 51 |
#' width = 1 / 3, |
|
| 52 |
#' tags$div( |
|
| 53 |
#' tags$h4("DateFilterState"),
|
|
| 54 |
#' fs$ui("fs")
|
|
| 55 |
#' ), |
|
| 56 |
#' tags$div( |
|
| 57 |
#' id = "outputs", # div id is needed for toggling the element |
|
| 58 |
#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|
| 59 |
#' textOutput("condition_date"), tags$br(),
|
|
| 60 |
#' tags$h4("Unformatted state"), # display raw filter state
|
|
| 61 |
#' textOutput("unformatted_date"), tags$br(),
|
|
| 62 |
#' tags$h4("Formatted state"), # display human readable filter state
|
|
| 63 |
#' textOutput("formatted_date"), tags$br()
|
|
| 64 |
#' ), |
|
| 65 |
#' tags$div( |
|
| 66 |
#' tags$h4("Programmatic filter control"),
|
|
| 67 |
#' actionButton("button1_date", "set drop NA", width = "100%"), tags$br(),
|
|
| 68 |
#' actionButton("button2_date", "set keep NA", width = "100%"), tags$br(),
|
|
| 69 |
#' actionButton("button3_date", "set a range", width = "100%"), tags$br(),
|
|
| 70 |
#' actionButton("button4_date", "set full range", width = "100%"), tags$br(),
|
|
| 71 |
#' actionButton("button0_date", "set initial state", width = "100%"), tags$br()
|
|
| 72 |
#' ) |
|
| 73 |
#' ) |
|
| 74 |
#' ) |
|
| 75 |
#' |
|
| 76 |
#' server <- function(input, output, session) {
|
|
| 77 |
#' fs$server("fs")
|
|
| 78 |
#' output$condition_date <- renderPrint(fs$get_call()) |
|
| 79 |
#' output$formatted_date <- renderText(fs$format()) |
|
| 80 |
#' output$unformatted_date <- renderPrint(fs$get_state()) |
|
| 81 |
#' # modify filter state programmatically |
|
| 82 |
#' observeEvent( |
|
| 83 |
#' input$button1_date, |
|
| 84 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE)) |
|
| 85 |
#' ) |
|
| 86 |
#' observeEvent( |
|
| 87 |
#' input$button2_date, |
|
| 88 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE)) |
|
| 89 |
#' ) |
|
| 90 |
#' observeEvent( |
|
| 91 |
#' input$button3_date, |
|
| 92 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)])) |
|
| 93 |
#' ) |
|
| 94 |
#' observeEvent( |
|
| 95 |
#' input$button4_date, |
|
| 96 |
#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates)) |
|
| 97 |
#' ) |
|
| 98 |
#' observeEvent( |
|
| 99 |
#' input$button0_date, |
|
| 100 |
#' fs$set_state( |
|
| 101 |
#' teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE)
|
|
| 102 |
#' ) |
|
| 103 |
#' ) |
|
| 104 |
#' } |
|
| 105 |
#' |
|
| 106 |
#' if (interactive()) {
|
|
| 107 |
#' shinyApp(ui, server) |
|
| 108 |
#' } |
|
| 109 |
#' |
|
| 110 |
#' @keywords internal |
|
| 111 |
#' |
|
| 112 |
DateFilterState <- R6::R6Class( # nolint |
|
| 113 |
"DateFilterState", |
|
| 114 |
inherit = FilterState, |
|
| 115 | ||
| 116 |
# public methods ---- |
|
| 117 | ||
| 118 |
public = list( |
|
| 119 | ||
| 120 |
#' @description |
|
| 121 |
#' Initialize a `FilterState` object. |
|
| 122 |
#' |
|
| 123 |
#' @param x (`Date`) |
|
| 124 |
#' variable to be filtered. |
|
| 125 |
#' @param x_reactive (`reactive`) |
|
| 126 |
#' returning vector of the same type as `x`. Is used to update |
|
| 127 |
#' counts following the change in values of the filtered dataset. |
|
| 128 |
#' If it is set to `reactive(NULL)` then counts based on filtered |
|
| 129 |
#' dataset are not shown. |
|
| 130 |
#' @param slice (`teal_slice`) |
|
| 131 |
#' specification of this filter state. |
|
| 132 |
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`. |
|
| 133 |
#' `get_state` returns `teal_slice` object which can be reused in other places. |
|
| 134 |
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e. |
|
| 135 |
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`. |
|
| 136 |
#' @param extract_type (`character`) |
|
| 137 |
#' specifying whether condition calls should be prefixed by `dataname`. Possible values: |
|
| 138 |
#' - `character(0)` (default) `varname` in the condition call will not be prefixed |
|
| 139 |
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>` |
|
| 140 |
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]` |
|
| 141 |
#' |
|
| 142 |
#' @return Object of class `DateFilterState`, invisibly. |
|
| 143 |
#' |
|
| 144 |
initialize = function(x, |
|
| 145 |
x_reactive = reactive(NULL), |
|
| 146 |
slice, |
|
| 147 |
extract_type = character(0)) {
|
|
| 148 | 26x |
isolate({
|
| 149 | 26x |
checkmate::assert_date(x) |
| 150 | 25x |
checkmate::assert_class(x_reactive, "reactive") |
| 151 | ||
| 152 | 25x |
super$initialize( |
| 153 | 25x |
x = x, |
| 154 | 25x |
x_reactive = x_reactive, |
| 155 | 25x |
slice = slice, |
| 156 | 25x |
extract_type = extract_type |
| 157 |
) |
|
| 158 | 25x |
checkmate::assert_date(slice$choices, null.ok = TRUE) |
| 159 | 24x |
private$set_choices(slice$choices) |
| 160 | 15x |
if (is.null(slice$selected)) slice$selected <- slice$choices |
| 161 | 24x |
private$set_selected(slice$selected) |
| 162 |
}) |
|
| 163 | ||
| 164 | 23x |
invisible(self) |
| 165 |
}, |
|
| 166 | ||
| 167 |
#' @description |
|
| 168 |
#' Returns reproducible condition call for current selection. |
|
| 169 |
#' For this class returned call looks like |
|
| 170 |
#' `<varname> >= <min value> & <varname> <= <max value>` with optional `is.na(<varname>)`. |
|
| 171 |
#' @param dataname (`character(1)`) containing possibly prefixed name of data set |
|
| 172 |
#' @return `call` or `NULL` |
|
| 173 |
#' |
|
| 174 |
get_call = function(dataname) {
|
|
| 175 | 7x |
if (isFALSE(private$is_any_filtered())) {
|
| 176 | 1x |
return(NULL) |
| 177 |
} |
|
| 178 | 6x |
choices <- as.character(private$get_selected()) |
| 179 | 6x |
varname <- private$get_varname_prefixed(dataname) |
| 180 | 6x |
filter_call <- |
| 181 | 6x |
call( |
| 182 |
"&", |
|
| 183 | 6x |
call(">=", varname, call("as.Date", choices[1L])),
|
| 184 | 6x |
call("<=", varname, call("as.Date", choices[2L]))
|
| 185 |
) |
|
| 186 | 6x |
private$add_keep_na_call(filter_call, varname) |
| 187 |
} |
|
| 188 |
), |
|
| 189 | ||
| 190 |
# private methods ---- |
|
| 191 | ||
| 192 |
private = list( |
|
| 193 |
set_choices = function(choices) {
|
|
| 194 | 24x |
if (is.null(choices)) {
|
| 195 | 21x |
choices <- range(private$x, na.rm = TRUE) |
| 196 |
} else {
|
|
| 197 | 3x |
choices_adjusted <- c( |
| 198 | 3x |
max(choices[1L], min(private$x, na.rm = TRUE)), |
| 199 | 3x |
min(choices[2L], max(private$x, na.rm = TRUE)) |
| 200 |
) |
|
| 201 | 3x |
if (any(choices != choices_adjusted)) {
|
| 202 | 1x |
warning(sprintf( |
| 203 | 1x |
"Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.", |
| 204 | 1x |
private$get_varname(), private$get_dataname() |
| 205 |
)) |
|
| 206 | 1x |
choices <- choices_adjusted |
| 207 |
} |
|
| 208 | 3x |
if (choices[1L] >= choices[2L]) {
|
| 209 | 1x |
warning(sprintf( |
| 210 | 1x |
"Invalid choices: lower is higher / equal to upper, or not in range of variable values. |
| 211 | 1x |
Setting defaults. Varname: %s, dataname: %s.", |
| 212 | 1x |
private$get_varname(), private$get_dataname() |
| 213 |
)) |
|
| 214 | 1x |
choices <- range(private$x, na.rm = TRUE) |
| 215 |
} |
|
| 216 |
} |
|
| 217 | 24x |
private$set_is_choice_limited(private$x, choices) |
| 218 | 24x |
private$x <- private$x[(private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x)] |
| 219 | 24x |
private$teal_slice$choices <- choices |
| 220 | 24x |
invisible(NULL) |
| 221 |
}, |
|
| 222 | ||
| 223 |
# @description |
|
| 224 |
# Check whether the initial choices filter out some values of x and set the flag in case. |
|
| 225 |
set_is_choice_limited = function(xl, choices) {
|
|
| 226 | 24x |
private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE)) |
| 227 | 24x |
invisible(NULL) |
| 228 |
}, |
|
| 229 |
cast_and_validate = function(values) {
|
|
| 230 | 36x |
tryCatch( |
| 231 | 36x |
expr = {
|
| 232 | 36x |
values <- as.Date(values, origin = "1970-01-01") |
| 233 | ! |
if (anyNA(values)) stop() |
| 234 | 33x |
values |
| 235 |
}, |
|
| 236 | 36x |
error = function(e) stop("Vector of set values must contain values coercible to Date.")
|
| 237 |
) |
|
| 238 |
}, |
|
| 239 |
check_length = function(values) {
|
|
| 240 | 1x |
if (length(values) != 2) stop("Vector of set values must have length two.")
|
| 241 | 32x |
if (values[1] > values[2]) {
|
| 242 | 1x |
warning( |
| 243 | 1x |
sprintf( |
| 244 | 1x |
"Start date %s is set after the end date %s, the values will be replaced with a default date range.", |
| 245 | 1x |
values[1], values[2] |
| 246 |
) |
|
| 247 |
) |
|
| 248 | 1x |
values <- isolate(private$get_choices()) |
| 249 |
} |
|
| 250 | 32x |
values |
| 251 |
}, |
|
| 252 |
remove_out_of_bounds_values = function(values) {
|
|
| 253 | 32x |
choices <- private$get_choices() |
| 254 | 32x |
if (values[1] < choices[1L] | values[1] > choices[2L]) {
|
| 255 | 5x |
warning( |
| 256 | 5x |
sprintf( |
| 257 | 5x |
"Value: %s is outside of the possible range for column %s of dataset %s, setting minimum possible value.", |
| 258 | 5x |
values[1], private$get_varname(), private$get_dataname() |
| 259 |
) |
|
| 260 |
) |
|
| 261 | 5x |
values[1] <- choices[1L] |
| 262 |
} |
|
| 263 | ||
| 264 | 32x |
if (values[2] > choices[2L] | values[2] < choices[1L]) {
|
| 265 | 5x |
warning( |
| 266 | 5x |
sprintf( |
| 267 | 5x |
"Value: %s is outside of the possible range for column %s of dataset %s, setting maximum possible value.", |
| 268 | 5x |
values[2], private$get_varname(), private$get_dataname() |
| 269 |
) |
|
| 270 |
) |
|
| 271 | 5x |
values[2] <- choices[2L] |
| 272 |
} |
|
| 273 | ||
| 274 | 32x |
values |
| 275 |
}, |
|
| 276 | ||
| 277 |
# shiny modules ---- |
|
| 278 | ||
| 279 |
# @description |
|
| 280 |
# UI Module for `DateFilterState`. |
|
| 281 |
# This UI element contains two date selections for `min` and `max` |
|
| 282 |
# of the range and a checkbox whether to keep the `NA` values. |
|
| 283 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 284 |
ui_inputs = function(id) {
|
|
| 285 | 2x |
ns <- NS(id) |
| 286 | 2x |
isolate({
|
| 287 | 2x |
tags$div( |
| 288 | 2x |
tags$div( |
| 289 | 2x |
style = "display: flex;", |
| 290 | 2x |
actionButton( |
| 291 | 2x |
class = "teal-slice date-reset-button", |
| 292 | 2x |
inputId = ns("start_date_reset"),
|
| 293 | 2x |
label = NULL, |
| 294 | 2x |
icon = icon("fas fa-undo")
|
| 295 |
), |
|
| 296 | 2x |
tags$div( |
| 297 | 2x |
class = "teal-slice filter_datelike_input", |
| 298 | 2x |
style = "width: 80%;", |
| 299 | 2x |
dateRangeInput( |
| 300 | 2x |
inputId = ns("selection"),
|
| 301 | 2x |
label = NULL, |
| 302 | 2x |
start = private$get_selected()[1], |
| 303 | 2x |
end = private$get_selected()[2], |
| 304 | 2x |
min = private$get_choices()[1L], |
| 305 | 2x |
max = private$get_choices()[2L], |
| 306 | 2x |
width = "100%" |
| 307 |
) |
|
| 308 |
), |
|
| 309 | 2x |
actionButton( |
| 310 | 2x |
class = "teal-slice date-reset-button", |
| 311 | 2x |
inputId = ns("end_date_reset"),
|
| 312 | 2x |
label = NULL, |
| 313 | 2x |
icon = icon("fas fa-undo")
|
| 314 |
) |
|
| 315 |
), |
|
| 316 | 2x |
private$keep_na_ui(ns("keep_na"))
|
| 317 |
) |
|
| 318 |
}) |
|
| 319 |
}, |
|
| 320 | ||
| 321 |
# @description |
|
| 322 |
# Server module |
|
| 323 |
# @param id (`character(1)`) `shiny` module instance id. |
|
| 324 |
# @return `NULL`. |
|
| 325 |
server_inputs = function(id) {
|
|
| 326 | 2x |
moduleServer( |
| 327 | 2x |
id = id, |
| 328 | 2x |
function(input, output, session) {
|
| 329 | 2x |
logger::log_debug("DateFilterState$server initializing, id: { private$get_id() }")
|
| 330 | ||
| 331 |
# this observer is needed in the situation when teal_slice$selected has been |
|
| 332 |
# changed directly by the api - then it's needed to rerender UI element |
|
| 333 |
# to show relevant values |
|
| 334 | 2x |
private$session_bindings[[session$ns("selection_api")]] <- observeEvent(
|
| 335 | 2x |
ignoreNULL = TRUE, # dates needs to be selected |
| 336 | 2x |
ignoreInit = TRUE, |
| 337 | 2x |
eventExpr = private$get_selected(), |
| 338 | 2x |
handlerExpr = {
|
| 339 | 1x |
if (!setequal(private$get_selected(), input$selection)) {
|
| 340 | 1x |
logger::log_debug("DateFilterState$server@1 state changed, id: { private$get_id() }")
|
| 341 | 1x |
updateDateRangeInput( |
| 342 | 1x |
session = session, |
| 343 | 1x |
inputId = "selection", |
| 344 | 1x |
start = private$get_selected()[1], |
| 345 | 1x |
end = private$get_selected()[2] |
| 346 |
) |
|
| 347 |
} |
|
| 348 |
} |
|
| 349 |
) |
|
| 350 | ||
| 351 | 2x |
private$session_bindings[[session$ns("selection")]] <- observeEvent(
|
| 352 | 2x |
ignoreNULL = TRUE, # dates needs to be selected |
| 353 | 2x |
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state |
| 354 | 2x |
eventExpr = input$selection, |
| 355 | 2x |
handlerExpr = {
|
| 356 | 1x |
logger::log_debug("DateFilterState$server@2 selection changed, id: { private$get_id() }")
|
| 357 | 1x |
start_date <- input$selection[1] |
| 358 | 1x |
end_date <- input$selection[2] |
| 359 | ||
| 360 | 1x |
if (is.na(start_date) || is.na(end_date) || start_date > end_date) {
|
| 361 | ! |
updateDateRangeInput( |
| 362 | ! |
session = session, |
| 363 | ! |
inputId = "selection", |
| 364 | ! |
start = private$get_selected()[1], |
| 365 | ! |
end = private$get_selected()[2] |
| 366 |
) |
|
| 367 | ! |
showNotification( |
| 368 | ! |
"Start date must not be greater than the end date. Setting back to previous value.", |
| 369 | ! |
type = "warning" |
| 370 |
) |
|
| 371 | ! |
return(NULL) |
| 372 |
} |
|
| 373 | ||
| 374 | 1x |
private$set_selected(c(start_date, end_date)) |
| 375 |
} |
|
| 376 |
) |
|
| 377 | ||
| 378 | ||
| 379 | 2x |
private$keep_na_srv("keep_na")
|
| 380 | ||
| 381 | 2x |
private$session_bindings[[session$ns("reset1")]] <- observeEvent(input$start_date_reset, {
|
| 382 | ! |
logger::log_debug("DateFilterState$server@3 reset start date, id: { private$get_id() }")
|
| 383 | ! |
updateDateRangeInput( |
| 384 | ! |
session = session, |
| 385 | ! |
inputId = "selection", |
| 386 | ! |
start = private$get_choices()[1L] |
| 387 |
) |
|
| 388 |
}) |
|
| 389 | ||
| 390 | 2x |
private$session_bindings[[session$ns("reset2")]] <- observeEvent(input$end_date_reset, {
|
| 391 | ! |
logger::log_debug("DateFilterState$server@4 reset end date, id: { private$get_id() }")
|
| 392 | ! |
updateDateRangeInput( |
| 393 | ! |
session = session, |
| 394 | ! |
inputId = "selection", |
| 395 | ! |
end = private$get_choices()[2L] |
| 396 |
) |
|
| 397 |
}) |
|
| 398 | ||
| 399 | 2x |
NULL |
| 400 |
} |
|
| 401 |
) |
|
| 402 |
}, |
|
| 403 |
server_inputs_fixed = function(id) {
|
|
| 404 | ! |
moduleServer( |
| 405 | ! |
id = id, |
| 406 | ! |
function(input, output, session) {
|
| 407 | ! |
logger::log_debug("DateFilterState$server initializing, id: { private$get_id() }")
|
| 408 | ||
| 409 | ! |
output$selection <- renderUI({
|
| 410 | ! |
vals <- format(private$get_selected(), nsmall = 3) |
| 411 | ! |
tags$div( |
| 412 | ! |
tags$div(icon("calendar-days"), vals[1]),
|
| 413 | ! |
tags$div(span(" - "), icon("calendar-days"), vals[2])
|
| 414 |
) |
|
| 415 |
}) |
|
| 416 | ||
| 417 | ! |
NULL |
| 418 |
} |
|
| 419 |
) |
|
| 420 |
}, |
|
| 421 | ||
| 422 |
# @description |
|
| 423 |
# Server module to display filter summary |
|
| 424 |
# renders text describing selected date range and |
|
| 425 |
# if NA are included also |
|
| 426 |
content_summary = function(id) {
|
|
| 427 | 3x |
selected <- as.character(private$get_selected()) |
| 428 | 3x |
min <- selected[1] |
| 429 | 3x |
max <- selected[2] |
| 430 | 3x |
tagList( |
| 431 | 3x |
tags$span( |
| 432 | 3x |
class = "teal-slice filter-card-summary-value", |
| 433 | 3x |
HTML(min, "–", max) |
| 434 |
), |
|
| 435 | 3x |
tags$span( |
| 436 | 3x |
class = "teal-slice filter-card-summary-controls", |
| 437 | 3x |
if (private$na_count > 0) {
|
| 438 | ! |
tags$span( |
| 439 | ! |
"NA", |
| 440 | ! |
if (isTRUE(private$get_keep_na())) {
|
| 441 | ! |
icon("check", class = "text-success")
|
| 442 |
} else {
|
|
| 443 | ! |
icon("xmark", class = "text-danger")
|
| 444 |
} |
|
| 445 |
) |
|
| 446 |
} |
|
| 447 |
) |
|
| 448 |
) |
|
| 449 |
} |
|
| 450 |
) |
|
| 451 |
) |
| 1 |
# FilteredDataset abstract -------- |
|
| 2 | ||
| 3 |
#' @name FilteredDataset |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilteredDataset` `R6` class |
|
| 7 |
#' @description |
|
| 8 |
#' `FilteredDataset` is a class which renders/controls `FilterStates`(s) |
|
| 9 |
#' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one |
|
| 10 |
#' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects. |
|
| 11 |
#' Each `FilterStates` is responsible for one filter/subset expression applied for specific |
|
| 12 |
#' components of the dataset. |
|
| 13 |
#' |
|
| 14 |
#' @keywords internal |
|
| 15 |
FilteredDataset <- R6::R6Class( # nolint |
|
| 16 |
"FilteredDataset", |
|
| 17 |
# public methods ---- |
|
| 18 |
public = list( |
|
| 19 |
#' @description |
|
| 20 |
#' Initializes this `FilteredDataset` object. |
|
| 21 |
#' |
|
| 22 |
#' @param dataset any object |
|
| 23 |
#' @param dataname (`character(1)`) |
|
| 24 |
#' syntactically valid name given to the dataset. |
|
| 25 |
#' @param keys (`character`) optional |
|
| 26 |
#' vector of primary key column names. |
|
| 27 |
#' @param label (`character(1)`) |
|
| 28 |
#' label to describe the dataset. |
|
| 29 |
#' |
|
| 30 |
#' @return Object of class `FilteredDataset`, invisibly. |
|
| 31 |
#' |
|
| 32 |
initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label", exact = TRUE)) {
|
|
| 33 | 176x |
checkmate::assert_string(dataname) |
| 34 | 174x |
logger::log_debug("Instantiating { class(self)[1] }, dataname: { dataname }")
|
| 35 | 174x |
checkmate::assert_character(keys, any.missing = FALSE) |
| 36 | 174x |
checkmate::assert_character(label, null.ok = TRUE) |
| 37 | 174x |
private$allow_add <- reactiveVal(TRUE) |
| 38 | 174x |
private$dataset <- dataset |
| 39 | 174x |
private$dataname <- dataname |
| 40 | 174x |
private$keys <- keys |
| 41 | 174x |
private$label <- if (is.null(label)) character(0) else label |
| 42 | ||
| 43 |
# function executing reactive call and returning data |
|
| 44 | 174x |
private$data_filtered_fun <- function(sid = "") {
|
| 45 | 30x |
checkmate::assert_character(sid) |
| 46 | 30x |
if (length(sid)) {
|
| 47 | 30x |
logger::log_debug("filtering data dataname: { dataname }, sid: { sid }")
|
| 48 |
} else {
|
|
| 49 | ! |
logger::log_debug("filtering data dataname: { dataname }")
|
| 50 |
} |
|
| 51 | 30x |
env <- new.env(parent = parent.env(globalenv())) |
| 52 | 30x |
env[[dataname]] <- private$dataset |
| 53 | 30x |
filter_call <- self$get_call(sid) |
| 54 | 30x |
eval_expr_with_msg(filter_call, env) |
| 55 | 30x |
get(x = dataname, envir = env) |
| 56 |
} |
|
| 57 | ||
| 58 | 174x |
private$data_filtered <- reactive(private$data_filtered_fun()) |
| 59 | 174x |
invisible(self) |
| 60 |
}, |
|
| 61 | ||
| 62 |
#' @description Destroys a `FilteredDataset` object. |
|
| 63 | 128x |
destroy = function() private$finalize(), |
| 64 | ||
| 65 | ||
| 66 |
#' @description |
|
| 67 |
#' Returns a formatted string representing this `FilteredDataset` object. |
|
| 68 |
#' |
|
| 69 |
#' @param show_all (`logical(1)`) passed to `format.teal_slice`. |
|
| 70 |
#' @param trim_lines (`logical(1)`) passed to `format.teal_slice`. |
|
| 71 |
#' |
|
| 72 |
#' @return The formatted character string. |
|
| 73 |
#' |
|
| 74 |
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) |
| 79 |
) |
|
| 80 |
}, |
|
| 81 | ||
| 82 |
#' @description |
|
| 83 |
#' Prints this `FilteredDataset` object. |
|
| 84 |
#' |
|
| 85 |
#' @param ... additional arguments passed to `format`. |
|
| 86 |
#' |
|
| 87 |
print = function(...) {
|
|
| 88 | 10x |
cat(isolate(self$format(...)), "\n") |
| 89 |
}, |
|
| 90 | ||
| 91 |
#' @description |
|
| 92 |
#' Removes all filter items applied to this dataset. |
|
| 93 |
#' |
|
| 94 |
#' @param force (`logical(1)`) |
|
| 95 |
#' flag specifying whether to include anchored filter states. |
|
| 96 |
#' |
|
| 97 |
#' @return `NULL`. |
|
| 98 |
clear_filter_states = function(force = FALSE) {
|
|
| 99 | 14x |
logger::log_debug("Removing filters from FilteredDataset: { private$dataname }")
|
| 100 | 14x |
lapply( |
| 101 | 14x |
private$get_filter_states(), |
| 102 | 14x |
function(filter_states) filter_states$clear_filter_states(force) |
| 103 |
) |
|
| 104 | 14x |
NULL |
| 105 |
}, |
|
| 106 | ||
| 107 |
# managing filter states ----- |
|
| 108 | ||
| 109 |
# getters ---- |
|
| 110 |
#' @description |
|
| 111 |
#' Gets a filter expression. |
|
| 112 |
#' |
|
| 113 |
#' This function returns filter calls equivalent to selected items |
|
| 114 |
#' within each of `filter_states`. Configuration of the calls is constant and |
|
| 115 |
#' depends on `filter_states` type and order which are set during initialization. |
|
| 116 |
#' |
|
| 117 |
#' @param sid (`character`) |
|
| 118 |
#' when specified, the method returns code containing conditions calls of |
|
| 119 |
#' `FilterState` objects with `sid` different to this `sid` argument. |
|
| 120 |
#' |
|
| 121 |
#' @return Either a `list` of filter `call`s, or `NULL`. |
|
| 122 |
get_call = function(sid = "") {
|
|
| 123 | 54x |
filter_call <- Filter( |
| 124 | 54x |
f = Negate(is.null), |
| 125 | 54x |
x = lapply(private$get_filter_states(), function(x) x$get_call(sid)) |
| 126 |
) |
|
| 127 | 54x |
if (length(filter_call) == 0) {
|
| 128 | 32x |
return(NULL) |
| 129 |
} |
|
| 130 | 22x |
filter_call |
| 131 |
}, |
|
| 132 | ||
| 133 |
#' @description |
|
| 134 |
#' Gets states of all contained `FilterState` objects. |
|
| 135 |
#' |
|
| 136 |
#' @return A `teal_slices` object. |
|
| 137 |
#' |
|
| 138 |
get_filter_state = function() {
|
|
| 139 | 330x |
states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state())) |
| 140 | 330x |
do.call(c, states) |
| 141 |
}, |
|
| 142 | ||
| 143 |
#' @description |
|
| 144 |
#' Set filter state. |
|
| 145 |
#' |
|
| 146 |
#' @param state (`teal_slices`) |
|
| 147 |
#' |
|
| 148 |
#' @return Virtual method, returns nothing and raises error. |
|
| 149 |
#' |
|
| 150 |
set_filter_state = function(state) {
|
|
| 151 | 119x |
isolate({
|
| 152 | 119x |
allow_add <- attr(state, "allow_add") |
| 153 | 119x |
if (!is.null(allow_add) && !identical(allow_add, private$allow_add())) {
|
| 154 | ! |
private$allow_add(allow_add) |
| 155 |
} |
|
| 156 | 119x |
invisible(self) |
| 157 |
}) |
|
| 158 |
}, |
|
| 159 | ||
| 160 |
#' @description |
|
| 161 |
#' Gets the name of the dataset. |
|
| 162 |
#' |
|
| 163 |
#' @return A character string. |
|
| 164 |
get_dataname = function() {
|
|
| 165 | 55x |
private$dataname |
| 166 |
}, |
|
| 167 | ||
| 168 |
#' @description |
|
| 169 |
#' Gets the dataset object in this `FilteredDataset`. |
|
| 170 |
#' |
|
| 171 |
#' @param filtered (`logical(1)`) |
|
| 172 |
#' |
|
| 173 |
#' @return |
|
| 174 |
#' The stored dataset. If `data.frame` or `MultiAssayExperiment`, |
|
| 175 |
#' either raw or as a reactive with current filters applied (depending on `filtered`). |
|
| 176 |
#' |
|
| 177 |
get_dataset = function(filtered = FALSE) {
|
|
| 178 | 65x |
if (filtered) {
|
| 179 | 41x |
private$data_filtered |
| 180 |
} else {
|
|
| 181 | 24x |
private$dataset |
| 182 |
} |
|
| 183 |
}, |
|
| 184 | ||
| 185 |
#' @description |
|
| 186 |
#' Get filter overview of a dataset. |
|
| 187 |
#' @return Virtual method, returns nothing and raises an error. |
|
| 188 |
get_filter_overview = function() {
|
|
| 189 | ! |
stop("get_filter_overview is an abstract class method")
|
| 190 |
}, |
|
| 191 | ||
| 192 |
#' @description |
|
| 193 |
#' Gets the key columns for this dataset. |
|
| 194 |
#' @return Character vector of variable names |
|
| 195 |
get_keys = function() {
|
|
| 196 | 159x |
private$keys |
| 197 |
}, |
|
| 198 | ||
| 199 |
#' @description |
|
| 200 |
#' Gets the dataset label. |
|
| 201 |
#' @return Character string. |
|
| 202 |
get_dataset_label = function() {
|
|
| 203 | 2x |
private$label |
| 204 |
}, |
|
| 205 | ||
| 206 |
# modules ------ |
|
| 207 |
#' @description |
|
| 208 |
#' `shiny` module containing active filters for a dataset, along with a title and a remove button. |
|
| 209 |
#' @param id (`character(1)`) |
|
| 210 |
#' `shiny` module instance id. |
|
| 211 |
#' |
|
| 212 |
#' @return `shiny.tag` |
|
| 213 |
ui_active = function(id) {
|
|
| 214 | ! |
ns <- NS(id) |
| 215 | ! |
uiOutput(ns("container"))
|
| 216 |
}, |
|
| 217 |
#' @description |
|
| 218 |
#' Server module for a dataset active filters. |
|
| 219 |
#' |
|
| 220 |
#' @param id (`character(1)`) |
|
| 221 |
#' `shiny` module instance id. |
|
| 222 |
#' @return `NULL`. |
|
| 223 |
srv_active = function(id) {
|
|
| 224 | 28x |
moduleServer( |
| 225 | 28x |
id = id, |
| 226 | 28x |
function(input, output, session) {
|
| 227 | 28x |
dataname <- self$get_dataname() |
| 228 | 28x |
logger::log_debug("FilteredDataset$srv_active initializing, dataname: { dataname }")
|
| 229 | ||
| 230 | 28x |
filter_count <- reactive(length(self$get_filter_state())) |
| 231 | ||
| 232 | 28x |
is_displayed <- reactiveVal() |
| 233 | 28x |
private$session_bindings[[session$ns("is_displayed")]] <- observe({
|
| 234 | 26x |
res <- private$allow_add() || filter_count() > 0 |
| 235 | 26x |
isolate( |
| 236 | 26x |
if (!identical(res, is_displayed())) is_displayed(res) |
| 237 |
) |
|
| 238 |
}) |
|
| 239 | ||
| 240 | 28x |
output$container <- renderUI({
|
| 241 | 26x |
if (is_displayed()) {
|
| 242 | 26x |
isolate({
|
| 243 | 26x |
tags$span( |
| 244 | 26x |
id = session$ns(id), |
| 245 | 26x |
class = "teal-slice", |
| 246 | 26x |
include_css_files("filter-panel"),
|
| 247 | 26x |
include_js_files(pattern = "icons"), |
| 248 | 26x |
bslib::accordion( |
| 249 | 26x |
id = session$ns("dataset_filter_accordion"),
|
| 250 | 26x |
class = "teal-slice-dataset-filter", |
| 251 | 26x |
bslib::accordion_panel( |
| 252 | 26x |
dataname, |
| 253 | 26x |
style = "padding: 0; margin: 0;", |
| 254 | 26x |
bslib::page_fluid( |
| 255 | 26x |
id = session$ns("whole_ui"),
|
| 256 | 26x |
style = "margin: 0; padding: 0;", |
| 257 | 26x |
uiOutput(session$ns("active_filter_badge")),
|
| 258 | 26x |
div( |
| 259 | 26x |
id = session$ns("filter_util_icons"),
|
| 260 | 26x |
class = "teal-slice filter-util-icons", |
| 261 | 26x |
tags$a( |
| 262 | 26x |
class = "teal-slice filter-icon", |
| 263 | 26x |
tags$i( |
| 264 | 26x |
id = session$ns("add_filter_icon"),
|
| 265 | 26x |
class = "fa fa-plus", |
| 266 | 26x |
title = "fold/expand transform panel", |
| 267 | 26x |
onclick = sprintf( |
| 268 | 26x |
"togglePanelItems(this, '%s', 'fa-plus', 'fa-minus'); |
| 269 | 26x |
if ($(this).hasClass('fa-minus')) {
|
| 270 | 26x |
$('#%s .accordion-button.collapsed').click();
|
| 271 |
}", |
|
| 272 | 26x |
session$ns("add_panel"),
|
| 273 | 26x |
session$ns("dataset_filter_accordion")
|
| 274 |
) |
|
| 275 |
) |
|
| 276 |
), |
|
| 277 | 26x |
uiOutput(session$ns("filter_util_remove_icons"))
|
| 278 |
), |
|
| 279 | 26x |
bslib::page_fluid( |
| 280 | 26x |
style = "padding: 0px; margin: 0;", |
| 281 | 26x |
tags$div( |
| 282 | 26x |
id = session$ns("add_panel"),
|
| 283 | 26x |
class = "add-panel", |
| 284 | 26x |
style = "display: none;", |
| 285 | 26x |
self$ui_add(session$ns(private$dataname)) |
| 286 |
) |
|
| 287 |
), |
|
| 288 | 26x |
tags$div( |
| 289 | 26x |
id = session$ns("filter_count_ui"),
|
| 290 | 26x |
style = "display: none;", |
| 291 | 26x |
tagList( |
| 292 | 26x |
textOutput(session$ns("filter_count"))
|
| 293 |
) |
|
| 294 |
), |
|
| 295 | 26x |
tags$div( |
| 296 |
# id needed to insert and remove UI to filter single variable as needed |
|
| 297 |
# it is currently also used by the above module to entirely hide this panel |
|
| 298 | 26x |
id = session$ns("filters"),
|
| 299 | 26x |
class = "parent-hideable-list-group", |
| 300 | 26x |
tagList( |
| 301 | 26x |
lapply( |
| 302 | 26x |
names(private$get_filter_states()), |
| 303 | 26x |
function(x) {
|
| 304 | 31x |
tagList(private$get_filter_states()[[x]]$ui_active(id = session$ns(x))) |
| 305 |
} |
|
| 306 |
) |
|
| 307 |
) |
|
| 308 |
) |
|
| 309 |
) |
|
| 310 |
) |
|
| 311 |
), |
|
| 312 | 26x |
tags$script( |
| 313 | 26x |
HTML( |
| 314 | 26x |
sprintf( |
| 315 |
" |
|
| 316 | 26x |
$(document).ready(function() {
|
| 317 | 26x |
$('#%s').appendTo('#%s > .accordion-item > .accordion-header');
|
| 318 | 26x |
$('#%s > .accordion-item > .accordion-header').css({
|
| 319 | 26x |
'display': 'flex' |
| 320 |
}); |
|
| 321 | 26x |
$('#%s').appendTo('#%s .accordion-header .accordion-title');
|
| 322 |
}); |
|
| 323 |
", |
|
| 324 | 26x |
session$ns("filter_util_icons"),
|
| 325 | 26x |
session$ns("dataset_filter_accordion"),
|
| 326 | 26x |
session$ns("dataset_filter_accordion"),
|
| 327 | 26x |
session$ns("active_filter_badge"),
|
| 328 | 26x |
session$ns("dataset_filter_accordion")
|
| 329 |
) |
|
| 330 |
) |
|
| 331 |
) |
|
| 332 |
) |
|
| 333 |
}) |
|
| 334 |
} |
|
| 335 |
}) |
|
| 336 | ||
| 337 | 28x |
output$active_filter_badge <- renderUI({
|
| 338 | 31x |
if (filter_count() == 0) {
|
| 339 | 5x |
return(NULL) |
| 340 |
} |
|
| 341 | 26x |
tags$span( |
| 342 | 26x |
filter_count(), |
| 343 | 26x |
class = "teal-slice data-filter-badge-count" |
| 344 |
) |
|
| 345 |
}) |
|
| 346 | ||
| 347 | 28x |
output$filter_count <- renderText( |
| 348 | 28x |
sprintf( |
| 349 | 28x |
"%d filter%s applied", |
| 350 | 28x |
filter_count(), |
| 351 | 28x |
if (filter_count() != 1) "s" else "" |
| 352 |
) |
|
| 353 |
) |
|
| 354 | ||
| 355 | 28x |
output$filter_util_remove_icons <- renderUI({
|
| 356 | 31x |
if (private$allow_add()) {
|
| 357 | 31x |
if (length(Filter(function(x) !x$anchored, self$get_filter_state())) > 0) {
|
| 358 | 25x |
tags$div( |
| 359 | 25x |
style = "display: flex;", |
| 360 | 25x |
actionLink( |
| 361 | 25x |
session$ns("remove_filters"),
|
| 362 | 25x |
label = "", |
| 363 | 25x |
icon = icon("far fa-circle-xmark"),
|
| 364 | 25x |
class = "teal-slice filter-icon" |
| 365 |
) |
|
| 366 |
) |
|
| 367 |
} |
|
| 368 |
} |
|
| 369 |
}) |
|
| 370 | ||
| 371 | 28x |
lapply( |
| 372 | 28x |
names(private$get_filter_states()), |
| 373 | 28x |
function(x) {
|
| 374 | 33x |
private$get_filter_states()[[x]]$srv_active(id = x) |
| 375 |
} |
|
| 376 |
) |
|
| 377 | ||
| 378 | 28x |
private$session_bindings[[session$ns("get_filter_state")]] <- observeEvent(
|
| 379 | 28x |
self$get_filter_state(), |
| 380 | 28x |
ignoreInit = TRUE, |
| 381 |
{
|
|
| 382 | 5x |
shinyjs::hide("filter_count_ui")
|
| 383 | 5x |
shinyjs::show("filters")
|
| 384 |
} |
|
| 385 |
) |
|
| 386 | ||
| 387 |
# If the accordion input is `NULL` it is being collapsed. |
|
| 388 |
# It has the accordion panel label if it is expanded. |
|
| 389 | 28x |
observeEvent(input$dataset_filter_accordion, ignoreNULL = FALSE, {
|
| 390 | 26x |
if (is.null(input$dataset_filter_accordion)) {
|
| 391 |
# Hiding the `add_panel` dropdown and changing the minus icon to plus |
|
| 392 |
# TODO: simplify this implementation. This is done in multiple places |
|
| 393 | 26x |
shinyjs::runjs( |
| 394 | 26x |
sprintf( |
| 395 | 26x |
"var element = $('#%s.fa-minus');
|
| 396 | 26x |
if (element.length) {
|
| 397 | 26x |
element.click(); |
| 398 | 26x |
$('#%s').hide();
|
| 399 |
}", |
|
| 400 | 26x |
session$ns("add_filter_icon"),
|
| 401 | 26x |
session$ns("add_panel")
|
| 402 |
) |
|
| 403 |
) |
|
| 404 |
} |
|
| 405 |
}) |
|
| 406 | ||
| 407 | 28x |
private$session_bindings[[session$ns("remove_filters")]] <- observeEvent(input$remove_filters, {
|
| 408 | 1x |
logger::log_debug("FilteredDataset$srv_active@1 removing all non-anchored filters, dataname: { dataname }")
|
| 409 | 1x |
self$clear_filter_states() |
| 410 |
}) |
|
| 411 | ||
| 412 | 28x |
private$session_bindings[[session$ns("inputs")]] <- list(
|
| 413 | 28x |
destroy = function() {
|
| 414 | 48x |
lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) |
| 415 |
} |
|
| 416 |
) |
|
| 417 | ||
| 418 | 28x |
self$srv_add(private$dataname) |
| 419 | ||
| 420 | 28x |
NULL |
| 421 |
} |
|
| 422 |
) |
|
| 423 |
}, |
|
| 424 | ||
| 425 |
#' @description |
|
| 426 |
#' UI module to add filter variable for this dataset. |
|
| 427 |
#' |
|
| 428 |
#' @param id (`character(1)`) |
|
| 429 |
#' `shiny` module instance id. |
|
| 430 |
#' |
|
| 431 |
#' @return Virtual method, returns nothing and raises error. |
|
| 432 |
ui_add = function(id) {
|
|
| 433 | 1x |
stop("Pure virtual method")
|
| 434 |
}, |
|
| 435 | ||
| 436 |
#' @description |
|
| 437 |
#' Server module to add filter variable for this dataset. |
|
| 438 |
#' For this class `srv_add` calls multiple modules |
|
| 439 |
#' of the same name from `FilterStates` as `MAEFilteredDataset` |
|
| 440 |
#' contains one `FilterStates` object for `colData` and one for each experiment. |
|
| 441 |
#' |
|
| 442 |
#' @param id (`character(1)`) |
|
| 443 |
#' `shiny` module instance id. |
|
| 444 |
#' |
|
| 445 |
#' @return `NULL`. |
|
| 446 |
srv_add = function(id) {
|
|
| 447 | 28x |
moduleServer( |
| 448 | 28x |
id = id, |
| 449 | 28x |
function(input, output, session) {
|
| 450 | 28x |
logger::log_debug("FilteredDataset$srv_add initializing, dataname: { private$dataname }")
|
| 451 | 28x |
elems <- private$get_filter_states() |
| 452 | 28x |
elem_names <- names(private$get_filter_states()) |
| 453 | 28x |
lapply( |
| 454 | 28x |
elem_names, |
| 455 | 28x |
function(elem_name) elems[[elem_name]]$srv_add(elem_name) |
| 456 |
) |
|
| 457 | ||
| 458 | 28x |
NULL |
| 459 |
} |
|
| 460 |
) |
|
| 461 |
} |
|
| 462 |
), |
|
| 463 |
# private fields ---- |
|
| 464 |
private = list( |
|
| 465 |
allow_add = NULL, # reactiveVal |
|
| 466 |
dataset = NULL, # data.frame or MultiAssayExperiment |
|
| 467 |
data_filtered = NULL, |
|
| 468 |
data_filtered_fun = NULL, # function |
|
| 469 |
filter_states = list(), |
|
| 470 |
dataname = character(0), |
|
| 471 |
keys = character(0), |
|
| 472 |
label = character(0), |
|
| 473 |
session_bindings = list(), |
|
| 474 | ||
| 475 |
# Adds `FilterStates` to the `private$filter_states`. |
|
| 476 |
# `FilterStates` is added once for each element of the dataset. |
|
| 477 |
# @param filter_states (`FilterStates`) |
|
| 478 |
# @param id (`character(1)`) |
|
| 479 |
add_filter_states = function(filter_states, id) {
|
|
| 480 | 237x |
checkmate::assert_class(filter_states, "FilterStates") |
| 481 | 237x |
checkmate::assert_string(id) |
| 482 | 237x |
x <- stats::setNames(list(filter_states), id) |
| 483 | 237x |
private$filter_states <- c(private$get_filter_states(), x) |
| 484 |
}, |
|
| 485 | ||
| 486 |
# @description |
|
| 487 |
# Gets `FilterStates` objects in this `FilteredDataset`. |
|
| 488 |
# @return list of `FilterStates` objects. |
|
| 489 |
get_filter_states = function() {
|
|
| 490 | 1044x |
private$filter_states |
| 491 |
}, |
|
| 492 | ||
| 493 |
# @description |
|
| 494 |
# Object and dependencies cleanup. |
|
| 495 |
# |
|
| 496 |
# - Destroy inputs and observers stored in `private$session_bindings` |
|
| 497 |
# - Finalize `FilterStates` stored in `private$filter_states` |
|
| 498 |
# |
|
| 499 |
# @return `NULL`, invisibly. |
|
| 500 |
finalize = function() {
|
|
| 501 | 302x |
.finalize_session_bindings(self, private) |
| 502 | 302x |
lapply(private$filter_states, function(x) x$destroy()) |
| 503 | 302x |
invisible(NULL) |
| 504 |
} |
|
| 505 |
) |
|
| 506 |
) |
| 1 |
#' Initialize `FilteredData` |
|
| 2 |
#' |
|
| 3 |
#' Function creates a `FilteredData` object. |
|
| 4 |
#' |
|
| 5 |
#' @param x (`named list`) of datasets. |
|
| 6 |
#' @param join_keys (`join_keys`) see [`teal.data::join_keys()`]. |
|
| 7 |
#' |
|
| 8 |
#' @return Object of class `FilteredData`. |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' datasets <- init_filtered_data(list(iris = iris, mtcars = mtcars)) |
|
| 12 |
#' datasets |
|
| 13 |
#' |
|
| 14 |
#' @export |
|
| 15 |
init_filtered_data <- function(x, join_keys = teal.data::join_keys()) { # nolint
|
|
| 16 | 32x |
checkmate::assert_list(x, any.missing = FALSE, names = "unique") |
| 17 | 31x |
checkmate::assert_class(join_keys, "join_keys") |
| 18 | 30x |
FilteredData$new(x, join_keys = join_keys) |
| 19 |
} |
|
| 20 | ||
| 21 |
#' Evaluate expression with meaningful message |
|
| 22 |
#' |
|
| 23 |
#' Method created for the `FilteredData` object to execute filter call with |
|
| 24 |
#' meaningful message. After evaluation used environment should contain |
|
| 25 |
#' all necessary bindings. |
|
| 26 |
#' |
|
| 27 |
#' @param expr (`language`) |
|
| 28 |
#' @param env (`environment`) where expression is evaluated. |
|
| 29 |
#' @return `NULL`, invisibly. |
|
| 30 |
#' @keywords internal |
|
| 31 |
eval_expr_with_msg <- function(expr, env) {
|
|
| 32 | 39x |
lapply( |
| 33 | 39x |
expr, |
| 34 | 39x |
function(x) {
|
| 35 | 24x |
tryCatch( |
| 36 | 24x |
eval(x, envir = env), |
| 37 | 24x |
error = function(e) {
|
| 38 | ! |
stop( |
| 39 | ! |
sprintf( |
| 40 | ! |
"Filter call execution failed:\n - call:\n %s\n - message:\n %s ", |
| 41 | ! |
deparse1(x, collapse = "\n"), e |
| 42 |
) |
|
| 43 |
) |
|
| 44 |
} |
|
| 45 |
) |
|
| 46 |
} |
|
| 47 |
) |
|
| 48 | 39x |
invisible(NULL) |
| 49 |
} |
|
| 50 | ||
| 51 | ||
| 52 |
#' Toggle button properties. |
|
| 53 |
#' |
|
| 54 |
#' Switch between different icons or titles on a button. |
|
| 55 |
#' |
|
| 56 |
#' Wrapper functions that use `shinyjs::runjs` to change button properties in response to events, |
|
| 57 |
#' typically clicking those very buttons. |
|
| 58 |
#' `shiny`'s `actionButton` and `actionLink` create `<a>` tags, |
|
| 59 |
#' which may contain a child `<i>` tag that specifies an icon to be displayed. |
|
| 60 |
#' `toggle_icon` calls the `toggleClass` (when `one_way = FALSE`) or |
|
| 61 |
#' `removeClass` and `addClass` methods (when `one_way = TRUE`) to change icons. |
|
| 62 |
#' `toggle_title` calls the `attr` method to modify the `Title` attribute of the button. |
|
| 63 |
#' |
|
| 64 |
#' @param input_id (`character(1)`) (name-spaced) id of the button |
|
| 65 |
#' @param icons,titles (`character(2)`) vector specifying values between which to toggle |
|
| 66 |
#' @param one_way (`logical(1)`) flag specifying whether to keep toggling; |
|
| 67 |
#' if TRUE, the target will be changed |
|
| 68 |
#' from the first element of `icons`/`titles` to the second |
|
| 69 |
#' |
|
| 70 |
#' @return `NULL`, invisibly. |
|
| 71 |
#' |
|
| 72 |
#' @examples |
|
| 73 |
#' # use non-exported function from teal.slice |
|
| 74 |
#' toggle_icon <- getFromNamespace("toggle_icon", "teal.slice")
|
|
| 75 |
#' |
|
| 76 |
#' library(shiny) |
|
| 77 |
#' library(shinyjs) |
|
| 78 |
#' |
|
| 79 |
#' ui <- bslib::page_fluid( |
|
| 80 |
#' useShinyjs(), |
|
| 81 |
#' actionButton("hide_content", label = "hide", icon = icon("xmark")),
|
|
| 82 |
#' actionButton("show_content", label = "show", icon = icon("check")),
|
|
| 83 |
#' actionButton("toggle_content", label = "toggle", icon = icon("angle-down")),
|
|
| 84 |
#' tags$br(), |
|
| 85 |
#' tags$div( |
|
| 86 |
#' id = "content", |
|
| 87 |
#' verbatimTextOutput("printout")
|
|
| 88 |
#' ) |
|
| 89 |
#' ) |
|
| 90 |
#' |
|
| 91 |
#' server <- function(input, output, session) {
|
|
| 92 |
#' observeEvent(input$hide_content, |
|
| 93 |
#' {
|
|
| 94 |
#' hide("content")
|
|
| 95 |
#' toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE)
|
|
| 96 |
#' }, |
|
| 97 |
#' ignoreInit = TRUE |
|
| 98 |
#' ) |
|
| 99 |
#' |
|
| 100 |
#' observeEvent(input$show_content, |
|
| 101 |
#' {
|
|
| 102 |
#' show("content")
|
|
| 103 |
#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE)
|
|
| 104 |
#' }, |
|
| 105 |
#' ignoreInit = TRUE |
|
| 106 |
#' ) |
|
| 107 |
#' |
|
| 108 |
#' observeEvent(input$toggle_content, |
|
| 109 |
#' {
|
|
| 110 |
#' toggle("content")
|
|
| 111 |
#' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"))
|
|
| 112 |
#' }, |
|
| 113 |
#' ignoreInit = TRUE |
|
| 114 |
#' ) |
|
| 115 |
#' |
|
| 116 |
#' output$printout <- renderPrint({
|
|
| 117 |
#' head(faithful, 10) |
|
| 118 |
#' }) |
|
| 119 |
#' } |
|
| 120 |
#' if (interactive()) {
|
|
| 121 |
#' shinyApp(ui, server) |
|
| 122 |
#' } |
|
| 123 |
#' |
|
| 124 |
#' @name toggle_button |
|
| 125 |
#' @rdname toggle_button |
|
| 126 |
#' @keywords internal |
|
| 127 |
toggle_icon <- function(input_id, icons, one_way = FALSE) {
|
|
| 128 | 26x |
checkmate::assert_string(input_id) |
| 129 | 26x |
checkmate::assert_character(icons, len = 2L) |
| 130 | 26x |
checkmate::assert_flag(one_way) |
| 131 | ||
| 132 | 26x |
expr <- |
| 133 | 26x |
if (one_way) {
|
| 134 | 26x |
sprintf( |
| 135 | 26x |
"$('#%s i').removeClass('%s').addClass('%s');",
|
| 136 | 26x |
input_id, icons[1], icons[2] |
| 137 |
) |
|
| 138 |
} else {
|
|
| 139 | ! |
sprintf("$('#%s i').toggleClass('%s');", input_id, paste(icons, collapse = " "))
|
| 140 |
} |
|
| 141 | ||
| 142 | 26x |
shinyjs::runjs(expr) |
| 143 | ||
| 144 | 26x |
invisible(NULL) |
| 145 |
} |
|
| 146 | ||
| 147 |
#' @rdname toggle_button |
|
| 148 |
#' @keywords internal |
|
| 149 |
toggle_title <- function(input_id, titles, one_way = FALSE) {
|
|
| 150 | 26x |
checkmate::assert_string(input_id) |
| 151 | 26x |
checkmate::assert_character(titles, len = 2L) |
| 152 | 26x |
checkmate::assert_flag(one_way) |
| 153 | ||
| 154 | 26x |
expr <- |
| 155 | 26x |
if (one_way) {
|
| 156 | 26x |
sprintf( |
| 157 | 26x |
"$('a#%s').attr('title', '%s');",
|
| 158 | 26x |
input_id, titles[2] |
| 159 |
) |
|
| 160 |
} else {
|
|
| 161 | ! |
sprintf( |
| 162 | ! |
paste0( |
| 163 | ! |
"var button_id = 'a#%1$s';", |
| 164 | ! |
"var curr = $(button_id).attr('title');",
|
| 165 | ! |
"if (curr == '%2$s') { $(button_id).attr('title', '%3$s');",
|
| 166 | ! |
"} else { $(button_id).attr('title', '%2$s');",
|
| 167 |
"}" |
|
| 168 |
), |
|
| 169 | ! |
input_id, titles[1], titles[2] |
| 170 |
) |
|
| 171 |
} |
|
| 172 | ||
| 173 | 26x |
shinyjs::runjs(expr) |
| 174 | ||
| 175 | 26x |
invisible(NULL) |
| 176 |
} |
|
| 177 | ||
| 178 |
#' @inherit teal.data::topological_sort description details params title |
|
| 179 |
#' @examples |
|
| 180 |
#' # use non-exported function from teal.slice |
|
| 181 |
#' topological_sort <- getFromNamespace("topological_sort", "teal.slice")
|
|
| 182 |
#' |
|
| 183 |
#' topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
|
|
| 184 |
#' topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
|
|
| 185 |
#' topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
|
|
| 186 |
#' @keywords internal |
|
| 187 |
topological_sort <- function(graph) {
|
|
| 188 | 89x |
utils::getFromNamespace("topological_sort", ns = "teal.data")(graph)
|
| 189 |
} |
| 1 |
# FilterPanelAPI ------ |
|
| 2 | ||
| 3 |
#' @name FilterPanelAPI |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title Class to encapsulate the API of the filter panel of a teal app |
|
| 7 |
#' |
|
| 8 |
#' @description |
|
| 9 |
#' An API class for managing filter states in a teal application's filter panel. |
|
| 10 |
#' |
|
| 11 |
#' @details |
|
| 12 |
#' The purpose of this class is to encapsulate the API of the filter panel in a |
|
| 13 |
#' new class `FilterPanelAPI` so that it can be passed and used in the server |
|
| 14 |
#' call of any module instead of passing the whole `FilteredData` object. |
|
| 15 |
#' |
|
| 16 |
#' This class is supported by methods to set, get, remove filter states in the |
|
| 17 |
#' filter panel API. |
|
| 18 |
#' |
|
| 19 |
#' @examples |
|
| 20 |
#' library(shiny) |
|
| 21 |
#' |
|
| 22 |
#' fd <- init_filtered_data(list(iris = iris)) |
|
| 23 |
#' fpa <- FilterPanelAPI$new(fd) |
|
| 24 |
#' |
|
| 25 |
#' # get the actual filter state --> empty named list |
|
| 26 |
#' isolate(fpa$get_filter_state()) |
|
| 27 |
#' |
|
| 28 |
#' # set a filter state |
|
| 29 |
#' set_filter_state( |
|
| 30 |
#' fpa, |
|
| 31 |
#' teal_slices( |
|
| 32 |
#' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE) |
|
| 33 |
#' ) |
|
| 34 |
#' ) |
|
| 35 |
#' |
|
| 36 |
#' # get the actual filter state --> named list with filters |
|
| 37 |
#' isolate(fpa$get_filter_state()) |
|
| 38 |
#' |
|
| 39 |
#' # remove all_filter_states |
|
| 40 |
#' fpa$clear_filter_states() |
|
| 41 |
#' |
|
| 42 |
#' # get the actual filter state --> empty named list |
|
| 43 |
#' isolate(fpa$get_filter_state()) |
|
| 44 |
#' |
|
| 45 |
#' @export |
|
| 46 |
#' |
|
| 47 |
FilterPanelAPI <- R6::R6Class( # nolint |
|
| 48 |
"FilterPanelAPI", |
|
| 49 |
# public methods ---- |
|
| 50 |
public = list( |
|
| 51 |
#' @description |
|
| 52 |
#' Initialize a `FilterPanelAPI` object. |
|
| 53 |
#' @param datasets (`FilteredData`) |
|
| 54 |
#' |
|
| 55 |
initialize = function(datasets) {
|
|
| 56 | 8x |
checkmate::assert_class(datasets, "FilteredData") |
| 57 | 6x |
private$filtered_data <- datasets |
| 58 |
}, |
|
| 59 | ||
| 60 |
#' @description |
|
| 61 |
#' Gets the reactive values from the active `FilterState` objects of the `FilteredData` object. |
|
| 62 |
#' |
|
| 63 |
#' Gets all active filters in the form of a nested list. |
|
| 64 |
#' The output list is a compatible input to `set_filter_state`. |
|
| 65 |
#' |
|
| 66 |
#' @return `list` with named elements corresponding to `FilteredDataset` objects with active filters. |
|
| 67 |
#' |
|
| 68 |
get_filter_state = function() {
|
|
| 69 | 8x |
private$filtered_data$get_filter_state() |
| 70 |
}, |
|
| 71 | ||
| 72 |
#' @description |
|
| 73 |
#' Sets active filter states. |
|
| 74 |
#' @param filter (`teal_slices`) |
|
| 75 |
#' |
|
| 76 |
#' @return `NULL`, invisibly. |
|
| 77 |
#' |
|
| 78 |
set_filter_state = function(filter) {
|
|
| 79 | 5x |
private$filtered_data$set_filter_state(filter) |
| 80 | 5x |
invisible(NULL) |
| 81 |
}, |
|
| 82 | ||
| 83 |
#' @description |
|
| 84 |
#' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object. |
|
| 85 |
#' |
|
| 86 |
#' @param filter (`teal_slices`) |
|
| 87 |
#' specifying `FilterState` objects to remove; |
|
| 88 |
#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored |
|
| 89 |
#' |
|
| 90 |
#' @return `NULL`, invisibly. |
|
| 91 |
#' |
|
| 92 |
remove_filter_state = function(filter) {
|
|
| 93 | 1x |
private$filtered_data$remove_filter_state(filter) |
| 94 | 1x |
invisible(NULL) |
| 95 |
}, |
|
| 96 | ||
| 97 |
#' @description |
|
| 98 |
#' Remove all `FilterStates` of the `FilteredData` object. |
|
| 99 |
#' |
|
| 100 |
#' @param datanames (`character`) |
|
| 101 |
#' `datanames` to remove their `FilterStates`; |
|
| 102 |
#' omit to remove all `FilterStates` in the `FilteredData` object |
|
| 103 |
#' |
|
| 104 |
#' @return `NULL`, invisibly. |
|
| 105 |
#' |
|
| 106 |
clear_filter_states = function(datanames) {
|
|
| 107 | 2x |
datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames |
| 108 | 2x |
private$filtered_data$clear_filter_states(datanames = datanames_to_remove) |
| 109 | 2x |
invisible(NULL) |
| 110 |
} |
|
| 111 |
), |
|
| 112 |
# private methods ---- |
|
| 113 |
private = list( |
|
| 114 |
filtered_data = NULL |
|
| 115 |
) |
|
| 116 |
) |
| 1 |
# MAEFilterStates ------ |
|
| 2 | ||
| 3 |
#' @name MAEFilterStates |
|
| 4 |
#' @docType class |
|
| 5 |
#' @title `FilterStates` subclass for `MultiAssayExperiment`s |
|
| 6 |
#' @description Handles filter states in a `MultiAssayExperiment`. |
|
| 7 |
#' @keywords internal |
|
| 8 |
#' |
|
| 9 |
MAEFilterStates <- R6::R6Class( # nolint |
|
| 10 |
classname = "MAEFilterStates", |
|
| 11 |
inherit = FilterStates, |
|
| 12 |
# public methods ---- |
|
| 13 |
public = list( |
|
| 14 |
#' @description |
|
| 15 |
#' Initialize `MAEFilterStates` object. |
|
| 16 |
#' |
|
| 17 |
#' @param data (`MultiAssayExperiment`) |
|
| 18 |
#' the `R` object which `MultiAssayExperiment::subsetByColData` function is applied on. |
|
| 19 |
#' @param data_reactive (`function(sid)`) |
|
| 20 |
#' should return a `MultiAssayExperiment` object or `NULL`. |
|
| 21 |
#' This object is needed for the `FilterState` counts being updated |
|
| 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. |
|
| 24 |
#' @param dataname (`character(1)`) |
|
| 25 |
#' name of the data used in the subset expression. |
|
| 26 |
#' Passed to the function argument attached to this `FilterStates`. |
|
| 27 |
#' @param datalabel (`character(1)`) optional |
|
| 28 |
#' text label. |
|
| 29 |
#' @param varlabels (`character`) |
|
| 30 |
#' labels of the variables used in this object. |
|
| 31 |
#' @param keys (`character`) |
|
| 32 |
#' key column names. |
|
| 33 |
#' |
|
| 34 |
initialize = function(data, |
|
| 35 |
data_reactive = function(sid = "") NULL, |
|
| 36 |
dataname, |
|
| 37 |
datalabel = "subjects", |
|
| 38 |
keys = character(0)) {
|
|
| 39 | 24x |
if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
| 40 | ! |
stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
|
| 41 |
} |
|
| 42 | 24x |
checkmate::assert_function(data_reactive, args = "sid") |
| 43 | 24x |
checkmate::assert_class(data, "MultiAssayExperiment") |
| 44 | ||
| 45 | 23x |
data <- SummarizedExperiment::colData(data) |
| 46 | 23x |
data_reactive <- function(sid = "") SummarizedExperiment::colData(data_reactive(sid = sid)) |
| 47 | 23x |
super$initialize(data, data_reactive, dataname, datalabel) |
| 48 | 23x |
private$keys <- keys |
| 49 | 23x |
private$set_filterable_varnames(include_varnames = colnames(data)) |
| 50 | ||
| 51 | 23x |
invisible(self) |
| 52 |
} |
|
| 53 |
), |
|
| 54 | ||
| 55 |
# private fields ---- |
|
| 56 | ||
| 57 |
private = list( |
|
| 58 |
extract_type = "list", |
|
| 59 |
fun = quote(MultiAssayExperiment::subsetByColData) |
|
| 60 |
) |
|
| 61 |
) |
| 1 |
#' Initialize `FilterStates` object |
|
| 2 |
#' |
|
| 3 |
#' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`) |
|
| 4 |
#' object to subset. |
|
| 5 |
#' @param data_reactive (`function(sid)`) |
|
| 6 |
#' should return an object of the same type as `data` or `NULL`. |
|
| 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. |
|
| 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)`) |
|
| 11 |
#' name of the data used in the subset expression, |
|
| 12 |
#' passed to the function argument attached to this `FilterStates`. |
|
| 13 |
#' @param datalabel (`character(1)`) optional |
|
| 14 |
#' text label. |
|
| 15 |
#' @param ... optional, |
|
| 16 |
#' additional arguments for specific classes: keys. |
|
| 17 |
#' |
|
| 18 |
#' @return Object of class `FilterStates`. |
|
| 19 |
#' |
|
| 20 |
#' @keywords internal |
|
| 21 |
#' @examples |
|
| 22 |
#' # use non-exported function from teal.slice |
|
| 23 |
#' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
|
|
| 24 |
#' |
|
| 25 |
#' df <- data.frame( |
|
| 26 |
#' character = letters, |
|
| 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") |
|
| 30 |
#' ) |
|
| 31 |
#' rf <- init_filter_states( |
|
| 32 |
#' data = df, |
|
| 33 |
#' dataname = "DF" |
|
| 34 |
#' ) |
|
| 35 |
#' |
|
| 36 |
#' library(shiny) |
|
| 37 |
#' ui <- bslib::page_fluid( |
|
| 38 |
#' actionButton("clear", tags$span(icon("xmark"), "Remove all filters")),
|
|
| 39 |
#' rf$ui_add(id = "add"), |
|
| 40 |
#' rf$ui_active("states"),
|
|
| 41 |
#' verbatimTextOutput("expr"),
|
|
| 42 |
#' ) |
|
| 43 |
#' |
|
| 44 |
#' server <- function(input, output, session) {
|
|
| 45 |
#' rf$srv_add(id = "add") |
|
| 46 |
#' rf$srv_active(id = "states") |
|
| 47 |
#' output$expr <- renderText({
|
|
| 48 |
#' deparse1(rf$get_call(), collapse = "\n") |
|
| 49 |
#' }) |
|
| 50 |
#' observeEvent(input$clear, rf$clear_filter_states()) |
|
| 51 |
#' } |
|
| 52 |
#' |
|
| 53 |
#' if (interactive()) {
|
|
| 54 |
#' shinyApp(ui, server) |
|
| 55 |
#' } |
|
| 56 |
#' |
|
| 57 |
#' @export |
|
| 58 |
#' |
|
| 59 |
init_filter_states <- function(data, |
|
| 60 |
data_reactive = reactive(NULL), |
|
| 61 |
dataname, |
|
| 62 |
datalabel = NULL, |
|
| 63 |
...) {
|
|
| 64 | 241x |
UseMethod("init_filter_states")
|
| 65 |
} |
|
| 66 | ||
| 67 |
#' @keywords internal |
|
| 68 |
#' @export |
|
| 69 |
init_filter_states.data.frame <- function(data, # nolint |
|
| 70 |
data_reactive = function(sid = "") NULL, |
|
| 71 |
dataname, |
|
| 72 |
datalabel = NULL, |
|
| 73 |
keys = character(0), |
|
| 74 |
...) {
|
|
| 75 | 124x |
DFFilterStates$new( |
| 76 | 124x |
data = data, |
| 77 | 124x |
data_reactive = data_reactive, |
| 78 | 124x |
dataname = dataname, |
| 79 | 124x |
datalabel = datalabel, |
| 80 | 124x |
keys = keys |
| 81 |
) |
|
| 82 |
} |
|
| 83 | ||
| 84 |
#' @keywords internal |
|
| 85 |
#' @export |
|
| 86 |
init_filter_states.matrix <- function(data, # nolint |
|
| 87 |
data_reactive = function(sid = "") NULL, |
|
| 88 |
dataname, |
|
| 89 |
datalabel = NULL, |
|
| 90 |
...) {
|
|
| 91 | 20x |
MatrixFilterStates$new( |
| 92 | 20x |
data = data, |
| 93 | 20x |
data_reactive = data_reactive, |
| 94 | 20x |
dataname = dataname, |
| 95 | 20x |
datalabel = datalabel |
| 96 |
) |
|
| 97 |
} |
|
| 98 | ||
| 99 |
#' @keywords internal |
|
| 100 |
#' @export |
|
| 101 |
init_filter_states.MultiAssayExperiment <- function(data, # nolint |
|
| 102 |
data_reactive = function(sid = "") NULL, |
|
| 103 |
dataname, |
|
| 104 |
datalabel = "subjects", |
|
| 105 |
keys = character(0), |
|
| 106 |
...) {
|
|
| 107 | 20x |
if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
| 108 | ! |
stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
|
| 109 |
} |
|
| 110 | 20x |
MAEFilterStates$new( |
| 111 | 20x |
data = data, |
| 112 | 20x |
data_reactive = data_reactive, |
| 113 | 20x |
dataname = dataname, |
| 114 | 20x |
datalabel = datalabel, |
| 115 | 20x |
keys = keys |
| 116 |
) |
|
| 117 |
} |
|
| 118 | ||
| 119 |
#' @keywords internal |
|
| 120 |
#' @export |
|
| 121 |
init_filter_states.SummarizedExperiment <- function(data, # nolint |
|
| 122 |
data_reactive = function(sid = "") NULL, |
|
| 123 |
dataname, |
|
| 124 |
datalabel = NULL, |
|
| 125 |
...) {
|
|
| 126 | 77x |
if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
|
| 127 | ! |
stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
|
| 128 |
} |
|
| 129 | 77x |
SEFilterStates$new( |
| 130 | 77x |
data = data, |
| 131 | 77x |
data_reactive = data_reactive, |
| 132 | 77x |
dataname = dataname, |
| 133 | 77x |
datalabel = datalabel |
| 134 |
) |
|
| 135 |
} |
|
| 136 | ||
| 137 |
#' Gets supported filterable variable names |
|
| 138 |
#' |
|
| 139 |
#' Gets filterable variable names from a given object. The names match variables |
|
| 140 |
#' of classes in an vector `teal.slice:::.filterable_class`. |
|
| 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. |
|
| 144 |
#' @examples |
|
| 145 |
#' # use non-exported function from teal.slice |
|
| 146 |
#' get_supported_filter_varnames <- getFromNamespace("get_supported_filter_varnames", "teal.slice")
|
|
| 147 |
#' |
|
| 148 |
#' df <- data.frame( |
|
| 149 |
#' a = letters[1:3], |
|
| 150 |
#' b = 1:3, |
|
| 151 |
#' c = Sys.Date() + 1:3, |
|
| 152 |
#' d = Sys.time() + 1:3, |
|
| 153 |
#' z = complex(3) |
|
| 154 |
#' ) |
|
| 155 |
#' get_supported_filter_varnames(df) |
|
| 156 |
#' @keywords internal |
|
| 157 |
#' @export |
|
| 158 |
get_supported_filter_varnames <- function(data) {
|
|
| 159 | 237x |
UseMethod("get_supported_filter_varnames")
|
| 160 |
} |
|
| 161 | ||
| 162 |
#' @keywords internal |
|
| 163 |
#' @export |
|
| 164 |
get_supported_filter_varnames.default <- function(data) { # nolint
|
|
| 165 | 211x |
is_expected_class <- vapply( |
| 166 | 211x |
X = data, |
| 167 | 211x |
FUN = function(x) any(class(x) %in% .filterable_class), |
| 168 | 211x |
FUN.VALUE = logical(1) |
| 169 |
) |
|
| 170 | 211x |
names(is_expected_class[is_expected_class]) |
| 171 |
} |
|
| 172 | ||
| 173 |
#' @keywords internal |
|
| 174 |
#' @export |
|
| 175 |
get_supported_filter_varnames.matrix <- function(data) { # nolint
|
|
| 176 |
# all columns are the same type in matrix |
|
| 177 | 26x |
is_expected_class <- class(data[, 1]) %in% .filterable_class |
| 178 | 26x |
if (is_expected_class && !is.null(colnames(data))) {
|
| 179 | 23x |
colnames(data) |
| 180 |
} else {
|
|
| 181 | 3x |
character(0) |
| 182 |
} |
|
| 183 |
} |
|
| 184 | ||
| 185 |
#' @keywords internal |
|
| 186 |
#' @export |
|
| 187 |
get_supported_filter_varnames.MultiAssayExperiment <- function(data) { # nolint
|
|
| 188 | ! |
data <- SummarizedExperiment::colData(data) |
| 189 |
# all columns are the same type in matrix |
|
| 190 | ! |
is_expected_class <- class(data[, 1]) %in% .filterable_class |
| 191 | ! |
if (is_expected_class && !is.null(names(data))) {
|
| 192 | ! |
names(data) |
| 193 |
} else {
|
|
| 194 | ! |
character(0) |
| 195 |
} |
|
| 196 |
} |
|
| 197 | ||
| 198 |
#' Returns a `choices_labeled` object |
|
| 199 |
#' |
|
| 200 |
#' @param data (`data.frame` or `DFrame` or `list`) |
|
| 201 |
#' where labels can be taken from in case when `varlabels` is not specified. |
|
| 202 |
#' `data` must be specified if `varlabels` is not specified. |
|
| 203 |
#' @param choices (`character`) |
|
| 204 |
#' the vector of chosen variables |
|
| 205 |
#' @param varlabels (`character`) |
|
| 206 |
#' the labels of variables in data |
|
| 207 |
#' @param keys (`character`) |
|
| 208 |
#' the names of the key columns in data |
|
| 209 |
#' @return `character(0)` if choices are empty; a `choices_labeled` object otherwise |
|
| 210 |
#' @keywords internal |
|
| 211 |
data_choices_labeled <- function(data, |
|
| 212 |
choices, |
|
| 213 |
varlabels = teal.data::col_labels(data, fill = TRUE), |
|
| 214 |
keys = character(0)) {
|
|
| 215 | 48x |
if (length(choices) == 0) {
|
| 216 | 6x |
return(character(0)) |
| 217 |
} |
|
| 218 | 42x |
choice_types <- variable_types(data = data, columns = choices) |
| 219 | 42x |
choice_types[keys] <- "primary_key" |
| 220 | ||
| 221 | 42x |
choices_labeled( |
| 222 | 42x |
choices = choices, |
| 223 | 42x |
labels = unname(varlabels[choices]), |
| 224 | 42x |
types = choice_types[choices] |
| 225 |
) |
|
| 226 |
} |
|
| 227 | ||
| 228 |
#' @noRd |
|
| 229 |
#' @keywords internal |
|
| 230 |
get_varlabels <- function(data) {
|
|
| 231 | 40x |
if (!is.array(data)) {
|
| 232 | 39x |
vapply( |
| 233 | 39x |
colnames(data), |
| 234 | 39x |
FUN = function(x) {
|
| 235 | 244x |
label <- attr(data[[x]], "label") |
| 236 | 244x |
if (is.null(label)) {
|
| 237 | 242x |
x |
| 238 |
} else {
|
|
| 239 | 2x |
label |
| 240 |
} |
|
| 241 |
}, |
|
| 242 | 39x |
FUN.VALUE = character(1) |
| 243 |
) |
|
| 244 |
} else {
|
|
| 245 | 1x |
character(0) |
| 246 |
} |
|
| 247 |
} |
| 1 |
# DefaultFilteredDataset ---- |
|
| 2 | ||
| 3 |
#' @name DefaultFilteredDataset |
|
| 4 |
#' @docType class |
|
| 5 |
#' @title `DefaultFilteredDataset` `R6` class |
|
| 6 |
#' |
|
| 7 |
#' @description Stores any object as inert entity. Filtering is not supported. |
|
| 8 |
#' |
|
| 9 |
#' @examples |
|
| 10 |
#' # use non-exported function from teal.slice |
|
| 11 |
#' DefaultFilteredDataset <- getFromNamespace("DefaultFilteredDataset", "teal.slice")
|
|
| 12 |
#' |
|
| 13 |
#' library(shiny) |
|
| 14 |
#' |
|
| 15 |
#' ds <- DefaultFilteredDataset$new(letters, "letters") |
|
| 16 |
#' isolate(ds$get_filter_state()) |
|
| 17 |
#' isolate(ds$get_call()) |
|
| 18 |
#' |
|
| 19 |
#' @keywords internal |
|
| 20 |
#' |
|
| 21 |
DefaultFilteredDataset <- R6::R6Class( # nolint |
|
| 22 |
classname = "DefaultFilteredDataset", |
|
| 23 |
inherit = FilteredDataset, |
|
| 24 | ||
| 25 |
# public methods ---- |
|
| 26 |
public = list( |
|
| 27 | ||
| 28 |
#' @description |
|
| 29 |
#' Initializes this `DefaultFilteredDataset` object. |
|
| 30 |
#' |
|
| 31 |
#' @param dataset |
|
| 32 |
#' any type of object; will not be filtered. |
|
| 33 |
#' @param dataname (`character(1)`) |
|
| 34 |
#' syntactically valid name given to the dataset. |
|
| 35 |
#' @param label (`character(1)`) |
|
| 36 |
#' label to describe the dataset. |
|
| 37 |
#' |
|
| 38 |
#' @return Object of class `DefaultFilteredDataset`, invisibly. |
|
| 39 |
#' |
|
| 40 |
initialize = function(dataset, dataname, label = character(0)) {
|
|
| 41 | 25x |
super$initialize(dataset = dataset, dataname = dataname, label = label) |
| 42 |
}, |
|
| 43 | ||
| 44 |
#' @description |
|
| 45 |
#' Returns a formatted string representing this `DefaultFilteredDataset` object. |
|
| 46 |
#' |
|
| 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 |
#' @return The formatted string. |
|
| 51 |
#' |
|
| 52 |
format = function(show_all, trim_lines = FALSE) {
|
|
| 53 | 4x |
class_string <- toString(class(private$dataset)) |
| 54 | 4x |
if (trim_lines) {
|
| 55 | 2x |
trim_position <- 37L |
| 56 | 2x |
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 |
}, |
|
| 61 | ||
| 62 |
#' @param sid (`character(1)`) for method consistency, ignored. |
|
| 63 |
#' @return `NULL`, invisibly. |
|
| 64 |
get_call = function(sid) {
|
|
| 65 | 1x |
invisible(NULL) |
| 66 |
}, |
|
| 67 |
#' @return `NULL`, invisibly. |
|
| 68 |
get_filter_state = function() {
|
|
| 69 | 2x |
invisible(NULL) |
| 70 |
}, |
|
| 71 |
#' @param state (`teal_slices`) for method consistency, ignored. |
|
| 72 |
#' @return `NULL`, invisibly. |
|
| 73 |
set_filter_state = function(state) {
|
|
| 74 | 3x |
if (length(state) != 0L) {
|
| 75 | 1x |
warning("DefaultFilterState cannot set state")
|
| 76 |
} |
|
| 77 | 3x |
invisible(NULL) |
| 78 |
}, |
|
| 79 |
#' @param force (`logical(1)`) for method consistency, ignored. |
|
| 80 |
#' @return `NULL`, invisibly. |
|
| 81 |
clear_filter_states = function(force) {
|
|
| 82 | 1x |
invisible(NULL) |
| 83 |
}, |
|
| 84 | ||
| 85 |
#' @description |
|
| 86 |
#' Creates row for filter overview in the form of \cr |
|
| 87 |
#' `dataname` - unsupported data class |
|
| 88 |
#' @return A `data.frame`. |
|
| 89 |
get_filter_overview = function() {
|
|
| 90 | 2x |
data.frame(dataname = private$dataname, obs = NA, obs_filtered = NA) |
| 91 |
}, |
|
| 92 | ||
| 93 |
# shiny modules ---- |
|
| 94 | ||
| 95 |
#' @description |
|
| 96 |
#' Overwrites parent method. |
|
| 97 |
#' @details |
|
| 98 |
#' Blank UI module that would list active filter states for this dataset. |
|
| 99 |
#' @param id (`character(1)`) |
|
| 100 |
#' `shiny` module instance id. |
|
| 101 |
#' @param allow_add (ignored) |
|
| 102 |
#' @return An empty `div`. |
|
| 103 |
ui_active = function(id, allow_add) {
|
|
| 104 | ! |
ns <- NS(id) |
| 105 | ! |
tags$div() |
| 106 |
}, |
|
| 107 | ||
| 108 |
#' @description |
|
| 109 |
#' Overwrites parent method. |
|
| 110 |
#' @details |
|
| 111 |
#' Blank UI module that would list active filter states for this dataset. |
|
| 112 |
#' @param id (`character(1)`) |
|
| 113 |
#' `shiny` module instance id. |
|
| 114 |
#' @return An empty `div`. |
|
| 115 |
ui_add = function(id) {
|
|
| 116 | ! |
ns <- NS(id) |
| 117 | ! |
tags$div() |
| 118 |
} |
|
| 119 |
), |
|
| 120 |
private = list( |
|
| 121 |
# private methods ---- |
|
| 122 |
# private fields ---- |
|
| 123 |
) |
|
| 124 |
) |
| 1 |
#' Set "`<choice>:<label>`" type of names |
|
| 2 |
#' |
|
| 3 |
#' @description |
|
| 4 |
#' |
|
| 5 |
#' This is often useful for as it marks up the drop-down boxes for [shiny::selectInput()]. |
|
| 6 |
#' |
|
| 7 |
#' @details |
|
| 8 |
#' If either `choices` or `labels` are factors, they are coerced to character. |
|
| 9 |
#' Duplicated elements from `choices` get removed. |
|
| 10 |
#' |
|
| 11 |
#' @param choices (`character` or `numeric` or `logical`) vector |
|
| 12 |
#' @param labels (`character`) vector containing labels to be applied to `choices`. If `NA` then |
|
| 13 |
#' "Label Missing" will be used. |
|
| 14 |
#' @param types vector containing the types of the columns. |
|
| 15 |
#' |
|
| 16 |
#' @return A named character vector. |
|
| 17 |
#' |
|
| 18 |
#' @keywords internal |
|
| 19 |
#' |
|
| 20 |
choices_labeled <- function(choices, labels, types = NULL) {
|
|
| 21 | 42x |
checkmate::assert_character(choices) |
| 22 | 42x |
checkmate::assert_character(labels[!is.na(labels)], len = length(choices)) |
| 23 | 39x |
checkmate::assert_character(types, len = length(choices), null.ok = TRUE) |
| 24 | ||
| 25 | 39x |
is_dupl <- duplicated(choices) |
| 26 | 39x |
choices <- choices[!is_dupl] |
| 27 | 39x |
labels <- labels[!is_dupl] |
| 28 | 39x |
types <- types[!is_dupl] |
| 29 | 39x |
labels[is.na(labels)] <- "Label Missing" |
| 30 | 39x |
raw_labels <- labels |
| 31 | 39x |
combined_labels <- if (length(choices) > 0) {
|
| 32 | 39x |
paste0(choices, ": ", labels) |
| 33 |
} else {
|
|
| 34 | ! |
character(0) |
| 35 |
} |
|
| 36 | ||
| 37 | 39x |
choices <- structure( |
| 38 | 39x |
choices, |
| 39 | 39x |
names = combined_labels, |
| 40 | 39x |
raw_labels = raw_labels, |
| 41 | 39x |
combined_labels = combined_labels, |
| 42 | 39x |
class = c("choices_labeled", "character"),
|
| 43 | 39x |
types = types |
| 44 |
) |
|
| 45 | ||
| 46 | 39x |
choices |
| 47 |
} |
| 1 |
.onLoad <- function(libname, pkgname) { # nolint
|
|
| 2 |
# adapted from https://github.com/r-lib/devtools/blob/master/R/zzz.R |
|
| 3 | ! |
teal_default_options <- list(teal.threshold_slider_vs_checkboxgroup = 5) |
| 4 | ! |
op <- options() |
| 5 | ! |
toset <- !(names(teal_default_options) %in% names(op)) |
| 6 | ! |
if (any(toset)) options(teal_default_options[toset]) |
| 7 | ||
| 8 |
# Set up the teal logger instance |
|
| 9 | ! |
teal.logger::register_logger("teal.slice")
|
| 10 | ! |
teal.logger::register_handlers("teal.slice")
|
| 11 | ||
| 12 | ! |
invisible() |
| 13 |
} |
|
| 14 | ||
| 15 |
### GLOBAL VARIABLES ### |
|
| 16 | ||
| 17 |
.filterable_class <- c("logical", "integer", "numeric", "factor", "character", "Date", "POSIXct", "POSIXlt")
|
|
| 18 | ||
| 19 | ||
| 20 |
### END GLOBAL VARIABLES ### |
|
| 21 | ||
| 22 | ||
| 23 |
### ENSURE CHECK PASSES |
|
| 24 | ||
| 25 |
# This function is necessary for check to properly process code dependencies within R6 classes. |
|
| 26 |
# If `package` is listed in `Imports` in `DESCRIPTION`, |
|
| 27 |
# (1) check goes through `NAMESPACE` looking for any `importFrom(package,<foo>)` statements |
|
| 28 |
# or an `import(package)` statement. If none are found, |
|
| 29 |
# (2) check looks for `package::*` calls in the code. If none are found again, |
|
| 30 |
# (3) check throws a NOTE; |
|
| 31 |
# # Namespaces in Imports field not imported from: |
|
| 32 |
# # 'package' |
|
| 33 |
# # All declared Imports should be used. |
|
| 34 |
# This note is banned by our CI. |
|
| 35 |
# When package::* statements are made within an R6 class, they are not registered. |
|
| 36 |
# This function provides single references to the imported namespaces for check to notice. |
|
| 37 |
.rectify_dependencies_check <- function() {
|
|
| 38 | ! |
dplyr::filter |
| 39 | ! |
grDevices::rgb |
| 40 | ! |
htmltools::tagInsertChildren |
| 41 | ! |
logger::log_debug |
| 42 | ! |
plotly::plot_ly |
| 43 | ! |
shinycssloaders::withSpinner |
| 44 | ! |
shinyWidgets::pickerOptions |
| 45 | ! |
teal.data::datanames |
| 46 | ! |
teal.widgets::optionalSelectInput |
| 47 |
} |
|
| 48 | ||
| 49 | ||
| 50 |
### END ENSURE CHECK PASSES |
| 1 |
# FilterStateExpr ------ |
|
| 2 | ||
| 3 |
#' @name FilterStateExpr |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterStateExpr` `R6` class |
|
| 7 |
#' |
|
| 8 |
#' @description Sister class to `FilterState` that handles arbitrary filter expressions. |
|
| 9 |
#' |
|
| 10 |
#' @details |
|
| 11 |
#' Creates a filter state around a predefined condition call (logical predicate). |
|
| 12 |
#' The condition call is independent of the data |
|
| 13 |
#' and the filter card allows no interaction (the filter is always fixed). |
|
| 14 |
#' |
|
| 15 |
#' @examples |
|
| 16 |
#' # use non-exported function from teal.slice |
|
| 17 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 18 |
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 19 |
#' FilterStateExpr <- getFromNamespace("FilterStateExpr", "teal.slice")
|
|
| 20 |
#' |
|
| 21 |
#' filter_state <- FilterStateExpr$new( |
|
| 22 |
#' slice = teal_slice( |
|
| 23 |
#' dataname = "x", |
|
| 24 |
#' id = "FA", |
|
| 25 |
#' title = "Adult females", |
|
| 26 |
#' expr = "sex == 'F' & age >= 18" |
|
| 27 |
#' ) |
|
| 28 |
#' ) |
|
| 29 |
#' filter_state$get_call() |
|
| 30 |
#' |
|
| 31 |
#' # working filter in an app |
|
| 32 |
#' library(shiny) |
|
| 33 |
#' library(shinyjs) |
|
| 34 |
#' |
|
| 35 |
#' ui <- fluidPage( |
|
| 36 |
#' useShinyjs(), |
|
| 37 |
#' include_css_files(pattern = "filter-panel"), |
|
| 38 |
#' include_js_files(pattern = "count-bar-labels"), |
|
| 39 |
#' bslib::layout_column_wrap( |
|
| 40 |
#' style = htmltools::css(grid_template_columns = "1fr 2fr"), |
|
| 41 |
#' tags$div( |
|
| 42 |
#' tags$h4("ChoicesFilterState"),
|
|
| 43 |
#' filter_state$ui("fs")
|
|
| 44 |
#' ), |
|
| 45 |
#' tags$div( |
|
| 46 |
#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
|
|
| 47 |
#' textOutput("condition_choices"), tags$br(),
|
|
| 48 |
#' tags$h4("Unformatted state"), # display raw filter state
|
|
| 49 |
#' textOutput("unformatted_choices"), tags$br(),
|
|
| 50 |
#' tags$h4("Formatted state"), # display human readable filter state
|
|
| 51 |
#' textOutput("formatted_choices"), tags$br()
|
|
| 52 |
#' ) |
|
| 53 |
#' ) |
|
| 54 |
#' ) |
|
| 55 |
#' |
|
| 56 |
#' server <- function(input, output, session) {
|
|
| 57 |
#' filter_state$server("fs")
|
|
| 58 |
#' output$condition_choices <- renderPrint(filter_state$get_call()) |
|
| 59 |
#' output$formatted_choices <- renderText(filter_state$format()) |
|
| 60 |
#' output$unformatted_choices <- renderPrint(filter_state$get_state()) |
|
| 61 |
#' } |
|
| 62 |
#' |
|
| 63 |
#' if (interactive()) {
|
|
| 64 |
#' shinyApp(ui, server) |
|
| 65 |
#' } |
|
| 66 |
#' |
|
| 67 |
#' @keywords internal |
|
| 68 |
#' |
|
| 69 |
FilterStateExpr <- R6::R6Class( # nolint |
|
| 70 |
classname = "FilterStateExpr", |
|
| 71 |
# public methods ---- |
|
| 72 |
public = list( |
|
| 73 |
#' @description |
|
| 74 |
#' Initialize a `FilterStateExpr` object. |
|
| 75 |
#' @param slice (`teal_slice_expr`) |
|
| 76 |
#' @return Object of class `FilterStateExpr`, invisibly. |
|
| 77 |
#' |
|
| 78 |
initialize = function(slice) {
|
|
| 79 | 22x |
checkmate::assert_class(slice, "teal_slice_expr") |
| 80 | 21x |
private$teal_slice <- slice |
| 81 | 21x |
invisible(self) |
| 82 |
}, |
|
| 83 | ||
| 84 |
#' @description Destroys a `FilterStateExpr` object. |
|
| 85 | 4x |
destroy = function() private$finalize(), |
| 86 | ||
| 87 |
#' @description |
|
| 88 |
#' Returns a formatted string representing this `FilterStateExpr` object. |
|
| 89 |
#' |
|
| 90 |
#' @param show_all (`logical(1)`) passed to `format.teal_slice` |
|
| 91 |
#' @param trim_lines (`logical(1)`) passed to `format.teal_slice` |
|
| 92 |
#' |
|
| 93 |
#' @return `character(1)` the formatted string |
|
| 94 |
#' |
|
| 95 |
format = function(show_all = FALSE, trim_lines = TRUE) {
|
|
| 96 | 12x |
sprintf( |
| 97 | 12x |
"%s:\n%s", |
| 98 | 12x |
class(self)[1], |
| 99 | 12x |
format(self$get_state(), show_all = show_all, trim_lines = trim_lines) |
| 100 |
) |
|
| 101 |
}, |
|
| 102 | ||
| 103 |
#' @description |
|
| 104 |
#' Prints this `FilterStateExpr` object. |
|
| 105 |
#' @param ... arguments passed to the `format` method |
|
| 106 |
#' @return `NULL`, invisibly. |
|
| 107 |
#' |
|
| 108 |
print = function(...) {
|
|
| 109 | 1x |
cat(isolate(self$format(...))) |
| 110 |
}, |
|
| 111 | ||
| 112 |
#' @description |
|
| 113 |
#' Returns a complete description of this filter state. |
|
| 114 |
#' |
|
| 115 |
#' @return A `teal_slice` object. |
|
| 116 |
#' |
|
| 117 |
get_state = function() {
|
|
| 118 | 132x |
private$teal_slice |
| 119 |
}, |
|
| 120 | ||
| 121 |
#' @description |
|
| 122 |
#' Does nothing. Exists for compatibility. |
|
| 123 |
#' |
|
| 124 |
#' @param state (`teal_slice`) |
|
| 125 |
#' |
|
| 126 |
#' @return `self`, invisibly. |
|
| 127 |
#' |
|
| 128 |
set_state = function(state) {
|
|
| 129 | 1x |
checkmate::assert_class(state, "teal_slice_expr") |
| 130 | 1x |
invisible(self) |
| 131 |
}, |
|
| 132 | ||
| 133 |
#' @description |
|
| 134 |
#' Get reproducible call. |
|
| 135 |
#' |
|
| 136 |
#' @param dataname (`ignored`) for a consistency with `FilterState` |
|
| 137 |
#' |
|
| 138 |
#' Returns reproducible condition call for current selection relevant |
|
| 139 |
#' for selected variable type. |
|
| 140 |
#' Method is using internal reactive values which makes it reactive |
|
| 141 |
#' and must be executed in reactive or isolated context. |
|
| 142 |
#' |
|
| 143 |
#' @return `call` or `NULL` |
|
| 144 |
#' |
|
| 145 |
get_call = function(dataname) {
|
|
| 146 | 3x |
isolate(str2lang(private$teal_slice$expr)) |
| 147 |
}, |
|
| 148 | ||
| 149 |
# public shiny modules ---- |
|
| 150 | ||
| 151 |
#' @description |
|
| 152 |
#' `shiny` module server. |
|
| 153 |
#' |
|
| 154 |
#' @param id (`character(1)`) |
|
| 155 |
#' `shiny` module instance id. |
|
| 156 |
#' |
|
| 157 |
#' @param remove_callback (`function`) |
|
| 158 |
#' callback to handle removal of this `FilterState` object from `state_list` |
|
| 159 |
#' |
|
| 160 |
#' @return Reactive expression signaling that the remove button has been clicked. |
|
| 161 |
#' |
|
| 162 |
server = function(id, remove_callback) {
|
|
| 163 | 7x |
moduleServer( |
| 164 | 7x |
id = id, |
| 165 | 7x |
function(input, output, session) {
|
| 166 | 7x |
private$server_summary("summary")
|
| 167 | ||
| 168 | 7x |
private$session_bindings[[session$ns("remove")]] <- observeEvent(
|
| 169 | 7x |
once = TRUE, # remove button can be called once, should be destroyed afterwards |
| 170 | 7x |
ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI |
| 171 | 7x |
eventExpr = input$remove, # when remove button is clicked in the FilterState ui |
| 172 | 7x |
handlerExpr = remove_callback() |
| 173 |
) |
|
| 174 | ||
| 175 | 7x |
private$session_bindings[[session$ns("inputs")]] <- list(
|
| 176 | 7x |
destroy = function() {
|
| 177 | 6x |
logger::log_debug("Destroying FilterState inputs and observers; id: { private$get_id() }")
|
| 178 | 6x |
lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove) |
| 179 |
} |
|
| 180 |
) |
|
| 181 | ||
| 182 | 7x |
NULL |
| 183 |
} |
|
| 184 |
) |
|
| 185 |
}, |
|
| 186 | ||
| 187 |
#' @description |
|
| 188 |
#' `shiny` module UI. |
|
| 189 |
#' The UI for this class contains simple message stating that it is not supported. |
|
| 190 |
#' @param id (`character(1)`) |
|
| 191 |
#' `shiny` module instance id. |
|
| 192 |
#' @param parent_id (`character(1)`) |
|
| 193 |
#' id of the `FilterStates` card container. |
|
| 194 |
ui = function(id, parent_id = "cards") {
|
|
| 195 | 7x |
ns <- NS(id) |
| 196 | 7x |
isolate({
|
| 197 | 7x |
tags$div( |
| 198 | 7x |
id = id, |
| 199 | 7x |
class = "teal-slice filter-card", |
| 200 | 7x |
include_js_files("count-bar-labels.js"),
|
| 201 | 7x |
tags$div( |
| 202 | 7x |
class = "filter-card-header", |
| 203 | 7x |
tags$div( |
| 204 | 7x |
class = "teal-slice filter-card-title", |
| 205 | 7x |
if (private$is_anchored()) {
|
| 206 | 1x |
icon("anchor-lock", class = "teal-slice filter-card-icon")
|
| 207 |
} else {
|
|
| 208 | 6x |
icon("lock", class = "teal-slice filter-card-icon")
|
| 209 |
}, |
|
| 210 | 7x |
tags$div(class = "teal-slice filter-card-varname", tags$strong(private$teal_slice$id)), |
| 211 | 7x |
tags$div(class = "teal-slice filter-card-varlabel", private$teal_slice$title), |
| 212 | 7x |
tags$div( |
| 213 | 7x |
class = "teal-slice filter-card-controls", |
| 214 | 7x |
if (isFALSE(private$is_anchored())) {
|
| 215 | 6x |
actionLink( |
| 216 | 6x |
inputId = ns("remove"),
|
| 217 | 6x |
label = icon("circle-xmark", lib = "font-awesome"),
|
| 218 | 6x |
title = "Remove filter", |
| 219 | 6x |
class = "filter-card-remove" |
| 220 |
) |
|
| 221 |
} |
|
| 222 |
) |
|
| 223 |
), |
|
| 224 | 7x |
tags$div( |
| 225 | 7x |
class = "teal-slice filter-card-summary", |
| 226 | 7x |
private$ui_summary(ns("summary"))
|
| 227 |
) |
|
| 228 |
) |
|
| 229 |
) |
|
| 230 |
}) |
|
| 231 |
} |
|
| 232 |
), |
|
| 233 | ||
| 234 |
# private members ---- |
|
| 235 | ||
| 236 |
private = list( |
|
| 237 |
session_bindings = list(), # stores observers and inputs to destroy afterwards |
|
| 238 |
teal_slice = NULL, # stores reactiveValues |
|
| 239 | ||
| 240 |
# @description |
|
| 241 |
# Get id of the teal_slice. |
|
| 242 |
# @return `character(1)` |
|
| 243 |
get_id = function() {
|
|
| 244 | ! |
isolate(private$teal_slice$id) |
| 245 |
}, |
|
| 246 | ||
| 247 |
# Check whether this filter is anchored (cannot be removed). |
|
| 248 |
# @return `logical(1)` |
|
| 249 |
is_anchored = function() {
|
|
| 250 | 14x |
isolate(isTRUE(private$teal_slice$anchored)) |
| 251 |
}, |
|
| 252 | ||
| 253 |
# @description |
|
| 254 |
# Server module to display filter summary |
|
| 255 |
# @param id `shiny` id parameter |
|
| 256 |
ui_summary = function(id) {
|
|
| 257 | 7x |
ns <- NS(id) |
| 258 | 7x |
uiOutput(ns("summary"), class = "teal-slice filter-card-summary")
|
| 259 |
}, |
|
| 260 | ||
| 261 |
# @description |
|
| 262 |
# UI module to display filter summary |
|
| 263 |
# @param shiny `id` parameter passed to moduleServer |
|
| 264 |
# renders text describing current state |
|
| 265 |
server_summary = function(id) {
|
|
| 266 | 7x |
moduleServer( |
| 267 | 7x |
id = id, |
| 268 | 7x |
function(input, output, session) {
|
| 269 | 7x |
output$summary <- renderUI(private$content_summary()) |
| 270 |
} |
|
| 271 |
) |
|
| 272 |
}, |
|
| 273 |
content_summary = function() {
|
|
| 274 | 7x |
isolate(private$teal_slice$expr) |
| 275 |
}, |
|
| 276 | ||
| 277 |
# @description |
|
| 278 |
# Destroy inputs and observers stored in `private$session_bindings`. |
|
| 279 |
# |
|
| 280 |
# @return `NULL`, invisibly. |
|
| 281 |
# |
|
| 282 |
finalize = function() {
|
|
| 283 | 25x |
.finalize_session_bindings(self, private) |
| 284 |
} |
|
| 285 |
) |
|
| 286 |
) |
| 1 |
#' Compose predicates |
|
| 2 |
#' |
|
| 3 |
#' Combines calls with a logical operator. |
|
| 4 |
#' |
|
| 5 |
#' This function is used to combine logical predicates produced by `FilterState` objects |
|
| 6 |
#' to build a complete subset expression. |
|
| 7 |
#' |
|
| 8 |
#' @param calls (`list`) |
|
| 9 |
#' containing calls (or symbols) to be combined by `operator` |
|
| 10 |
#' @param operator (`character(1)`) |
|
| 11 |
#' infix operator to use in predicate composition, _e.g._ `"&"` |
|
| 12 |
#' |
|
| 13 |
#' @return |
|
| 14 |
#' A `call` where elements of `calls` are composed with `operator` or `NULL` if `calls` is an empty list. |
|
| 15 |
#' |
|
| 16 |
#' @examples |
|
| 17 |
#' # use non-exported function from teal.slice |
|
| 18 |
#' calls_combine_by <- getFromNamespace("calls_combine_by", "teal.slice")
|
|
| 19 |
#' |
|
| 20 |
#' calls <- list( |
|
| 21 |
#' quote(SEX == "F"), # subsetting on factor |
|
| 22 |
#' quote(AGE >= 20 & AGE <= 50), # subsetting on range |
|
| 23 |
#' quote(!SURV) # subsetting on logical |
|
| 24 |
#' ) |
|
| 25 |
#' calls_combine_by(calls, "&") |
|
| 26 |
#' |
|
| 27 |
#' @keywords internal |
|
| 28 |
#' |
|
| 29 |
calls_combine_by <- function(calls, operator) {
|
|
| 30 | 51x |
checkmate::assert_list(calls) |
| 31 | 49x |
if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
|
| 32 | 50x |
checkmate::assert_string(operator) |
| 33 | ||
| 34 | 48x |
Reduce( |
| 35 | 48x |
x = calls, |
| 36 | 48x |
f = function(x, y) call(operator, x, y) |
| 37 |
) |
|
| 38 |
} |
| 1 |
#' Get classes of selected columns from dataset |
|
| 2 |
#' |
|
| 3 |
#' @param data (`data.frame` or `DataFrame` or `matrix`) Object in which to determine variable types. |
|
| 4 |
#' @param columns (`character`) Vector of columns in `data` for which to get types. |
|
| 5 |
#' Set to `NULL` to get types of all columns. |
|
| 6 |
#' |
|
| 7 |
#' @return Character vector of classes of `columns` from provided `data`. |
|
| 8 |
#' |
|
| 9 |
#' @examples |
|
| 10 |
#' # use non-exported function from teal.slice |
|
| 11 |
#' variable_types <- getFromNamespace("variable_types", "teal.slice")
|
|
| 12 |
#' |
|
| 13 |
#' variable_types( |
|
| 14 |
#' data.frame( |
|
| 15 |
#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
|
|
| 16 |
#' stringsAsFactors = FALSE |
|
| 17 |
#' ), |
|
| 18 |
#' "x" |
|
| 19 |
#' ) |
|
| 20 |
#' |
|
| 21 |
#' variable_types( |
|
| 22 |
#' data.frame( |
|
| 23 |
#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
|
|
| 24 |
#' stringsAsFactors = FALSE |
|
| 25 |
#' ), |
|
| 26 |
#' c("x", "z")
|
|
| 27 |
#' ) |
|
| 28 |
#' |
|
| 29 |
#' variable_types( |
|
| 30 |
#' data.frame( |
|
| 31 |
#' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
|
|
| 32 |
#' stringsAsFactors = FALSE |
|
| 33 |
#' ) |
|
| 34 |
#' ) |
|
| 35 |
#' |
|
| 36 |
#' @keywords internal |
|
| 37 |
#' |
|
| 38 |
variable_types <- function(data, columns = NULL) {
|
|
| 39 | 42x |
checkmate::assert_multi_class(data, c("data.frame", "DataFrame", "matrix"))
|
| 40 | 42x |
checkmate::assert_character(columns, any.missing = FALSE, null.ok = TRUE) |
| 41 | 42x |
checkmate::assert_subset(columns, colnames(data)) |
| 42 | ||
| 43 | 42x |
if (is.matrix(data)) {
|
| 44 | 1x |
type <- typeof(data) |
| 45 | 1x |
if (type == "double") type <- "numeric" |
| 46 | 1x |
types <- |
| 47 | 1x |
if (is.null(columns)) {
|
| 48 | ! |
stats::setNames(rep_len(type, ncol(data)), nm = colnames(data)) |
| 49 |
} else {
|
|
| 50 | 1x |
stats::setNames(rep_len(type, length(columns)), nm = columns) |
| 51 |
} |
|
| 52 |
} else {
|
|
| 53 | 41x |
types <- vapply(data, function(x) class(x)[1L], character(1L)) |
| 54 | 41x |
if (!is.null(columns)) types <- types[columns] |
| 55 |
# alternative after R 4.4.0: `types <- types[columns %||% TRUE]` |
|
| 56 |
} |
|
| 57 | 42x |
types |
| 58 |
} |
| 1 |
# MatrixFilterStates ------ |
|
| 2 | ||
| 3 |
#' @name MatrixFilterStates |
|
| 4 |
#' @docType class |
|
| 5 |
#' @title `FilterStates` subclass for matrices |
|
| 6 |
#' @description Handles filter states in a `matrix`. |
|
| 7 |
#' @keywords internal |
|
| 8 |
#' |
|
| 9 |
MatrixFilterStates <- R6::R6Class( # nolint |
|
| 10 |
classname = "MatrixFilterStates", |
|
| 11 |
inherit = FilterStates, |
|
| 12 | ||
| 13 |
# public methods ---- |
|
| 14 |
public = list( |
|
| 15 |
#' @description |
|
| 16 |
#' Initialize `MatrixFilterStates` object. |
|
| 17 |
#' |
|
| 18 |
#' @param data (`matrix`) |
|
| 19 |
#' the `R` object which `subset` function is applied on. |
|
| 20 |
#' @param data_reactive (`function(sid)`) |
|
| 21 |
#' should return a `matrix` object or `NULL`. |
|
| 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. |
|
| 24 |
#' Function has to have `sid` argument being a character. |
|
| 25 |
#' @param dataname (`character(1)`) |
|
| 26 |
#' name of the data used in the subset expression. |
|
| 27 |
#' Passed to the function argument attached to this `FilterStates`. |
|
| 28 |
#' @param datalabel (`character(1)`) optional |
|
| 29 |
#' text label. Should be a name of experiment. |
|
| 30 |
#' |
|
| 31 |
initialize = function(data, |
|
| 32 |
data_reactive = function(sid = "") NULL, |
|
| 33 |
dataname, |
|
| 34 |
datalabel = NULL) {
|
|
| 35 | 24x |
checkmate::assert_matrix(data) |
| 36 | 23x |
super$initialize(data, data_reactive, dataname, datalabel) |
| 37 | 23x |
private$set_filterable_varnames(include_varnames = colnames(private$data)) |
| 38 | 23x |
if (!is.null(datalabel)) {
|
| 39 | 19x |
private$dataname_prefixed <- sprintf( |
| 40 | 19x |
"%s[['%s']]", private$dataname_prefixed, datalabel |
| 41 |
) |
|
| 42 |
} |
|
| 43 |
} |
|
| 44 |
), |
|
| 45 |
private = list( |
|
| 46 |
extract_type = "matrix" |
|
| 47 |
) |
|
| 48 |
) |
| 1 |
#' Initialize `FilteredDataset` |
|
| 2 |
#' |
|
| 3 |
#' Initializes a `FilteredDataset` object corresponding to the class of the filtered dataset. |
|
| 4 |
#' |
|
| 5 |
#' @param dataset any object |
|
| 6 |
#' @param dataname (`character(1)`) |
|
| 7 |
#' syntactically valid name given to the dataset. |
|
| 8 |
#' @param keys (`character`) optional |
|
| 9 |
#' vector of primary key column names. |
|
| 10 |
#' @param parent_name (`character(1)`) |
|
| 11 |
#' name of the parent dataset. |
|
| 12 |
#' @param parent (`reactive`) |
|
| 13 |
#' that returns a filtered `data.frame` from other `FilteredDataset` named `parent_name`. |
|
| 14 |
#' Passing `parent` results in a `reactive` link that causes re-filtering of this `dataset` |
|
| 15 |
#' based on the changes in `parent`. |
|
| 16 |
#' @param join_keys (`character`) |
|
| 17 |
#' 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 |
#' @param label (`character(1)`) |
|
| 20 |
#' label to describe the dataset. |
|
| 21 |
#' |
|
| 22 |
#' @return Object of class `FilteredDataset`. |
|
| 23 |
#' |
|
| 24 |
#' @section Warning: |
|
| 25 |
#' This function is exported to allow other packages to extend `teal.slice` but it is treated as internal. |
|
| 26 |
#' Breaking changes may occur without warning. |
|
| 27 |
#' We recommend consulting the package maintainer before using it. |
|
| 28 |
#' |
|
| 29 |
#' @examples |
|
| 30 |
#' # DataframeFilteredDataset example |
|
| 31 |
#' library(shiny) |
|
| 32 |
#' |
|
| 33 |
#' iris_fd <- init_filtered_dataset(iris, dataname = "iris") |
|
| 34 |
#' ui <- bslib::page_fluid( |
|
| 35 |
#' iris_fd$ui_add(id = "add"), |
|
| 36 |
#' iris_fd$ui_active("dataset"),
|
|
| 37 |
#' verbatimTextOutput("call")
|
|
| 38 |
#' ) |
|
| 39 |
#' server <- function(input, output, session) {
|
|
| 40 |
#' iris_fd$srv_add(id = "add") |
|
| 41 |
#' iris_fd$srv_active(id = "dataset") |
|
| 42 |
#' |
|
| 43 |
#' output$call <- renderText({
|
|
| 44 |
#' paste( |
|
| 45 |
#' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"), |
|
| 46 |
#' collapse = "\n" |
|
| 47 |
#' ) |
|
| 48 |
#' }) |
|
| 49 |
#' } |
|
| 50 |
#' if (interactive()) {
|
|
| 51 |
#' shinyApp(ui, server) |
|
| 52 |
#' } |
|
| 53 |
#' |
|
| 54 |
#' @examples |
|
| 55 |
#' \donttest{
|
|
| 56 |
#' if (requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
|
| 57 |
#' # MAEFilteredDataset example |
|
| 58 |
#' library(shiny) |
|
| 59 |
#' |
|
| 60 |
#' data(miniACC, package = "MultiAssayExperiment") |
|
| 61 |
#' |
|
| 62 |
#' MAE_fd <- init_filtered_dataset(miniACC, "MAE") |
|
| 63 |
#' ui <- fluidPage( |
|
| 64 |
#' MAE_fd$ui_add(id = "add"), |
|
| 65 |
#' MAE_fd$ui_active("dataset"),
|
|
| 66 |
#' verbatimTextOutput("call")
|
|
| 67 |
#' ) |
|
| 68 |
#' server <- function(input, output, session) {
|
|
| 69 |
#' MAE_fd$srv_add(id = "add") |
|
| 70 |
#' MAE_fd$srv_active(id = "dataset") |
|
| 71 |
#' output$call <- renderText({
|
|
| 72 |
#' paste( |
|
| 73 |
#' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"), |
|
| 74 |
#' collapse = "\n" |
|
| 75 |
#' ) |
|
| 76 |
#' }) |
|
| 77 |
#' } |
|
| 78 |
#' if (interactive()) {
|
|
| 79 |
#' shinyApp(ui, server) |
|
| 80 |
#' } |
|
| 81 |
#' } |
|
| 82 |
#' } |
|
| 83 |
#' @keywords internal |
|
| 84 |
#' @export |
|
| 85 |
init_filtered_dataset <- function(dataset, |
|
| 86 |
dataname, |
|
| 87 |
keys = character(0), |
|
| 88 |
parent_name = character(0), |
|
| 89 |
parent = reactive(dataset), |
|
| 90 |
join_keys = character(0), |
|
| 91 |
label = attr(dataset, "label", exact = TRUE)) {
|
|
| 92 | 130x |
UseMethod("init_filtered_dataset")
|
| 93 |
} |
|
| 94 | ||
| 95 |
#' @keywords internal |
|
| 96 |
#' @export |
|
| 97 |
init_filtered_dataset.data.frame <- function(dataset, |
|
| 98 |
dataname, |
|
| 99 |
keys = character(0), |
|
| 100 |
parent_name = character(0), |
|
| 101 |
parent = NULL, |
|
| 102 |
join_keys = character(0), |
|
| 103 |
label = attr(dataset, "label", exact = TRUE)) {
|
|
| 104 | 107x |
DataframeFilteredDataset$new( |
| 105 | 107x |
dataset = dataset, |
| 106 | 107x |
dataname = dataname, |
| 107 | 107x |
keys = keys, |
| 108 | 107x |
parent_name = parent_name, |
| 109 | 107x |
parent = parent, |
| 110 | 107x |
join_keys = join_keys, |
| 111 | 107x |
label = label |
| 112 |
) |
|
| 113 |
} |
|
| 114 | ||
| 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 | 5x |
if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
|
| 125 | ! |
stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
|
| 126 |
} |
|
| 127 | 5x |
MAEFilteredDataset$new( |
| 128 | 5x |
dataset = dataset, |
| 129 | 5x |
dataname = dataname, |
| 130 | 5x |
keys = keys, |
| 131 | 5x |
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 | 18x |
DefaultFilteredDataset$new( |
| 145 | 18x |
dataset = dataset, |
| 146 | 18x |
dataname = dataname, |
| 147 | 18x |
label = label |
| 148 |
) |
|
| 149 |
} |
| 1 |
# DFFilterStates ------ |
|
| 2 | ||
| 3 |
#' @name DFFilterStates |
|
| 4 |
#' @docType class |
|
| 5 |
#' |
|
| 6 |
#' @title `FilterStates` subclass for data frames |
|
| 7 |
#' |
|
| 8 |
#' @description Handles filter states in a `data.frame`. |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' # use non-exported function from teal.slice |
|
| 12 |
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
|
|
| 13 |
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
|
|
| 14 |
#' init_filter_states <- getFromNamespace("init_filter_states", "teal.slice")
|
|
| 15 |
#' |
|
| 16 |
#' library(shiny) |
|
| 17 |
#' library(shinyjs) |
|
| 18 |
#' |
|
| 19 |
#' # create data frame to filter |
|
| 20 |
#' data_df <- data.frame( |
|
| 21 |
#' NUM1 = 1:100, |
|
| 22 |
#' NUM2 = round(runif(100, min = 20, max = 23)), |
|
| 23 |
#' CHAR1 = sample(LETTERS[1:6], size = 100, replace = TRUE), |
|
| 24 |
#' CHAR2 = sample(c("M", "F"), size = 100, replace = TRUE),
|
|
| 25 |
#' DATE = seq(as.Date("2020-01-01"), by = 1, length.out = 100),
|
|
| 26 |
#' DATETIME = as.POSIXct(seq(as.Date("2020-01-01"), by = 1, length.out = 100))
|
|
| 27 |
#' ) |
|
| 28 |
#' data_na <- data.frame( |
|
| 29 |
#' NUM1 = NA, |
|
| 30 |
#' NUM2 = NA, |
|
| 31 |
#' CHAR1 = NA, |
|
| 32 |
#' CHAR2 = NA, |
|
| 33 |
#' DATE = NA, |
|
| 34 |
#' DATETIME = NA |
|
| 35 |
#' ) |
|
| 36 |
#' data_df <- rbind(data_df, data_na) |
|
| 37 |
#' |
|
| 38 |
#' # initiate `FilterStates` object |
|
| 39 |
#' filter_states_df <- init_filter_states( |
|
| 40 |
#' data = data_df, |
|
| 41 |
#' dataname = "dataset", |
|
| 42 |
#' datalabel = ("label")
|
|
| 43 |
#' ) |
|
| 44 |
#' |
|
| 45 |
#' ui <- bslib::page_fluid( |
|
| 46 |
#' useShinyjs(), |
|
| 47 |
#' include_css_files(pattern = "filter-panel"), |
|
| 48 |
#' include_js_files(pattern = "count-bar-labels"), |
|
| 49 |
#' bslib::layout_column_wrap( |
|
| 50 |
#' width = 1 / 3, |
|
| 51 |
#' tags$div( |
|
| 52 |
#' tags$h4("Active filters"),
|
|
| 53 |
#' filter_states_df$ui_active("fsdf")
|
|
| 54 |
#' ), |
|
| 55 |
#' tags$div( |
|
| 56 |
#' tags$h4("Manual filter control"),
|
|
| 57 |
#' filter_states_df$ui_add("add_filters"), tags$br(),
|
|
| 58 |
#' tags$h4("Condition (i.e. call)"), # display the subset expression generated by FilterStates
|
|
| 59 |
#' textOutput("call_df"), tags$br(),
|
|
| 60 |
#' tags$h4("Formatted state"), # display human readable filter state
|
|
| 61 |
#' textOutput("formatted_df"), tags$br()
|
|
| 62 |
#' ), |
|
| 63 |
#' tags$div( |
|
| 64 |
#' tags$h4("Programmatic filter control"),
|
|
| 65 |
#' actionButton("button1_df", "set NUM1 < 30", width = "100%"), tags$br(),
|
|
| 66 |
#' actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), tags$br(),
|
|
| 67 |
#' actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"),
|
|
| 68 |
#' tags$br(), |
|
| 69 |
#' actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), tags$br(),
|
|
| 70 |
#' actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), tags$br(),
|
|
| 71 |
#' actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), tags$br(),
|
|
| 72 |
#' tags$hr(), |
|
| 73 |
#' actionButton("button7_df", "remove NUM1", width = "100%"), tags$br(),
|
|
| 74 |
#' actionButton("button8_df", "remove NUM2", width = "100%"), tags$br(),
|
|
| 75 |
#' actionButton("button9_df", "remove CHAR1", width = "100%"), tags$br(),
|
|
| 76 |
#' actionButton("button10_df", "remove CHAR2", width = "100%"), tags$br(),
|
|
| 77 |
#' actionButton("button11_df", "remove DATE", width = "100%"), tags$br(),
|
|
| 78 |
#' actionButton("button12_df", "remove DATETIME", width = "100%"), tags$br(),
|
|
| 79 |
#' tags$hr(), |
|
| 80 |
#' actionButton("button0_df", "clear all filters", width = "100%"), tags$br()
|
|
| 81 |
#' ) |
|
| 82 |
#' ) |
|
| 83 |
#' ) |
|
| 84 |
#' |
|
| 85 |
#' server <- function(input, output, session) {
|
|
| 86 |
#' filter_states_df$srv_add("add_filters")
|
|
| 87 |
#' filter_states_df$srv_active("fsdf")
|
|
| 88 |
#' |
|
| 89 |
#' output$call_df <- renderPrint(filter_states_df$get_call()) |
|
| 90 |
#' output$formatted_df <- renderText(filter_states_df$format()) |
|
| 91 |
#' |
|
| 92 |
#' observeEvent(input$button1_df, {
|
|
| 93 |
#' filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30)))
|
|
| 94 |
#' filter_states_df$set_filter_state(state = filter_state) |
|
| 95 |
#' }) |
|
| 96 |
#' observeEvent(input$button2_df, {
|
|
| 97 |
#' filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21)))
|
|
| 98 |
#' filter_states_df$set_filter_state(state = filter_state) |
|
| 99 |
#' }) |
|
| 100 |
#' observeEvent(input$button3_df, {
|
|
| 101 |
#' filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D")))
|
|
| 102 |
#' filter_states_df$set_filter_state(state = filter_state) |
|
| 103 |
#' }) |
|
| 104 |
#' observeEvent(input$button4_df, {
|
|
| 105 |
#' filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F")))
|
|
| 106 |
#' filter_states_df$set_filter_state(state = filter_state) |
|
| 107 |
#' }) |
|
| 108 |
#' observeEvent(input$button5_df, {
|
|
| 109 |
#' filter_state <- teal_slices( |
|
| 110 |
#' teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02"))
|
|
| 111 |
#' ) |
|
| 112 |
#' filter_states_df$set_filter_state(state = filter_state) |
|
| 113 |
#' }) |
|
| 114 |
#' observeEvent(input$button6_df, {
|
|
| 115 |
#' filter_state <- teal_slices( |
|
| 116 |
#' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
|
|
| 117 |
#' ) |
|
| 118 |
#' filter_states_df$set_filter_state(state = filter_state) |
|
| 119 |
#' }) |
|
| 120 |
#' |
|
| 121 |
#' observeEvent(input$button7_df, {
|
|
| 122 |
#' filter_state <- teal_slices(teal_slice("dataset", "NUM1"))
|
|
| 123 |
#' filter_states_df$remove_filter_state(filter_state) |
|
| 124 |
#' }) |
|
| 125 |
#' observeEvent(input$button8_df, {
|
|
| 126 |
#' filter_state <- teal_slices(teal_slice("dataset", "NUM2"))
|
|
| 127 |
#' filter_states_df$remove_filter_state(filter_state) |
|
| 128 |
#' }) |
|
| 129 |
#' observeEvent(input$button9_df, {
|
|
| 130 |
#' filter_state <- teal_slices(teal_slice("dataset", "CHAR1"))
|
|
| 131 |
#' filter_states_df$remove_filter_state(filter_state) |
|
| 132 |
#' }) |
|
| 133 |
#' observeEvent(input$button10_df, {
|
|
| 134 |
#' filter_state <- teal_slices(teal_slice("dataset", "CHAR2"))
|
|
| 135 |
#' filter_states_df$remove_filter_state(filter_state) |
|
| 136 |
#' }) |
|
| 137 |
#' observeEvent(input$button11_df, {
|
|
| 138 |
#' filter_state <- teal_slices( |
|
| 139 |
#' teal_slice("dataset", "DATE")
|
|
| 140 |
#' ) |
|
| 141 |
#' filter_states_df$remove_filter_state(filter_state) |
|
| 142 |
#' }) |
|
| 143 |
#' observeEvent(input$button12_df, {
|
|
| 144 |
#' filter_state <- teal_slices( |
|
| 145 |
#' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
|
|
| 146 |
#' ) |
|
| 147 |
#' filter_states_df$remove_filter_state(filter_state) |
|
| 148 |
#' }) |
|
| 149 |
#' |
|
| 150 |
#' observeEvent(input$button0_df, filter_states_df$clear_filter_states()) |
|
| 151 |
#' } |
|
| 152 |
#' |
|
| 153 |
#' if (interactive()) {
|
|
| 154 |
#' shinyApp(ui, server) |
|
| 155 |
#' } |
|
| 156 |
#' @keywords internal |
|
| 157 |
#' |
|
| 158 |
DFFilterStates <- R6::R6Class( # nolint |
|
| 159 |
classname = "DFFilterStates", |
|
| 160 |
inherit = FilterStates, |
|
| 161 | ||
| 162 |
# public methods ---- |
|
| 163 |
public = list( |
|
| 164 |
#' @description |
|
| 165 |
#' Initializes `DFFilterStates` object by setting `dataname` |
|
| 166 |
#' and initializing `state_list` (`shiny::reactiveVal`). |
|
| 167 |
#' This class contains a single `state_list` with no specified name, |
|
| 168 |
#' which means that when calling the subset function associated with this class |
|
| 169 |
#' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`). |
|
| 170 |
#' |
|
| 171 |
#' @param data (`data.frame`) |
|
| 172 |
#' the `R` object which `dplyr::filter` function will be applied on. |
|
| 173 |
#' @param data_reactive (`function(sid)`) |
|
| 174 |
#' should return a `data.frame` object or `NULL`. |
|
| 175 |
#' This object is needed for the `FilterState` counts being updated on a change in filters. |
|
| 176 |
#' If function returns `NULL` then filtered counts are not shown. |
|
| 177 |
#' Function has to have `sid` argument being a character. |
|
| 178 |
#' @param dataname (`character`) |
|
| 179 |
#' name of the data used in the *subset expression*. |
|
| 180 |
#' Passed to the function argument attached to this `FilterStates`. |
|
| 181 |
#' @param datalabel (`character(1)`) optional |
|
| 182 |
#' text label. |
|
| 183 |
#' @param keys (`character`) |
|
| 184 |
#' key column names. |
|
| 185 |
#' |
|
| 186 |
initialize = function(data, |
|
| 187 |
data_reactive = function(sid = "") NULL, |
|
| 188 |
dataname, |
|
| 189 |
datalabel = NULL, |
|
| 190 |
keys = character(0)) {
|
|
| 191 | 127x |
checkmate::assert_function(data_reactive, args = "sid") |
| 192 | 127x |
checkmate::assert_data_frame(data) |
| 193 | 127x |
super$initialize(data, data_reactive, dataname, datalabel) |
| 194 | 127x |
private$keys <- keys |
| 195 | 127x |
private$set_filterable_varnames(include_varnames = colnames(private$data)) |
| 196 |
} |
|
| 197 |
), |
|
| 198 | ||
| 199 |
# private members ---- |
|
| 200 |
private = list( |
|
| 201 |
fun = quote(dplyr::filter) |
|
| 202 |
) |
|
| 203 |
) |
| 1 |
#' Include `CSS` files from `/inst/css/` package directory to application header |
|
| 2 |
#' |
|
| 3 |
#' `system.file` should not be used to access files in other packages, it does |
|
| 4 |
#' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 5 |
#' as needed. Thus, we do not export this method. |
|
| 6 |
#' |
|
| 7 |
#' @param pattern (`character`) pattern of files to be included |
|
| 8 |
#' |
|
| 9 |
#' @return HTML code that includes `CSS` files |
|
| 10 |
#' @keywords internal |
|
| 11 |
include_css_files <- function(pattern = "*") {
|
|
| 12 | 57x |
css_files <- list.files( |
| 13 | 57x |
system.file("css", package = "teal.slice", mustWork = TRUE),
|
| 14 | 57x |
pattern = pattern, full.names = TRUE |
| 15 |
) |
|
| 16 | 57x |
singleton(tags$head(lapply(css_files, includeCSS))) |
| 17 |
} |