Nothing
# FilterStates ------
#' @name FilterStates
#' @docType class
#' @title `FilterStates` `R6` class
#'
#' @description
#' Abstract class that manages adding and removing `FilterState` objects
#' and builds a *subset expression*.
#'
#' A `FilterStates` object tracks all condition calls
#' (logical predicates that limit observations) associated with a given dataset
#' and composes them into a single reproducible `R` expression
#' that will assign a subset of the original data to a new variable.
#' This expression is hereafter referred to as *subset expression*.
#'
#' The *subset expression* is constructed differently for different
#' classes of the underlying data object and `FilterStates` sub-classes.
#' Currently implemented for `data.frame`, `matrix`,
#' `SummarizedExperiment`, and `MultiAssayExperiment`.
#'
#' @keywords internal
#'
FilterStates <- R6::R6Class( # nolint
classname = "FilterStates",
# public members ----
public = list(
#' @description
#' Initializes `FilterStates` object by setting
#' `dataname`, and `datalabel`.
#'
#' @param data (`data.frame` or `MultiAssayExperiment` or `SummarizedExperiment` or `matrix`)
#' the `R` object which `subset` function is applied on.
#' @param data_reactive (`function(sid)`)
#' should return an object of the same type as `data` object or `NULL`.
#' This object is needed for the `FilterState` counts being updated
#' on a change in filters. If function returns `NULL` then filtered counts are not shown.
#' Function has to have `sid` argument being a character.
#' @param dataname (`character(1)`)
#' name of the dataset, used in the subset expression.
#' Passed to the function argument attached to this `FilterStates`.
#' @param datalabel (`character(1)`) optional
#' text label.
#'
#' @return
#' Object of class `FilterStates`, invisibly.
#'
initialize = function(data,
data_reactive = function(sid = "") NULL,
dataname,
datalabel = NULL) {
checkmate::assert_string(dataname)
logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
checkmate::assert_function(data_reactive, args = "sid")
checkmate::assert_string(datalabel, null.ok = TRUE)
private$dataname <- dataname
private$datalabel <- datalabel
private$dataname_prefixed <- dataname
private$data <- data
private$data_reactive <- data_reactive
private$state_list <- reactiveVal()
logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
invisible(self)
},
#' @description
#' Returns a formatted string representing this `FilterStates` object.
#'
#' @param show_all (`logical(1)`) passed to `format.teal_slices`
#' @param trim_lines (`logical(1)`) passed to `format.teal_slices`
#'
#' @return `character(1)` the formatted string
#'
format = function(show_all = FALSE, trim_lines = TRUE) {
sprintf(
"%s:\n%s",
class(self)[1],
format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)
)
},
#' @description
#' Filter call
#'
#' Builds *subset expression* from condition calls generated by `FilterState`.
#' The `lhs` of the expression is a `dataname_prefixed`, where word prefixed refers to
#' situation when call is evaluated on elements of the original data, for example `dataname[[x]]`.
#' By default `dataname_prefixed = dataname` and it's not alterable through class methods.
#' Customization of `private$dataname_prefixed` is done through inheriting classes.
#'
#' The `rhs` is a call to `private$fun` with following arguments:
#' - `dataname_prefixed`
#' - list of logical expressions generated by `FilterState` objects
#' stored in `private$state_list`. Each logical predicate is combined with `&` operator.
#' Variables in these logical expressions by default are not prefixed but this can be changed
#' by setting `private$extract_type` (change in the similar way as `dataname_prefixed`)
#' Possible call outputs depending on a custom fields/options:
#' ```
#' # default
#' dataname <- subset(dataname, col == "x")
#'
#' # fun = dplyr::filter
#' dataname <- dplyr::filter(dataname, col == "x")
#'
#' # fun = MultiAssayExperiment::subsetByColData; extract_type = "list"
#' dataname <- MultiAssayExperiment::subsetByColData(dataname, dataname$col == "x")
#'
#' # teal_slice objects having `arg = "subset"` and `arg = "select"`
#' dataname <- subset(dataname, subset = row_col == "x", select = col_col == "x")
#'
#' # dataname = dataname[[element]]
#' dataname[[element]] <- subset(dataname[[element]], subset = col == "x")
#' ```
#'
#' If no filters are applied, `NULL` is returned to avoid no-op calls such as `dataname <- dataname`.
#'
#' @param sid (`character`)
#' when specified then method returns code containing condition calls (logical predicates) of
#' `FilterState` objects which `"sid"` attribute is different than this `sid` argument.
#'
#' @return `call` or `NULL`
#'
get_call = function(sid = "") {
logger::log_trace("FilterStates$get_call initializing")
# `arg` must be the same as argument of the function where
# predicate is passed to.
# For unnamed arguments state_list should have `arg = NULL`
states_list <- private$state_list_get()
if (length(states_list) == 0) {
return(NULL)
}
args <- vapply(
states_list,
function(x) {
arg <- x$get_state()$arg
`if`(is.null(arg), "", arg) # converting NULL -> "" to enable tapply.
},
character(1)
)
filter_items <- tapply(
X = states_list,
INDEX = args,
simplify = FALSE,
function(items) {
# removing filters identified by sid
other_filter_idx <- !names(items) %in% sid
filtered_items <- items[other_filter_idx]
calls <- Filter(
Negate(is.null),
lapply(
filtered_items,
function(state) {
state$get_call(dataname = private$dataname_prefixed)
}
)
)
calls_combine_by(calls, operator = "&")
}
)
filter_items <- Filter(
x = filter_items,
f = Negate(is.null)
)
if (length(filter_items) > 0L) {
filter_function <- private$fun
data_name <- str2lang(private$dataname_prefixed)
substitute(
env = list(
lhs = data_name,
rhs = as.call(c(filter_function, c(list(data_name), filter_items)))
),
expr = lhs <- rhs
)
} else {
# return NULL to avoid no-op call
NULL
}
},
#' @description
#' Prints this `FilterStates` object.
#'
#' @param ... additional arguments passed to `format`.
print = function(...) {
cat(isolate(self$format(...)), "\n")
},
#' @description
#' Remove one or more `FilterState`s from the `state_list` along with their UI elements.
#'
#' @param state (`teal_slices`)
#' specifying `FilterState` objects to remove;
#' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored
#'
#' @return `NULL`, invisibly.
#'
remove_filter_state = function(state) {
checkmate::assert_class(state, "teal_slices")
isolate({
state_ids <- vapply(state, `[[`, character(1), "id")
logger::log_trace("{ class(self)[1] }$remove_filter_state removing filters, state_id: { toString(state_ids) }")
private$state_list_remove(state_ids)
})
invisible(NULL)
},
#' @description
#' Gets reactive values from active `FilterState` objects.
#'
#' Get active filter state from `FilterState` objects stored in `state_list`(s).
#' The output is a list compatible with input to `self$set_filter_state`.
#'
#' @return Object of class `teal_slices`.
#'
get_filter_state = function() {
slices <- unname(lapply(private$state_list(), function(x) x$get_state()))
fs <- do.call(teal_slices, c(slices, list(count_type = private$count_type)))
include_varnames <- private$include_varnames
if (length(include_varnames)) {
attr(fs, "include_varnames") <- structure(
list(include_varnames),
names = private$dataname
)
}
exclude_varnames <- private$exclude_varnames
if (length(exclude_varnames)) {
attr(fs, "exclude_varnames") <- structure(
list(exclude_varnames),
names = private$dataname
)
}
fs
},
#' @description
#' Sets active `FilterState` objects.
#' @param state (`teal_slices`)
#' @return Function that raises an error.
set_filter_state = function(state) {
isolate({
logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
checkmate::assert_class(state, "teal_slices")
lapply(state, function(x) {
checkmate::assert_true(
x$dataname == private$dataname,
.var.name = "dataname matches private$dataname"
)
})
private$set_filterable_varnames(
include_varnames = attr(state, "include_varnames")[[private$dataname]],
exclude_varnames = attr(state, "exclude_varnames")[[private$dataname]]
)
count_type <- attr(state, "count_type")
if (length(count_type)) {
private$count_type <- count_type
}
# Drop teal_slices that refer to excluded variables.
varnames <- unique(unlist(lapply(state, "[[", "varname")))
excluded_varnames <- setdiff(varnames, private$get_filterable_varnames())
if (length(excluded_varnames)) {
state <- Filter(function(x) !isTRUE(x$varname %in% excluded_varnames), state)
warning(sprintf("filters for columns: %s excluded from %s", toString(excluded_varnames), private$dataname))
}
if (length(state) > 0) {
private$set_filter_state_impl(
state = state,
data = private$data,
data_reactive = private$data_reactive
)
}
logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
})
invisible(NULL)
},
#' @description
#' Remove all `FilterState` objects from this `FilterStates` object.
#'
#' @param force (`logical(1)`)
#' flag specifying whether to include anchored filter states.
#'
#' @return `NULL`, invisibly.
#'
clear_filter_states = function(force = FALSE) {
private$state_list_empty(force)
invisible(NULL)
},
# shiny modules ----
#' @description
#' `shiny` UI definition that stores `FilterState` UI elements.
#' Populated with elements created with `renderUI` in the module server.
#'
#' @param id (`character(1)`)
#' `shiny` module instance id.
#'
#' @return `shiny.tag`
#'
ui_active = function(id) {
ns <- NS(id)
tagList(
include_css_files(pattern = "filter-panel"),
uiOutput(ns("trigger_visible_state_change"), inline = TRUE),
uiOutput(
ns("cards"),
class = "accordion",
`data-label` = ifelse(length(private$datalabel), paste0("> ", private$datalabel), ""),
)
)
},
#' @description
#' `shiny` server module.
#'
#' @param id (`character(1)`)
#' `shiny` module instance id.
#'
#' @return `NULL`.
#'
srv_active = function(id) {
moduleServer(
id = id,
function(input, output, session) {
logger::log_trace("FilterState$srv_active initializing, dataname: { private$dataname }")
current_state <- reactive(private$state_list_get())
previous_state <- reactiveVal(NULL) # FilterState list
added_states <- reactiveVal(NULL) # FilterState list
# gives a valid shiny ns based on a default slice id
fs_to_shiny_ns <- function(x) {
checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
gsub("[^[:alnum:]]+", "_", get_default_slice_id(x$get_state()))
}
output$trigger_visible_state_change <- renderUI({
current_state()
isolate({
logger::log_trace("FilterStates$srv_active@1 determining added and removed filter states")
# Be aware this returns a list because `current_state` is a list and not `teal_slices`.
added_states(setdiff_teal_slices(current_state(), previous_state()))
previous_state(current_state())
NULL
})
})
output[["cards"]] <- renderUI({
lapply(
current_state(), # observes only if added/removed
function(state) {
isolate( # isolates when existing state changes
state$ui(id = session$ns(fs_to_shiny_ns(state)), parent_id = session$ns("cards"))
)
}
)
})
observeEvent(
added_states(), # we want to call FilterState module only once when it's added
ignoreNULL = TRUE,
{
added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L))
logger::log_trace("FilterStates$srv_active@2 triggered by added states: { toString(added_state_names) }")
lapply(added_states(), function(state) {
fs_callback <- state$server(id = fs_to_shiny_ns(state))
observeEvent(
once = TRUE, # remove button can be called once, should be destroyed afterwards
ignoreInit = TRUE, # ignoreInit: should not matter because we destroy the previous input set of the UI
eventExpr = fs_callback(), # when remove button is clicked in the FilterState ui
handlerExpr = private$state_list_remove(state$get_state()$id)
)
})
added_states(NULL)
}
)
NULL
}
)
},
#' @description
#' `shiny` UI module to add filter variable.
#'
#' @param id (`character(1)`)
#' `shiny` module instance id.
#'
#' @return `shiny.tag`
#'
ui_add = function(id) {
checkmate::assert_string(id)
data <- private$data
ns <- NS(id)
if (ncol(data) == 0) {
tags$div("no sample variables available")
} else if (nrow(data) == 0) {
tags$div("no samples available")
} else {
uiOutput(ns("add_filter"))
}
},
#' @description
#' `shiny` server module to add filter variable.
#'
#' This module controls available choices to select as a filter variable.
#' Once selected, a variable is removed from available choices.
#' Removing a filter variable adds it back to available choices.
#'
#' @param id (`character(1)`)
#' `shiny` module instance id.
#'
#' @return `NULL`.
srv_add = function(id) {
moduleServer(
id = id,
function(input, output, session) {
logger::log_trace("FilterStates$srv_add initializing, dataname: { private$dataname }")
# available choices to display
avail_column_choices <- reactive({
data <- private$data
vars_include <- private$get_filterable_varnames()
active_filter_vars <- unique(unlist(lapply(self$get_filter_state(), "[[", "varname")))
choices <- setdiff(vars_include, active_filter_vars)
varlabels <- get_varlabels(data)
data_choices_labeled(
data = data,
choices = choices,
varlabels = varlabels,
keys = private$keys
)
})
output$add_filter <- renderUI({
logger::log_trace(
"FilterStates$srv_add@1 updating available column choices, dataname: { private$dataname }"
)
if (length(avail_column_choices()) == 0) {
tags$span("No available columns to add.")
} else {
tags$div(
teal.widgets::optionalSelectInput(
session$ns("var_to_add"),
choices = avail_column_choices(),
selected = NULL,
options = shinyWidgets::pickerOptions(
liveSearch = TRUE,
noneSelectedText = "Select variable to filter"
)
)
)
}
})
observeEvent(
eventExpr = input$var_to_add,
handlerExpr = {
logger::log_trace(
sprintf(
"FilterStates$srv_add@2 adding FilterState of variable %s, dataname: %s",
input$var_to_add,
private$dataname
)
)
self$set_filter_state(
teal_slices(
teal_slice(dataname = private$dataname, varname = input$var_to_add)
)
)
logger::log_trace(
sprintf(
"FilterStates$srv_add@2 added FilterState of variable %s, dataname: %s",
input$var_to_add,
private$dataname
)
)
}
)
logger::log_trace("FilterStates$srv_add initialized, dataname: { private$dataname }")
NULL
}
)
}
),
private = list(
# private fields ----
count_type = "none", # specifies how observation numbers are displayed in filter cards,
data = NULL, # data.frame, MAE, SE or matrix
data_reactive = NULL, # reactive
datalabel = NULL, # to follow default `experiment = NULL` in `teal_slice`
dataname = NULL, # because it holds object of class name
dataname_prefixed = character(0), # name used in call returned from get_call
exclude_varnames = character(0), # holds column names
include_varnames = character(0), # holds column names
extract_type = character(0), # type of the prefix in a subset call (eg. "list": x$var; "matrix": x[["var"]])
fun = quote(subset), # function used to generate subset call
keys = character(0),
ns = NULL, # shiny ns()
observers = list(), # observers
state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes,
# private methods ----
# @description
# Set the allowed filterable variables
# @param include_varnames (`character`) Names of variables included in filtering.
# @param exclude_varnames (`character`) Names of variables excluded from filtering.
#
# @details When retrieving the filtered variables only
# those which have filtering supported (i.e. are of the permitted types).
# Only one from `include_varnames` and `exclude_varnames` can be used in one call. When `exclude_varnames`
# is called `include_varnames` is cleared - same otherwise.
# are included.
#
# @return `NULL`, invisibly.
set_filterable_varnames = function(include_varnames = character(0), exclude_varnames = character(0)) {
if ((length(include_varnames) + length(exclude_varnames)) == 0L) {
return(invisible(NULL))
}
checkmate::assert_character(include_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE)
checkmate::assert_character(exclude_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE)
if (length(include_varnames) && length(exclude_varnames)) {
stop(
"`include_varnames` and `exclude_varnames` has been both specified for",
private$dataname,
". Only one per dataset is allowed.",
)
}
supported_vars <- get_supported_filter_varnames(private$data)
if (length(include_varnames)) {
private$include_varnames <- intersect(include_varnames, supported_vars)
private$exclude_varnames <- character(0)
} else {
private$exclude_varnames <- exclude_varnames
private$include_varnames <- character(0)
}
invisible(NULL)
},
# @description
# Get vector of filterable varnames
#
# @details
# These are the only columns which can be used in the filter panel
#
# @return character vector with names of the columns
get_filterable_varnames = function() {
if (length(private$include_varnames)) {
private$include_varnames
} else {
supported_varnames <- get_supported_filter_varnames(private$data)
setdiff(supported_varnames, private$exclude_varnames)
}
},
# state_list methods ----
# @description
# Returns a list of `FilterState` objects stored in this `FilterStates`.
#
# @param state_id (`character(1)`)
# name of element in a filter state (which is a `reactiveVal` containing a list)
#
# @return `list` of `FilterState` objects
#
state_list_get = function(state_id = NULL) {
checkmate::assert_string(state_id, null.ok = TRUE)
if (is.null(state_id)) {
private$state_list()
} else {
private$state_list()[[state_id]]
}
},
# @description
# Adds a new `FilterState` object to this `FilterStates`.
# Raises error if the length of `x` does not match the length of `state_id`.
#
# @param x (`FilterState`)
# object to be added to filter state list
# @param state_id (`character(1)`)
# name of element in a filter state (which is a `reactiveVal` containing a list)
#
# @return `NULL`.
#
state_list_push = function(x, state_id) {
logger::log_trace("{ class(self)[1] } pushing into state_list, dataname: { private$dataname }")
checkmate::assert_string(state_id)
checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
state <- stats::setNames(list(x), state_id)
new_state_list <- c(
isolate(private$state_list()),
state
)
isolate(private$state_list(new_state_list))
logger::log_trace("{ class(self)[1] } pushed into queue, dataname: { private$dataname }")
invisible(NULL)
},
# @description
# Removes a single filter state with all associated shiny elements:
# * specified `FilterState` from `private$state_list`
# * UI card created for this filter
# * observers tracking the selection and remove button
#
# @param state_id (`character`)
# identifiers of elements in a filter state (which is a `reactiveVal` containing a list).
# @param force (`logical(1)`)
# flag specifying whether to include anchored filter states.
#
# @return `NULL`, invisibly.
#
state_list_remove = function(state_id, force = FALSE) {
checkmate::assert_character(state_id)
logger::log_trace("{ class(self)[1] } removing a filter, state_id: { toString(state_id) }")
isolate({
current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1))
to_remove <- state_id %in% current_state_ids
if (any(to_remove)) {
new_state_list <- Filter(
function(state) {
if (state$get_state()$id %in% state_id) {
if (state$get_state()$anchored && !force) {
return(TRUE)
} else {
state$destroy_observers()
FALSE
}
} else {
TRUE
}
},
private$state_list()
)
private$state_list(new_state_list)
} else {
warning(sprintf("\"%s\" not found in state list", state_id))
}
})
invisible(NULL)
},
# @description
# Remove all `FilterState` objects from this `FilterStates` object.
# @param force (`logical(1)`)
# flag specifying whether to include anchored filter states.
# @return `NULL`, invisibly.
#
state_list_empty = function(force = FALSE) {
isolate({
logger::log_trace(
"{ class(self)[1] }$state_list_empty removing all non-anchored filters for dataname: { private$dataname }"
)
state_list <- private$state_list()
if (length(state_list)) {
state_ids <- vapply(state_list, function(x) x$get_state()$id, character(1))
private$state_list_remove(state_ids, force)
}
})
invisible(NULL)
},
# @description
# Set filter state
#
# Utility method for `set_filter_state` to create or modify `FilterState` using a single
# `teal_slice`.
# @param state (`teal_slices`)
# @param data (`data.frame`, `matrix` or `DataFrame`)
# @param data_reactive (`function`)
# function having `sid` as argument.
#
# @return `NULL`, invisibly.
#
set_filter_state_impl = function(state,
data,
data_reactive) {
checkmate::assert_class(state, "teal_slices")
checkmate::assert_multi_class(data, c("data.frame", "matrix", "DataFrame", "HermesData"))
checkmate::assert_function(data_reactive, args = "sid")
if (length(state) == 0L) {
return(invisible(NULL))
}
slices_hashed <- vapply(state, `[[`, character(1L), "id")
if (any(duplicated(slices_hashed))) {
stop(
"Some of the teal_slice objects refer to the same filter. ",
"Please specify different 'id' when calling teal_slice"
)
}
state_list <- isolate(private$state_list_get())
lapply(state, function(slice) {
state_id <- slice$id
if (state_id %in% names(state_list)) {
# Modify existing filter states.
state_list[[state_id]]$set_state(slice)
} else {
if (inherits(slice, "teal_slice_expr")) {
# create a new FilterStateExpr
fstate <- init_filter_state_expr(slice)
} else {
# create a new FilterState
fstate <- init_filter_state(
x = data[, slice$varname, drop = TRUE],
# data_reactive is a function which eventually calls get_call(sid).
# This chain of calls returns column from the data filtered by everything
# but filter identified by the sid argument. FilterState then get x_reactive
# and this no longer needs to be a function to pass sid. reactive in the FilterState
# is also beneficial as it can be cached and retriger filter counts only if
# returned vector is different.
x_reactive = if (private$count_type == "none") {
reactive(NULL)
} else {
reactive(data_reactive(state_id)[, slice$varname, drop = TRUE])
},
slice = slice,
extract_type = private$extract_type
)
}
private$state_list_push(x = fstate, state_id = state_id)
}
})
invisible(NULL)
}
)
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.