Nothing
# FilteredDataset abstract --------
#' @name FilteredDataset
#' @docType class
#'
#' @title `FilteredDataset` `R6` class
#' @description
#' `FilteredDataset` is a class which renders/controls `FilterStates`(s)
#' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one
#' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects.
#' Each `FilterStates` is responsible for one filter/subset expression applied for specific
#' components of the dataset.
#'
#' @keywords internal
FilteredDataset <- R6::R6Class( # nolint
"FilteredDataset",
# public methods ----
public = list(
#' @description
#' Initializes this `FilteredDataset` object.
#'
#' @param dataset any object
#' @param dataname (`character(1)`)
#' syntactically valid name given to the dataset.
#' @param keys (`character`) optional
#' vector of primary key column names.
#' @param label (`character(1)`)
#' label to describe the dataset.
#'
#' @return Object of class `FilteredDataset`, invisibly.
#'
initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label", exact = TRUE)) {
logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
# dataset assertion in child classes
check_simple_name(dataname)
checkmate::assert_character(keys, any.missing = FALSE)
checkmate::assert_character(label, null.ok = TRUE)
logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
private$dataset <- dataset
private$dataname <- dataname
private$keys <- keys
private$label <- if (is.null(label)) character(0) else label
# function executing reactive call and returning data
private$data_filtered_fun <- function(sid = "") {
checkmate::assert_character(sid)
if (length(sid)) {
logger::log_trace("filtering data dataname: { dataname }, sid: { sid }")
} else {
logger::log_trace("filtering data dataname: { private$dataname }")
}
env <- new.env(parent = parent.env(globalenv()))
env[[dataname]] <- private$dataset
filter_call <- self$get_call(sid)
eval_expr_with_msg(filter_call, env)
get(x = dataname, envir = env)
}
private$data_filtered <- reactive(private$data_filtered_fun())
logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
invisible(self)
},
#' @description
#' Returns a formatted string representing this `FilteredDataset` object.
#'
#' @param show_all (`logical(1)`) passed to `format.teal_slice`.
#' @param trim_lines (`logical(1)`) passed to `format.teal_slice`.
#'
#' @return The formatted character 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
#' Prints this `FilteredDataset` object.
#'
#' @param ... additional arguments passed to `format`.
#'
print = function(...) {
cat(isolate(self$format(...)), "\n")
},
#' @description
#' Removes all filter items applied to this dataset.
#'
#' @param force (`logical(1)`)
#' flag specifying whether to include anchored filter states.
#'
#' @return `NULL`.
clear_filter_states = function(force = FALSE) {
logger::log_trace("Removing filters from FilteredDataset: { deparse1(self$get_dataname()) }")
lapply(
private$get_filter_states(),
function(filter_states) filter_states$clear_filter_states(force)
)
logger::log_trace("Removed filters from FilteredDataset: { deparse1(self$get_dataname()) }")
NULL
},
# managing filter states -----
# getters ----
#' @description
#' Gets a filter expression.
#'
#' This function returns filter calls equivalent to selected items
#' within each of `filter_states`. Configuration of the calls is constant and
#' depends on `filter_states` type and order which are set during initialization.
#'
#' @param sid (`character`)
#' when specified, the method returns code containing conditions calls of
#' `FilterState` objects with `sid` different to this `sid` argument.
#'
#' @return Either a `list` of filter `call`s, or `NULL`.
get_call = function(sid = "") {
filter_call <- Filter(
f = Negate(is.null),
x = lapply(private$get_filter_states(), function(x) x$get_call(sid))
)
if (length(filter_call) == 0) {
return(NULL)
}
filter_call
},
#' @description
#' Gets states of all contained `FilterState` objects.
#'
#' @return A `teal_slices` object.
#'
get_filter_state = function() {
states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state()))
do.call(c, states)
},
#' @description
#' Set filter state.
#'
#' @param state (`teal_slices`)
#'
#' @return Virtual method, returns nothing and raises error.
#'
set_filter_state = function(state) {
stop("set_filter_state is an abstract class method.")
},
#' @description
#' Gets the number of `FilterState` objects in all `FilterStates` in this `FilteredDataset`.
#' @return `integer(1)`
get_filter_count = function() {
length(self$get_filter_state())
},
#' @description
#' Gets the name of the dataset.
#'
#' @return A character string.
get_dataname = function() {
private$dataname
},
#' @description
#' Gets the dataset object in this `FilteredDataset`.
#'
#' @param filtered (`logical(1)`)
#'
#' @return
#' The stored dataset. If `data.frame` or `MultiAssayExperiment`,
#' either raw or as a reactive with current filters applied (depending on `filtered`).
#'
get_dataset = function(filtered = FALSE) {
if (filtered) {
private$data_filtered
} else {
private$dataset
}
},
#' @description
#' Get filter overview of a dataset.
#' @return Virtual method, returns nothing and raises an error.
get_filter_overview = function() {
stop("get_filter_overview is an abstract class method")
},
#' @description
#' Gets the key columns for this dataset.
#' @return Character vector of variable names
get_keys = function() {
private$keys
},
#' @description
#' Gets the dataset label.
#' @return Character string.
get_dataset_label = function() {
private$label
},
# modules ------
#' @description
#' `shiny` module containing active filters for a dataset, along with a title and a remove button.
#' @param id (`character(1)`)
#' `shiny` module instance id.
#'
#' @return `shiny.tag`
ui_active = function(id) {
dataname <- self$get_dataname()
checkmate::assert_string(dataname)
ns <- NS(id)
if_multiple_filter_states <- length(private$get_filter_states()) > 1
tags$span(
id = id,
include_css_files("filter-panel"),
tags$div(
id = ns("whole_ui"), # to hide it entirely
fluidRow(
column(
width = 8,
tags$span(dataname, class = "filter_panel_dataname")
),
column(
width = 4,
tagList(
actionLink(
ns("remove_filters"),
label = "",
icon = icon("circle-xmark", lib = "font-awesome"),
class = "remove pull-right"
),
actionLink(
ns("collapse"),
label = "",
icon = icon("angle-down", lib = "font-awesome"),
class = "remove pull-right"
)
)
)
),
shinyjs::hidden(
tags$div(
id = ns("filter_count_ui"),
tagList(
textOutput(ns("filter_count")),
tags$br()
)
)
),
tags$div(
# id needed to insert and remove UI to filter single variable as needed
# it is currently also used by the above module to entirely hide this panel
id = ns("filters"),
class = "parent-hideable-list-group",
tagList(
lapply(
names(private$get_filter_states()),
function(x) {
tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x)))
}
)
)
)
)
)
},
#' @description
#' Server module for a dataset active filters.
#'
#' @param id (`character(1)`)
#' `shiny` module instance id.
#' @return `NULL`.
srv_active = function(id) {
moduleServer(
id = id,
function(input, output, session) {
dataname <- self$get_dataname()
logger::log_trace("FilteredDataset$srv_active initializing, dataname: { dataname }")
checkmate::assert_string(dataname)
output$filter_count <- renderText(
sprintf(
"%d filter%s applied",
self$get_filter_count(),
if (self$get_filter_count() != 1) "s" else ""
)
)
lapply(
names(private$get_filter_states()),
function(x) {
private$get_filter_states()[[x]]$srv_active(id = x)
}
)
observeEvent(self$get_filter_state(), {
shinyjs::hide("filter_count_ui")
shinyjs::show("filters")
shinyjs::toggle("remove_filters", condition = length(self$get_filter_state()) != 0)
shinyjs::toggle("collapse", condition = length(self$get_filter_state()) != 0)
})
observeEvent(input$collapse, {
shinyjs::toggle("filter_count_ui")
shinyjs::toggle("filters")
toggle_icon(session$ns("collapse"), c("fa-angle-right", "fa-angle-down"))
})
observeEvent(input$remove_filters, {
logger::log_trace("FilteredDataset$srv_active@1 removing all non-anchored filters, dataname: { dataname }")
self$clear_filter_states()
logger::log_trace("FilteredDataset$srv_active@1 removed all non-anchored filters, dataname: { dataname }")
})
logger::log_trace("FilteredDataset$initialized, dataname: { dataname }")
NULL
}
)
},
#' @description
#' UI module to add filter variable for this dataset.
#'
#' @param id (`character(1)`)
#' `shiny` module instance id.
#'
#' @return Virtual method, returns nothing and raises error.
ui_add = function(id) {
stop("Pure virtual method")
},
#' @description
#' Server module to add filter variable for this dataset.
#' For this class `srv_add` calls multiple modules
#' of the same name from `FilterStates` as `MAEFilteredDataset`
#' contains one `FilterStates` object for `colData` and one for each experiment.
#'
#' @param id (`character(1)`)
#' `shiny` module instance id.
#'
#' @return `NULL`.
srv_add = function(id) {
moduleServer(
id = id,
function(input, output, session) {
logger::log_trace("MAEFilteredDataset$srv_add initializing, dataname: { deparse1(self$get_dataname()) }")
elems <- private$get_filter_states()
elem_names <- names(private$get_filter_states())
lapply(
elem_names,
function(elem_name) elems[[elem_name]]$srv_add(elem_name)
)
logger::log_trace("MAEFilteredDataset$srv_add initialized, dataname: { deparse1(self$get_dataname()) }")
NULL
}
)
}
),
# private fields ----
private = list(
dataset = NULL, # data.frame or MultiAssayExperiment
data_filtered = NULL,
data_filtered_fun = NULL, # function
filter_states = list(),
dataname = character(0),
keys = character(0),
label = character(0),
# Adds `FilterStates` to the `private$filter_states`.
# `FilterStates` is added once for each element of the dataset.
# @param filter_states (`FilterStates`)
# @param id (`character(1)`)
add_filter_states = function(filter_states, id) {
checkmate::assert_class(filter_states, "FilterStates")
checkmate::assert_string(id)
x <- stats::setNames(list(filter_states), id)
private$filter_states <- c(private$get_filter_states(), x)
},
# @description
# Gets `FilterStates` objects in this `FilteredDataset`.
# @return list of `FilterStates` objects.
get_filter_states = function() {
private$filter_states
}
)
)
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.