| 1 | ++ |
+ #' Initializes `FilteredDataset`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @keywords internal+ |
+
| 4 | ++ |
+ #' @examples+ |
+
| 5 | ++ |
+ #' # DefaultFilteredDataset example+ |
+
| 6 | ++ |
+ #' iris_fd <- teal.slice:::init_filtered_dataset(+ |
+
| 7 | ++ |
+ #' iris,+ |
+
| 8 | ++ |
+ #' dataname = "iris",+ |
+
| 9 | ++ |
+ #' metadata = list(type = "teal")+ |
+
| 10 | ++ |
+ #' )+ |
+
| 11 | ++ |
+ #' app <- shinyApp(+ |
+
| 12 | ++ |
+ #' ui = fluidPage(+ |
+
| 13 | ++ |
+ #' iris_fd$ui_add(id = "add"),+ |
+
| 14 | ++ |
+ #' iris_fd$ui_active("dataset"),
+ |
+
| 15 | ++ |
+ #' verbatimTextOutput("call"),
+ |
+
| 16 | ++ |
+ #' verbatimTextOutput("metadata")
+ |
+
| 17 | ++ |
+ #' ),+ |
+
| 18 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 19 | ++ |
+ #' iris_fd$srv_add(id = "add")+ |
+
| 20 | ++ |
+ #' iris_fd$srv_active(id = "dataset")+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' output$metadata <- renderText({
+ |
+
| 23 | ++ |
+ #' paste("Type =", iris_fd$get_metadata()$type)
+ |
+
| 24 | ++ |
+ #' })+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' output$call <- renderText({
+ |
+
| 27 | ++ |
+ #' paste(+ |
+
| 28 | ++ |
+ #' vapply(iris_fd$get_call(), deparse1, character(1), collapse = "\n"),+ |
+
| 29 | ++ |
+ #' collapse = "\n"+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #' })+ |
+
| 32 | ++ |
+ #' }+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #' if (interactive()) {
+ |
+
| 35 | ++ |
+ #' runApp(app)+ |
+
| 36 | ++ |
+ #' }+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' # MAEFilteredDataset example+ |
+
| 39 | ++ |
+ #' library(MultiAssayExperiment)+ |
+
| 40 | ++ |
+ #' data(miniACC)+ |
+
| 41 | ++ |
+ #' MAE_fd <- teal.slice:::init_filtered_dataset(miniACC, "MAE", metadata = list(type = "MAE"))+ |
+
| 42 | ++ |
+ #' app <- shinyApp(+ |
+
| 43 | ++ |
+ #' ui = fluidPage(+ |
+
| 44 | ++ |
+ #' MAE_fd$ui_add(id = "add"),+ |
+
| 45 | ++ |
+ #' MAE_fd$ui_active("dataset"),
+ |
+
| 46 | ++ |
+ #' verbatimTextOutput("call"),
+ |
+
| 47 | ++ |
+ #' verbatimTextOutput("metadata")
+ |
+
| 48 | ++ |
+ #' ),+ |
+
| 49 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 50 | ++ |
+ #' MAE_fd$srv_add(id = "add")+ |
+
| 51 | ++ |
+ #' MAE_fd$srv_active(id = "dataset")+ |
+
| 52 | ++ |
+ #' output$metadata <- renderText({
+ |
+
| 53 | ++ |
+ #' paste("Type =", MAE_fd$get_metadata()$type)
+ |
+
| 54 | ++ |
+ #' })+ |
+
| 55 | ++ |
+ #' output$call <- renderText({
+ |
+
| 56 | ++ |
+ #' paste(+ |
+
| 57 | ++ |
+ #' vapply(MAE_fd$get_call(), deparse1, character(1), collapse = "\n"),+ |
+
| 58 | ++ |
+ #' collapse = "\n"+ |
+
| 59 | ++ |
+ #' )+ |
+
| 60 | ++ |
+ #' })+ |
+
| 61 | ++ |
+ #' }+ |
+
| 62 | ++ |
+ #' )+ |
+
| 63 | ++ |
+ #' if (interactive()) {
+ |
+
| 64 | ++ |
+ #' runApp(app)+ |
+
| 65 | ++ |
+ #' }+ |
+
| 66 | ++ |
+ #' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr+ |
+
| 67 | ++ |
+ #' @param dataname (`character`)\cr+ |
+
| 68 | ++ |
+ #' A given name for the dataset it may not contain spaces+ |
+
| 69 | ++ |
+ #' @param keys optional, (`character`)\cr+ |
+
| 70 | ++ |
+ #' Vector with primary keys+ |
+
| 71 | ++ |
+ #' @param parent_name (`character(1)`)\cr+ |
+
| 72 | ++ |
+ #' Name of the parent dataset+ |
+
| 73 | ++ |
+ #' @param parent (`reactive`)\cr+ |
+
| 74 | ++ |
+ #' object returned by this reactive is a filtered `data.frame` from other `FilteredDataset`+ |
+
| 75 | ++ |
+ #' named `parent_name`. Consequence of passing `parent` is a `reactive` link which causes+ |
+
| 76 | ++ |
+ #' causing re-filtering of this `dataset` based on the changes in `parent`.+ |
+
| 77 | ++ |
+ #' @param join_keys (`character`)\cr+ |
+
| 78 | ++ |
+ #' Name of the columns in this dataset to join with `parent`+ |
+
| 79 | ++ |
+ #' dataset. If the column names are different if both datasets+ |
+
| 80 | ++ |
+ #' then the names of the vector define the `parent` columns.+ |
+
| 81 | ++ |
+ #' @param label (`character`)\cr+ |
+
| 82 | ++ |
+ #' Label to describe the dataset+ |
+
| 83 | ++ |
+ #' @param metadata (named `list` or `NULL`) \cr+ |
+
| 84 | ++ |
+ #' Field containing metadata about the dataset. Each element of the list+ |
+
| 85 | ++ |
+ #' should be atomic and length one.+ |
+
| 86 | ++ |
+ #' @export+ |
+
| 87 | ++ |
+ #' @note Although this function is exported for use in other packages, it may be changed or removed in a future release+ |
+
| 88 | ++ |
+ #' at which point any code which relies on this exported function will need to be changed.+ |
+
| 89 | ++ |
+ init_filtered_dataset <- function(dataset, # nolint+ |
+
| 90 | ++ |
+ dataname,+ |
+
| 91 | ++ |
+ keys = character(0),+ |
+
| 92 | ++ |
+ parent_name = character(0),+ |
+
| 93 | ++ |
+ parent = reactive(dataset),+ |
+
| 94 | ++ |
+ join_keys = character(0),+ |
+
| 95 | ++ |
+ label = attr(dataset, "label"),+ |
+
| 96 | ++ |
+ metadata = NULL) {
+ |
+
| 97 | +104x | +
+ UseMethod("init_filtered_dataset")
+ |
+
| 98 | ++ |
+ }+ |
+
| 99 | ++ | + + | +
| 100 | ++ |
+ #' @keywords internal+ |
+
| 101 | ++ |
+ #' @export+ |
+
| 102 | ++ |
+ init_filtered_dataset.data.frame <- function(dataset, # nolint+ |
+
| 103 | ++ |
+ dataname,+ |
+
| 104 | ++ |
+ keys = character(0),+ |
+
| 105 | ++ |
+ parent_name = character(0),+ |
+
| 106 | ++ |
+ parent = NULL,+ |
+
| 107 | ++ |
+ join_keys = character(0),+ |
+
| 108 | ++ |
+ label = attr(dataset, "label"),+ |
+
| 109 | ++ |
+ metadata = NULL) {
+ |
+
| 110 | +95x | +
+ DefaultFilteredDataset$new(+ |
+
| 111 | +95x | +
+ dataset = dataset,+ |
+
| 112 | +95x | +
+ dataname = dataname,+ |
+
| 113 | +95x | +
+ keys = keys,+ |
+
| 114 | +95x | +
+ parent_name = parent_name,+ |
+
| 115 | +95x | +
+ parent = parent,+ |
+
| 116 | +95x | +
+ join_keys = join_keys,+ |
+
| 117 | +95x | +
+ label = label,+ |
+
| 118 | +95x | +
+ metadata = metadata+ |
+
| 119 | ++ |
+ )+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ #' @keywords internal+ |
+
| 123 | ++ |
+ #' @export+ |
+
| 124 | ++ |
+ init_filtered_dataset.MultiAssayExperiment <- function(dataset, # nolint+ |
+
| 125 | ++ |
+ dataname,+ |
+
| 126 | ++ |
+ keys = character(0),+ |
+
| 127 | ++ |
+ parent_name, # ignored+ |
+
| 128 | ++ |
+ parent, # ignored+ |
+
| 129 | ++ |
+ join_keys, # ignored+ |
+
| 130 | ++ |
+ label = attr(dataset, "label"),+ |
+
| 131 | ++ |
+ metadata = NULL) {
+ |
+
| 132 | +9x | +
+ if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ |
+
| 133 | +! | +
+ stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | +9x | +
+ MAEFilteredDataset$new(+ |
+
| 136 | +9x | +
+ dataset = dataset,+ |
+
| 137 | +9x | +
+ dataname = dataname,+ |
+
| 138 | +9x | +
+ keys = keys,+ |
+
| 139 | +9x | +
+ label = label,+ |
+
| 140 | +9x | +
+ metadata = metadata+ |
+
| 141 | ++ |
+ )+ |
+
| 142 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @name ChoicesFilterState+ |
+
| 2 | ++ |
+ #' @title `FilterState` object for factor or character variable+ |
+
| 3 | ++ |
+ #' @description Manages choosing elements from a set+ |
+
| 4 | ++ |
+ #' @docType class+ |
+
| 5 | ++ |
+ #' @keywords internal+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @examples+ |
+
| 9 | ++ |
+ #' filter_state <- teal.slice:::ChoicesFilterState$new(+ |
+
| 10 | ++ |
+ #' x = c(LETTERS, NA),+ |
+
| 11 | ++ |
+ #' slice = teal_slice(varname = "x", dataname = "data")+ |
+
| 12 | ++ |
+ #' )+ |
+
| 13 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 14 | ++ |
+ #' filter_state$set_state(+ |
+
| 15 | ++ |
+ #' teal_slice(+ |
+
| 16 | ++ |
+ #' dataname = "data",+ |
+
| 17 | ++ |
+ #' varname = "x",+ |
+
| 18 | ++ |
+ #' selected = "A",+ |
+
| 19 | ++ |
+ #' keep_na = TRUE+ |
+
| 20 | ++ |
+ #' )+ |
+
| 21 | ++ |
+ #' )+ |
+
| 22 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' # working filter in an app+ |
+
| 25 | ++ |
+ #' library(shiny)+ |
+
| 26 | ++ |
+ #' library(shinyjs)+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA)+ |
+
| 29 | ++ |
+ #' attr(data_choices, "label") <- "lowercase letters"+ |
+
| 30 | ++ |
+ #' fs <- teal.slice:::ChoicesFilterState$new(+ |
+
| 31 | ++ |
+ #' x = data_choices,+ |
+
| 32 | ++ |
+ #' slice = teal_slice(+ |
+
| 33 | ++ |
+ #' dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE
+ |
+
| 34 | ++ |
+ #' )+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' ui <- fluidPage(+ |
+
| 38 | ++ |
+ #' useShinyjs(),+ |
+
| 39 | ++ |
+ #' teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 40 | ++ |
+ #' teal.slice:::include_js_files(pattern = "count-bar-labels"),+ |
+
| 41 | ++ |
+ #' column(4, div(+ |
+
| 42 | ++ |
+ #' h4("ChoicesFilterState"),
+ |
+
| 43 | ++ |
+ #' fs$ui("fs")
+ |
+
| 44 | ++ |
+ #' )),+ |
+
| 45 | ++ |
+ #' column(4, div(+ |
+
| 46 | ++ |
+ #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
+ |
+
| 47 | ++ |
+ #' textOutput("condition_choices"), br(),
+ |
+
| 48 | ++ |
+ #' h4("Unformatted state"), # display raw filter state
+ |
+
| 49 | ++ |
+ #' textOutput("unformatted_choices"), br(),
+ |
+
| 50 | ++ |
+ #' h4("Formatted state"), # display human readable filter state
+ |
+
| 51 | ++ |
+ #' textOutput("formatted_choices"), br()
+ |
+
| 52 | ++ |
+ #' )),+ |
+
| 53 | ++ |
+ #' column(4, div(+ |
+
| 54 | ++ |
+ #' h4("Programmatic filter control"),
+ |
+
| 55 | ++ |
+ #' actionButton("button1_choices", "set drop NA", width = "100%"), br(),
+ |
+
| 56 | ++ |
+ #' actionButton("button2_choices", "set keep NA", width = "100%"), br(),
+ |
+
| 57 | ++ |
+ #' actionButton("button3_choices", "set selection: a, b", width = "100%"), br(),
+ |
+
| 58 | ++ |
+ #' actionButton("button4_choices", "deselect all", width = "100%"), br(),
+ |
+
| 59 | ++ |
+ #' actionButton("button0_choices", "set initial state", width = "100%"), br()
+ |
+
| 60 | ++ |
+ #' ))+ |
+
| 61 | ++ |
+ #' )+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 64 | ++ |
+ #' fs$server("fs")
+ |
+
| 65 | ++ |
+ #' output$condition_choices <- renderPrint(fs$get_call())+ |
+
| 66 | ++ |
+ #' output$formatted_choices <- renderText(fs$format())+ |
+
| 67 | ++ |
+ #' output$unformatted_choices <- renderPrint(fs$get_state())+ |
+
| 68 | ++ |
+ #' # modify filter state programmatically+ |
+
| 69 | ++ |
+ #' observeEvent(+ |
+
| 70 | ++ |
+ #' input$button1_choices,+ |
+
| 71 | ++ |
+ #' fs$set_state(+ |
+
| 72 | ++ |
+ #' teal_slice(dataname = "data", varname = "variable", keep_na = FALSE)+ |
+
| 73 | ++ |
+ #' )+ |
+
| 74 | ++ |
+ #' )+ |
+
| 75 | ++ |
+ #' observeEvent(+ |
+
| 76 | ++ |
+ #' input$button2_choices,+ |
+
| 77 | ++ |
+ #' fs$set_state(+ |
+
| 78 | ++ |
+ #' teal_slice(dataname = "data", varname = "variable", keep_na = TRUE)+ |
+
| 79 | ++ |
+ #' )+ |
+
| 80 | ++ |
+ #' )+ |
+
| 81 | ++ |
+ #' observeEvent(+ |
+
| 82 | ++ |
+ #' input$button3_choices,+ |
+
| 83 | ++ |
+ #' fs$set_state(+ |
+
| 84 | ++ |
+ #' teal_slice(dataname = "data", varname = "variable", selected = c("a", "b"))
+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ #' )+ |
+
| 87 | ++ |
+ #' observeEvent(+ |
+
| 88 | ++ |
+ #' input$button4_choices,+ |
+
| 89 | ++ |
+ #' fs$set_state(+ |
+
| 90 | ++ |
+ #' teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE)+ |
+
| 91 | ++ |
+ #' )+ |
+
| 92 | ++ |
+ #' )+ |
+
| 93 | ++ |
+ #' observeEvent(+ |
+
| 94 | ++ |
+ #' input$button0_choices,+ |
+
| 95 | ++ |
+ #' fs$set_state(+ |
+
| 96 | ++ |
+ #' teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE)
+ |
+
| 97 | ++ |
+ #' )+ |
+
| 98 | ++ |
+ #' )+ |
+
| 99 | ++ |
+ #' }+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' if (interactive()) {
+ |
+
| 102 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 103 | ++ |
+ #' }+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ ChoicesFilterState <- R6::R6Class( # nolint+ |
+
| 106 | ++ |
+ "ChoicesFilterState",+ |
+
| 107 | ++ |
+ inherit = FilterState,+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ # public methods ----+ |
+
| 110 | ++ | + + | +
| 111 | ++ |
+ public = list(+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ #' @description+ |
+
| 114 | ++ |
+ #' Initialize a `InteractiveFilterState` object+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' @param x (`vector`)\cr+ |
+
| 117 | ++ |
+ #' values of the variable used in filter+ |
+
| 118 | ++ |
+ #' @param x_reactive (`reactive`)\cr+ |
+
| 119 | ++ |
+ #' returning vector of the same type as `x`. Is used to update+ |
+
| 120 | ++ |
+ #' counts following the change in values of the filtered dataset.+ |
+
| 121 | ++ |
+ #' If it is set to `reactive(NULL)` then counts based on filtered+ |
+
| 122 | ++ |
+ #' dataset are not shown.+ |
+
| 123 | ++ |
+ #' @param slice (`teal_slice`)\cr+ |
+
| 124 | ++ |
+ #' object created using [teal_slice()]. `teal_slice` is stored+ |
+
| 125 | ++ |
+ #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`+ |
+
| 126 | ++ |
+ #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`+ |
+
| 127 | ++ |
+ #' is a `reactiveValues` which means that changes in particular object are automatically+ |
+
| 128 | ++ |
+ #' reflected in all places which refer to the same `teal_slice`.+ |
+
| 129 | ++ |
+ #' @param extract_type (`character(0)`, `character(1)`)\cr+ |
+
| 130 | ++ |
+ #' whether condition calls should be prefixed by `dataname`. Possible values:+ |
+
| 131 | ++ |
+ #' \itemize{
+ |
+
| 132 | ++ |
+ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
+ |
+
| 133 | ++ |
+ #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
+ |
+
| 134 | ++ |
+ #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
+ |
+
| 135 | ++ |
+ #' }+ |
+
| 136 | ++ |
+ #' @param ... additional arguments to be saved as a list in `private$extras` field+ |
+
| 137 | ++ |
+ #'+ |
+
| 138 | ++ |
+ initialize = function(x,+ |
+
| 139 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 140 | ++ |
+ slice,+ |
+
| 141 | ++ |
+ extract_type = character(0)) {
+ |
+
| 142 | +140x | +
+ shiny::isolate({
+ |
+
| 143 | +140x | +
+ checkmate::assert(+ |
+
| 144 | +140x | +
+ is.character(x),+ |
+
| 145 | +140x | +
+ is.factor(x),+ |
+
| 146 | +140x | +
+ length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
+ |
+
| 147 | +140x | +
+ combine = "or"+ |
+
| 148 | ++ |
+ )+ |
+
| 149 | ++ | + + | +
| 150 | +140x | +
+ x_factor <- if (!is.factor(x)) {
+ |
+
| 151 | +104x | +
+ structure(+ |
+
| 152 | +104x | +
+ factor(as.character(x), levels = as.character(sort(unique(x)))),+ |
+
| 153 | +104x | +
+ label = attr(x, "label")+ |
+
| 154 | ++ |
+ )+ |
+
| 155 | ++ |
+ } else {
+ |
+
| 156 | +36x | +
+ x+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | +140x | +
+ super$initialize(+ |
+
| 160 | +140x | +
+ x = x_factor,+ |
+
| 161 | +140x | +
+ x_reactive = x_reactive,+ |
+
| 162 | +140x | +
+ slice = slice,+ |
+
| 163 | +140x | +
+ extract_type = extract_type+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | +140x | +
+ private$set_choices(slice$choices)+ |
+
| 166 | +140x | +
+ if (is.null(slice$selected) && slice$multiple) {
+ |
+
| 167 | +35x | +
+ slice$selected <- private$get_choices()+ |
+
| 168 | +105x | +
+ } else if (is.null(slice$selected)) {
+ |
+
| 169 | +1x | +
+ slice$selected <- private$get_choices()[1]+ |
+
| 170 | +104x | +
+ } else if (length(slice$selected) > 1 && !slice$multiple) {
+ |
+
| 171 | +1x | +
+ warning(+ |
+
| 172 | +1x | +
+ "ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ",+ |
+
| 173 | +1x | +
+ "Only the first value will be used."+ |
+
| 174 | ++ |
+ )+ |
+
| 175 | +1x | +
+ slice$selected <- slice$selected[1]+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | +140x | +
+ private$set_selected(slice$selected)+ |
+
| 178 | +140x | +
+ private$data_class <- class(x)[1L]+ |
+
| 179 | +140x | +
+ if (inherits(x, "POSIXt")) {
+ |
+
| 180 | +9x | +
+ private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ | + + | +
| 183 | +140x | +
+ private$set_choices_counts(unname(table(x_factor)))+ |
+
| 184 | ++ |
+ })+ |
+
| 185 | +140x | +
+ invisible(self)+ |
+
| 186 | ++ |
+ },+ |
+
| 187 | ++ | + + | +
| 188 | ++ |
+ #' @description+ |
+
| 189 | ++ |
+ #' Returns reproducible condition call for current selection.+ |
+
| 190 | ++ |
+ #' For this class returned call looks like+ |
+
| 191 | ++ |
+ #' `<varname> %in% c(<values selected>)` with+ |
+
| 192 | ++ |
+ #' optional `is.na(<varname>)`.+ |
+
| 193 | ++ |
+ #' @param dataname name of data set; defaults to `private$get_dataname()`+ |
+
| 194 | ++ |
+ #' @return (`call`) or `NULL`+ |
+
| 195 | ++ |
+ #'+ |
+
| 196 | ++ |
+ get_call = function(dataname) {
+ |
+
| 197 | +36x | +
+ if (isFALSE(private$is_any_filtered())) {
+ |
+
| 198 | +2x | +
+ return(NULL)+ |
+
| 199 | ++ |
+ }+ |
+
| 200 | +10x | +
+ if (missing(dataname)) dataname <- private$get_dataname()+ |
+
| 201 | +34x | +
+ varname <- private$get_varname_prefixed(dataname)+ |
+
| 202 | +34x | +
+ choices <- private$get_selected()+ |
+
| 203 | +34x | +
+ if (private$data_class != "factor") {
+ |
+
| 204 | +27x | +
+ choices <- do.call(sprintf("as.%s", private$data_class), list(x = choices))
+ |
+
| 205 | ++ |
+ }+ |
+
| 206 | +34x | +
+ fun_compare <- if (length(choices) == 1L) "==" else "%in%"+ |
+
| 207 | ++ | + + | +
| 208 | +34x | +
+ filter_call <-+ |
+
| 209 | +34x | +
+ if (inherits(choices, "Date")) {
+ |
+
| 210 | +1x | +
+ call(fun_compare, varname, call("as.Date", make_c_call(as.character(choices))))
+ |
+
| 211 | +34x | +
+ } else if (inherits(choices, c("POSIXct", "POSIXlt"))) {
+ |
+
| 212 | +2x | +
+ class <- class(choices)[1L]+ |
+
| 213 | +2x | +
+ date_fun <- as.name(+ |
+
| 214 | +2x | +
+ switch(class,+ |
+
| 215 | +2x | +
+ "POSIXct" = "as.POSIXct",+ |
+
| 216 | +2x | +
+ "POSIXlt" = "as.POSIXlt"+ |
+
| 217 | ++ |
+ )+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | +2x | +
+ call(+ |
+
| 220 | +2x | +
+ fun_compare,+ |
+
| 221 | +2x | +
+ varname,+ |
+
| 222 | +2x | +
+ as.call(list(date_fun, make_c_call(as.character(choices)), tz = private$tzone))+ |
+
| 223 | ++ |
+ )+ |
+
| 224 | ++ |
+ } else {
+ |
+
| 225 | ++ |
+ # This handles numerics, characters, and factors.+ |
+
| 226 | +31x | +
+ call(fun_compare, varname, make_c_call(choices))+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | +34x | +
+ private$add_keep_na_call(filter_call, dataname)+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | ++ |
+ ),+ |
+
| 231 | ++ | + + | +
| 232 | ++ |
+ # private members ----+ |
+
| 233 | ++ |
+ private = list(+ |
+
| 234 | ++ |
+ x = NULL,+ |
+
| 235 | ++ |
+ choices_counts = integer(0),+ |
+
| 236 | ++ |
+ data_class = character(0), # stores class of filtered variable so that it can be restored in $get_call+ |
+
| 237 | ++ |
+ tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call+ |
+
| 238 | ++ | + + | +
| 239 | ++ |
+ # private methods ----+ |
+
| 240 | ++ | + + | +
| 241 | ++ |
+ # @description+ |
+
| 242 | ++ |
+ # Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices+ |
+
| 243 | ++ |
+ # are limited by default from the start.+ |
+
| 244 | ++ |
+ set_choices = function(choices) {
+ |
+
| 245 | +140x | +
+ if (is.null(choices)) {
+ |
+
| 246 | +127x | +
+ choices <- levels(private$x)+ |
+
| 247 | ++ |
+ } else {
+ |
+
| 248 | +13x | +
+ choices <- as.character(choices)+ |
+
| 249 | +13x | +
+ choices_adjusted <- choices[choices %in% private$x]+ |
+
| 250 | +13x | +
+ if (length(setdiff(choices, choices_adjusted)) > 0L) {
+ |
+
| 251 | +2x | +
+ warning(+ |
+
| 252 | +2x | +
+ sprintf(+ |
+
| 253 | +2x | +
+ "Some choices not found in data. Adjusting. Filter id: %s.",+ |
+
| 254 | +2x | +
+ private$get_id()+ |
+
| 255 | ++ |
+ )+ |
+
| 256 | ++ |
+ )+ |
+
| 257 | +2x | +
+ choices <- choices_adjusted+ |
+
| 258 | ++ |
+ }+ |
+
| 259 | +13x | +
+ if (length(choices) == 0) {
+ |
+
| 260 | +1x | +
+ warning(+ |
+
| 261 | +1x | +
+ sprintf(+ |
+
| 262 | +1x | +
+ "None of the choices were found in data. Setting defaults. Filter id: %s.",+ |
+
| 263 | +1x | +
+ private$get_id()+ |
+
| 264 | ++ |
+ )+ |
+
| 265 | ++ |
+ )+ |
+
| 266 | +1x | +
+ choices <- levels(private$x)+ |
+
| 267 | ++ |
+ }+ |
+
| 268 | ++ |
+ }+ |
+
| 269 | +140x | +
+ private$set_is_choice_limited(private$x, choices)+ |
+
| 270 | +140x | +
+ private$teal_slice$choices <- choices+ |
+
| 271 | +140x | +
+ private$x <- private$x[(private$x %in% private$get_choices()) | is.na(private$x)]+ |
+
| 272 | +140x | +
+ private$x <- droplevels(private$x)+ |
+
| 273 | +140x | +
+ invisible(NULL)+ |
+
| 274 | ++ |
+ },+ |
+
| 275 | ++ |
+ # @description+ |
+
| 276 | ++ |
+ # Check whether the initial choices filter out some values of x and set the flag in case.+ |
+
| 277 | ++ |
+ set_is_choice_limited = function(x, choices) {
+ |
+
| 278 | +140x | +
+ xl <- x[!is.na(x)]+ |
+
| 279 | +140x | +
+ private$is_choice_limited <- length(setdiff(xl, choices)) > 0L+ |
+
| 280 | +140x | +
+ invisible(NULL)+ |
+
| 281 | ++ |
+ },+ |
+
| 282 | ++ |
+ # @description+ |
+
| 283 | ++ |
+ # Sets choices_counts private field.+ |
+
| 284 | ++ |
+ set_choices_counts = function(choices_counts) {
+ |
+
| 285 | +140x | +
+ private$choices_counts <- choices_counts+ |
+
| 286 | +140x | +
+ invisible(NULL)+ |
+
| 287 | ++ |
+ },+ |
+
| 288 | ++ |
+ # @description+ |
+
| 289 | ++ |
+ # Checks how many counts of each choice is present in the data.+ |
+
| 290 | ++ |
+ get_choices_counts = function() {
+ |
+
| 291 | +! | +
+ if (!is.null(private$x_reactive)) {
+ |
+
| 292 | +! | +
+ table(factor(private$x_reactive(), levels = private$get_choices()))+ |
+
| 293 | ++ |
+ } else {
+ |
+
| 294 | +! | +
+ NULL+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | ++ |
+ },+ |
+
| 297 | ++ |
+ # @description+ |
+
| 298 | ++ |
+ # Checks whether the input should be rendered as a checkboxgroup/radiobutton or a drop-down.+ |
+
| 299 | ++ |
+ is_checkboxgroup = function() {
+ |
+
| 300 | +23x | +
+ length(private$get_choices()) <= getOption("teal.threshold_slider_vs_checkboxgroup")
+ |
+
| 301 | ++ |
+ },+ |
+
| 302 | ++ |
+ cast_and_validate = function(values) {
+ |
+
| 303 | +163x | +
+ tryCatch(+ |
+
| 304 | +163x | +
+ expr = {
+ |
+
| 305 | +163x | +
+ values <- as.character(values)+ |
+
| 306 | +! | +
+ if (any(is.na(values))) stop()+ |
+
| 307 | ++ |
+ },+ |
+
| 308 | +163x | +
+ error = function(error) stop("The array of set values must contain values coercible to character.")
+ |
+
| 309 | ++ |
+ )+ |
+
| 310 | +163x | +
+ values+ |
+
| 311 | ++ |
+ },+ |
+
| 312 | ++ |
+ remove_out_of_bound_values = function(values) {
+ |
+
| 313 | +163x | +
+ in_choices_mask <- values %in% private$get_choices()+ |
+
| 314 | +163x | +
+ if (length(values[!in_choices_mask]) > 0) {
+ |
+
| 315 | +17x | +
+ warning(paste(+ |
+
| 316 | +17x | +
+ "Values:", toString(values[!in_choices_mask], width = 360),+ |
+
| 317 | +17x | +
+ "are not in choices of column", private$get_varname(), "in dataset", private$get_dataname(), "."+ |
+
| 318 | ++ |
+ ))+ |
+
| 319 | ++ |
+ }+ |
+
| 320 | +163x | +
+ values[in_choices_mask]+ |
+
| 321 | ++ |
+ },+ |
+
| 322 | ++ |
+ check_multiple = function(value) {
+ |
+
| 323 | +163x | +
+ if (!private$is_multiple() && length(value) > 1) {
+ |
+
| 324 | +1x | +
+ warning(+ |
+
| 325 | +1x | +
+ sprintf("Selection: %s is not a vector of length one. ", toString(value, width = 360)),
+ |
+
| 326 | +1x | +
+ "Maintaining previous selection."+ |
+
| 327 | ++ |
+ )+ |
+
| 328 | +1x | +
+ value <- shiny::isolate(private$get_selected())+ |
+
| 329 | ++ |
+ }+ |
+
| 330 | +163x | +
+ value+ |
+
| 331 | ++ |
+ },+ |
+
| 332 | ++ |
+ validate_selection = function(value) {
+ |
+
| 333 | +163x | +
+ if (!is.character(value)) {
+ |
+
| 334 | +! | +
+ stop(+ |
+
| 335 | +! | +
+ sprintf(+ |
+
| 336 | +! | +
+ "Values of the selection for `%s` in `%s` should be an array of character.",+ |
+
| 337 | +! | +
+ private$get_varname(),+ |
+
| 338 | +! | +
+ private$get_dataname()+ |
+
| 339 | ++ |
+ )+ |
+
| 340 | ++ |
+ )+ |
+
| 341 | ++ |
+ }+ |
+
| 342 | +163x | +
+ pre_msg <- sprintf(+ |
+
| 343 | +163x | +
+ "data '%s', variable '%s': ",+ |
+
| 344 | +163x | +
+ private$get_dataname(),+ |
+
| 345 | +163x | +
+ private$get_varname()+ |
+
| 346 | ++ |
+ )+ |
+
| 347 | +163x | +
+ check_in_subset(value, private$get_choices(), pre_msg = pre_msg)+ |
+
| 348 | ++ |
+ },+ |
+
| 349 | ++ | + + | +
| 350 | ++ |
+ # shiny modules ----+ |
+
| 351 | ++ | + + | +
| 352 | ++ |
+ # @description+ |
+
| 353 | ++ |
+ # UI Module for `ChoicesFilterState`.+ |
+
| 354 | ++ |
+ # This UI element contains available choices selection and+ |
+
| 355 | ++ |
+ # checkbox whether to keep or not keep the `NA` values.+ |
+
| 356 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 357 | ++ |
+ # id of shiny element+ |
+
| 358 | ++ |
+ ui_inputs = function(id) {
+ |
+
| 359 | +7x | +
+ ns <- NS(id)+ |
+
| 360 | ++ | + + | +
| 361 | ++ |
+ # we need to isolate UI to not rettrigger renderUI+ |
+
| 362 | +7x | +
+ shiny::isolate({
+ |
+
| 363 | +7x | +
+ countsmax <- private$choices_counts+ |
+
| 364 | +7x | +
+ countsnow <- if (!is.null(private$x_reactive())) {
+ |
+
| 365 | +! | +
+ unname(table(factor(private$x_reactive(), levels = private$get_choices())))+ |
+
| 366 | ++ |
+ } else {
+ |
+
| 367 | +7x | +
+ NULL+ |
+
| 368 | ++ |
+ }+ |
+
| 369 | ++ | + + | +
| 370 | +7x | +
+ ui_input <- if (private$is_checkboxgroup()) {
+ |
+
| 371 | +7x | +
+ labels <- countBars(+ |
+
| 372 | +7x | +
+ inputId = ns("labels"),
+ |
+
| 373 | +7x | +
+ choices = private$get_choices(),+ |
+
| 374 | +7x | +
+ countsnow = countsnow,+ |
+
| 375 | +7x | +
+ countsmax = countsmax+ |
+
| 376 | ++ |
+ )+ |
+
| 377 | +7x | +
+ div(+ |
+
| 378 | +7x | +
+ class = "choices_state",+ |
+
| 379 | +7x | +
+ if (private$is_multiple()) {
+ |
+
| 380 | +7x | +
+ checkboxGroupInput(+ |
+
| 381 | +7x | +
+ inputId = ns("selection"),
+ |
+
| 382 | +7x | +
+ label = NULL,+ |
+
| 383 | +7x | +
+ selected = private$get_selected(),+ |
+
| 384 | +7x | +
+ choiceNames = labels,+ |
+
| 385 | +7x | +
+ choiceValues = private$get_choices(),+ |
+
| 386 | +7x | +
+ width = "100%"+ |
+
| 387 | ++ |
+ )+ |
+
| 388 | ++ |
+ } else {
+ |
+
| 389 | +! | +
+ radioButtons(+ |
+
| 390 | +! | +
+ inputId = ns("selection"),
+ |
+
| 391 | +! | +
+ label = NULL,+ |
+
| 392 | +! | +
+ selected = private$get_selected(),+ |
+
| 393 | +! | +
+ choiceNames = labels,+ |
+
| 394 | +! | +
+ choiceValues = private$get_choices(),+ |
+
| 395 | +! | +
+ width = "100%"+ |
+
| 396 | ++ |
+ )+ |
+
| 397 | ++ |
+ }+ |
+
| 398 | ++ |
+ )+ |
+
| 399 | ++ |
+ } else {
+ |
+
| 400 | +! | +
+ labels <- mapply(+ |
+
| 401 | +! | +
+ FUN = make_count_text,+ |
+
| 402 | +! | +
+ label = private$get_choices(),+ |
+
| 403 | +! | +
+ countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,+ |
+
| 404 | +! | +
+ countmax = countsmax+ |
+
| 405 | ++ |
+ )+ |
+
| 406 | ++ | + + | +
| 407 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 408 | +! | +
+ inputId = ns("selection"),
+ |
+
| 409 | +! | +
+ choices = stats::setNames(private$get_choices(), labels),+ |
+
| 410 | +! | +
+ selected = private$get_selected(),+ |
+
| 411 | +! | +
+ multiple = private$is_multiple(),+ |
+
| 412 | +! | +
+ options = shinyWidgets::pickerOptions(+ |
+
| 413 | +! | +
+ actionsBox = TRUE,+ |
+
| 414 | +! | +
+ liveSearch = (length(private$get_choices()) > 10),+ |
+
| 415 | +! | +
+ noneSelectedText = "Select a value"+ |
+
| 416 | ++ |
+ )+ |
+
| 417 | ++ |
+ )+ |
+
| 418 | ++ |
+ }+ |
+
| 419 | +7x | +
+ div(+ |
+
| 420 | +7x | +
+ uiOutput(ns("trigger_visible")),
+ |
+
| 421 | +7x | +
+ ui_input,+ |
+
| 422 | +7x | +
+ private$keep_na_ui(ns("keep_na"))
+ |
+
| 423 | ++ |
+ )+ |
+
| 424 | ++ |
+ })+ |
+
| 425 | ++ |
+ },+ |
+
| 426 | ++ | + + | +
| 427 | ++ |
+ # @description+ |
+
| 428 | ++ |
+ # Server module+ |
+
| 429 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 430 | ++ |
+ # an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 431 | ++ |
+ # @return `moduleServer` function which returns `NULL`+ |
+
| 432 | ++ |
+ server_inputs = function(id) {
+ |
+
| 433 | +7x | +
+ moduleServer(+ |
+
| 434 | +7x | +
+ id = id,+ |
+
| 435 | +7x | +
+ function(input, output, session) {
+ |
+
| 436 | +7x | +
+ logger::log_trace("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }")
+ |
+
| 437 | ++ | + + | +
| 438 | ++ |
+ # 1. renderUI is used here as an observer which triggers only if output is visible+ |
+
| 439 | ++ |
+ # and if the reactive changes - reactive triggers only if the output is visible.+ |
+
| 440 | ++ |
+ # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)+ |
+
| 441 | +7x | +
+ non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))+ |
+
| 442 | +7x | +
+ output$trigger_visible <- renderUI({
+ |
+
| 443 | +7x | +
+ logger::log_trace("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")
+ |
+
| 444 | ++ | + + | +
| 445 | +7x | +
+ countsnow <- if (!is.null(private$x_reactive())) {
+ |
+
| 446 | +! | +
+ unname(table(factor(non_missing_values(), levels = private$get_choices())))+ |
+
| 447 | ++ |
+ } else {
+ |
+
| 448 | +7x | +
+ NULL+ |
+
| 449 | ++ |
+ }+ |
+
| 450 | ++ | + + | +
| 451 | ++ |
+ # update should be based on a change of counts only+ |
+
| 452 | +7x | +
+ shiny::isolate({
+ |
+
| 453 | +7x | +
+ if (private$is_checkboxgroup()) {
+ |
+
| 454 | +7x | +
+ updateCountBars(+ |
+
| 455 | +7x | +
+ inputId = "labels",+ |
+
| 456 | +7x | +
+ choices = private$get_choices(),+ |
+
| 457 | +7x | +
+ countsmax = private$choices_counts,+ |
+
| 458 | +7x | +
+ countsnow = countsnow+ |
+
| 459 | ++ |
+ )+ |
+
| 460 | ++ |
+ } else {
+ |
+
| 461 | +! | +
+ labels <- mapply(+ |
+
| 462 | +! | +
+ FUN = make_count_text,+ |
+
| 463 | +! | +
+ label = private$get_choices(),+ |
+
| 464 | +! | +
+ countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,+ |
+
| 465 | +! | +
+ countmax = private$choices_counts+ |
+
| 466 | ++ |
+ )+ |
+
| 467 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+
| 468 | +! | +
+ session = session,+ |
+
| 469 | +! | +
+ inputId = "selection",+ |
+
| 470 | +! | +
+ choices = stats::setNames(private$get_choices(), labels),+ |
+
| 471 | +! | +
+ selected = private$get_selected()+ |
+
| 472 | ++ |
+ )+ |
+
| 473 | ++ |
+ }+ |
+
| 474 | +7x | +
+ NULL+ |
+
| 475 | ++ |
+ })+ |
+
| 476 | ++ |
+ })+ |
+
| 477 | ++ | + + | +
| 478 | +7x | +
+ if (private$is_checkboxgroup()) {
+ |
+
| 479 | +7x | +
+ private$observers$selection <- observeEvent(+ |
+
| 480 | +7x | +
+ ignoreNULL = FALSE,+ |
+
| 481 | +7x | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 482 | +7x | +
+ eventExpr = input$selection,+ |
+
| 483 | +7x | +
+ handlerExpr = {
+ |
+
| 484 | +! | +
+ logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
+ |
+
| 485 | ++ | + + | +
| 486 | +! | +
+ selection <- if (is.null(input$selection) && private$is_multiple()) {
+ |
+
| 487 | +! | +
+ character(0)+ |
+
| 488 | ++ |
+ } else {
+ |
+
| 489 | +! | +
+ input$selection+ |
+
| 490 | ++ |
+ }+ |
+
| 491 | ++ | + + | +
| 492 | +! | +
+ private$set_selected(selection)+ |
+
| 493 | ++ |
+ }+ |
+
| 494 | ++ |
+ )+ |
+
| 495 | ++ |
+ } else {
+ |
+
| 496 | +! | +
+ private$observers$selection <- observeEvent(+ |
+
| 497 | +! | +
+ ignoreNULL = FALSE,+ |
+
| 498 | +! | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 499 | +! | +
+ eventExpr = input$selection_open, # observe click on a dropdown+ |
+
| 500 | +! | +
+ handlerExpr = {
+ |
+
| 501 | +! | +
+ if (!isTRUE(input$selection_open)) { # only when the dropdown got closed
+ |
+
| 502 | +! | +
+ logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")
+ |
+
| 503 | ++ | + + | +
| 504 | +! | +
+ selection <- if (is.null(input$selection) && private$is_multiple()) {
+ |
+
| 505 | +! | +
+ character(0)+ |
+
| 506 | +! | +
+ } else if (isTRUE(length(input$selection) != 1) && !private$is_multiple()) {
+ |
+
| 507 | ++ |
+ # In optionalSelectInput user is able to select mutliple options. But if FilterState is not multiple+ |
+
| 508 | ++ |
+ # we should prevent this selection to be processed further.+ |
+
| 509 | ++ |
+ # This is why notification is thrown and dropdown is changed back to latest selected.+ |
+
| 510 | +! | +
+ showNotification(paste(+ |
+
| 511 | +! | +
+ "This filter exclusively supports single selection.",+ |
+
| 512 | +! | +
+ "Any additional choices made will be disregarded."+ |
+
| 513 | ++ |
+ ))+ |
+
| 514 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+
| 515 | +! | +
+ session, "selection",+ |
+
| 516 | +! | +
+ selected = private$get_selected()+ |
+
| 517 | ++ |
+ )+ |
+
| 518 | +! | +
+ return(NULL)+ |
+
| 519 | ++ |
+ } else {
+ |
+
| 520 | +! | +
+ input$selection+ |
+
| 521 | ++ |
+ }+ |
+
| 522 | +! | +
+ private$set_selected(selection)+ |
+
| 523 | ++ |
+ }+ |
+
| 524 | ++ |
+ }+ |
+
| 525 | ++ |
+ )+ |
+
| 526 | ++ |
+ }+ |
+
| 527 | ++ | + + | +
| 528 | ++ | + + | +
| 529 | +7x | +
+ private$keep_na_srv("keep_na")
+ |
+
| 530 | ++ | + + | +
| 531 | ++ |
+ # this observer is needed in the situation when teal_slice$selected has been+ |
+
| 532 | ++ |
+ # changed directly by the api - then it's needed to rerender UI element+ |
+
| 533 | ++ |
+ # to show relevant values+ |
+
| 534 | +7x | +
+ private$observers$selection_api <- observeEvent(private$get_selected(), {
+ |
+
| 535 | ++ |
+ # it's important to not retrigger when the input$selection is the same as reactive values+ |
+
| 536 | ++ |
+ # kept in the teal_slice$selected+ |
+
| 537 | +2x | +
+ if (!setequal(input$selection, private$get_selected())) {
+ |
+
| 538 | +2x | +
+ logger::log_trace("ChoicesFilterState$server@1 state changed, id: { private$get_id() }")
+ |
+
| 539 | +2x | +
+ if (private$is_checkboxgroup()) {
+ |
+
| 540 | +2x | +
+ if (private$is_multiple()) {
+ |
+
| 541 | +2x | +
+ updateCheckboxGroupInput(+ |
+
| 542 | +2x | +
+ inputId = "selection",+ |
+
| 543 | +2x | +
+ selected = private$get_selected()+ |
+
| 544 | ++ |
+ )+ |
+
| 545 | ++ |
+ } else {
+ |
+
| 546 | +! | +
+ updateRadioButtons(+ |
+
| 547 | +! | +
+ inputId = "selection",+ |
+
| 548 | +! | +
+ selected = private$get_selected()+ |
+
| 549 | ++ |
+ )+ |
+
| 550 | ++ |
+ }+ |
+
| 551 | ++ |
+ } else {
+ |
+
| 552 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+
| 553 | +! | +
+ session, "selection",+ |
+
| 554 | +! | +
+ selected = private$get_selected()+ |
+
| 555 | ++ |
+ )+ |
+
| 556 | ++ |
+ }+ |
+
| 557 | ++ |
+ }+ |
+
| 558 | ++ |
+ })+ |
+
| 559 | ++ | + + | +
| 560 | +7x | +
+ logger::log_trace("ChoicesFilterState$server_inputs initialized, id: { private$get_id() }")
+ |
+
| 561 | +7x | +
+ NULL+ |
+
| 562 | ++ |
+ }+ |
+
| 563 | ++ |
+ )+ |
+
| 564 | ++ |
+ },+ |
+
| 565 | ++ |
+ server_inputs_fixed = function(id) {
+ |
+
| 566 | +! | +
+ moduleServer(+ |
+
| 567 | +! | +
+ id = id,+ |
+
| 568 | +! | +
+ function(input, output, session) {
+ |
+
| 569 | +! | +
+ logger::log_trace("ChoicesFilterState$server_inputs_fixed initializing, id: { private$get_id() }")
+ |
+
| 570 | ++ | + + | +
| 571 | +! | +
+ output$selection <- renderUI({
+ |
+
| 572 | +! | +
+ countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices())))+ |
+
| 573 | +! | +
+ countsmax <- private$choices_counts+ |
+
| 574 | ++ | + + | +
| 575 | +! | +
+ ind <- private$get_choices() %in% shiny::isolate(private$get_selected())+ |
+
| 576 | +! | +
+ countBars(+ |
+
| 577 | +! | +
+ inputId = session$ns("labels"),
+ |
+
| 578 | +! | +
+ choices = shiny::isolate(private$get_selected()),+ |
+
| 579 | +! | +
+ countsnow = countsnow[ind],+ |
+
| 580 | +! | +
+ countsmax = countsmax[ind]+ |
+
| 581 | ++ |
+ )+ |
+
| 582 | ++ |
+ })+ |
+
| 583 | ++ | + + | +
| 584 | +! | +
+ logger::log_trace("ChoicesFilterState$server_inputs_fixed initialized, id: { private$get_id() }")
+ |
+
| 585 | +! | +
+ NULL+ |
+
| 586 | ++ |
+ }+ |
+
| 587 | ++ |
+ )+ |
+
| 588 | ++ |
+ },+ |
+
| 589 | ++ | + + | +
| 590 | ++ |
+ # @description+ |
+
| 591 | ++ |
+ # UI module to display filter summary+ |
+
| 592 | ++ |
+ # renders text describing number of selected levels+ |
+
| 593 | ++ |
+ # and if NA are included also+ |
+
| 594 | ++ |
+ content_summary = function(id) {
+ |
+
| 595 | +7x | +
+ selected <- private$get_selected()+ |
+
| 596 | +7x | +
+ selected_length <- nchar(paste0(selected, collapse = ""))+ |
+
| 597 | +7x | +
+ if (selected_length <= 40) {
+ |
+
| 598 | +7x | +
+ selected_text <- paste0(selected, collapse = ", ")+ |
+
| 599 | ++ |
+ } else {
+ |
+
| 600 | +! | +
+ n_selected <- length(selected)+ |
+
| 601 | +! | +
+ selected_text <- paste(n_selected, "levels selected")+ |
+
| 602 | ++ |
+ }+ |
+
| 603 | +7x | +
+ tagList(+ |
+
| 604 | +7x | +
+ tags$span(+ |
+
| 605 | +7x | +
+ class = "filter-card-summary-value",+ |
+
| 606 | +7x | +
+ selected_text+ |
+
| 607 | ++ |
+ ),+ |
+
| 608 | +7x | +
+ tags$span(+ |
+
| 609 | +7x | +
+ class = "filter-card-summary-controls",+ |
+
| 610 | +7x | +
+ if (isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 611 | +! | +
+ tags$span(+ |
+
| 612 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 613 | +! | +
+ "NA",+ |
+
| 614 | +! | +
+ shiny::icon("check")
+ |
+
| 615 | ++ |
+ )+ |
+
| 616 | +7x | +
+ } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 617 | +! | +
+ tags$span(+ |
+
| 618 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 619 | +! | +
+ "NA",+ |
+
| 620 | +! | +
+ shiny::icon("xmark")
+ |
+
| 621 | ++ |
+ )+ |
+
| 622 | ++ |
+ } else {
+ |
+
| 623 | +7x | +
+ NULL+ |
+
| 624 | ++ |
+ }+ |
+
| 625 | ++ |
+ )+ |
+
| 626 | ++ |
+ )+ |
+
| 627 | ++ |
+ }+ |
+
| 628 | ++ |
+ )+ |
+
| 629 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' @name FilteredData+ |
+
| 2 | ++ |
+ #' @docType class+ |
+
| 3 | ++ |
+ #'+ |
+
| 4 | ++ |
+ #' @title Class to encapsulate filtered datasets+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @details+ |
+
| 7 | ++ |
+ #' The main purpose of this class is to provide a collection of reactive datasets,+ |
+
| 8 | ++ |
+ #' each dataset having a filter state that determines how it is filtered.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' For each dataset, `get_filter_expr` returns the call to filter the dataset according+ |
+
| 11 | ++ |
+ #' to the filter state. The data itself can be obtained through `get_data`.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' The datasets are filtered lazily, i.e. only when requested / needed in a Shiny app.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' By design, any `dataname` set through `set_dataset` cannot be removed because+ |
+
| 16 | ++ |
+ #' other code may already depend on it. As a workaround, the underlying+ |
+
| 17 | ++ |
+ #' data can be set to `NULL`.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' The class currently supports variables of the following types within datasets:+ |
+
| 20 | ++ |
+ #' - `choices`: variable of type `factor`, e.g. `ADSL$COUNTRY`, `iris$Species`+ |
+
| 21 | ++ |
+ #' zero or more options can be selected, when the variable is a factor+ |
+
| 22 | ++ |
+ #' - `logical`: variable of type `logical`, e.g. `ADSL$TRT_FLAG`+ |
+
| 23 | ++ |
+ #' exactly one option must be selected, `TRUE` or `FALSE`+ |
+
| 24 | ++ |
+ #' - `ranges`: variable of type `numeric`, e.g. `ADSL$AGE`, `iris$Sepal.Length`+ |
+
| 25 | ++ |
+ #' numerical range, a range within this range can be selected+ |
+
| 26 | ++ |
+ #' - `dates`: variable of type `Date`, `POSIXlt`+ |
+
| 27 | ++ |
+ #' Other variables cannot be used for filtering the data in this class.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' Common arguments are:+ |
+
| 30 | ++ |
+ #' 1. `filtered`: whether to return a filtered result or not+ |
+
| 31 | ++ |
+ #' 2. `dataname`: the name of one of the datasets in this `FilteredData`+ |
+
| 32 | ++ |
+ #' 3. `varname`: one of the columns in a dataset+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @keywords internal+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @examples+ |
+
| 37 | ++ |
+ #' library(shiny)+ |
+
| 38 | ++ |
+ #' datasets <- teal.slice:::FilteredData$new(+ |
+
| 39 | ++ |
+ #' list(+ |
+
| 40 | ++ |
+ #' iris = list(dataset = iris),+ |
+
| 41 | ++ |
+ #' mtcars = list(dataset = mtcars)+ |
+
| 42 | ++ |
+ #' )+ |
+
| 43 | ++ |
+ #' )+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' # get datanames+ |
+
| 46 | ++ |
+ #' datasets$datanames()+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' datasets$set_filter_state(+ |
+
| 49 | ++ |
+ #' teal_slices(teal_slice(dataname = "iris", varname = "Species", selected = "virginica"))+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #' isolate(datasets$get_call("iris"))
+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' datasets$set_filter_state(+ |
+
| 54 | ++ |
+ #' teal_slices(teal_slice(dataname = "mtcars", varname = "mpg", selected = c(15, 20)))+ |
+
| 55 | ++ |
+ #' )+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' isolate(datasets$get_filter_state())+ |
+
| 58 | ++ |
+ #' isolate(datasets$get_call("iris"))
+ |
+
| 59 | ++ |
+ #' isolate(datasets$get_call("mtcars"))
+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ FilteredData <- R6::R6Class( # nolint+ |
+
| 62 | ++ |
+ "FilteredData",+ |
+
| 63 | ++ |
+ ## __Public Methods ====+ |
+
| 64 | ++ |
+ public = list(+ |
+
| 65 | ++ |
+ #' @description+ |
+
| 66 | ++ |
+ #' Initialize a `FilteredData` object+ |
+
| 67 | ++ |
+ #' @param data_objects (`list`)+ |
+
| 68 | ++ |
+ #' should named elements containing `data.frame` or `MultiAssayExperiment`.+ |
+
| 69 | ++ |
+ #' Names of the list will serve as `dataname`.+ |
+
| 70 | ++ |
+ #' @param join_keys (`JoinKeys` or NULL) see [`teal.data::join_keys()`].+ |
+
| 71 | ++ |
+ #' @param code (`CodeClass` or `NULL`) see [`teal.data::CodeClass`].+ |
+
| 72 | ++ |
+ #' @param check (`logical(1)`) whether data has been check against reproducibility.+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ initialize = function(data_objects, join_keys = teal.data::join_keys(), code = NULL, check = FALSE) {
+ |
+
| 75 | +69x | +
+ checkmate::assert_list(data_objects, any.missing = FALSE, min.len = 0, names = "unique")+ |
+
| 76 | ++ |
+ # Note the internals of data_objects are checked in set_dataset+ |
+
| 77 | +69x | +
+ checkmate::assert_class(join_keys, "JoinKeys")+ |
+
| 78 | +65x | +
+ checkmate::assert_class(code, "CodeClass", null.ok = TRUE)+ |
+
| 79 | +65x | +
+ checkmate::assert_flag(check)+ |
+
| 80 | ++ | + + | +
| 81 | +65x | +
+ self$set_check(check)+ |
+
| 82 | +65x | +
+ if (!is.null(code)) {
+ |
+
| 83 | +6x | +
+ self$set_code(code)+ |
+
| 84 | ++ |
+ }+ |
+
| 85 | ++ | + + | +
| 86 | +65x | +
+ self$set_join_keys(join_keys)+ |
+
| 87 | ++ | + + | +
| 88 | +65x | +
+ child_parent <- sapply(+ |
+
| 89 | +65x | +
+ names(data_objects),+ |
+
| 90 | +65x | +
+ function(i) join_keys$get_parent(i),+ |
+
| 91 | +65x | +
+ USE.NAMES = TRUE,+ |
+
| 92 | +65x | +
+ simplify = FALSE+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | +65x | +
+ ordered_datanames <- topological_sort(child_parent)+ |
+
| 95 | ++ | + + | +
| 96 | +64x | +
+ for (dataname in ordered_datanames) {
+ |
+
| 97 | +98x | +
+ ds_object <- data_objects[[dataname]]+ |
+
| 98 | +98x | +
+ validate_dataset_args(ds_object, dataname)+ |
+
| 99 | +97x | +
+ if (inherits(ds_object, c("data.frame", "MultiAssayExperiment"))) {
+ |
+
| 100 | +! | +
+ self$set_dataset(+ |
+
| 101 | +! | +
+ data = ds_object,+ |
+
| 102 | +! | +
+ dataname = dataname+ |
+
| 103 | ++ |
+ )+ |
+
| 104 | ++ |
+ } else {
+ |
+
| 105 | ++ |
+ # custom support for TealData object which pass metadata and label also+ |
+
| 106 | ++ |
+ # see init_filtered_data.TealData+ |
+
| 107 | +97x | +
+ self$set_dataset(+ |
+
| 108 | +97x | +
+ data = ds_object$dataset,+ |
+
| 109 | +97x | +
+ dataname = dataname,+ |
+
| 110 | +97x | +
+ metadata = ds_object$metadata,+ |
+
| 111 | +97x | +
+ label = ds_object$label+ |
+
| 112 | ++ |
+ )+ |
+
| 113 | ++ |
+ }+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ | + + | +
| 116 | +63x | +
+ self$set_available_teal_slices(x = reactive(NULL))+ |
+
| 117 | ++ | + + | +
| 118 | +63x | +
+ invisible(self)+ |
+
| 119 | ++ |
+ },+ |
+
| 120 | ++ | + + | +
| 121 | ++ |
+ #' @description+ |
+
| 122 | ++ |
+ #' Gets `datanames`+ |
+
| 123 | ++ |
+ #'+ |
+
| 124 | ++ |
+ #' The `datanames` are returned in the order in which they must be+ |
+
| 125 | ++ |
+ #' evaluated (in case of dependencies).+ |
+
| 126 | ++ |
+ #' @return (`character` vector) of `datanames`+ |
+
| 127 | ++ |
+ datanames = function() {
+ |
+
| 128 | +111x | +
+ names(private$filtered_datasets)+ |
+
| 129 | ++ |
+ },+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' Gets data label for the dataset+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' Useful to display in `Show R Code`.+ |
+
| 134 | ++ |
+ #'+ |
+
| 135 | ++ |
+ #' @param dataname (`character(1)`) name of the dataset+ |
+
| 136 | ++ |
+ #' @return (`character`) keys of dataset+ |
+
| 137 | ++ |
+ get_datalabel = function(dataname) {
+ |
+
| 138 | +2x | +
+ private$get_filtered_dataset(dataname)$get_dataset_label()+ |
+
| 139 | ++ |
+ },+ |
+
| 140 | ++ | + + | +
| 141 | ++ |
+ # datasets methods ----+ |
+
| 142 | ++ |
+ #' @description+ |
+
| 143 | ++ |
+ #' Gets a `call` to filter the dataset according to the filter state.+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' It returns a `call` to filter the dataset only, assuming the+ |
+
| 146 | ++ |
+ #' other (filtered) datasets it depends on are available.+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' Together with `self$datanames()` which returns the datasets in the correct+ |
+
| 149 | ++ |
+ #' evaluation order, this generates the whole filter code, see the function+ |
+
| 150 | ++ |
+ #' `FilteredData$get_filter_code`.+ |
+
| 151 | ++ |
+ #'+ |
+
| 152 | ++ |
+ #' For the return type, note that `rlang::is_expression` returns `TRUE` on the+ |
+
| 153 | ++ |
+ #' return type, both for base R expressions and calls (single expression,+ |
+
| 154 | ++ |
+ #' capturing a function call).+ |
+
| 155 | ++ |
+ #'+ |
+
| 156 | ++ |
+ #' The filtered dataset has the name given by `self$filtered_dataname(dataname)`+ |
+
| 157 | ++ |
+ #'+ |
+
| 158 | ++ |
+ #' This can be used for the `Show R Code` generation.+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' @param dataname (`character(1)`) name of the dataset+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' @return (`call` or `list` of calls) to filter dataset calls+ |
+
| 163 | ++ |
+ #'+ |
+
| 164 | ++ |
+ get_call = function(dataname) {
+ |
+
| 165 | +10x | +
+ checkmate::assert_subset(dataname, self$datanames())+ |
+
| 166 | +9x | +
+ private$get_filtered_dataset(dataname)$get_call()+ |
+
| 167 | ++ |
+ },+ |
+
| 168 | ++ | + + | +
| 169 | ++ |
+ #' @description+ |
+
| 170 | ++ |
+ #' Gets the R preprocessing code string that generates the unfiltered datasets.+ |
+
| 171 | ++ |
+ #'+ |
+
| 172 | ++ |
+ #' @param dataname (`character(1)`) name(s) of dataset(s)+ |
+
| 173 | ++ |
+ #'+ |
+
| 174 | ++ |
+ #' @return (`character(1)`) deparsed code+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ get_code = function(dataname = self$datanames()) {
+ |
+
| 177 | +2x | +
+ if (!is.null(private$code)) {
+ |
+
| 178 | +1x | +
+ paste0(private$code$get_code(dataname), collapse = "\n")+ |
+
| 179 | ++ |
+ } else {
+ |
+
| 180 | +1x | +
+ paste0("# No pre-processing code provided")
+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ |
+ },+ |
+
| 183 | ++ | + + | +
| 184 | ++ |
+ #' @description+ |
+
| 185 | ++ |
+ #' Gets filtered or unfiltered dataset.+ |
+
| 186 | ++ |
+ #'+ |
+
| 187 | ++ |
+ #' For `filtered = FALSE`, the original data set with+ |
+
| 188 | ++ |
+ #' `set_data` is returned including all attributes.+ |
+
| 189 | ++ |
+ #'+ |
+
| 190 | ++ |
+ #' @param dataname (`character(1)`) name of the dataset+ |
+
| 191 | ++ |
+ #' @param filtered (`logical`) whether to return a filtered or unfiltered dataset+ |
+
| 192 | ++ |
+ #'+ |
+
| 193 | ++ |
+ get_data = function(dataname, filtered = TRUE) {
+ |
+
| 194 | +18x | +
+ checkmate::assert_subset(dataname, self$datanames())+ |
+
| 195 | +17x | +
+ checkmate::assert_flag(filtered)+ |
+
| 196 | +16x | +
+ data <- private$get_filtered_dataset(dataname)$get_dataset(filtered)+ |
+
| 197 | +3x | +
+ if (filtered) data() else data+ |
+
| 198 | ++ |
+ },+ |
+
| 199 | ++ | + + | +
| 200 | ++ |
+ #' @description+ |
+
| 201 | ++ |
+ #' Returns whether the datasets in the object has undergone a reproducibility check.+ |
+
| 202 | ++ |
+ #'+ |
+
| 203 | ++ |
+ #' @return `logical`+ |
+
| 204 | ++ |
+ #'+ |
+
| 205 | ++ |
+ get_check = function() {
+ |
+
| 206 | +2x | +
+ private$.check+ |
+
| 207 | ++ |
+ },+ |
+
| 208 | ++ | + + | +
| 209 | ++ |
+ #' @description+ |
+
| 210 | ++ |
+ #' Gets metadata for a given dataset.+ |
+
| 211 | ++ |
+ #'+ |
+
| 212 | ++ |
+ #' @param dataname (`character(1)`) name of the dataset+ |
+
| 213 | ++ |
+ #'+ |
+
| 214 | ++ |
+ #' @return value of metadata for given data (or `NULL` if it does not exist)+ |
+
| 215 | ++ |
+ #'+ |
+
| 216 | ++ |
+ get_metadata = function(dataname) {
+ |
+
| 217 | +3x | +
+ checkmate::assert_subset(dataname, self$datanames())+ |
+
| 218 | +2x | +
+ private$get_filtered_dataset(dataname)$get_metadata()+ |
+
| 219 | ++ |
+ },+ |
+
| 220 | ++ | + + | +
| 221 | ++ |
+ #' @description+ |
+
| 222 | ++ |
+ #' Get join keys between two datasets.+ |
+
| 223 | ++ |
+ #'+ |
+
| 224 | ++ |
+ #' @return (`JoinKeys`)+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ get_join_keys = function() {
+ |
+
| 227 | +206x | +
+ return(private$join_keys)+ |
+
| 228 | ++ |
+ },+ |
+
| 229 | ++ | + + | +
| 230 | ++ |
+ #' @description+ |
+
| 231 | ++ |
+ #' Get filter overview table in form of X (filtered) / Y (non-filtered).+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' This is intended to be presented in the application.+ |
+
| 234 | ++ |
+ #' The content for each of the data names is defined in `get_filter_overview_info` method.+ |
+
| 235 | ++ |
+ #'+ |
+
| 236 | ++ |
+ #' @param datanames (`character` vector) names of the dataset+ |
+
| 237 | ++ |
+ #'+ |
+
| 238 | ++ |
+ #' @return (`matrix`) matrix of observations and subjects of all datasets+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ get_filter_overview = function(datanames) {
+ |
+
| 241 | +9x | +
+ rows <- lapply(+ |
+
| 242 | +9x | +
+ datanames,+ |
+
| 243 | +9x | +
+ function(dataname) {
+ |
+
| 244 | +11x | +
+ private$get_filtered_dataset(dataname)$get_filter_overview()+ |
+
| 245 | ++ |
+ }+ |
+
| 246 | ++ |
+ )+ |
+
| 247 | +5x | +
+ dplyr::bind_rows(rows)+ |
+
| 248 | ++ |
+ },+ |
+
| 249 | ++ | + + | +
| 250 | ++ |
+ #' @description+ |
+
| 251 | ++ |
+ #' Get keys for the dataset.+ |
+
| 252 | ++ |
+ #'+ |
+
| 253 | ++ |
+ #' @param dataname (`character(1)`) name of the dataset+ |
+
| 254 | ++ |
+ #'+ |
+
| 255 | ++ |
+ #' @return (`character`) keys of dataset+ |
+
| 256 | ++ |
+ #'+ |
+
| 257 | ++ |
+ get_keys = function(dataname) {
+ |
+
| 258 | +1x | +
+ private$get_filtered_dataset(dataname)$get_keys()+ |
+
| 259 | ++ |
+ },+ |
+
| 260 | ++ | + + | +
| 261 | ++ |
+ #' @description+ |
+
| 262 | ++ |
+ #' Adds a dataset to this `FilteredData`.+ |
+
| 263 | ++ |
+ #'+ |
+
| 264 | ++ |
+ #' @details+ |
+
| 265 | ++ |
+ #' `set_dataset` creates a `FilteredDataset` object which keeps `dataset` for the filtering purpose.+ |
+
| 266 | ++ |
+ #' If this data has a parent specified in the `JoinKeys` object stored in `private$join_keys`+ |
+
| 267 | ++ |
+ #' then created `FilteredDataset` (child) gets linked with other `FilteredDataset` (parent).+ |
+
| 268 | ++ |
+ #' "Child" dataset return filtered data then dependent on the reactive filtered data of the+ |
+
| 269 | ++ |
+ #' "parent". See more in documentation of `parent` argument in `FilteredDatasetDefault` constructor.+ |
+
| 270 | ++ |
+ #'+ |
+
| 271 | ++ |
+ #' @param data (`data.frame`, `MultiAssayExperiment`)\cr+ |
+
| 272 | ++ |
+ #' data to be filtered.+ |
+
| 273 | ++ |
+ #'+ |
+
| 274 | ++ |
+ #' @param dataname (`string`)\cr+ |
+
| 275 | ++ |
+ #' the name of the `dataset` to be added to this object+ |
+
| 276 | ++ |
+ #'+ |
+
| 277 | ++ |
+ #' @param metadata (named `list` or `NULL`) \cr+ |
+
| 278 | ++ |
+ #' Field containing metadata about the dataset. Each element of the list+ |
+
| 279 | ++ |
+ #' should be atomic and length one.+ |
+
| 280 | ++ |
+ #'+ |
+
| 281 | ++ |
+ #' @param label (`character(1)`)\cr+ |
+
| 282 | ++ |
+ #' Label to describe the dataset+ |
+
| 283 | ++ |
+ #' @return (`self`) invisibly this `FilteredData`+ |
+
| 284 | ++ |
+ #'+ |
+
| 285 | ++ |
+ set_dataset = function(data, dataname, metadata, label) {
+ |
+
| 286 | +102x | +
+ logger::log_trace("FilteredData$set_dataset setting dataset, name: { dataname }")
+ |
+
| 287 | ++ |
+ # to include it nicely in the Show R Code;+ |
+
| 288 | ++ |
+ # the UI also uses `datanames` in ids, so no whitespaces allowed+ |
+
| 289 | +102x | +
+ check_simple_name(dataname)+ |
+
| 290 | ++ | + + | +
| 291 | +102x | +
+ join_keys <- self$get_join_keys()+ |
+
| 292 | +102x | +
+ parent_dataname <- join_keys$get_parent(dataname)+ |
+
| 293 | +102x | +
+ if (length(parent_dataname) == 0) {
+ |
+
| 294 | +95x | +
+ private$filtered_datasets[[dataname]] <- init_filtered_dataset(+ |
+
| 295 | +95x | +
+ dataset = data,+ |
+
| 296 | +95x | +
+ dataname = dataname,+ |
+
| 297 | +95x | +
+ metadata = metadata,+ |
+
| 298 | +95x | +
+ label = label,+ |
+
| 299 | +95x | +
+ keys = self$get_join_keys()$get(dataname, dataname)+ |
+
| 300 | ++ |
+ )+ |
+
| 301 | ++ |
+ } else {
+ |
+
| 302 | +7x | +
+ private$filtered_datasets[[dataname]] <- init_filtered_dataset(+ |
+
| 303 | +7x | +
+ dataset = data,+ |
+
| 304 | +7x | +
+ dataname = dataname,+ |
+
| 305 | +7x | +
+ keys = join_keys$get(dataname, dataname),+ |
+
| 306 | +7x | +
+ parent_name = parent_dataname,+ |
+
| 307 | +7x | +
+ parent = reactive(self$get_data(parent_dataname, filtered = TRUE)),+ |
+
| 308 | +7x | +
+ join_keys = self$get_join_keys()$get(dataname, parent_dataname),+ |
+
| 309 | +7x | +
+ label = label,+ |
+
| 310 | +7x | +
+ metadata = metadata+ |
+
| 311 | ++ |
+ )+ |
+
| 312 | ++ |
+ }+ |
+
| 313 | ++ | + + | +
| 314 | +102x | +
+ invisible(self)+ |
+
| 315 | ++ |
+ },+ |
+
| 316 | ++ | + + | +
| 317 | ++ |
+ #' @description+ |
+
| 318 | ++ |
+ #' Set the `join_keys`.+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' @param join_keys (`JoinKeys`) join_key (converted to a nested list)+ |
+
| 321 | ++ |
+ #'+ |
+
| 322 | ++ |
+ #' @return (`self`) invisibly this `FilteredData`+ |
+
| 323 | ++ |
+ #'+ |
+
| 324 | ++ |
+ set_join_keys = function(join_keys) {
+ |
+
| 325 | +65x | +
+ checkmate::assert_class(join_keys, "JoinKeys")+ |
+
| 326 | +65x | +
+ private$join_keys <- join_keys+ |
+
| 327 | +65x | +
+ invisible(self)+ |
+
| 328 | ++ |
+ },+ |
+
| 329 | ++ | + + | +
| 330 | ++ |
+ #' @description+ |
+
| 331 | ++ |
+ #' Sets whether the datasets in the object have undergone a reproducibility check.+ |
+
| 332 | ++ |
+ #'+ |
+
| 333 | ++ |
+ #' @param check (`logical`) whether datasets have undergone reproducibility check+ |
+
| 334 | ++ |
+ #'+ |
+
| 335 | ++ |
+ #' @return (`self`)+ |
+
| 336 | ++ |
+ #'+ |
+
| 337 | ++ |
+ set_check = function(check) {
+ |
+
| 338 | +65x | +
+ checkmate::assert_flag(check)+ |
+
| 339 | +65x | +
+ private$.check <- check+ |
+
| 340 | +65x | +
+ invisible(self)+ |
+
| 341 | ++ |
+ },+ |
+
| 342 | ++ | + + | +
| 343 | ++ |
+ #' @description+ |
+
| 344 | ++ |
+ #' Sets the R preprocessing code for single dataset.+ |
+
| 345 | ++ |
+ #'+ |
+
| 346 | ++ |
+ #' @param code (`CodeClass`)\cr+ |
+
| 347 | ++ |
+ #' preprocessing code that can be parsed to generate the unfiltered datasets+ |
+
| 348 | ++ |
+ #'+ |
+
| 349 | ++ |
+ #' @return (`self`)+ |
+
| 350 | ++ |
+ #'+ |
+
| 351 | ++ |
+ set_code = function(code) {
+ |
+
| 352 | +6x | +
+ checkmate::assert_class(code, "CodeClass")+ |
+
| 353 | +6x | +
+ logger::log_trace("FilteredData$set_code setting code")
+ |
+
| 354 | +6x | +
+ private$code <- code+ |
+
| 355 | +6x | +
+ invisible(self)+ |
+
| 356 | ++ |
+ },+ |
+
| 357 | ++ | + + | +
| 358 | ++ |
+ # Functions useful for restoring from another dataset ----+ |
+
| 359 | ++ | + + | +
| 360 | ++ |
+ #' @description+ |
+
| 361 | ++ |
+ #' Gets states of all active `FilterState` objects.+ |
+
| 362 | ++ |
+ #'+ |
+
| 363 | ++ |
+ #' @return A `teal_slices` object.+ |
+
| 364 | ++ |
+ #'+ |
+
| 365 | ++ |
+ get_filter_state = function() {
+ |
+
| 366 | +57x | +
+ states <- unname(lapply(private$filtered_datasets, function(x) x$get_filter_state()))+ |
+
| 367 | +57x | +
+ slices <- Filter(Negate(is.null), states)+ |
+
| 368 | +57x | +
+ slices <- do.call(c, slices)+ |
+
| 369 | +57x | +
+ if (!is.null(slices)) {
+ |
+
| 370 | +57x | +
+ attr(slices, "module_add") <- private$module_add+ |
+
| 371 | ++ |
+ }+ |
+
| 372 | +57x | +
+ slices+ |
+
| 373 | ++ |
+ },+ |
+
| 374 | ++ | + + | +
| 375 | ++ |
+ #' @description+ |
+
| 376 | ++ |
+ #' Returns a formatted string representing this `FilteredData` object.+ |
+
| 377 | ++ |
+ #'+ |
+
| 378 | ++ |
+ #' @param show_all `logical(1)` passed to `format.teal_slice`+ |
+
| 379 | ++ |
+ #' @param trim_lines `logical(1)` passed to `format.teal_slice`+ |
+
| 380 | ++ |
+ #'+ |
+
| 381 | ++ |
+ #' @return `character(1)` the formatted string+ |
+
| 382 | ++ |
+ #'+ |
+
| 383 | ++ |
+ format = function(show_all = FALSE, trim_lines = TRUE) {
+ |
+
| 384 | +7x | +
+ sprintf(+ |
+
| 385 | +7x | +
+ "%s:\n%s",+ |
+
| 386 | +7x | +
+ class(self)[1],+ |
+
| 387 | +7x | +
+ format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)+ |
+
| 388 | ++ |
+ )+ |
+
| 389 | ++ |
+ },+ |
+
| 390 | ++ | + + | +
| 391 | ++ |
+ #' @description+ |
+
| 392 | ++ |
+ #' Prints this `FilteredData` object.+ |
+
| 393 | ++ |
+ #'+ |
+
| 394 | ++ |
+ #' @param ... additional arguments+ |
+
| 395 | ++ |
+ #'+ |
+
| 396 | ++ |
+ print = function(...) {
+ |
+
| 397 | +3x | +
+ cat(shiny::isolate(self$format(...)), "\n")+ |
+
| 398 | ++ |
+ },+ |
+
| 399 | ++ | + + | +
| 400 | ++ |
+ #' @description+ |
+
| 401 | ++ |
+ #' Sets active filter states.+ |
+
| 402 | ++ |
+ #'+ |
+
| 403 | ++ |
+ #' @param state either a `named list` list of filter selections+ |
+
| 404 | ++ |
+ #' or a `teal_slices` object\cr+ |
+
| 405 | ++ |
+ #' specification by list will be deprecated soon+ |
+
| 406 | ++ |
+ #'+ |
+
| 407 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 408 | ++ |
+ #'+ |
+
| 409 | ++ |
+ #' @examples+ |
+
| 410 | ++ |
+ #' utils::data(miniACC, package = "MultiAssayExperiment")+ |
+
| 411 | ++ |
+ #'+ |
+
| 412 | ++ |
+ #' datasets <- teal.slice:::FilteredData$new(+ |
+
| 413 | ++ |
+ #' list(iris = list(dataset = iris),+ |
+
| 414 | ++ |
+ #' mae = list(dataset = miniACC)+ |
+
| 415 | ++ |
+ #' )+ |
+
| 416 | ++ |
+ #' )+ |
+
| 417 | ++ |
+ #' fs <-+ |
+
| 418 | ++ |
+ #' teal_slices(+ |
+
| 419 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4),+ |
+
| 420 | ++ |
+ #' keep_na = TRUE, keep_inf = FALSE),+ |
+
| 421 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor"),
+ |
+
| 422 | ++ |
+ #' keep_na = FALSE),+ |
+
| 423 | ++ |
+ #' teal_slice(dataname = "mae", varname = "years_to_birth", selected = c(30, 50),+ |
+
| 424 | ++ |
+ #' keep_na = TRUE, keep_inf = FALSE),+ |
+
| 425 | ++ |
+ #' teal_slice(dataname = "mae", varname = "vital_status", selected = "1", keep_na = FALSE),+ |
+
| 426 | ++ |
+ #' teal_slice(dataname = "mae", varname = "gender", selected = "female", keep_na = TRUE),+ |
+
| 427 | ++ |
+ #' teal_slice(dataname = "mae", varname = "ARRAY_TYPE",+ |
+
| 428 | ++ |
+ #' selected = "", keep_na = TRUE, datalabel = "RPPAArray", arg = "subset")+ |
+
| 429 | ++ |
+ #' )+ |
+
| 430 | ++ |
+ #' datasets$set_filter_state(state = fs)+ |
+
| 431 | ++ |
+ #' shiny::isolate(datasets$get_filter_state())+ |
+
| 432 | ++ |
+ #'+ |
+
| 433 | ++ |
+ set_filter_state = function(state) {
+ |
+
| 434 | +31x | +
+ shiny::isolate({
+ |
+
| 435 | +31x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing")
+ |
+
| 436 | +31x | +
+ if (!is.teal_slices(state)) {
+ |
+
| 437 | +1x | +
+ warning(+ |
+
| 438 | +1x | +
+ paste(+ |
+
| 439 | +1x | +
+ "From FilteredData$set_filter_state:",+ |
+
| 440 | +1x | +
+ "Specifying filters as lists is obsolete and will be deprecated in the next release.",+ |
+
| 441 | +1x | +
+ "Please see ?set_filter_state and ?teal_slices for details."+ |
+
| 442 | ++ |
+ ),+ |
+
| 443 | +1x | +
+ call. = FALSE+ |
+
| 444 | ++ |
+ )+ |
+
| 445 | +1x | +
+ state <- as.teal_slices(state)+ |
+
| 446 | ++ |
+ }+ |
+
| 447 | ++ | + + | +
| 448 | +31x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 449 | +31x | +
+ module_add <- attr(state, "module_add")+ |
+
| 450 | +31x | +
+ if (!is.null(module_add)) {
+ |
+
| 451 | +31x | +
+ private$module_add <- module_add+ |
+
| 452 | ++ |
+ }+ |
+
| 453 | ++ | + + | +
| 454 | +31x | +
+ lapply(self$datanames(), function(dataname) {
+ |
+
| 455 | +61x | +
+ states <- Filter(function(x) identical(x$dataname, dataname), state)+ |
+
| 456 | +61x | +
+ private$get_filtered_dataset(dataname)$set_filter_state(states)+ |
+
| 457 | ++ |
+ })+ |
+
| 458 | ++ | + + | +
| 459 | +31x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initialized")
+ |
+
| 460 | ++ | + + | +
| 461 | +31x | +
+ invisible(NULL)+ |
+
| 462 | ++ |
+ })+ |
+
| 463 | ++ |
+ },+ |
+
| 464 | ++ | + + | +
| 465 | ++ |
+ #' @description+ |
+
| 466 | ++ |
+ #' Removes one or more `FilterState` from a `FilteredData` object.+ |
+
| 467 | ++ |
+ #'+ |
+
| 468 | ++ |
+ #' @param state (`teal_slices`)\cr+ |
+
| 469 | ++ |
+ #' specifying `FilterState` objects to remove;+ |
+
| 470 | ++ |
+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored+ |
+
| 471 | ++ |
+ #'+ |
+
| 472 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 473 | ++ |
+ #'+ |
+
| 474 | ++ |
+ remove_filter_state = function(state) {
+ |
+
| 475 | +8x | +
+ shiny::isolate({
+ |
+
| 476 | +8x | +
+ if (!is.teal_slices(state)) {
+ |
+
| 477 | +! | +
+ warning(+ |
+
| 478 | +! | +
+ paste(+ |
+
| 479 | +! | +
+ "From FilteredData$remove_filter_state:",+ |
+
| 480 | +! | +
+ "Specifying filters as lists is obsolete and will be deprecated in the next release.",+ |
+
| 481 | +! | +
+ "Please see ?set_filter_state and ?teal_slices for details."+ |
+
| 482 | ++ |
+ ),+ |
+
| 483 | +! | +
+ call. = FALSE+ |
+
| 484 | ++ |
+ )+ |
+
| 485 | +! | +
+ state <- as.teal_slices(state)+ |
+
| 486 | ++ |
+ }+ |
+
| 487 | ++ | + + | +
| 488 | +8x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 489 | +8x | +
+ datanames <- slices_field(state, "dataname")+ |
+
| 490 | +8x | +
+ checkmate::assert_subset(datanames, self$datanames())+ |
+
| 491 | ++ | + + | +
| 492 | +8x | +
+ logger::log_trace(+ |
+
| 493 | +8x | +
+ "{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }"
+ |
+
| 494 | ++ |
+ )+ |
+
| 495 | ++ | + + | +
| 496 | +8x | +
+ lapply(datanames, function(dataname) {
+ |
+
| 497 | +9x | +
+ slices <- Filter(function(x) identical(x$dataname, dataname), state)+ |
+
| 498 | +9x | +
+ private$get_filtered_dataset(dataname)$remove_filter_state(slices)+ |
+
| 499 | ++ |
+ })+ |
+
| 500 | ++ | + + | +
| 501 | +8x | +
+ logger::log_trace(+ |
+
| 502 | +8x | +
+ "{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }"
+ |
+
| 503 | ++ |
+ )+ |
+
| 504 | ++ | + + | +
| 505 | +8x | +
+ invisible(NULL)+ |
+
| 506 | ++ |
+ })+ |
+
| 507 | ++ |
+ },+ |
+
| 508 | ++ | + + | +
| 509 | ++ |
+ #' @description+ |
+
| 510 | ++ |
+ #' Remove all `FilterStates` of a `FilteredDataset` or all `FilterStates`+ |
+
| 511 | ++ |
+ #' of a `FilteredData` object.+ |
+
| 512 | ++ |
+ #'+ |
+
| 513 | ++ |
+ #' @param datanames (`character`)\cr+ |
+
| 514 | ++ |
+ #' `datanames` to remove their `FilterStates` or empty which removes+ |
+
| 515 | ++ |
+ #' all `FilterStates` in the `FilteredData` object+ |
+
| 516 | ++ |
+ #'+ |
+
| 517 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 518 | ++ |
+ #'+ |
+
| 519 | ++ |
+ clear_filter_states = function(datanames = self$datanames()) {
+ |
+
| 520 | +7x | +
+ logger::log_trace(+ |
+
| 521 | +7x | +
+ "FilteredData$clear_filter_states called, datanames: { toString(datanames) }"
+ |
+
| 522 | ++ |
+ )+ |
+
| 523 | ++ | + + | +
| 524 | +7x | +
+ for (dataname in datanames) {
+ |
+
| 525 | +12x | +
+ fdataset <- private$get_filtered_dataset(dataname = dataname)+ |
+
| 526 | +12x | +
+ fdataset$clear_filter_states()+ |
+
| 527 | ++ |
+ }+ |
+
| 528 | ++ | + + | +
| 529 | +7x | +
+ logger::log_trace(+ |
+
| 530 | +7x | +
+ paste(+ |
+
| 531 | +7x | +
+ "FilteredData$clear_filter_states removed all non-locked FilterStates,",+ |
+
| 532 | +7x | +
+ "datanames: { toString(datanames) }"
+ |
+
| 533 | ++ |
+ )+ |
+
| 534 | ++ |
+ )+ |
+
| 535 | ++ | + + | +
| 536 | +7x | +
+ invisible(NULL)+ |
+
| 537 | ++ |
+ },+ |
+
| 538 | ++ | + + | +
| 539 | ++ |
+ # shiny modules -----+ |
+
| 540 | ++ | + + | +
| 541 | ++ |
+ #' Set external `teal_slice`+ |
+
| 542 | ++ |
+ #'+ |
+
| 543 | ++ |
+ #' Unlike adding new filter from the column, these filters can be added with some prespecified+ |
+
| 544 | ++ |
+ #' settings. List of `teal_slices` should be a reactive so one can make this list to be dynamic.+ |
+
| 545 | ++ |
+ #' List is accessible in `ui/srv_active` through `ui/srv_available_filters`.+ |
+
| 546 | ++ |
+ #' @param x (`reactive`)\cr+ |
+
| 547 | ++ |
+ #' should return `teal_slices`+ |
+
| 548 | ++ |
+ #' @return invisible `NULL`+ |
+
| 549 | ++ |
+ set_available_teal_slices = function(x) {
+ |
+
| 550 | +64x | +
+ checkmate::assert_class(x, "reactive")+ |
+
| 551 | +64x | +
+ private$available_teal_slices <- reactive({
+ |
+
| 552 | ++ |
+ # we want to limit the available filters to the ones that are relevant for this FilteredData+ |
+
| 553 | +4x | +
+ Filter(function(x) x$dataname %in% self$datanames(), x())+ |
+
| 554 | ++ |
+ })+ |
+
| 555 | +64x | +
+ invisible(NULL)+ |
+
| 556 | ++ |
+ },+ |
+
| 557 | ++ | + + | +
| 558 | ++ |
+ #' Module for the right filter panel in the teal app+ |
+
| 559 | ++ |
+ #' with a filter overview panel and a filter variable panel.+ |
+
| 560 | ++ |
+ #'+ |
+
| 561 | ++ |
+ #' This panel contains info about the number of observations left in+ |
+
| 562 | ++ |
+ #' the (active) datasets and allows to filter the datasets.+ |
+
| 563 | ++ |
+ #'+ |
+
| 564 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 565 | ++ |
+ #' module id+ |
+
| 566 | ++ |
+ #' @return `shiny.tag`+ |
+
| 567 | ++ |
+ ui_filter_panel = function(id) {
+ |
+
| 568 | +! | +
+ ns <- NS(id)+ |
+
| 569 | +! | +
+ div(+ |
+
| 570 | +! | +
+ id = ns(NULL), # used for hiding / showing+ |
+
| 571 | +! | +
+ include_css_files(pattern = "filter-panel"),+ |
+
| 572 | +! | +
+ self$ui_overview(ns("overview")),
+ |
+
| 573 | +! | +
+ self$ui_active(ns("active")),
+ |
+
| 574 | +! | +
+ if (private$module_add) {
+ |
+
| 575 | +! | +
+ self$ui_add(ns("add"))
+ |
+
| 576 | ++ |
+ }+ |
+
| 577 | ++ |
+ )+ |
+
| 578 | ++ |
+ },+ |
+
| 579 | ++ | + + | +
| 580 | ++ |
+ #' Server function for filter panel+ |
+
| 581 | ++ |
+ #'+ |
+
| 582 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 583 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 584 | ++ |
+ #' @param active_datanames `function / reactive` returning `datanames` that+ |
+
| 585 | ++ |
+ #' should be shown on the filter panel,+ |
+
| 586 | ++ |
+ #' must be a subset of the `datanames` argument provided to `ui_filter_panel`;+ |
+
| 587 | ++ |
+ #' if the function returns `NULL` (as opposed to `character(0)`), the filter+ |
+
| 588 | ++ |
+ #' panel will be hidden+ |
+
| 589 | ++ |
+ #' @return `moduleServer` function which returns `NULL`+ |
+
| 590 | ++ |
+ srv_filter_panel = function(id, active_datanames = self$datanames) {
+ |
+
| 591 | +1x | +
+ checkmate::assert_function(active_datanames)+ |
+
| 592 | +1x | +
+ moduleServer(+ |
+
| 593 | +1x | +
+ id = id,+ |
+
| 594 | +1x | +
+ function(input, output, session) {
+ |
+
| 595 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_panel initializing")
+ |
+
| 596 | ++ | + + | +
| 597 | +1x | +
+ active_datanames_resolved <- reactive({
+ |
+
| 598 | +1x | +
+ checkmate::assert_subset(active_datanames(), self$datanames())+ |
+
| 599 | +! | +
+ active_datanames()+ |
+
| 600 | ++ |
+ })+ |
+
| 601 | ++ | + + | +
| 602 | +1x | +
+ self$srv_overview("overview", active_datanames_resolved)
+ |
+
| 603 | +1x | +
+ self$srv_active("active", active_datanames_resolved)
+ |
+
| 604 | +1x | +
+ if (private$module_add) {
+ |
+
| 605 | +1x | +
+ self$srv_add("add", active_datanames_resolved)
+ |
+
| 606 | ++ |
+ }+ |
+
| 607 | ++ | + + | +
| 608 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_panel initialized")
+ |
+
| 609 | +1x | +
+ NULL+ |
+
| 610 | ++ |
+ }+ |
+
| 611 | ++ |
+ )+ |
+
| 612 | ++ |
+ },+ |
+
| 613 | ++ | + + | +
| 614 | ++ |
+ #' @description+ |
+
| 615 | ++ |
+ #' Server module responsible for displaying active filters.+ |
+
| 616 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 617 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 618 | ++ |
+ #' @return `shiny.tag`+ |
+
| 619 | ++ |
+ ui_active = function(id) {
+ |
+
| 620 | +! | +
+ ns <- NS(id)+ |
+
| 621 | +! | +
+ div(+ |
+
| 622 | +! | +
+ id = id, # not used, can be used to customize CSS behavior+ |
+
| 623 | +! | +
+ class = "well",+ |
+
| 624 | +! | +
+ tags$div(+ |
+
| 625 | +! | +
+ class = "filter-panel-active-header",+ |
+
| 626 | +! | +
+ tags$span("Active Filter Variables", class = "text-primary mb-4"),
+ |
+
| 627 | +! | +
+ private$ui_available_filters(ns("available_filters")),
+ |
+
| 628 | +! | +
+ actionLink(+ |
+
| 629 | +! | +
+ ns("minimise_filter_active"),
+ |
+
| 630 | +! | +
+ label = NULL,+ |
+
| 631 | +! | +
+ icon = icon("angle-down", lib = "font-awesome"),
+ |
+
| 632 | +! | +
+ title = "Minimise panel",+ |
+
| 633 | +! | +
+ class = "remove pull-right"+ |
+
| 634 | ++ |
+ ),+ |
+
| 635 | +! | +
+ actionLink(+ |
+
| 636 | +! | +
+ ns("remove_all_filters"),
+ |
+
| 637 | +! | +
+ label = "",+ |
+
| 638 | +! | +
+ icon("circle-xmark", lib = "font-awesome"),
+ |
+
| 639 | +! | +
+ title = "Remove active filters",+ |
+
| 640 | +! | +
+ class = "remove_all pull-right"+ |
+
| 641 | ++ |
+ )+ |
+
| 642 | ++ |
+ ),+ |
+
| 643 | +! | +
+ div(+ |
+
| 644 | +! | +
+ id = ns("filter_active_vars_contents"),
+ |
+
| 645 | +! | +
+ tagList(+ |
+
| 646 | +! | +
+ lapply(+ |
+
| 647 | +! | +
+ self$datanames(),+ |
+
| 648 | +! | +
+ function(dataname) {
+ |
+
| 649 | +! | +
+ fdataset <- private$get_filtered_dataset(dataname)+ |
+
| 650 | +! | +
+ fdataset$ui_active(id = ns(dataname))+ |
+
| 651 | ++ |
+ }+ |
+
| 652 | ++ |
+ )+ |
+
| 653 | ++ |
+ )+ |
+
| 654 | ++ |
+ ),+ |
+
| 655 | +! | +
+ shinyjs::hidden(+ |
+
| 656 | +! | +
+ div(+ |
+
| 657 | +! | +
+ id = ns("filters_active_count"),
+ |
+
| 658 | +! | +
+ textOutput(ns("teal_filters_count"))
+ |
+
| 659 | ++ |
+ )+ |
+
| 660 | ++ |
+ )+ |
+
| 661 | ++ |
+ )+ |
+
| 662 | ++ |
+ },+ |
+
| 663 | ++ | + + | +
| 664 | ++ |
+ #' @description+ |
+
| 665 | ++ |
+ #' Server module responsible for displaying active filters.+ |
+
| 666 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 667 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 668 | ++ |
+ #' @param active_datanames (`reactive`)\cr+ |
+
| 669 | ++ |
+ #' defining subset of `self$datanames()` to be displayed.+ |
+
| 670 | ++ |
+ #' @return `moduleServer` returning `NULL`+ |
+
| 671 | ++ |
+ srv_active = function(id, active_datanames = self$datanames) {
+ |
+
| 672 | +3x | +
+ checkmate::assert_function(active_datanames)+ |
+
| 673 | +3x | +
+ shiny::moduleServer(id, function(input, output, session) {
+ |
+
| 674 | +3x | +
+ logger::log_trace("FilteredData$srv_active initializing")
+ |
+
| 675 | ++ | + + | +
| 676 | +3x | +
+ private$srv_available_filters("available_filters")
+ |
+
| 677 | ++ | + + | +
| 678 | +3x | +
+ shiny::observeEvent(input$minimise_filter_active, {
+ |
+
| 679 | +! | +
+ shinyjs::toggle("filter_active_vars_contents")
+ |
+
| 680 | +! | +
+ shinyjs::toggle("filters_active_count")
+ |
+
| 681 | +! | +
+ toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"))
+ |
+
| 682 | +! | +
+ toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"))
+ |
+
| 683 | ++ |
+ })+ |
+
| 684 | ++ | + + | +
| 685 | +3x | +
+ shiny::observeEvent(private$get_filter_count(), {
+ |
+
| 686 | +3x | +
+ shinyjs::toggle("remove_all_filters", condition = private$get_filter_count() != 0)
+ |
+
| 687 | +3x | +
+ shinyjs::show("filter_active_vars_contents")
+ |
+
| 688 | +3x | +
+ shinyjs::hide("filters_active_count")
+ |
+
| 689 | +3x | +
+ toggle_icon(session$ns("minimise_filter_active"), c("fa-angle-right", "fa-angle-down"), TRUE)
+ |
+
| 690 | +3x | +
+ toggle_title(session$ns("minimise_filter_active"), c("Restore panel", "Minimise Panel"), TRUE)
+ |
+
| 691 | ++ |
+ })+ |
+
| 692 | ++ | + + | +
| 693 | +3x | +
+ observeEvent(active_datanames(), {
+ |
+
| 694 | +2x | +
+ lapply(self$datanames(), function(dataname) {
+ |
+
| 695 | +4x | +
+ if (dataname %in% active_datanames()) {
+ |
+
| 696 | +4x | +
+ shinyjs::show(dataname)+ |
+
| 697 | ++ |
+ } else {
+ |
+
| 698 | +! | +
+ shinyjs::hide(dataname)+ |
+
| 699 | ++ |
+ }+ |
+
| 700 | ++ |
+ })+ |
+
| 701 | ++ |
+ })+ |
+
| 702 | ++ | + + | +
| 703 | ++ |
+ # should not use for-loop as variables are otherwise only bound by reference+ |
+
| 704 | ++ |
+ # and last dataname would be used+ |
+
| 705 | +3x | +
+ lapply(+ |
+
| 706 | +3x | +
+ self$datanames(),+ |
+
| 707 | +3x | +
+ function(dataname) {
+ |
+
| 708 | +6x | +
+ fdataset <- private$get_filtered_dataset(dataname)+ |
+
| 709 | +6x | +
+ fdataset$srv_active(id = dataname)+ |
+
| 710 | ++ |
+ }+ |
+
| 711 | ++ |
+ )+ |
+
| 712 | ++ | + + | +
| 713 | +3x | +
+ output$teal_filters_count <- shiny::renderText({
+ |
+
| 714 | +3x | +
+ n_filters_active <- private$get_filter_count()+ |
+
| 715 | +3x | +
+ shiny::req(n_filters_active > 0L)+ |
+
| 716 | +2x | +
+ sprintf(+ |
+
| 717 | +2x | +
+ "%s filter%s applied across datasets",+ |
+
| 718 | +2x | +
+ n_filters_active,+ |
+
| 719 | +2x | +
+ ifelse(n_filters_active == 1, "", "s")+ |
+
| 720 | ++ |
+ )+ |
+
| 721 | ++ |
+ })+ |
+
| 722 | ++ | + + | +
| 723 | +3x | +
+ observeEvent(input$remove_all_filters, {
+ |
+
| 724 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_panel@1 removing all non-locked filters")
+ |
+
| 725 | +1x | +
+ self$clear_filter_states()+ |
+
| 726 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_panel@1 removed all non-locked filters")
+ |
+
| 727 | ++ |
+ })+ |
+
| 728 | +3x | +
+ logger::log_trace("FilteredData$srv_active initialized")
+ |
+
| 729 | +3x | +
+ NULL+ |
+
| 730 | ++ |
+ })+ |
+
| 731 | ++ |
+ },+ |
+
| 732 | ++ | + + | +
| 733 | ++ |
+ #' @description+ |
+
| 734 | ++ |
+ #' Server module responsible for displaying drop-downs with variables to add a filter.+ |
+
| 735 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 736 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 737 | ++ |
+ #' @return `shiny.tag`+ |
+
| 738 | ++ |
+ ui_add = function(id) {
+ |
+
| 739 | +! | +
+ ns <- NS(id)+ |
+
| 740 | +! | +
+ div(+ |
+
| 741 | +! | +
+ id = id, # not used, can be used to customize CSS behavior+ |
+
| 742 | +! | +
+ class = "well",+ |
+
| 743 | +! | +
+ tags$div(+ |
+
| 744 | +! | +
+ class = "row",+ |
+
| 745 | +! | +
+ tags$div(+ |
+
| 746 | +! | +
+ class = "col-sm-9",+ |
+
| 747 | +! | +
+ tags$label("Add Filter Variables", class = "text-primary mb-4")
+ |
+
| 748 | ++ |
+ ),+ |
+
| 749 | +! | +
+ tags$div(+ |
+
| 750 | +! | +
+ class = "col-sm-3",+ |
+
| 751 | +! | +
+ actionLink(+ |
+
| 752 | +! | +
+ ns("minimise_filter_add_vars"),
+ |
+
| 753 | +! | +
+ label = NULL,+ |
+
| 754 | +! | +
+ icon = icon("angle-down", lib = "font-awesome"),
+ |
+
| 755 | +! | +
+ title = "Minimise panel",+ |
+
| 756 | +! | +
+ class = "remove pull-right"+ |
+
| 757 | ++ |
+ )+ |
+
| 758 | ++ |
+ )+ |
+
| 759 | ++ |
+ ),+ |
+
| 760 | +! | +
+ div(+ |
+
| 761 | +! | +
+ id = ns("filter_add_vars_contents"),
+ |
+
| 762 | +! | +
+ tagList(+ |
+
| 763 | +! | +
+ lapply(+ |
+
| 764 | +! | +
+ self$datanames(),+ |
+
| 765 | +! | +
+ function(dataname) {
+ |
+
| 766 | +! | +
+ fdataset <- private$get_filtered_dataset(dataname)+ |
+
| 767 | +! | +
+ span(id = ns(dataname), fdataset$ui_add(ns(dataname)))+ |
+
| 768 | ++ |
+ }+ |
+
| 769 | ++ |
+ )+ |
+
| 770 | ++ |
+ )+ |
+
| 771 | ++ |
+ )+ |
+
| 772 | ++ |
+ )+ |
+
| 773 | ++ |
+ },+ |
+
| 774 | ++ | + + | +
| 775 | ++ |
+ #' @description+ |
+
| 776 | ++ |
+ #' Server module responsible for displaying drop-downs with variables to add a filter.+ |
+
| 777 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 778 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 779 | ++ |
+ #' @param active_datanames (`reactive`)\cr+ |
+
| 780 | ++ |
+ #' defining subset of `self$datanames()` to be displayed.+ |
+
| 781 | ++ |
+ #' @return `moduleServer` returning `NULL`+ |
+
| 782 | ++ |
+ srv_add = function(id, active_datanames = reactive(self$datanames())) {
+ |
+
| 783 | +1x | +
+ checkmate::assert_class(active_datanames, "reactive")+ |
+
| 784 | +1x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 785 | +1x | +
+ logger::log_trace("FilteredData$srv_add initializing")
+ |
+
| 786 | +1x | +
+ shiny::observeEvent(input$minimise_filter_add_vars, {
+ |
+
| 787 | +! | +
+ shinyjs::toggle("filter_add_vars_contents")
+ |
+
| 788 | +! | +
+ toggle_icon(session$ns("minimise_filter_add_vars"), c("fa-angle-right", "fa-angle-down"))
+ |
+
| 789 | +! | +
+ toggle_title(session$ns("minimise_filter_add_vars"), c("Restore panel", "Minimise Panel"))
+ |
+
| 790 | ++ |
+ })+ |
+
| 791 | ++ | + + | +
| 792 | +1x | +
+ observeEvent(active_datanames(), {
+ |
+
| 793 | +! | +
+ lapply(self$datanames(), function(dataname) {
+ |
+
| 794 | +! | +
+ if (dataname %in% active_datanames()) {
+ |
+
| 795 | +! | +
+ shinyjs::show(dataname)+ |
+
| 796 | ++ |
+ } else {
+ |
+
| 797 | +! | +
+ shinyjs::hide(dataname)+ |
+
| 798 | ++ |
+ }+ |
+
| 799 | ++ |
+ })+ |
+
| 800 | ++ |
+ })+ |
+
| 801 | ++ | + + | +
| 802 | ++ |
+ # should not use for-loop as variables are otherwise only bound by reference+ |
+
| 803 | ++ |
+ # and last dataname would be used+ |
+
| 804 | +1x | +
+ lapply(+ |
+
| 805 | +1x | +
+ self$datanames(),+ |
+
| 806 | +1x | +
+ function(dataname) {
+ |
+
| 807 | +2x | +
+ fdataset <- private$get_filtered_dataset(dataname)+ |
+
| 808 | +2x | +
+ fdataset$srv_add(id = dataname)+ |
+
| 809 | ++ |
+ }+ |
+
| 810 | ++ |
+ )+ |
+
| 811 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_panel initialized")
+ |
+
| 812 | +1x | +
+ NULL+ |
+
| 813 | ++ |
+ })+ |
+
| 814 | ++ |
+ },+ |
+
| 815 | ++ | + + | +
| 816 | ++ |
+ #' Creates the UI for the module showing counts for each dataset+ |
+
| 817 | ++ |
+ #' contrasting the filtered to the full unfiltered dataset+ |
+
| 818 | ++ |
+ #'+ |
+
| 819 | ++ |
+ #' Per dataset, it displays+ |
+
| 820 | ++ |
+ #' the number of rows/observations in each dataset,+ |
+
| 821 | ++ |
+ #' the number of unique subjects.+ |
+
| 822 | ++ |
+ #'+ |
+
| 823 | ++ |
+ #' @param id module id+ |
+
| 824 | ++ |
+ ui_overview = function(id) {
+ |
+
| 825 | +! | +
+ ns <- NS(id)+ |
+
| 826 | +! | +
+ div(+ |
+
| 827 | +! | +
+ id = id, # not used, can be used to customize CSS behavior+ |
+
| 828 | +! | +
+ class = "well",+ |
+
| 829 | +! | +
+ tags$div(+ |
+
| 830 | +! | +
+ class = "row",+ |
+
| 831 | +! | +
+ tags$div(+ |
+
| 832 | +! | +
+ class = "col-sm-9",+ |
+
| 833 | +! | +
+ tags$label("Active Filter Summary", class = "text-primary mb-4")
+ |
+
| 834 | ++ |
+ ),+ |
+
| 835 | +! | +
+ tags$div(+ |
+
| 836 | +! | +
+ class = "col-sm-3",+ |
+
| 837 | +! | +
+ actionLink(+ |
+
| 838 | +! | +
+ ns("minimise_filter_overview"),
+ |
+
| 839 | +! | +
+ label = NULL,+ |
+
| 840 | +! | +
+ icon = icon("angle-down", lib = "font-awesome"),
+ |
+
| 841 | +! | +
+ title = "Minimise panel",+ |
+
| 842 | +! | +
+ class = "remove pull-right"+ |
+
| 843 | ++ |
+ )+ |
+
| 844 | ++ |
+ )+ |
+
| 845 | ++ |
+ ),+ |
+
| 846 | +! | +
+ tags$br(),+ |
+
| 847 | +! | +
+ div(+ |
+
| 848 | +! | +
+ id = ns("filters_overview_contents"),
+ |
+
| 849 | +! | +
+ div(+ |
+
| 850 | +! | +
+ class = "teal_active_summary_filter_panel",+ |
+
| 851 | +! | +
+ tableOutput(ns("table"))
+ |
+
| 852 | ++ |
+ )+ |
+
| 853 | ++ |
+ )+ |
+
| 854 | ++ |
+ )+ |
+
| 855 | ++ |
+ },+ |
+
| 856 | ++ | + + | +
| 857 | ++ |
+ #' Server function to display the number of records in the filtered and unfiltered+ |
+
| 858 | ++ |
+ #' data+ |
+
| 859 | ++ |
+ #'+ |
+
| 860 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 861 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 862 | ++ |
+ #' @param active_datanames (`reactive`)\cr+ |
+
| 863 | ++ |
+ #' returning `datanames` that should be shown on the filter panel,+ |
+
| 864 | ++ |
+ #' must be a subset of the `datanames` argument provided to `ui_filter_panel`;+ |
+
| 865 | ++ |
+ #' if the function returns `NULL` (as opposed to `character(0)`), the filter+ |
+
| 866 | ++ |
+ #' panel will be hidden.+ |
+
| 867 | ++ |
+ #' @return `moduleServer` function which returns `NULL`+ |
+
| 868 | ++ |
+ srv_overview = function(id, active_datanames = self$datanames) {
+ |
+
| 869 | +1x | +
+ checkmate::assert_class(active_datanames, "reactive")+ |
+
| 870 | +1x | +
+ moduleServer(+ |
+
| 871 | +1x | +
+ id = id,+ |
+
| 872 | +1x | +
+ function(input, output, session) {
+ |
+
| 873 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_overview initializing")
+ |
+
| 874 | ++ | + + | +
| 875 | +1x | +
+ shiny::observeEvent(input$minimise_filter_overview, {
+ |
+
| 876 | +! | +
+ shinyjs::toggle("filters_overview_contents")
+ |
+
| 877 | +! | +
+ toggle_icon(session$ns("minimise_filter_overview"), c("fa-angle-right", "fa-angle-down"))
+ |
+
| 878 | +! | +
+ toggle_title(session$ns("minimise_filter_overview"), c("Restore panel", "Minimise Panel"))
+ |
+
| 879 | ++ |
+ })+ |
+
| 880 | ++ | + + | +
| 881 | +1x | +
+ output$table <- renderUI({
+ |
+
| 882 | +! | +
+ logger::log_trace("FilteredData$srv_filter_overview@1 updating counts")
+ |
+
| 883 | +! | +
+ if (length(active_datanames()) == 0) {
+ |
+
| 884 | +! | +
+ return(NULL)+ |
+
| 885 | ++ |
+ }+ |
+
| 886 | ++ | + + | +
| 887 | +! | +
+ datasets_df <- self$get_filter_overview(datanames = active_datanames())+ |
+
| 888 | ++ | + + | +
| 889 | +! | +
+ if (!is.null(datasets_df$obs)) {
+ |
+
| 890 | ++ |
+ # some datasets (MAE colData) doesn't return obs column+ |
+
| 891 | +! | +
+ datasets_df <- transform(+ |
+
| 892 | +! | +
+ datasets_df,+ |
+
| 893 | +! | +
+ Obs = ifelse(+ |
+
| 894 | +! | +
+ !is.na(obs),+ |
+
| 895 | +! | +
+ sprintf("%s/%s", obs_filtered, obs),
+ |
+
| 896 | ++ |
+ ""+ |
+
| 897 | ++ |
+ )+ |
+
| 898 | ++ |
+ )+ |
+
| 899 | ++ |
+ }+ |
+
| 900 | ++ | + + | +
| 901 | ++ | + + | +
| 902 | +! | +
+ if (!is.null(datasets_df$subjects)) {
+ |
+
| 903 | ++ |
+ # some datasets (without keys) doesn't return subjects+ |
+
| 904 | +! | +
+ datasets_df <- transform(+ |
+
| 905 | +! | +
+ datasets_df,+ |
+
| 906 | +! | +
+ Subjects = ifelse(+ |
+
| 907 | +! | +
+ !is.na(subjects),+ |
+
| 908 | +! | +
+ sprintf("%s/%s", subjects_filtered, subjects),
+ |
+
| 909 | ++ |
+ ""+ |
+
| 910 | ++ |
+ )+ |
+
| 911 | ++ |
+ )+ |
+
| 912 | ++ |
+ }+ |
+
| 913 | +! | +
+ datasets_df <- datasets_df[, colnames(datasets_df) %in% c("dataname", "Obs", "Subjects")]
+ |
+
| 914 | ++ | + + | +
| 915 | +! | +
+ body_html <- apply(+ |
+
| 916 | +! | +
+ datasets_df,+ |
+
| 917 | +! | +
+ 1,+ |
+
| 918 | +! | +
+ function(x) {
+ |
+
| 919 | +! | +
+ tags$tr(+ |
+
| 920 | +! | +
+ tagList(+ |
+
| 921 | +! | +
+ lapply(x, tags$td)+ |
+
| 922 | ++ |
+ )+ |
+
| 923 | ++ |
+ )+ |
+
| 924 | ++ |
+ }+ |
+
| 925 | ++ |
+ )+ |
+
| 926 | ++ | + + | +
| 927 | +! | +
+ header_html <- tags$tr(+ |
+
| 928 | +! | +
+ tagList(+ |
+
| 929 | +! | +
+ lapply(colnames(datasets_df), tags$td)+ |
+
| 930 | ++ |
+ )+ |
+
| 931 | ++ |
+ )+ |
+
| 932 | ++ | + + | +
| 933 | +! | +
+ table_html <- tags$table(+ |
+
| 934 | +! | +
+ class = "table custom-table",+ |
+
| 935 | +! | +
+ tags$thead(header_html),+ |
+
| 936 | +! | +
+ tags$tbody(body_html)+ |
+
| 937 | ++ |
+ )+ |
+
| 938 | +! | +
+ logger::log_trace("FilteredData$srv_filter_overview@1 updated counts")
+ |
+
| 939 | +! | +
+ table_html+ |
+
| 940 | ++ |
+ })+ |
+
| 941 | +1x | +
+ logger::log_trace("FilteredData$srv_filter_overview initialized")
+ |
+
| 942 | +1x | +
+ NULL+ |
+
| 943 | ++ |
+ }+ |
+
| 944 | ++ |
+ )+ |
+
| 945 | ++ |
+ },+ |
+
| 946 | ++ | + + | +
| 947 | ++ |
+ # deprecated - to remove after release --------------------------------------+ |
+
| 948 | ++ | + + | +
| 949 | ++ |
+ #' @description+ |
+
| 950 | ++ |
+ #' Method is deprecated. Provide resolved `active_datanames` to `srv_filter_panel`+ |
+
| 951 | ++ |
+ #'+ |
+
| 952 | ++ |
+ #' @param datanames `character vector` `datanames` to pick+ |
+
| 953 | ++ |
+ #'+ |
+
| 954 | ++ |
+ #' @return the intersection of `self$datanames()` and `datanames`+ |
+
| 955 | ++ |
+ #'+ |
+
| 956 | ++ |
+ handle_active_datanames = function(datanames) {
+ |
+
| 957 | +! | +
+ stop("Deprecated with teal.slice 0.4.0")
+ |
+
| 958 | ++ |
+ },+ |
+
| 959 | ++ | + + | +
| 960 | ++ |
+ #' @description+ |
+
| 961 | ++ |
+ #' Method is deprecated. Please extract column labels directly from the data.+ |
+
| 962 | ++ |
+ #'+ |
+
| 963 | ++ |
+ #' @param dataname (`character(1)`) name of the dataset+ |
+
| 964 | ++ |
+ #' @param variables (`character`) variables to get labels for;+ |
+
| 965 | ++ |
+ #' if `NULL`, for all variables in data+ |
+
| 966 | ++ |
+ #'+ |
+
| 967 | ++ |
+ get_varlabels = function(dataname, variables = NULL) {
+ |
+
| 968 | +! | +
+ stop("Deprecated with 0.4.0 - please extract column labels directly from the data.")
+ |
+
| 969 | ++ |
+ },+ |
+
| 970 | ++ | + + | +
| 971 | ++ |
+ #' @description+ |
+
| 972 | ++ |
+ #' Method is deprecated, Please extract variable names directly from the data instead+ |
+
| 973 | ++ |
+ #'+ |
+
| 974 | ++ |
+ #' @param dataname (`character`) the name of the dataset+ |
+
| 975 | ++ |
+ #'+ |
+
| 976 | ++ |
+ get_varnames = function(dataname) {
+ |
+
| 977 | +! | +
+ stop("Deprecated with 0.4.0 - please extract varniable names directly from the data")
+ |
+
| 978 | ++ |
+ },+ |
+
| 979 | ++ | + + | +
| 980 | ++ |
+ #' @description+ |
+
| 981 | ++ |
+ #' Method is deprecated, please use `self$datanames()` instead+ |
+
| 982 | ++ |
+ #'+ |
+
| 983 | ++ |
+ #' @param dataname (`character` vector) names of the dataset+ |
+
| 984 | ++ |
+ #'+ |
+
| 985 | ++ |
+ get_filterable_datanames = function() {
+ |
+
| 986 | +! | +
+ stop("Deprecated with 0.4.0 - please use self$datanames() instead")
+ |
+
| 987 | ++ |
+ },+ |
+
| 988 | ++ | + + | +
| 989 | ++ |
+ #' @description+ |
+
| 990 | ++ |
+ #' Method is deprecated, please use `self$get_filter_state()` and retain `attr(, "filterable_varnames")` instead.+ |
+
| 991 | ++ |
+ #'+ |
+
| 992 | ++ |
+ #' @param dataname (`character(1)`) name of the dataset+ |
+
| 993 | ++ |
+ #'+ |
+
| 994 | ++ |
+ get_filterable_varnames = function(dataname) {
+ |
+
| 995 | +! | +
+ stop("Deprecated with teal.slice 0.4.0 - see help(teal_slices) and description of include_varnames argument.")
+ |
+
| 996 | ++ |
+ },+ |
+
| 997 | ++ | + + | +
| 998 | ++ |
+ #' @description+ |
+
| 999 | ++ |
+ #' Method is deprecated, please use `self$set_filter_state` and [teal_slices()] with `include_varnames` instead.+ |
+
| 1000 | ++ |
+ #'+ |
+
| 1001 | ++ |
+ #' @param dataname (`character(1)`) name of the dataset+ |
+
| 1002 | ++ |
+ #' @param varnames (`character` or `NULL`)+ |
+
| 1003 | ++ |
+ #' variables which users can choose to filter the data;+ |
+
| 1004 | ++ |
+ #' see `self$get_filterable_varnames` for more details+ |
+
| 1005 | ++ |
+ #'+ |
+
| 1006 | ++ |
+ #'+ |
+
| 1007 | ++ |
+ set_filterable_varnames = function(dataname, varnames) {
+ |
+
| 1008 | +! | +
+ stop("Deprecated with teal.slice 0.4.0 - see help(teal_slices) and description of include_varnames argument.")
+ |
+
| 1009 | ++ |
+ },+ |
+
| 1010 | ++ | + + | +
| 1011 | ++ |
+ #' @description+ |
+
| 1012 | ++ |
+ #' Method is deprecated, please use `format.teal_slices` on object returned from `self$get_filter_state()`+ |
+
| 1013 | ++ |
+ #'+ |
+
| 1014 | ++ |
+ get_formatted_filter_state = function() {
+ |
+
| 1015 | +! | +
+ stop("Deprecated with teal.slice 0.4.0 - get_filter_state returns teal_slice which has dedicated format method")
+ |
+
| 1016 | ++ |
+ },+ |
+
| 1017 | ++ | + + | +
| 1018 | ++ |
+ #' @description+ |
+
| 1019 | ++ |
+ #' Deprecated - please use `clear_filter_states` method.+ |
+
| 1020 | ++ |
+ #'+ |
+
| 1021 | ++ |
+ #' @param datanames (`character`)+ |
+
| 1022 | ++ |
+ #'+ |
+
| 1023 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 1024 | ++ |
+ #'+ |
+
| 1025 | ++ |
+ remove_all_filter_states = function(datanames) {
+ |
+
| 1026 | +! | +
+ warning("FilteredData$remove_all_filter_states is deprecated, please use FilteredData$clear_filter_states.")
+ |
+
| 1027 | +! | +
+ self$clear_filter_states(dataname)+ |
+
| 1028 | ++ |
+ }+ |
+
| 1029 | ++ |
+ ),+ |
+
| 1030 | ++ | + + | +
| 1031 | ++ |
+ ## __Private Methods ====+ |
+
| 1032 | ++ |
+ private = list(+ |
+
| 1033 | ++ |
+ # selectively hide / show to only show `active_datanames` out of all datanames+ |
+
| 1034 | ++ | + + | +
| 1035 | ++ |
+ # private attributes ----+ |
+
| 1036 | ++ |
+ filtered_datasets = list(),+ |
+
| 1037 | ++ | + + | +
| 1038 | ++ |
+ # activate/deactivate filter panel+ |
+
| 1039 | ++ |
+ filter_panel_active = TRUE,+ |
+
| 1040 | ++ | + + | +
| 1041 | ++ |
+ # whether the datasets had a reproducibility check+ |
+
| 1042 | ++ |
+ .check = FALSE,+ |
+
| 1043 | ++ | + + | +
| 1044 | ++ |
+ # preprocessing code used to generate the unfiltered datasets as a string+ |
+
| 1045 | ++ |
+ code = NULL,+ |
+
| 1046 | ++ |
+ available_teal_slices = NULL,+ |
+
| 1047 | ++ | + + | +
| 1048 | ++ |
+ # keys used for joining/filtering data a JoinKeys object (see teal.data)+ |
+
| 1049 | ++ |
+ join_keys = NULL,+ |
+
| 1050 | ++ | + + | +
| 1051 | ++ |
+ # reactive i.e. filtered data+ |
+
| 1052 | ++ |
+ reactive_data = list(),+ |
+
| 1053 | ++ |
+ cached_states = NULL,+ |
+
| 1054 | ++ |
+ module_add = TRUE,+ |
+
| 1055 | ++ | + + | +
| 1056 | ++ |
+ # private methods ----+ |
+
| 1057 | ++ | + + | +
| 1058 | ++ |
+ # @description+ |
+
| 1059 | ++ |
+ # Gets `FilteredDataset` object which contains all information+ |
+
| 1060 | ++ |
+ # pertaining to the specified dataset.+ |
+
| 1061 | ++ |
+ #+ |
+
| 1062 | ++ |
+ # @param dataname (`character(1)`)\cr+ |
+
| 1063 | ++ |
+ # name of the dataset+ |
+
| 1064 | ++ |
+ #+ |
+
| 1065 | ++ |
+ # @return `FilteredDataset` object or list of `FilteredDataset`s+ |
+
| 1066 | ++ |
+ #+ |
+
| 1067 | ++ |
+ get_filtered_dataset = function(dataname = character(0)) {
+ |
+
| 1068 | +131x | +
+ if (length(dataname) == 0) {
+ |
+
| 1069 | +! | +
+ private$filtered_datasets+ |
+
| 1070 | ++ |
+ } else {
+ |
+
| 1071 | +131x | +
+ private$filtered_datasets[[dataname]]+ |
+
| 1072 | ++ |
+ }+ |
+
| 1073 | ++ |
+ },+ |
+
| 1074 | ++ | + + | +
| 1075 | ++ |
+ # we implement these functions as checks rather than returning logicals so they can+ |
+
| 1076 | ++ |
+ # give informative error messages immediately+ |
+
| 1077 | ++ | + + | +
| 1078 | ++ |
+ # @description+ |
+
| 1079 | ++ |
+ # Gets the number of active `FilterState` objects in all `FilterStates`+ |
+
| 1080 | ++ |
+ # in all `FilteredDataset`s in this `FilteredData` object.+ |
+
| 1081 | ++ |
+ # @return `integer(1)`+ |
+
| 1082 | ++ |
+ get_filter_count = function() {
+ |
+
| 1083 | +11x | +
+ length(self$get_filter_state())+ |
+
| 1084 | ++ |
+ },+ |
+
| 1085 | ++ | + + | +
| 1086 | ++ |
+ # @description+ |
+
| 1087 | ++ |
+ # Activate available filters.+ |
+
| 1088 | ++ |
+ # Module is composed from plus button and dropdown menu. Menu is shown when+ |
+
| 1089 | ++ |
+ # the button is clicked. Menu contains available/active filters list+ |
+
| 1090 | ++ |
+ # passed via `set_available_teal_slice`.+ |
+
| 1091 | ++ |
+ ui_available_filters = function(id) {
+ |
+
| 1092 | +! | +
+ ns <- NS(id)+ |
+
| 1093 | ++ | + + | +
| 1094 | +! | +
+ active_slices_id <- shiny::isolate(vapply(self$get_filter_state(), `[[`, character(1), "id"))+ |
+
| 1095 | +! | +
+ div(+ |
+
| 1096 | +! | +
+ id = ns("available_menu"),
+ |
+
| 1097 | +! | +
+ shinyWidgets::dropMenu(+ |
+
| 1098 | +! | +
+ actionLink(+ |
+
| 1099 | +! | +
+ ns("show"),
+ |
+
| 1100 | +! | +
+ label = NULL,+ |
+
| 1101 | +! | +
+ icon = icon("plus", lib = "font-awesome"),
+ |
+
| 1102 | +! | +
+ title = "Available filters",+ |
+
| 1103 | +! | +
+ class = "remove pull-right"+ |
+
| 1104 | ++ |
+ ),+ |
+
| 1105 | +! | +
+ div(+ |
+
| 1106 | +! | +
+ class = "menu-content",+ |
+
| 1107 | +! | +
+ uiOutput(ns("checkbox"))
+ |
+
| 1108 | ++ |
+ )+ |
+
| 1109 | ++ |
+ )+ |
+
| 1110 | ++ |
+ )+ |
+
| 1111 | ++ |
+ },+ |
+
| 1112 | ++ | + + | +
| 1113 | ++ |
+ # @description+ |
+
| 1114 | ++ |
+ # Activate available filters. When the filter is selected or removed+ |
+
| 1115 | ++ |
+ # then `set_filter_state` or `remove_filter_state` is executed for+ |
+
| 1116 | ++ |
+ # appropriate filter (identified by it's id)+ |
+
| 1117 | ++ |
+ srv_available_filters = function(id) {
+ |
+
| 1118 | +4x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 1119 | +4x | +
+ slices_interactive <- reactive(+ |
+
| 1120 | +4x | +
+ Filter(+ |
+
| 1121 | +4x | +
+ function(slice) !isTRUE(slice$fixed) && !inherits(slice, "teal_slice_expr"),+ |
+
| 1122 | +4x | +
+ private$available_teal_slices()+ |
+
| 1123 | ++ |
+ )+ |
+
| 1124 | ++ |
+ )+ |
+
| 1125 | +4x | +
+ slices_fixed <- reactive(+ |
+
| 1126 | +4x | +
+ Filter(+ |
+
| 1127 | +4x | +
+ function(slice) isTRUE(slice$fixed) || inherits(slice, "teal_slice_expr"),+ |
+
| 1128 | +4x | +
+ private$available_teal_slices()+ |
+
| 1129 | ++ |
+ )+ |
+
| 1130 | ++ |
+ )+ |
+
| 1131 | +4x | +
+ available_slices_id <- reactive(vapply(private$available_teal_slices(), `[[`, character(1), "id"))+ |
+
| 1132 | +4x | +
+ active_slices_id <- reactive(vapply(self$get_filter_state(), `[[`, character(1), "id"))+ |
+
| 1133 | +4x | +
+ duplicated_slice_references <- reactive({
+ |
+
| 1134 | ++ |
+ # slice refers to a particular column+ |
+
| 1135 | +8x | +
+ slice_reference <- vapply(private$available_teal_slices(), get_default_slice_id, character(1))+ |
+
| 1136 | +8x | +
+ is_duplicated_reference <- duplicated(slice_reference) | duplicated(slice_reference, fromLast = TRUE)+ |
+
| 1137 | +8x | +
+ is_active <- available_slices_id() %in% active_slices_id()+ |
+
| 1138 | +8x | +
+ is_not_expr <- !vapply(private$available_teal_slices(), inherits, logical(1), "teal_slice_expr")+ |
+
| 1139 | +8x | +
+ slice_reference[is_duplicated_reference & is_active & is_not_expr]+ |
+
| 1140 | ++ |
+ })+ |
+
| 1141 | ++ | + + | +
| 1142 | +4x | +
+ checkbox_group_element <- function(name, value, label, checked, disabled = FALSE) {
+ |
+
| 1143 | +35x | +
+ tags$div(+ |
+
| 1144 | +35x | +
+ class = "checkbox available-filters",+ |
+
| 1145 | +35x | +
+ tags$label(+ |
+
| 1146 | +35x | +
+ tags$input(+ |
+
| 1147 | +35x | +
+ type = "checkbox",+ |
+
| 1148 | +35x | +
+ name = name,+ |
+
| 1149 | +35x | +
+ value = value,+ |
+
| 1150 | +35x | +
+ checked = checked,+ |
+
| 1151 | +35x | +
+ disabled = if (disabled) "disabled"+ |
+
| 1152 | ++ |
+ ),+ |
+
| 1153 | +35x | +
+ tags$span(label, disabled = if (disabled) disabled)+ |
+
| 1154 | ++ |
+ )+ |
+
| 1155 | ++ |
+ )+ |
+
| 1156 | ++ |
+ }+ |
+
| 1157 | ++ | + + | +
| 1158 | +4x | +
+ output$checkbox <- renderUI({
+ |
+
| 1159 | +8x | +
+ checkbox <- checkboxGroupInput(+ |
+
| 1160 | +8x | +
+ session$ns("available_slices_id"),
+ |
+
| 1161 | +8x | +
+ label = NULL,+ |
+
| 1162 | +8x | +
+ choices = NULL,+ |
+
| 1163 | +8x | +
+ selected = NULL+ |
+
| 1164 | ++ |
+ )+ |
+
| 1165 | +8x | +
+ active_slices_ids <- active_slices_id()+ |
+
| 1166 | +8x | +
+ duplicated_slice_refs <- duplicated_slice_references()+ |
+
| 1167 | ++ | + + | +
| 1168 | +8x | +
+ checkbox_group_slice <- function(slice) {
+ |
+
| 1169 | ++ |
+ # we need to isolate changes in the fields of the slice (teal_slice)+ |
+
| 1170 | +35x | +
+ shiny::isolate({
+ |
+
| 1171 | +35x | +
+ checkbox_group_element(+ |
+
| 1172 | +35x | +
+ name = session$ns("available_slices_id"),
+ |
+
| 1173 | +35x | +
+ value = slice$id,+ |
+
| 1174 | +35x | +
+ label = slice$id,+ |
+
| 1175 | +35x | +
+ checked = if (slice$id %in% active_slices_ids) "checked",+ |
+
| 1176 | +35x | +
+ disabled = slice$locked ||+ |
+
| 1177 | +35x | +
+ get_default_slice_id(slice) %in% duplicated_slice_refs &&+ |
+
| 1178 | +35x | +
+ !slice$id %in% active_slices_ids+ |
+
| 1179 | ++ |
+ )+ |
+
| 1180 | ++ |
+ })+ |
+
| 1181 | ++ |
+ }+ |
+
| 1182 | ++ | + + | +
| 1183 | +8x | +
+ interactive_choice_mock <- lapply(slices_interactive(), checkbox_group_slice)+ |
+
| 1184 | +8x | +
+ non_interactive_choice_mock <- lapply(slices_fixed(), checkbox_group_slice)+ |
+
| 1185 | ++ | + + | +
| 1186 | +8x | +
+ htmltools::tagInsertChildren(+ |
+
| 1187 | +8x | +
+ checkbox,+ |
+
| 1188 | +8x | +
+ br(),+ |
+
| 1189 | +8x | +
+ tags$strong("Fixed filters"),
+ |
+
| 1190 | +8x | +
+ non_interactive_choice_mock,+ |
+
| 1191 | +8x | +
+ tags$strong("Interactive filters"),
+ |
+
| 1192 | +8x | +
+ interactive_choice_mock,+ |
+
| 1193 | +8x | +
+ .cssSelector = "div.shiny-options-group",+ |
+
| 1194 | +8x | +
+ after = 0+ |
+
| 1195 | ++ |
+ )+ |
+
| 1196 | ++ |
+ })+ |
+
| 1197 | ++ | + + | +
| 1198 | +4x | +
+ observeEvent(input$available_slices_id, ignoreNULL = FALSE, ignoreInit = TRUE, {
+ |
+
| 1199 | +5x | +
+ new_slices_id <- setdiff(input$available_slices_id, active_slices_id())+ |
+
| 1200 | +5x | +
+ removed_slices_id <- setdiff(active_slices_id(), input$available_slices_id)+ |
+
| 1201 | +5x | +
+ if (length(new_slices_id)) {
+ |
+
| 1202 | +3x | +
+ new_teal_slices <- Filter(+ |
+
| 1203 | +3x | +
+ function(slice) slice$id %in% new_slices_id,+ |
+
| 1204 | +3x | +
+ private$available_teal_slices()+ |
+
| 1205 | ++ |
+ )+ |
+
| 1206 | +3x | +
+ self$set_filter_state(new_teal_slices)+ |
+
| 1207 | ++ |
+ }+ |
+
| 1208 | ++ | + + | +
| 1209 | +5x | +
+ if (length(removed_slices_id)) {
+ |
+
| 1210 | +4x | +
+ removed_teal_slices <- Filter(+ |
+
| 1211 | +4x | +
+ function(slice) slice$id %in% removed_slices_id,+ |
+
| 1212 | +4x | +
+ self$get_filter_state()+ |
+
| 1213 | ++ |
+ )+ |
+
| 1214 | +4x | +
+ self$remove_filter_state(removed_teal_slices)+ |
+
| 1215 | ++ |
+ }+ |
+
| 1216 | ++ |
+ })+ |
+
| 1217 | ++ | + + | +
| 1218 | +4x | +
+ observeEvent(private$available_teal_slices(), ignoreNULL = FALSE, {
+ |
+
| 1219 | +3x | +
+ if (length(private$available_teal_slices())) {
+ |
+
| 1220 | +1x | +
+ shinyjs::show("available_menu")
+ |
+
| 1221 | ++ |
+ } else {
+ |
+
| 1222 | +2x | +
+ shinyjs::hide("available_menu")
+ |
+
| 1223 | ++ |
+ }+ |
+
| 1224 | ++ |
+ })+ |
+
| 1225 | ++ |
+ })+ |
+
| 1226 | ++ |
+ }+ |
+
| 1227 | ++ |
+ )+ |
+
| 1228 | ++ |
+ )+ |
+
| 1 | ++ |
+ # FilteredDataset abstract --------+ |
+
| 2 | ++ |
+ #' @title `FilterStates` R6 class+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' `FilteredDataset` is a class which renders/controls `FilterStates`(s)+ |
+
| 5 | ++ |
+ #' Each `FilteredDataset` contains `filter_states` field - a `list` which contains one+ |
+
| 6 | ++ |
+ #' (`data.frame`) or multiple (`MultiAssayExperiment`) `FilterStates` objects.+ |
+
| 7 | ++ |
+ #' Each `FilterStates` is responsible for one filter/subset expression applied for specific+ |
+
| 8 | ++ |
+ #' components of the dataset.+ |
+
| 9 | ++ |
+ #' @keywords internal+ |
+
| 10 | ++ |
+ FilteredDataset <- R6::R6Class( # nolint+ |
+
| 11 | ++ |
+ "FilteredDataset",+ |
+
| 12 | ++ |
+ ## __Public Methods ====+ |
+
| 13 | ++ |
+ public = list(+ |
+
| 14 | ++ |
+ #' @description+ |
+
| 15 | ++ |
+ #' Initializes this `FilteredDataset` object+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @param dataset (`data.frame` or `MultiAssayExperiment`)\cr+ |
+
| 18 | ++ |
+ #' single dataset for which filters are rendered+ |
+
| 19 | ++ |
+ #' @param dataname (`character(1)`)\cr+ |
+
| 20 | ++ |
+ #' A given name for the dataset it may not contain spaces+ |
+
| 21 | ++ |
+ #' @param keys optional, (`character`)\cr+ |
+
| 22 | ++ |
+ #' Vector with primary keys+ |
+
| 23 | ++ |
+ #' @param label (`character(1)`)\cr+ |
+
| 24 | ++ |
+ #' Label to describe the dataset+ |
+
| 25 | ++ |
+ #' @param metadata (named `list` or `NULL`) \cr+ |
+
| 26 | ++ |
+ #' Field containing metadata about the dataset. Each element of the list+ |
+
| 27 | ++ |
+ #' should be atomic and length one.+ |
+
| 28 | ++ |
+ initialize = function(dataset, dataname, keys = character(0), label = attr(dataset, "label"), metadata = NULL) {
+ |
+
| 29 | +145x | +
+ logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # dataset assertion in child classes+ |
+
| 32 | +145x | +
+ check_simple_name(dataname)+ |
+
| 33 | +143x | +
+ checkmate::assert_character(keys, any.missing = FALSE)+ |
+
| 34 | +143x | +
+ checkmate::assert_character(label, null.ok = TRUE)+ |
+
| 35 | +143x | +
+ teal.data::validate_metadata(metadata)+ |
+
| 36 | ++ | + + | +
| 37 | +143x | +
+ logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
+ |
+
| 38 | +143x | +
+ private$dataset <- dataset+ |
+
| 39 | +143x | +
+ private$dataname <- dataname+ |
+
| 40 | +143x | +
+ private$keys <- keys+ |
+
| 41 | +143x | +
+ private$label <- if (is.null(label)) character(0) else label+ |
+
| 42 | +143x | +
+ private$metadata <- metadata+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ # function executing reactive call and returning data+ |
+
| 45 | +143x | +
+ private$data_filtered_fun <- function(sid = "") {
+ |
+
| 46 | +21x | +
+ checkmate::assert_character(sid)+ |
+
| 47 | +21x | +
+ if (length(sid)) {
+ |
+
| 48 | +21x | +
+ logger::log_trace("filtering data dataname: { dataname }, sid: { sid }")
+ |
+
| 49 | ++ |
+ } else {
+ |
+
| 50 | +! | +
+ logger::log_trace("filtering data dataname: { private$dataname }")
+ |
+
| 51 | ++ |
+ }+ |
+
| 52 | +21x | +
+ env <- new.env(parent = parent.env(globalenv()))+ |
+
| 53 | +21x | +
+ env[[dataname]] <- private$dataset+ |
+
| 54 | +21x | +
+ filter_call <- self$get_call(sid)+ |
+
| 55 | +21x | +
+ eval_expr_with_msg(filter_call, env)+ |
+
| 56 | +21x | +
+ get(x = dataname, envir = env)+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | ++ | + + | +
| 59 | +143x | +
+ private$data_filtered <- reactive(private$data_filtered_fun())+ |
+
| 60 | +143x | +
+ logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
+ |
+
| 61 | +143x | +
+ invisible(self)+ |
+
| 62 | ++ |
+ },+ |
+
| 63 | ++ | + + | +
| 64 | ++ |
+ #' @description+ |
+
| 65 | ++ |
+ #' Returns a formatted string representing this `FilteredDataset` object.+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @param show_all `logical(1)` passed to `format.teal_slice`+ |
+
| 68 | ++ |
+ #' @param trim_lines `logical(1)` passed to `format.teal_slice`+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @return `character(1)` the formatted string+ |
+
| 71 | ++ |
+ #'+ |
+
| 72 | ++ |
+ format = function(show_all = FALSE, trim_lines = TRUE) {
+ |
+
| 73 | +24x | +
+ sprintf(+ |
+
| 74 | +24x | +
+ "%s:\n%s",+ |
+
| 75 | +24x | +
+ class(self)[1],+ |
+
| 76 | +24x | +
+ format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ |
+ },+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ #' @description+ |
+
| 81 | ++ |
+ #' Prints this `FilteredDataset` object.+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @param ... additional arguments+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ print = function(...) {
+ |
+
| 86 | +10x | +
+ cat(shiny::isolate(self$format(...)), "\n")+ |
+
| 87 | ++ |
+ },+ |
+
| 88 | ++ | + + | +
| 89 | ++ |
+ #' @description+ |
+
| 90 | ++ |
+ #' Removes all active filter items applied to this dataset+ |
+
| 91 | ++ |
+ #' @return NULL+ |
+
| 92 | ++ |
+ clear_filter_states = function() {
+ |
+
| 93 | +14x | +
+ logger::log_trace("Removing all non-locked filters from FilteredDataset: { deparse1(self$get_dataname()) }")
+ |
+
| 94 | +14x | +
+ lapply(+ |
+
| 95 | +14x | +
+ private$get_filter_states(),+ |
+
| 96 | +14x | +
+ function(filter_states) filter_states$clear_filter_states()+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | +14x | +
+ logger::log_trace("Removed all non-locked filters from FilteredDataset: { deparse1(self$get_dataname()) }")
+ |
+
| 99 | +14x | +
+ NULL+ |
+
| 100 | ++ |
+ },+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ # managing filter states -----+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ # getters ----+ |
+
| 105 | ++ |
+ #' @description+ |
+
| 106 | ++ |
+ #' Gets a filter expression+ |
+
| 107 | ++ |
+ #'+ |
+
| 108 | ++ |
+ #' This functions returns filter calls equivalent to selected items+ |
+
| 109 | ++ |
+ #' within each of `filter_states`. Configuration of the calls is constant and+ |
+
| 110 | ++ |
+ #' depends on `filter_states` type and order which are set during initialization.+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' @param sid (`character`)\cr+ |
+
| 113 | ++ |
+ #' when specified then method returns code containing filter conditions of+ |
+
| 114 | ++ |
+ #' `FilterState` objects which `"sid"` attribute is different than this `sid` argument.+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' @return filter `call` or `list` of filter calls+ |
+
| 117 | ++ |
+ get_call = function(sid = "") {
+ |
+
| 118 | +41x | +
+ filter_call <- Filter(+ |
+
| 119 | +41x | +
+ f = Negate(is.null),+ |
+
| 120 | +41x | +
+ x = lapply(private$get_filter_states(), function(x) x$get_call(sid))+ |
+
| 121 | ++ |
+ )+ |
+
| 122 | +41x | +
+ if (length(filter_call) == 0) {
+ |
+
| 123 | +24x | +
+ return(NULL)+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | +17x | +
+ filter_call+ |
+
| 126 | ++ |
+ },+ |
+
| 127 | ++ | + + | +
| 128 | ++ |
+ #' @description+ |
+
| 129 | ++ |
+ #' Gets states of all active `FilterState` objects+ |
+
| 130 | ++ |
+ #'+ |
+
| 131 | ++ |
+ #' @return A `teal_slices` object.+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ get_filter_state = function() {
+ |
+
| 134 | +184x | +
+ states <- unname(lapply(private$get_filter_states(), function(x) x$get_filter_state()))+ |
+
| 135 | +184x | +
+ do.call(c, states)+ |
+
| 136 | ++ |
+ },+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ #' @description+ |
+
| 139 | ++ |
+ #' Set filter state+ |
+
| 140 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' @param state (`teal_slice`) object+ |
+
| 142 | ++ |
+ #'+ |
+
| 143 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ set_filter_state = function(state) {
+ |
+
| 146 | +! | +
+ stop("set_filter_state is an abstract class method.")
+ |
+
| 147 | ++ |
+ },+ |
+
| 148 | ++ | + + | +
| 149 | ++ |
+ #' @description+ |
+
| 150 | ++ |
+ #' Gets the number of active `FilterState` objects in all `FilterStates` in this `FilteredDataset`.+ |
+
| 151 | ++ |
+ #' @return `integer(1)`+ |
+
| 152 | ++ |
+ get_filter_count = function() {
+ |
+
| 153 | +16x | +
+ length(self$get_filter_state())+ |
+
| 154 | ++ |
+ },+ |
+
| 155 | ++ | + + | +
| 156 | ++ |
+ #' @description+ |
+
| 157 | ++ |
+ #' Gets the name of the dataset+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @return `character(1)` as a name of this dataset+ |
+
| 160 | ++ |
+ get_dataname = function() {
+ |
+
| 161 | +8x | +
+ private$dataname+ |
+
| 162 | ++ |
+ },+ |
+
| 163 | ++ | + + | +
| 164 | ++ |
+ #' @description+ |
+
| 165 | ++ |
+ #' Gets the dataset object in this `FilteredDataset`+ |
+
| 166 | ++ |
+ #' @param filtered (`logical(1)`)\cr+ |
+
| 167 | ++ |
+ #'+ |
+
| 168 | ++ |
+ #' @return `data.frame` or `MultiAssayExperiment`, either raw+ |
+
| 169 | ++ |
+ #' or as a reactive with current filters applied+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ get_dataset = function(filtered = FALSE) {
+ |
+
| 172 | +45x | +
+ if (filtered) {
+ |
+
| 173 | +27x | +
+ private$data_filtered+ |
+
| 174 | ++ |
+ } else {
+ |
+
| 175 | +18x | +
+ private$dataset+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | ++ |
+ },+ |
+
| 178 | ++ | + + | +
| 179 | ++ |
+ #' @description+ |
+
| 180 | ++ |
+ #' Gets the metadata for the dataset in this `FilteredDataset`+ |
+
| 181 | ++ |
+ #' @return named `list` or `NULL`+ |
+
| 182 | ++ |
+ get_metadata = function() {
+ |
+
| 183 | +4x | +
+ private$metadata+ |
+
| 184 | ++ |
+ },+ |
+
| 185 | ++ | + + | +
| 186 | ++ |
+ #' @description+ |
+
| 187 | ++ |
+ #' Get filter overview rows of a dataset+ |
+
| 188 | ++ |
+ #' The output shows the comparison between `filtered_dataset`+ |
+
| 189 | ++ |
+ #' function parameter and the dataset inside self+ |
+
| 190 | ++ |
+ #' @param filtered_dataset comparison object, of the same class+ |
+
| 191 | ++ |
+ #' as `self$get_dataset()`, if `NULL` then `self$get_dataset()`+ |
+
| 192 | ++ |
+ #' is used.+ |
+
| 193 | ++ |
+ #' @return (`data.frame`) matrix of observations and subjects+ |
+
| 194 | ++ |
+ get_filter_overview = function() {
+ |
+
| 195 | +! | +
+ dataset <- self$get_dataset()+ |
+
| 196 | +! | +
+ data_filtered <- self$get_dataset(TRUE)+ |
+
| 197 | +! | +
+ data.frame(+ |
+
| 198 | +! | +
+ dataname = private$dataname,+ |
+
| 199 | +! | +
+ obs = nrow(dataset),+ |
+
| 200 | +! | +
+ obs_filtered = nrow(data_filtered)+ |
+
| 201 | ++ |
+ )+ |
+
| 202 | ++ |
+ },+ |
+
| 203 | ++ | + + | +
| 204 | ++ |
+ #' @description+ |
+
| 205 | ++ |
+ #' Gets the keys for the dataset of this `FilteredDataset`+ |
+
| 206 | ++ |
+ #' @return (`character`) the keys of dataset+ |
+
| 207 | ++ |
+ get_keys = function() {
+ |
+
| 208 | +147x | +
+ private$keys+ |
+
| 209 | ++ |
+ },+ |
+
| 210 | ++ | + + | +
| 211 | ++ |
+ #' @description+ |
+
| 212 | ++ |
+ #' Gets the dataset label+ |
+
| 213 | ++ |
+ #' @return (`character`) the dataset label+ |
+
| 214 | ++ |
+ get_dataset_label = function() {
+ |
+
| 215 | +3x | +
+ private$label+ |
+
| 216 | ++ |
+ },+ |
+
| 217 | ++ | + + | +
| 218 | ++ |
+ # modules ------+ |
+
| 219 | ++ |
+ #' @description+ |
+
| 220 | ++ |
+ #' UI module for dataset active filters+ |
+
| 221 | ++ |
+ #'+ |
+
| 222 | ++ |
+ #' UI module containing dataset active filters along with+ |
+
| 223 | ++ |
+ #' title and remove button.+ |
+
| 224 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 225 | ++ |
+ #' identifier of the element - preferably containing dataset name+ |
+
| 226 | ++ |
+ #'+ |
+
| 227 | ++ |
+ #' @return function - shiny UI module+ |
+
| 228 | ++ |
+ ui_active = function(id) {
+ |
+
| 229 | +! | +
+ dataname <- self$get_dataname()+ |
+
| 230 | +! | +
+ checkmate::assert_string(dataname)+ |
+
| 231 | ++ | + + | +
| 232 | +! | +
+ ns <- NS(id)+ |
+
| 233 | +! | +
+ if_multiple_filter_states <- length(private$get_filter_states()) > 1+ |
+
| 234 | +! | +
+ span(+ |
+
| 235 | +! | +
+ id = id,+ |
+
| 236 | +! | +
+ include_css_files("filter-panel"),
+ |
+
| 237 | +! | +
+ div(+ |
+
| 238 | +! | +
+ id = ns("whole_ui"), # to hide it entirely
+ |
+
| 239 | +! | +
+ fluidRow(+ |
+
| 240 | +! | +
+ column(+ |
+
| 241 | +! | +
+ width = 8,+ |
+
| 242 | +! | +
+ tags$span(dataname, class = "filter_panel_dataname")+ |
+
| 243 | ++ |
+ ),+ |
+
| 244 | +! | +
+ column(+ |
+
| 245 | +! | +
+ width = 4,+ |
+
| 246 | +! | +
+ tagList(+ |
+
| 247 | +! | +
+ actionLink(+ |
+
| 248 | +! | +
+ ns("remove_filters"),
+ |
+
| 249 | +! | +
+ label = "",+ |
+
| 250 | +! | +
+ icon = icon("circle-xmark", lib = "font-awesome"),
+ |
+
| 251 | +! | +
+ class = "remove pull-right"+ |
+
| 252 | ++ |
+ ),+ |
+
| 253 | +! | +
+ actionLink(+ |
+
| 254 | +! | +
+ ns("collapse"),
+ |
+
| 255 | +! | +
+ label = "",+ |
+
| 256 | +! | +
+ icon = icon("angle-down", lib = "font-awesome"),
+ |
+
| 257 | +! | +
+ class = "remove pull-right"+ |
+
| 258 | ++ |
+ )+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | ++ |
+ )+ |
+
| 261 | ++ |
+ ),+ |
+
| 262 | +! | +
+ shinyjs::hidden(+ |
+
| 263 | +! | +
+ div(+ |
+
| 264 | +! | +
+ id = ns("filter_count_ui"),
+ |
+
| 265 | +! | +
+ tagList(+ |
+
| 266 | +! | +
+ textOutput(ns("filter_count")),
+ |
+
| 267 | +! | +
+ br()+ |
+
| 268 | ++ |
+ )+ |
+
| 269 | ++ |
+ )+ |
+
| 270 | ++ |
+ ),+ |
+
| 271 | +! | +
+ div(+ |
+
| 272 | ++ |
+ # id needed to insert and remove UI to filter single variable as needed+ |
+
| 273 | ++ |
+ # it is currently also used by the above module to entirely hide this panel+ |
+
| 274 | +! | +
+ id = ns("filters"),
+ |
+
| 275 | +! | +
+ class = "parent-hideable-list-group",+ |
+
| 276 | +! | +
+ tagList(+ |
+
| 277 | +! | +
+ lapply(+ |
+
| 278 | +! | +
+ names(private$get_filter_states()),+ |
+
| 279 | +! | +
+ function(x) {
+ |
+
| 280 | +! | +
+ tagList(private$get_filter_states()[[x]]$ui_active(id = ns(x)))+ |
+
| 281 | ++ |
+ }+ |
+
| 282 | ++ |
+ )+ |
+
| 283 | ++ |
+ )+ |
+
| 284 | ++ |
+ )+ |
+
| 285 | ++ |
+ )+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | ++ |
+ },+ |
+
| 288 | ++ | + + | +
| 289 | ++ |
+ #' @description+ |
+
| 290 | ++ |
+ #' Server module for a dataset active filters+ |
+
| 291 | ++ |
+ #'+ |
+
| 292 | ++ |
+ #' Server module managing a active filters.+ |
+
| 293 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 294 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 295 | ++ |
+ #' @return `moduleServer` function which returns `NULL`+ |
+
| 296 | ++ |
+ srv_active = function(id) {
+ |
+
| 297 | +7x | +
+ moduleServer(+ |
+
| 298 | +7x | +
+ id = id,+ |
+
| 299 | +7x | +
+ function(input, output, session) {
+ |
+
| 300 | +7x | +
+ dataname <- self$get_dataname()+ |
+
| 301 | +7x | +
+ logger::log_trace("FilteredDataset$srv_active initializing, dataname: { dataname }")
+ |
+
| 302 | +7x | +
+ checkmate::assert_string(dataname)+ |
+
| 303 | +7x | +
+ output$filter_count <- renderText(+ |
+
| 304 | +7x | +
+ sprintf(+ |
+
| 305 | +7x | +
+ "%d filter%s applied",+ |
+
| 306 | +7x | +
+ self$get_filter_count(),+ |
+
| 307 | +7x | +
+ if (self$get_filter_count() != 1) "s" else ""+ |
+
| 308 | ++ |
+ )+ |
+
| 309 | ++ |
+ )+ |
+
| 310 | ++ | + + | +
| 311 | +7x | +
+ lapply(+ |
+
| 312 | +7x | +
+ names(private$get_filter_states()),+ |
+
| 313 | +7x | +
+ function(x) {
+ |
+
| 314 | +12x | +
+ private$get_filter_states()[[x]]$srv_active(id = x)+ |
+
| 315 | ++ |
+ }+ |
+
| 316 | ++ |
+ )+ |
+
| 317 | ++ | + + | +
| 318 | +7x | +
+ shiny::observeEvent(self$get_filter_state(), {
+ |
+
| 319 | +8x | +
+ shinyjs::hide("filter_count_ui")
+ |
+
| 320 | +8x | +
+ shinyjs::show("filters")
+ |
+
| 321 | +8x | +
+ shinyjs::toggle("remove_filters", condition = length(self$get_filter_state()) != 0)
+ |
+
| 322 | +8x | +
+ shinyjs::toggle("collapse", condition = length(self$get_filter_state()) != 0)
+ |
+
| 323 | ++ |
+ })+ |
+
| 324 | ++ | + + | +
| 325 | +7x | +
+ shiny::observeEvent(input$collapse, {
+ |
+
| 326 | +! | +
+ shinyjs::toggle("filter_count_ui")
+ |
+
| 327 | +! | +
+ shinyjs::toggle("filters")
+ |
+
| 328 | +! | +
+ toggle_icon(session$ns("collapse"), c("fa-angle-right", "fa-angle-down"))
+ |
+
| 329 | ++ |
+ })+ |
+
| 330 | ++ | + + | +
| 331 | +7x | +
+ observeEvent(input$remove_filters, {
+ |
+
| 332 | +1x | +
+ logger::log_trace("FilteredDataset$srv_active@1 removing all non-locked filters, dataname: { dataname }")
+ |
+
| 333 | +1x | +
+ self$clear_filter_states()+ |
+
| 334 | +1x | +
+ logger::log_trace("FilteredDataset$srv_active@1 removed all non-locked filters, dataname: { dataname }")
+ |
+
| 335 | ++ |
+ })+ |
+
| 336 | ++ | + + | +
| 337 | +7x | +
+ logger::log_trace("FilteredDataset$initialized, dataname: { dataname }")
+ |
+
| 338 | ++ | + + | +
| 339 | +7x | +
+ NULL+ |
+
| 340 | ++ |
+ }+ |
+
| 341 | ++ |
+ )+ |
+
| 342 | ++ |
+ },+ |
+
| 343 | ++ | + + | +
| 344 | ++ |
+ #' @description+ |
+
| 345 | ++ |
+ #' UI module to add filter variable for this dataset+ |
+
| 346 | ++ |
+ #'+ |
+
| 347 | ++ |
+ #' UI module to add filter variable for this dataset+ |
+
| 348 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 349 | ++ |
+ #' identifier of the element - preferably containing dataset name+ |
+
| 350 | ++ |
+ #'+ |
+
| 351 | ++ |
+ #' @return function - shiny UI module+ |
+
| 352 | ++ |
+ ui_add = function(id) {
+ |
+
| 353 | +1x | +
+ stop("Pure virtual method")
+ |
+
| 354 | ++ |
+ },+ |
+
| 355 | ++ | + + | +
| 356 | ++ |
+ #' @description+ |
+
| 357 | ++ |
+ #' Server module to add filter variable for this dataset+ |
+
| 358 | ++ |
+ #'+ |
+
| 359 | ++ |
+ #' Server module to add filter variable for this dataset.+ |
+
| 360 | ++ |
+ #' For this class `srv_add` calls multiple modules+ |
+
| 361 | ++ |
+ #' of the same name from `FilterStates` as `MAEFilteredDataset`+ |
+
| 362 | ++ |
+ #' contains one `FilterStates` object for `colData` and one for each+ |
+
| 363 | ++ |
+ #' experiment.+ |
+
| 364 | ++ |
+ #'+ |
+
| 365 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 366 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 367 | ++ |
+ #'+ |
+
| 368 | ++ |
+ #' @return `moduleServer` function which returns `NULL`+ |
+
| 369 | ++ |
+ #'+ |
+
| 370 | ++ |
+ srv_add = function(id) {
+ |
+
| 371 | +2x | +
+ moduleServer(+ |
+
| 372 | +2x | +
+ id = id,+ |
+
| 373 | +2x | +
+ function(input, output, session) {
+ |
+
| 374 | +2x | +
+ logger::log_trace("MAEFilteredDataset$srv_add initializing, dataname: { deparse1(self$get_dataname()) }")
+ |
+
| 375 | +2x | +
+ elems <- private$get_filter_states()+ |
+
| 376 | +2x | +
+ elem_names <- names(private$get_filter_states())+ |
+
| 377 | +2x | +
+ lapply(+ |
+
| 378 | +2x | +
+ elem_names,+ |
+
| 379 | +2x | +
+ function(elem_name) elems[[elem_name]]$srv_add(elem_name)+ |
+
| 380 | ++ |
+ )+ |
+
| 381 | +2x | +
+ logger::log_trace("MAEFilteredDataset$srv_add initialized, dataname: { deparse1(self$get_dataname()) }")
+ |
+
| 382 | +2x | +
+ NULL+ |
+
| 383 | ++ |
+ }+ |
+
| 384 | ++ |
+ )+ |
+
| 385 | ++ |
+ }+ |
+
| 386 | ++ |
+ ),+ |
+
| 387 | ++ |
+ ## __Private Fields ====+ |
+
| 388 | ++ |
+ private = list(+ |
+
| 389 | ++ |
+ dataset = NULL, # data.frame or MultiAssayExperiment+ |
+
| 390 | ++ |
+ data_filtered = NULL,+ |
+
| 391 | ++ |
+ data_filtered_fun = NULL, # function+ |
+
| 392 | ++ |
+ filter_states = list(),+ |
+
| 393 | ++ |
+ dataname = character(0),+ |
+
| 394 | ++ |
+ keys = character(0),+ |
+
| 395 | ++ |
+ label = character(0),+ |
+
| 396 | ++ |
+ metadata = NULL,+ |
+
| 397 | ++ | + + | +
| 398 | ++ |
+ # Adds `FilterStates` to the `private$filter_states`.+ |
+
| 399 | ++ |
+ # `FilterStates` is added once for each element of the dataset.+ |
+
| 400 | ++ |
+ # @param filter_states (`FilterStates`)+ |
+
| 401 | ++ |
+ # @param id (`character(1)`)+ |
+
| 402 | ++ |
+ add_filter_states = function(filter_states, id) {
+ |
+
| 403 | +249x | +
+ checkmate::assert_class(filter_states, "FilterStates")+ |
+
| 404 | +249x | +
+ checkmate::assert_string(id)+ |
+
| 405 | +249x | +
+ x <- stats::setNames(list(filter_states), id)+ |
+
| 406 | +249x | +
+ private$filter_states <- c(private$get_filter_states(), x)+ |
+
| 407 | ++ |
+ },+ |
+
| 408 | ++ | + + | +
| 409 | ++ |
+ # @description+ |
+
| 410 | ++ |
+ # Gets the active `FilterStates` objects.+ |
+
| 411 | ++ |
+ # @param id (`character(1)`, `character(0)`)\cr+ |
+
| 412 | ++ |
+ # the id of the `private$filter_states` list element where `FilterStates` is kept.+ |
+
| 413 | ++ |
+ # @return `FilterStates` or `list` of `FilterStates` objects.+ |
+
| 414 | ++ |
+ get_filter_states = function() {
+ |
+
| 415 | +710x | +
+ private$filter_states+ |
+
| 416 | ++ |
+ }+ |
+
| 417 | ++ |
+ )+ |
+
| 418 | ++ |
+ )+ |
+
| 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 | +! | +
+ css_files <- list.files(+ |
+
| 13 | +! | +
+ system.file("css", package = "teal.slice", mustWork = TRUE),
+ |
+
| 14 | +! | +
+ pattern = pattern, full.names = TRUE+ |
+
| 15 | ++ |
+ )+ |
+
| 16 | +! | +
+ return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))+ |
+
| 17 | ++ |
+ }+ |
+
| 1 | ++ |
+ # MAEFilteredDataset ------+ |
+
| 2 | ++ |
+ #' @keywords internal+ |
+
| 3 | ++ |
+ #' @title `MAEFilteredDataset` R6 class+ |
+
| 4 | ++ |
+ MAEFilteredDataset <- R6::R6Class( # nolint+ |
+
| 5 | ++ |
+ classname = "MAEFilteredDataset",+ |
+
| 6 | ++ |
+ inherit = FilteredDataset,+ |
+
| 7 | ++ | + + | +
| 8 | ++ |
+ # public methods ----+ |
+
| 9 | ++ |
+ public = list(+ |
+
| 10 | ++ |
+ #' @description+ |
+
| 11 | ++ |
+ #' Initialize `MAEFilteredDataset` object+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @param dataset (`MulitiAssayExperiment`)\cr+ |
+
| 14 | ++ |
+ #' a single `MultiAssayExperiment` for which to define a subset+ |
+
| 15 | ++ |
+ #' @param dataname (`character`)\cr+ |
+
| 16 | ++ |
+ #' a given name for the dataset it may not contain spaces+ |
+
| 17 | ++ |
+ #' @param keys optional, (`character`)\cr+ |
+
| 18 | ++ |
+ #' vector with primary keys+ |
+
| 19 | ++ |
+ #' @param label (`character`)\cr+ |
+
| 20 | ++ |
+ #' label to describe the dataset+ |
+
| 21 | ++ |
+ #' @param metadata (named `list` or `NULL`) \cr+ |
+
| 22 | ++ |
+ #' field containing metadata about the dataset;+ |
+
| 23 | ++ |
+ #' each element of the list must be atomic and length one+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ initialize = function(dataset, dataname, keys = character(0), label = character(0), metadata = NULL) {
+ |
+
| 26 | +25x | +
+ if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ |
+
| 27 | +! | +
+ stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ |
+
| 28 | ++ |
+ }+ |
+
| 29 | +25x | +
+ checkmate::assert_class(dataset, "MultiAssayExperiment")+ |
+
| 30 | +23x | +
+ super$initialize(dataset, dataname, keys, label, metadata)+ |
+
| 31 | +23x | +
+ experiment_names <- names(dataset)+ |
+
| 32 | ++ | + + | +
| 33 | ++ |
+ # subsetting by subjects means subsetting by colData(MAE)+ |
+
| 34 | +23x | +
+ private$add_filter_states(+ |
+
| 35 | +23x | +
+ filter_states = init_filter_states(+ |
+
| 36 | +23x | +
+ data = dataset,+ |
+
| 37 | +23x | +
+ data_reactive = private$data_filtered_fun,+ |
+
| 38 | +23x | +
+ dataname = dataname,+ |
+
| 39 | +23x | +
+ datalabel = "subjects",+ |
+
| 40 | +23x | +
+ keys = self$get_keys()+ |
+
| 41 | ++ |
+ ),+ |
+
| 42 | +23x | +
+ id = "subjects"+ |
+
| 43 | ++ |
+ )+ |
+
| 44 | ++ |
+ # elements of the list (experiments) are unknown+ |
+
| 45 | ++ |
+ # dispatch needed because we can't hardcode methods otherwise:+ |
+
| 46 | ++ |
+ # if (matrix) else if (SummarizedExperiment) else if ...+ |
+
| 47 | +23x | +
+ lapply(+ |
+
| 48 | +23x | +
+ experiment_names,+ |
+
| 49 | +23x | +
+ function(experiment_name) {
+ |
+
| 50 | +115x | +
+ data_reactive <- function(sid = "") private$data_filtered_fun(sid)[[experiment_name]]+ |
+
| 51 | +115x | +
+ private$add_filter_states(+ |
+
| 52 | +115x | +
+ filter_states = init_filter_states(+ |
+
| 53 | +115x | +
+ data = dataset[[experiment_name]],+ |
+
| 54 | +115x | +
+ data_reactive = data_reactive,+ |
+
| 55 | +115x | +
+ dataname = dataname,+ |
+
| 56 | +115x | +
+ datalabel = experiment_name+ |
+
| 57 | ++ |
+ ),+ |
+
| 58 | +115x | +
+ id = experiment_name+ |
+
| 59 | ++ |
+ )+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | ++ |
+ },+ |
+
| 63 | ++ | + + | +
| 64 | ++ |
+ #' @description+ |
+
| 65 | ++ |
+ #' Set filter state+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @param state (`named list`)\cr+ |
+
| 68 | ++ |
+ #' names of the list should correspond to the names of the initialized `FilterStates`+ |
+
| 69 | ++ |
+ #' kept in `private$filter_states`. For this object they are `"subjects"` and+ |
+
| 70 | ++ |
+ #' names of the experiments. Values of initial state should be relevant+ |
+
| 71 | ++ |
+ #' to the referred column.+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @examples+ |
+
| 74 | ++ |
+ #' utils::data(miniACC, package = "MultiAssayExperiment")+ |
+
| 75 | ++ |
+ #' dataset <- teal.slice:::MAEFilteredDataset$new(miniACC, "MAE")+ |
+
| 76 | ++ |
+ #' fs <- teal_slices(+ |
+
| 77 | ++ |
+ #' teal_slice(+ |
+
| 78 | ++ |
+ #' dataname = "MAE", varname = "years_to_birth", selected = c(30, 50), keep_na = TRUE+ |
+
| 79 | ++ |
+ #' ),+ |
+
| 80 | ++ |
+ #' teal_slice(+ |
+
| 81 | ++ |
+ #' dataname = "MAE", varname = "vital_status", selected = "1", keep_na = FALSE+ |
+
| 82 | ++ |
+ #' ),+ |
+
| 83 | ++ |
+ #' teal_slice(+ |
+
| 84 | ++ |
+ #' dataname = "MAE", varname = "gender", selected = "female", keep_na = TRUE+ |
+
| 85 | ++ |
+ #' ),+ |
+
| 86 | ++ |
+ #' teal_slice(+ |
+
| 87 | ++ |
+ #' dataname = "MAE", varname = "ARRAY_TYPE", selected = "", keep_na = TRUE+ |
+
| 88 | ++ |
+ #' )+ |
+
| 89 | ++ |
+ #' )+ |
+
| 90 | ++ |
+ #' dataset$set_filter_state(state = fs)+ |
+
| 91 | ++ |
+ #' shiny::isolate(dataset$get_filter_state())+ |
+
| 92 | ++ |
+ #'+ |
+
| 93 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ set_filter_state = function(state) {
+ |
+
| 96 | +17x | +
+ shiny::isolate({
+ |
+
| 97 | +17x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
+ |
+
| 98 | +17x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 99 | +16x | +
+ lapply(state, function(x) {
+ |
+
| 100 | +60x | +
+ checkmate::assert_true(x$dataname == private$dataname, .var.name = "dataname matches private$dataname")+ |
+
| 101 | ++ |
+ })+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ # set state on subjects+ |
+
| 104 | +16x | +
+ subject_state <- Filter(function(x) is.null(x$experiment), state)+ |
+
| 105 | +16x | +
+ private$get_filter_states()[["subjects"]]$set_filter_state(subject_state)+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ # set state on experiments+ |
+
| 108 | ++ |
+ # determine target experiments (defined in teal_slices)+ |
+
| 109 | +16x | +
+ experiments <- slices_field(state, "experiment")+ |
+
| 110 | +16x | +
+ available_experiments <- setdiff(names(private$get_filter_states()), "subjects")+ |
+
| 111 | +16x | +
+ excluded_filters <- setdiff(experiments, available_experiments)+ |
+
| 112 | +16x | +
+ if (length(excluded_filters)) {
+ |
+
| 113 | +! | +
+ stop(sprintf(+ |
+
| 114 | +! | +
+ "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",+ |
+
| 115 | +! | +
+ private$dataname,+ |
+
| 116 | +! | +
+ toString(excluded_filters),+ |
+
| 117 | +! | +
+ toString(available_experiments)+ |
+
| 118 | ++ |
+ ))+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | ++ | + + | +
| 121 | ++ |
+ # set states on state_lists with corresponding experiments+ |
+
| 122 | +16x | +
+ lapply(available_experiments, function(experiment) {
+ |
+
| 123 | +80x | +
+ slices <- Filter(function(x) identical(x$experiment, experiment), state)+ |
+
| 124 | +80x | +
+ private$get_filter_states()[[experiment]]$set_filter_state(slices)+ |
+
| 125 | ++ |
+ })+ |
+
| 126 | ++ | + + | +
| 127 | +16x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
+ |
+
| 128 | ++ | + + | +
| 129 | +16x | +
+ invisible(NULL)+ |
+
| 130 | ++ |
+ })+ |
+
| 131 | ++ |
+ },+ |
+
| 132 | ++ | + + | +
| 133 | ++ |
+ #' @description+ |
+
| 134 | ++ |
+ #' Remove one or more `FilterState` of a `MAEFilteredDataset`+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' @param state (`teal_slices`)\cr+ |
+
| 137 | ++ |
+ #' specifying `FilterState` objects to remove;+ |
+
| 138 | ++ |
+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ remove_filter_state = function(state) {
+ |
+
| 143 | +1x | +
+ shiny::isolate({
+ |
+
| 144 | +1x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 145 | ++ | + + | +
| 146 | +1x | +
+ logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")
+ |
+
| 147 | ++ |
+ # remove state on subjects+ |
+
| 148 | +1x | +
+ subject_state <- Filter(function(x) is.null(x$experiment), state)+ |
+
| 149 | +1x | +
+ private$get_filter_states()[["subjects"]]$remove_filter_state(subject_state)+ |
+
| 150 | ++ | + + | +
| 151 | ++ |
+ # remove state on experiments+ |
+
| 152 | ++ |
+ # determine target experiments (defined in teal_slices)+ |
+
| 153 | +1x | +
+ experiments <- slices_field(state, "experiment")+ |
+
| 154 | +1x | +
+ available_experiments <- setdiff(names(private$get_filter_states()), "subjects")+ |
+
| 155 | +1x | +
+ excluded_filters <- setdiff(experiments, available_experiments)+ |
+
| 156 | +1x | +
+ if (length(excluded_filters)) {
+ |
+
| 157 | +! | +
+ stop(sprintf(+ |
+
| 158 | +! | +
+ "%s doesn't contain elements specified in 'experiment': %s\n'experiment' should be a subset of: %s",+ |
+
| 159 | +! | +
+ private$dataname,+ |
+
| 160 | +! | +
+ toString(excluded_filters),+ |
+
| 161 | +! | +
+ toString(available_experiments)+ |
+
| 162 | ++ |
+ ))+ |
+
| 163 | ++ |
+ }+ |
+
| 164 | ++ |
+ # remove states on state_lists with corresponding experiments+ |
+
| 165 | +1x | +
+ lapply(experiments, function(experiment) {
+ |
+
| 166 | +! | +
+ slices <- Filter(function(x) identical(x$experiment, experiment), state)+ |
+
| 167 | +! | +
+ private$get_filter_states()[[experiment]]$remove_filter_state(slices)+ |
+
| 168 | ++ |
+ })+ |
+
| 169 | ++ | + + | +
| 170 | ++ | + + | +
| 171 | +1x | +
+ logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
+ |
+
| 172 | ++ | + + | +
| 173 | +1x | +
+ invisible(NULL)+ |
+
| 174 | ++ |
+ })+ |
+
| 175 | ++ |
+ },+ |
+
| 176 | ++ | + + | +
| 177 | ++ |
+ #' @description+ |
+
| 178 | ++ |
+ #' UI module to add filter variable for this dataset+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ #' UI module to add filter variable for this dataset+ |
+
| 181 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 182 | ++ |
+ #' identifier of the element - preferably containing dataset name+ |
+
| 183 | ++ |
+ #'+ |
+
| 184 | ++ |
+ #' @return function - shiny UI module+ |
+
| 185 | ++ |
+ #'+ |
+
| 186 | ++ |
+ ui_add = function(id) {
+ |
+
| 187 | +! | +
+ ns <- NS(id)+ |
+
| 188 | +! | +
+ data <- self$get_dataset()+ |
+
| 189 | +! | +
+ experiment_names <- names(data)+ |
+
| 190 | ++ | + + | +
| 191 | +! | +
+ div(+ |
+
| 192 | +! | +
+ tags$label("Add", tags$code(self$get_dataname()), "filter"),
+ |
+
| 193 | +! | +
+ br(),+ |
+
| 194 | +! | +
+ HTML("►"),
+ |
+
| 195 | +! | +
+ tags$label("Add subjects filter"),
+ |
+
| 196 | +! | +
+ private$get_filter_states()[["subjects"]]$ui_add(id = ns("subjects")),
+ |
+
| 197 | +! | +
+ tagList(+ |
+
| 198 | +! | +
+ lapply(+ |
+
| 199 | +! | +
+ experiment_names,+ |
+
| 200 | +! | +
+ function(experiment_name) {
+ |
+
| 201 | +! | +
+ tagList(+ |
+
| 202 | +! | +
+ HTML("►"),
+ |
+
| 203 | +! | +
+ tags$label("Add", tags$code(experiment_name), "filter"),
+ |
+
| 204 | +! | +
+ private$get_filter_states()[[experiment_name]]$ui_add(id = ns(experiment_name))+ |
+
| 205 | ++ |
+ )+ |
+
| 206 | ++ |
+ }+ |
+
| 207 | ++ |
+ )+ |
+
| 208 | ++ |
+ )+ |
+
| 209 | ++ |
+ )+ |
+
| 210 | ++ |
+ },+ |
+
| 211 | ++ | + + | +
| 212 | ++ |
+ #' @description+ |
+
| 213 | ++ |
+ #' Get filter overview rows of a dataset+ |
+
| 214 | ++ |
+ #' @return (`matrix`) matrix of observations and subjects+ |
+
| 215 | ++ |
+ get_filter_overview = function() {
+ |
+
| 216 | +2x | +
+ data <- self$get_dataset()+ |
+
| 217 | +2x | +
+ data_filtered <- self$get_dataset(TRUE)+ |
+
| 218 | +2x | +
+ experiment_names <- names(data)+ |
+
| 219 | ++ | + + | +
| 220 | +2x | +
+ mae_info <- data.frame(+ |
+
| 221 | +2x | +
+ dataname = private$dataname,+ |
+
| 222 | +2x | +
+ subjects = nrow(SummarizedExperiment::colData(data)),+ |
+
| 223 | +2x | +
+ subjects_filtered = nrow(SummarizedExperiment::colData(data_filtered()))+ |
+
| 224 | ++ |
+ )+ |
+
| 225 | ++ | + + | +
| 226 | +2x | +
+ experiment_obs_info <- do.call("rbind", lapply(
+ |
+
| 227 | +2x | +
+ experiment_names,+ |
+
| 228 | +2x | +
+ function(experiment_name) {
+ |
+
| 229 | +10x | +
+ data.frame(+ |
+
| 230 | +10x | +
+ dataname = sprintf("- %s", experiment_name),
+ |
+
| 231 | +10x | +
+ obs = nrow(data[[experiment_name]]),+ |
+
| 232 | +10x | +
+ obs_filtered = nrow(data_filtered()[[experiment_name]])+ |
+
| 233 | ++ |
+ )+ |
+
| 234 | ++ |
+ }+ |
+
| 235 | ++ |
+ ))+ |
+
| 236 | ++ | + + | +
| 237 | +2x | +
+ get_experiment_keys <- function(mae, experiment) {
+ |
+
| 238 | +20x | +
+ sample_subset <- subset(MultiAssayExperiment::sampleMap(mae), colname %in% colnames(experiment))+ |
+
| 239 | +20x | +
+ length(unique(sample_subset$primary))+ |
+
| 240 | ++ |
+ }+ |
+
| 241 | ++ | + + | +
| 242 | +2x | +
+ experiment_subjects_info <- do.call("rbind", lapply(
+ |
+
| 243 | +2x | +
+ experiment_names,+ |
+
| 244 | +2x | +
+ function(experiment_name) {
+ |
+
| 245 | +10x | +
+ data.frame(+ |
+
| 246 | +10x | +
+ subjects = get_experiment_keys(data, data[[experiment_name]]),+ |
+
| 247 | +10x | +
+ subjects_filtered = get_experiment_keys(data_filtered(), data_filtered()[[experiment_name]])+ |
+
| 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 | ++ |
+ #' @name LogicalFilterState+ |
+
| 2 | ++ |
+ #' @title `FilterState` object for logical variable+ |
+
| 3 | ++ |
+ #' @description Manages choosing a logical state+ |
+
| 4 | ++ |
+ #' @docType class+ |
+
| 5 | ++ |
+ #' @keywords internal+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @examples+ |
+
| 9 | ++ |
+ #' filter_state <- teal.slice:::LogicalFilterState$new(+ |
+
| 10 | ++ |
+ #' x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE),+ |
+
| 11 | ++ |
+ #' slice = teal_slice(varname = "x", dataname = "data")+ |
+
| 12 | ++ |
+ #' )+ |
+
| 13 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 14 | ++ |
+ #' filter_state$set_state(+ |
+
| 15 | ++ |
+ #' teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE)+ |
+
| 16 | ++ |
+ #' )+ |
+
| 17 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' # working filter in an app+ |
+
| 20 | ++ |
+ #' library(shiny)+ |
+
| 21 | ++ |
+ #' library(shinyjs)+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA)+ |
+
| 24 | ++ |
+ #' fs <- teal.slice:::LogicalFilterState$new(+ |
+
| 25 | ++ |
+ #' x = data_logical,+ |
+
| 26 | ++ |
+ #' slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)+ |
+
| 27 | ++ |
+ #' )+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' ui <- fluidPage(+ |
+
| 30 | ++ |
+ #' useShinyjs(),+ |
+
| 31 | ++ |
+ #' teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 32 | ++ |
+ #' teal.slice:::include_js_files(pattern = "count-bar-labels"),+ |
+
| 33 | ++ |
+ #' column(4, div(+ |
+
| 34 | ++ |
+ #' h4("LogicalFilterState"),
+ |
+
| 35 | ++ |
+ #' fs$ui("fs")
+ |
+
| 36 | ++ |
+ #' )),+ |
+
| 37 | ++ |
+ #' column(4, div(+ |
+
| 38 | ++ |
+ #' id = "outputs", # div id is needed for toggling the element+ |
+
| 39 | ++ |
+ #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
+ |
+
| 40 | ++ |
+ #' textOutput("condition_logical"), br(),
+ |
+
| 41 | ++ |
+ #' h4("Unformatted state"), # display raw filter state
+ |
+
| 42 | ++ |
+ #' textOutput("unformatted_logical"), br(),
+ |
+
| 43 | ++ |
+ #' h4("Formatted state"), # display human readable filter state
+ |
+
| 44 | ++ |
+ #' textOutput("formatted_logical"), br()
+ |
+
| 45 | ++ |
+ #' )),+ |
+
| 46 | ++ |
+ #' column(4, div(+ |
+
| 47 | ++ |
+ #' h4("Programmatic filter control"),
+ |
+
| 48 | ++ |
+ #' actionButton("button1_logical", "set drop NA", width = "100%"), br(),
+ |
+
| 49 | ++ |
+ #' actionButton("button2_logical", "set keep NA", width = "100%"), br(),
+ |
+
| 50 | ++ |
+ #' actionButton("button3_logical", "set a selection", width = "100%"), br(),
+ |
+
| 51 | ++ |
+ #' actionButton("button0_logical", "set initial state", width = "100%"), br()
+ |
+
| 52 | ++ |
+ #' ))+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 56 | ++ |
+ #' fs$server("fs")
+ |
+
| 57 | ++ |
+ #' output$condition_logical <- renderPrint(fs$get_call())+ |
+
| 58 | ++ |
+ #' output$formatted_logical <- renderText(fs$format())+ |
+
| 59 | ++ |
+ #' output$unformatted_logical <- renderPrint(fs$get_state())+ |
+
| 60 | ++ |
+ #' # modify filter state programmatically+ |
+
| 61 | ++ |
+ #' observeEvent(+ |
+
| 62 | ++ |
+ #' input$button1_logical,+ |
+
| 63 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))+ |
+
| 64 | ++ |
+ #' )+ |
+
| 65 | ++ |
+ #' observeEvent(+ |
+
| 66 | ++ |
+ #' input$button2_logical,+ |
+
| 67 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ |
+
| 68 | ++ |
+ #' )+ |
+
| 69 | ++ |
+ #' observeEvent(+ |
+
| 70 | ++ |
+ #' input$button3_logical,+ |
+
| 71 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE))+ |
+
| 72 | ++ |
+ #' )+ |
+
| 73 | ++ |
+ #' observeEvent(+ |
+
| 74 | ++ |
+ #' input$button0_logical,+ |
+
| 75 | ++ |
+ #' fs$set_state(+ |
+
| 76 | ++ |
+ #' teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)+ |
+
| 77 | ++ |
+ #' )+ |
+
| 78 | ++ |
+ #' )+ |
+
| 79 | ++ |
+ #' }+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' if (interactive()) {
+ |
+
| 82 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 83 | ++ |
+ #' }+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ LogicalFilterState <- R6::R6Class( # nolint+ |
+
| 86 | ++ |
+ "LogicalFilterState",+ |
+
| 87 | ++ |
+ inherit = FilterState,+ |
+
| 88 | ++ | + + | +
| 89 | ++ |
+ # public methods ----+ |
+
| 90 | ++ |
+ public = list(+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ #' @description+ |
+
| 93 | ++ |
+ #' Initialize a `FilterState` object+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ #' @param x (`logical`)\cr+ |
+
| 96 | ++ |
+ #' values of the variable used in filter+ |
+
| 97 | ++ |
+ #' @param x_reactive (`reactive`)\cr+ |
+
| 98 | ++ |
+ #' returning vector of the same type as `x`. Is used to update+ |
+
| 99 | ++ |
+ #' counts following the change in values of the filtered dataset.+ |
+
| 100 | ++ |
+ #' If it is set to `reactive(NULL)` then counts based on filtered+ |
+
| 101 | ++ |
+ #' dataset are not shown.+ |
+
| 102 | ++ |
+ #' @param slice (`teal_slice`)\cr+ |
+
| 103 | ++ |
+ #' object created using [teal_slice()]. `teal_slice` is stored+ |
+
| 104 | ++ |
+ #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`+ |
+
| 105 | ++ |
+ #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`+ |
+
| 106 | ++ |
+ #' is a `reactiveValues` which means that changes in particular object are automatically+ |
+
| 107 | ++ |
+ #' reflected in all places which refer to the same `teal_slice`.+ |
+
| 108 | ++ |
+ #' @param extract_type (`character(0)`, `character(1)`)\cr+ |
+
| 109 | ++ |
+ #' whether condition calls should be prefixed by `dataname`. Possible values:+ |
+
| 110 | ++ |
+ #' \itemize{
+ |
+
| 111 | ++ |
+ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
+ |
+
| 112 | ++ |
+ #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
+ |
+
| 113 | ++ |
+ #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
+ |
+
| 114 | ++ |
+ #' }+ |
+
| 115 | ++ |
+ #' @param ... additional arguments to be saved as a list in `private$extras` field+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ initialize = function(x,+ |
+
| 118 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 119 | ++ |
+ extract_type = character(0),+ |
+
| 120 | ++ |
+ slice) {
+ |
+
| 121 | +16x | +
+ shiny::isolate({
+ |
+
| 122 | +16x | +
+ checkmate::assert_logical(x)+ |
+
| 123 | +15x | +
+ checkmate::assert_logical(slice$selected, null.ok = TRUE)+ |
+
| 124 | +14x | +
+ super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type)+ |
+
| 125 | ++ | + + | +
| 126 | +14x | +
+ private$set_choices(slice$choices)+ |
+
| 127 | +! | +
+ if (is.null(slice$multiple)) slice$multiple <- FALSE+ |
+
| 128 | +14x | +
+ if (is.null(slice$selected) && slice$multiple) {
+ |
+
| 129 | +7x | +
+ slice$selected <- private$get_choices()+ |
+
| 130 | +7x | +
+ } else if (length(slice$selected) != 1 && !slice$multiple) {
+ |
+
| 131 | +3x | +
+ slice$selected <- TRUE+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | +14x | +
+ private$set_selected(slice$selected)+ |
+
| 134 | +14x | +
+ df <- factor(x, levels = c(TRUE, FALSE))+ |
+
| 135 | +14x | +
+ tbl <- table(df)+ |
+
| 136 | +14x | +
+ private$set_choices_counts(tbl)+ |
+
| 137 | ++ |
+ })+ |
+
| 138 | +14x | +
+ invisible(self)+ |
+
| 139 | ++ |
+ },+ |
+
| 140 | ++ | + + | +
| 141 | ++ |
+ #' @description+ |
+
| 142 | ++ |
+ #' Returns reproducible condition call for current selection.+ |
+
| 143 | ++ |
+ #' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally+ |
+
| 144 | ++ |
+ #' `is.na(<varname>)`+ |
+
| 145 | ++ |
+ #' @param dataname name of data set; defaults to `private$get_dataname()`+ |
+
| 146 | ++ |
+ #' @return (`call`)+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ get_call = function(dataname) {
+ |
+
| 149 | +6x | +
+ if (isFALSE(private$is_any_filtered())) {
+ |
+
| 150 | +! | +
+ return(NULL)+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | +4x | +
+ if (missing(dataname)) dataname <- private$get_dataname()+ |
+
| 153 | +6x | +
+ varname <- private$get_varname_prefixed(dataname)+ |
+
| 154 | +6x | +
+ choices <- private$get_selected()+ |
+
| 155 | +6x | +
+ n_choices <- length(choices)+ |
+
| 156 | ++ | + + | +
| 157 | +6x | +
+ filter_call <-+ |
+
| 158 | +6x | +
+ if (n_choices == 1 && choices) {
+ |
+
| 159 | +1x | +
+ private$get_varname_prefixed(dataname)+ |
+
| 160 | +6x | +
+ } else if (n_choices == 1 && !choices) {
+ |
+
| 161 | +4x | +
+ call("!", private$get_varname_prefixed(dataname))
+ |
+
| 162 | ++ |
+ } else {
+ |
+
| 163 | +1x | +
+ call("%in%", private$get_varname_prefixed(dataname), make_c_call(choices))
+ |
+
| 164 | ++ |
+ }+ |
+
| 165 | +6x | +
+ private$add_keep_na_call(filter_call, dataname)+ |
+
| 166 | ++ |
+ }+ |
+
| 167 | ++ |
+ ),+ |
+
| 168 | ++ | + + | +
| 169 | ++ |
+ # private members ----+ |
+
| 170 | ++ |
+ private = list(+ |
+
| 171 | ++ |
+ choices_counts = integer(0),+ |
+
| 172 | ++ | + + | +
| 173 | ++ |
+ # private methods ----+ |
+
| 174 | ++ |
+ set_choices = function(choices) {
+ |
+
| 175 | +14x | +
+ private$teal_slice$choices <- c(TRUE, FALSE)+ |
+
| 176 | +14x | +
+ invisible(NULL)+ |
+
| 177 | ++ |
+ },+ |
+
| 178 | ++ |
+ # @description+ |
+
| 179 | ++ |
+ # Sets choices_counts private field+ |
+
| 180 | ++ |
+ set_choices_counts = function(choices_counts) {
+ |
+
| 181 | +14x | +
+ private$choices_counts <- choices_counts+ |
+
| 182 | +14x | +
+ invisible(NULL)+ |
+
| 183 | ++ |
+ },+ |
+
| 184 | ++ |
+ cast_and_validate = function(values) {
+ |
+
| 185 | +21x | +
+ tryCatch(+ |
+
| 186 | +21x | +
+ expr = {
+ |
+
| 187 | +21x | +
+ values_logical <- as.logical(values)+ |
+
| 188 | +1x | +
+ if (any(is.na(values_logical))) stop()+ |
+
| 189 | ++ |
+ },+ |
+
| 190 | +21x | +
+ error = function(cond) stop("The array of set values must contain values coercible to logical.")
+ |
+
| 191 | ++ |
+ )+ |
+
| 192 | +20x | +
+ values_logical+ |
+
| 193 | ++ |
+ },+ |
+
| 194 | ++ |
+ check_multiple = function(value) {
+ |
+
| 195 | +20x | +
+ if (!private$is_multiple() && length(value) > 1) {
+ |
+
| 196 | +1x | +
+ warning(+ |
+
| 197 | +1x | +
+ sprintf("Selection: %s is not a vector of length one. ", toString(value, width = 360)),
+ |
+
| 198 | +1x | +
+ "Maintaining previous selection."+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | +1x | +
+ value <- shiny::isolate(private$get_selected())+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | +20x | +
+ value+ |
+
| 203 | ++ |
+ },+ |
+
| 204 | ++ |
+ validate_selection = function(value) {
+ |
+
| 205 | +20x | +
+ if (!is.logical(value)) {
+ |
+
| 206 | +! | +
+ stop(+ |
+
| 207 | +! | +
+ sprintf(+ |
+
| 208 | +! | +
+ "value of the selection for `%s` in `%s` should be a logical vector of length <= 2",+ |
+
| 209 | +! | +
+ private$get_varname(),+ |
+
| 210 | +! | +
+ private$get_dataname()+ |
+
| 211 | ++ |
+ )+ |
+
| 212 | ++ |
+ )+ |
+
| 213 | ++ |
+ }+ |
+
| 214 | ++ |
+ },+ |
+
| 215 | ++ | + + | +
| 216 | ++ |
+ # Answers the question of whether the current settings and values selected actually filters out any values.+ |
+
| 217 | ++ |
+ # @return logical scalar+ |
+
| 218 | ++ |
+ is_any_filtered = function() {
+ |
+
| 219 | +6x | +
+ if (private$is_choice_limited) {
+ |
+
| 220 | +! | +
+ TRUE+ |
+
| 221 | +6x | +
+ } else if (all(private$choices_counts > 0)) {
+ |
+
| 222 | +6x | +
+ TRUE+ |
+
| 223 | +! | +
+ } else if (setequal(private$get_selected(), private$get_choices()) &&+ |
+
| 224 | +! | +
+ !anyNA(private$get_selected(), private$get_choices())) {
+ |
+
| 225 | +! | +
+ TRUE+ |
+
| 226 | +! | +
+ } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 227 | +! | +
+ TRUE+ |
+
| 228 | ++ |
+ } else {
+ |
+
| 229 | +! | +
+ FALSE+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ |
+ },+ |
+
| 232 | ++ | + + | +
| 233 | ++ |
+ # shiny modules ----+ |
+
| 234 | ++ | + + | +
| 235 | ++ |
+ # @description+ |
+
| 236 | ++ |
+ # UI Module for `EmptyFilterState`.+ |
+
| 237 | ++ |
+ # This UI element contains available choices selection and+ |
+
| 238 | ++ |
+ # checkbox whether to keep or not keep the `NA` values.+ |
+
| 239 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 240 | ++ |
+ # id of shiny element+ |
+
| 241 | ++ |
+ ui_inputs = function(id) {
+ |
+
| 242 | +! | +
+ ns <- NS(id)+ |
+
| 243 | +! | +
+ shiny::isolate({
+ |
+
| 244 | +! | +
+ countsmax <- private$choices_counts+ |
+
| 245 | +! | +
+ countsnow <- if (!is.null(private$x_reactive())) {
+ |
+
| 246 | +! | +
+ unname(table(factor(private$x_reactive(), levels = private$get_choices())))+ |
+
| 247 | ++ |
+ } else {
+ |
+
| 248 | +! | +
+ NULL+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ | + + | +
| 251 | +! | +
+ labels <- countBars(+ |
+
| 252 | +! | +
+ inputId = ns("labels"),
+ |
+
| 253 | +! | +
+ choices = as.character(private$get_choices()),+ |
+
| 254 | +! | +
+ countsnow = countsnow,+ |
+
| 255 | +! | +
+ countsmax = countsmax+ |
+
| 256 | ++ |
+ )+ |
+
| 257 | +! | +
+ ui_input <- if (private$is_multiple()) {
+ |
+
| 258 | +! | +
+ checkboxGroupInput(+ |
+
| 259 | +! | +
+ inputId = ns("selection"),
+ |
+
| 260 | +! | +
+ label = NULL,+ |
+
| 261 | +! | +
+ selected = shiny::isolate(as.character(private$get_selected())),+ |
+
| 262 | +! | +
+ choiceNames = labels,+ |
+
| 263 | +! | +
+ choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
+ |
+
| 264 | +! | +
+ width = "100%"+ |
+
| 265 | ++ |
+ )+ |
+
| 266 | ++ |
+ } else {
+ |
+
| 267 | +! | +
+ radioButtons(+ |
+
| 268 | +! | +
+ inputId = ns("selection"),
+ |
+
| 269 | +! | +
+ label = NULL,+ |
+
| 270 | +! | +
+ selected = shiny::isolate(as.character(private$get_selected())),+ |
+
| 271 | +! | +
+ choiceNames = labels,+ |
+
| 272 | +! | +
+ choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
+ |
+
| 273 | +! | +
+ width = "100%"+ |
+
| 274 | ++ |
+ )+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | +! | +
+ div(+ |
+
| 277 | +! | +
+ div(+ |
+
| 278 | +! | +
+ class = "choices_state",+ |
+
| 279 | +! | +
+ uiOutput(ns("trigger_visible"), inline = TRUE),
+ |
+
| 280 | +! | +
+ ui_input+ |
+
| 281 | ++ |
+ ),+ |
+
| 282 | +! | +
+ private$keep_na_ui(ns("keep_na"))
+ |
+
| 283 | ++ |
+ )+ |
+
| 284 | ++ |
+ })+ |
+
| 285 | ++ |
+ },+ |
+
| 286 | ++ | + + | +
| 287 | ++ |
+ # @description+ |
+
| 288 | ++ |
+ # Server module+ |
+
| 289 | ++ |
+ #+ |
+
| 290 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 291 | ++ |
+ # an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 292 | ++ |
+ # @return `moduleServer` function which returns `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_trace("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$observers$seleted_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_trace("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$observers$selection <- observeEvent(+ |
+
| 342 | +! | +
+ ignoreNULL = FALSE,+ |
+
| 343 | +! | +
+ ignoreInit = TRUE,+ |
+
| 344 | +! | +
+ eventExpr = input$selection,+ |
+
| 345 | +! | +
+ handlerExpr = {
+ |
+
| 346 | +! | +
+ logger::log_trace("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 | +! | +
+ logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
+ |
+
| 364 | +! | +
+ NULL+ |
+
| 365 | ++ |
+ }+ |
+
| 366 | ++ |
+ )+ |
+
| 367 | ++ |
+ },+ |
+
| 368 | ++ |
+ server_inputs_fixed = function(id) {
+ |
+
| 369 | +! | +
+ moduleServer(+ |
+
| 370 | +! | +
+ id = id,+ |
+
| 371 | +! | +
+ function(input, output, session) {
+ |
+
| 372 | +! | +
+ logger::log_trace("LogicalFilterState$server initializing, id: { private$get_id() }")
+ |
+
| 373 | ++ | + + | +
| 374 | +! | +
+ output$selection <- renderUI({
+ |
+
| 375 | +! | +
+ countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices())))+ |
+
| 376 | +! | +
+ countsmax <- private$choices_counts+ |
+
| 377 | ++ | + + | +
| 378 | +! | +
+ ind <- private$get_choices() %in% private$get_selected()+ |
+
| 379 | +! | +
+ countBars(+ |
+
| 380 | +! | +
+ inputId = session$ns("labels"),
+ |
+
| 381 | +! | +
+ choices = private$get_selected(),+ |
+
| 382 | +! | +
+ countsnow = countsnow[ind],+ |
+
| 383 | +! | +
+ countsmax = countsmax[ind]+ |
+
| 384 | ++ |
+ )+ |
+
| 385 | ++ |
+ })+ |
+
| 386 | ++ | + + | +
| 387 | +! | +
+ logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
+ |
+
| 388 | +! | +
+ NULL+ |
+
| 389 | ++ |
+ }+ |
+
| 390 | ++ |
+ )+ |
+
| 391 | ++ |
+ },+ |
+
| 392 | ++ | + + | +
| 393 | ++ |
+ # @description+ |
+
| 394 | ++ |
+ # Server module to display filter summary+ |
+
| 395 | ++ |
+ # renders text describing whether TRUE or FALSE is selected+ |
+
| 396 | ++ |
+ # and if NA are included also+ |
+
| 397 | ++ |
+ content_summary = function(id) {
+ |
+
| 398 | +! | +
+ tagList(+ |
+
| 399 | +! | +
+ tags$span(+ |
+
| 400 | +! | +
+ class = "filter-card-summary-value",+ |
+
| 401 | +! | +
+ toString(private$get_selected())+ |
+
| 402 | ++ |
+ ),+ |
+
| 403 | +! | +
+ tags$span(+ |
+
| 404 | +! | +
+ class = "filter-card-summary-controls",+ |
+
| 405 | +! | +
+ if (isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 406 | +! | +
+ tags$span(+ |
+
| 407 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 408 | +! | +
+ "NA",+ |
+
| 409 | +! | +
+ shiny::icon("check")
+ |
+
| 410 | ++ |
+ )+ |
+
| 411 | +! | +
+ } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 412 | +! | +
+ tags$span(+ |
+
| 413 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 414 | +! | +
+ "NA",+ |
+
| 415 | +! | +
+ shiny::icon("xmark")
+ |
+
| 416 | ++ |
+ )+ |
+
| 417 | ++ |
+ } else {
+ |
+
| 418 | +! | +
+ NULL+ |
+
| 419 | ++ |
+ }+ |
+
| 420 | ++ |
+ )+ |
+
| 421 | ++ |
+ )+ |
+
| 422 | ++ |
+ }+ |
+
| 423 | ++ |
+ )+ |
+
| 424 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' @rdname DatetimeFilterState+ |
+
| 2 | ++ |
+ #' @title `FilterState` object for `POSIXct` variable+ |
+
| 3 | ++ |
+ #' @description Manages choosing a range of date-times+ |
+
| 4 | ++ |
+ #' @docType class+ |
+
| 5 | ++ |
+ #' @keywords internal+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @examples+ |
+
| 9 | ++ |
+ #' filter_state <- teal.slice:::DatetimeFilterState$new(+ |
+
| 10 | ++ |
+ #' x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA),+ |
+
| 11 | ++ |
+ #' slice = teal_slice(varname = "x", dataname = "data"),+ |
+
| 12 | ++ |
+ #' extract_type = character(0)+ |
+
| 13 | ++ |
+ #' )+ |
+
| 14 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 15 | ++ |
+ #' filter_state$set_state(+ |
+
| 16 | ++ |
+ #' teal_slice(+ |
+
| 17 | ++ |
+ #' dataname = "data",+ |
+
| 18 | ++ |
+ #' varname = "x",+ |
+
| 19 | ++ |
+ #' selected = c(Sys.time() + 3L, Sys.time() + 8L),+ |
+
| 20 | ++ |
+ #' keep_na = TRUE+ |
+
| 21 | ++ |
+ #' )+ |
+
| 22 | ++ |
+ #' )+ |
+
| 23 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' # working filter in an app+ |
+
| 26 | ++ |
+ #' library(shiny)+ |
+
| 27 | ++ |
+ #' library(shinyjs)+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00"))
+ |
+
| 30 | ++ |
+ #' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA)+ |
+
| 31 | ++ |
+ #' fs <- teal.slice:::DatetimeFilterState$new(+ |
+
| 32 | ++ |
+ #' x = data_datetime,+ |
+
| 33 | ++ |
+ #' slice = teal_slice(+ |
+
| 34 | ++ |
+ #' varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' ui <- fluidPage(+ |
+
| 39 | ++ |
+ #' useShinyjs(),+ |
+
| 40 | ++ |
+ #' teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 41 | ++ |
+ #' teal.slice:::include_js_files(pattern = "count-bar-labels"),+ |
+
| 42 | ++ |
+ #' column(4, div(+ |
+
| 43 | ++ |
+ #' h4("DatetimeFilterState"),
+ |
+
| 44 | ++ |
+ #' fs$ui("fs")
+ |
+
| 45 | ++ |
+ #' )),+ |
+
| 46 | ++ |
+ #' column(4, div(+ |
+
| 47 | ++ |
+ #' id = "outputs", # div id is needed for toggling the element+ |
+
| 48 | ++ |
+ #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
+ |
+
| 49 | ++ |
+ #' textOutput("condition_datetime"), br(),
+ |
+
| 50 | ++ |
+ #' h4("Unformatted state"), # display raw filter state
+ |
+
| 51 | ++ |
+ #' textOutput("unformatted_datetime"), br(),
+ |
+
| 52 | ++ |
+ #' h4("Formatted state"), # display human readable filter state
+ |
+
| 53 | ++ |
+ #' textOutput("formatted_datetime"), br()
+ |
+
| 54 | ++ |
+ #' )),+ |
+
| 55 | ++ |
+ #' column(4, div(+ |
+
| 56 | ++ |
+ #' h4("Programmatic filter control"),
+ |
+
| 57 | ++ |
+ #' actionButton("button1_datetime", "set drop NA", width = "100%"), br(),
+ |
+
| 58 | ++ |
+ #' actionButton("button2_datetime", "set keep NA", width = "100%"), br(),
+ |
+
| 59 | ++ |
+ #' actionButton("button3_datetime", "set a range", width = "100%"), br(),
+ |
+
| 60 | ++ |
+ #' actionButton("button4_datetime", "set full range", width = "100%"), br(),
+ |
+
| 61 | ++ |
+ #' actionButton("button0_datetime", "set initial state", width = "100%"), br()
+ |
+
| 62 | ++ |
+ #' ))+ |
+
| 63 | ++ |
+ #' )+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 66 | ++ |
+ #' fs$server("fs")
+ |
+
| 67 | ++ |
+ #' output$condition_datetime <- renderPrint(fs$get_call())+ |
+
| 68 | ++ |
+ #' output$formatted_datetime <- renderText(fs$format())+ |
+
| 69 | ++ |
+ #' output$unformatted_datetime <- renderPrint(fs$get_state())+ |
+
| 70 | ++ |
+ #' # modify filter state programmatically+ |
+
| 71 | ++ |
+ #' observeEvent(+ |
+
| 72 | ++ |
+ #' input$button1_datetime,+ |
+
| 73 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))+ |
+
| 74 | ++ |
+ #' )+ |
+
| 75 | ++ |
+ #' observeEvent(+ |
+
| 76 | ++ |
+ #' input$button2_datetime,+ |
+
| 77 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ |
+
| 78 | ++ |
+ #' )+ |
+
| 79 | ++ |
+ #' observeEvent(+ |
+
| 80 | ++ |
+ #' input$button3_datetime,+ |
+
| 81 | ++ |
+ #' fs$set_state(+ |
+
| 82 | ++ |
+ #' teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)])+ |
+
| 83 | ++ |
+ #' )+ |
+
| 84 | ++ |
+ #' )+ |
+
| 85 | ++ |
+ #' observeEvent(+ |
+
| 86 | ++ |
+ #' input$button4_datetime,+ |
+
| 87 | ++ |
+ #' fs$set_state(+ |
+
| 88 | ++ |
+ #' teal_slice(dataname = "data", varname = "x", selected = datetimes)+ |
+
| 89 | ++ |
+ #' )+ |
+
| 90 | ++ |
+ #' )+ |
+
| 91 | ++ |
+ #' observeEvent(+ |
+
| 92 | ++ |
+ #' input$button0_datetime,+ |
+
| 93 | ++ |
+ #' fs$set_state(+ |
+
| 94 | ++ |
+ #' teal_slice(+ |
+
| 95 | ++ |
+ #' dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE+ |
+
| 96 | ++ |
+ #' )+ |
+
| 97 | ++ |
+ #' )+ |
+
| 98 | ++ |
+ #' )+ |
+
| 99 | ++ |
+ #' }+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' if (interactive()) {
+ |
+
| 102 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 103 | ++ |
+ #' }+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ DatetimeFilterState <- R6::R6Class( # nolint+ |
+
| 106 | ++ |
+ "DatetimeFilterState",+ |
+
| 107 | ++ |
+ inherit = FilterState,+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ # public methods ----+ |
+
| 110 | ++ | + + | +
| 111 | ++ |
+ public = list(+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ #' @description+ |
+
| 114 | ++ |
+ #' Initialize a `FilterState` object. This class+ |
+
| 115 | ++ |
+ #' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by+ |
+
| 116 | ++ |
+ #' default. However, in case when using this module in `teal` app, one needs+ |
+
| 117 | ++ |
+ #' timezone of the app user. App user timezone is taken from `session$userData$timezone`+ |
+
| 118 | ++ |
+ #' and is set only if object is initialized in `shiny`.+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #' @param x (`POSIXct` or `POSIXlt`)\cr+ |
+
| 121 | ++ |
+ #' values of the variable used in filter+ |
+
| 122 | ++ |
+ #' @param x_reactive (`reactive`)\cr+ |
+
| 123 | ++ |
+ #' returning vector of the same type as `x`. Is used to update+ |
+
| 124 | ++ |
+ #' counts following the change in values of the filtered dataset.+ |
+
| 125 | ++ |
+ #' If it is set to `reactive(NULL)` then counts based on filtered+ |
+
| 126 | ++ |
+ #' dataset are not shown.+ |
+
| 127 | ++ |
+ #' @param slice (`teal_slice`)\cr+ |
+
| 128 | ++ |
+ #' object created using [teal_slice()]. `teal_slice` is stored+ |
+
| 129 | ++ |
+ #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`+ |
+
| 130 | ++ |
+ #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`+ |
+
| 131 | ++ |
+ #' is a `reactiveValues` which means that changes in particular object are automatically+ |
+
| 132 | ++ |
+ #' reflected in all places which refer to the same `teal_slice`.+ |
+
| 133 | ++ |
+ #' @param extract_type (`character(0)`, `character(1)`)\cr+ |
+
| 134 | ++ |
+ #' whether condition calls should be prefixed by `dataname`. Possible values:+ |
+
| 135 | ++ |
+ #' \itemize{
+ |
+
| 136 | ++ |
+ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
+ |
+
| 137 | ++ |
+ #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
+ |
+
| 138 | ++ |
+ #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
+ |
+
| 139 | ++ |
+ #' }+ |
+
| 140 | ++ |
+ #' @param ... additional arguments to be saved as a list in `private$extras` field+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ initialize = function(x,+ |
+
| 143 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 144 | ++ |
+ extract_type = character(0),+ |
+
| 145 | ++ |
+ slice) {
+ |
+
| 146 | +25x | +
+ shiny::isolate({
+ |
+
| 147 | +25x | +
+ checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
+ |
+
| 148 | +24x | +
+ checkmate::assert_class(x_reactive, "reactive")+ |
+
| 149 | ++ | + + | +
| 150 | +24x | +
+ super$initialize(+ |
+
| 151 | +24x | +
+ x = x,+ |
+
| 152 | +24x | +
+ x_reactive = x_reactive,+ |
+
| 153 | +24x | +
+ slice = slice,+ |
+
| 154 | +24x | +
+ extract_type = extract_type+ |
+
| 155 | ++ |
+ )+ |
+
| 156 | +24x | +
+ checkmate::assert_multi_class(slice$choices, c("POSIXct", "POSIXlt"), null.ok = TRUE)
+ |
+
| 157 | +23x | +
+ private$set_choices(slice$choices)+ |
+
| 158 | +15x | +
+ if (is.null(slice$selected)) slice$selected <- slice$choices+ |
+
| 159 | +23x | +
+ private$set_selected(slice$selected)+ |
+
| 160 | ++ |
+ })+ |
+
| 161 | ++ | + + | +
| 162 | +22x | +
+ invisible(self)+ |
+
| 163 | ++ |
+ },+ |
+
| 164 | ++ | + + | +
| 165 | ++ |
+ #' @description+ |
+
| 166 | ++ |
+ #' Returns reproducible condition call for current selection.+ |
+
| 167 | ++ |
+ #' For this class returned call looks like+ |
+
| 168 | ++ |
+ #' `<varname> >= as.POSIXct(<min>) & <varname> <= <max>)`+ |
+
| 169 | ++ |
+ #' with optional `is.na(<varname>)`.+ |
+
| 170 | ++ |
+ #' @param dataname name of data set; defaults to `private$get_dataname()`+ |
+
| 171 | ++ |
+ #' @return (`call`)+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ get_call = function(dataname) {
+ |
+
| 174 | +7x | +
+ if (isFALSE(private$is_any_filtered())) {
+ |
+
| 175 | +1x | +
+ return(NULL)+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | +4x | +
+ if (missing(dataname)) dataname <- private$get_dataname()+ |
+
| 178 | +6x | +
+ choices <- private$get_selected()+ |
+
| 179 | +6x | +
+ tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone"))+ |
+
| 180 | +6x | +
+ class <- class(choices)[1L]+ |
+
| 181 | +6x | +
+ date_fun <- as.name(+ |
+
| 182 | +6x | +
+ switch(class,+ |
+
| 183 | +6x | +
+ "POSIXct" = "as.POSIXct",+ |
+
| 184 | +6x | +
+ "POSIXlt" = "as.POSIXlt"+ |
+
| 185 | ++ |
+ )+ |
+
| 186 | ++ |
+ )+ |
+
| 187 | +6x | +
+ choices <- as.character(choices + c(0, 1))+ |
+
| 188 | +6x | +
+ filter_call <-+ |
+
| 189 | +6x | +
+ call(+ |
+
| 190 | ++ |
+ "&",+ |
+
| 191 | +6x | +
+ call(+ |
+
| 192 | ++ |
+ ">=",+ |
+
| 193 | +6x | +
+ private$get_varname_prefixed(dataname),+ |
+
| 194 | +6x | +
+ as.call(list(date_fun, choices[1L], tz = tzone))+ |
+
| 195 | ++ |
+ ),+ |
+
| 196 | +6x | +
+ call(+ |
+
| 197 | ++ |
+ "<",+ |
+
| 198 | +6x | +
+ private$get_varname_prefixed(dataname),+ |
+
| 199 | +6x | +
+ as.call(list(date_fun, choices[2L], tz = tzone))+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ |
+ )+ |
+
| 202 | +6x | +
+ private$add_keep_na_call(filter_call, dataname)+ |
+
| 203 | ++ |
+ }+ |
+
| 204 | ++ |
+ ),+ |
+
| 205 | ++ | + + | +
| 206 | ++ |
+ # private members ----+ |
+
| 207 | ++ | + + | +
| 208 | ++ |
+ private = list(+ |
+
| 209 | ++ |
+ # private methods ----+ |
+
| 210 | ++ |
+ set_choices = function(choices) {
+ |
+
| 211 | +23x | +
+ if (is.null(choices)) {
+ |
+
| 212 | +20x | +
+ choices <- as.POSIXct(trunc(range(private$x, na.rm = TRUE), units = "secs"))+ |
+
| 213 | ++ |
+ } else {
+ |
+
| 214 | +3x | +
+ choices <- as.POSIXct(choices, units = "secs")+ |
+
| 215 | +3x | +
+ choices_adjusted <- c(+ |
+
| 216 | +3x | +
+ max(choices[1L], min(as.POSIXct(private$x), na.rm = TRUE)),+ |
+
| 217 | +3x | +
+ min(choices[2L], max(as.POSIXct(private$x), na.rm = TRUE))+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | +3x | +
+ if (any(choices != choices_adjusted)) {
+ |
+
| 220 | +1x | +
+ warning(sprintf(+ |
+
| 221 | +1x | +
+ "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",+ |
+
| 222 | +1x | +
+ private$get_varname(), private$get_dataname()+ |
+
| 223 | ++ |
+ ))+ |
+
| 224 | +1x | +
+ choices <- choices_adjusted+ |
+
| 225 | ++ |
+ }+ |
+
| 226 | +3x | +
+ if (choices[1L] >= choices[2L]) {
+ |
+
| 227 | +1x | +
+ warning(sprintf(+ |
+
| 228 | +1x | +
+ "Invalid choices: lower is higher / equal to upper, or not in range of variable values.+ |
+
| 229 | +1x | +
+ Setting defaults. Varname: %s, dataname: %s.",+ |
+
| 230 | +1x | +
+ private$get_varname(), private$get_dataname()+ |
+
| 231 | ++ |
+ ))+ |
+
| 232 | +1x | +
+ choices <- range(private$x, na.rm = TRUE)+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | ++ |
+ }+ |
+
| 235 | ++ | + + | +
| 236 | +23x | +
+ private$set_is_choice_limited(private$x, choices)+ |
+
| 237 | +23x | +
+ private$x <- private$x[+ |
+
| 238 | +23x | +
+ (as.POSIXct(trunc(private$x, units = "secs")) >= choices[1L] &+ |
+
| 239 | +23x | +
+ as.POSIXct(trunc(private$x, units = "secs")) <= choices[2L]) | is.na(private$x)+ |
+
| 240 | ++ |
+ ]+ |
+
| 241 | +23x | +
+ private$teal_slice$choices <- choices+ |
+
| 242 | +23x | +
+ invisible(NULL)+ |
+
| 243 | ++ |
+ },+ |
+
| 244 | ++ | + + | +
| 245 | ++ |
+ # @description+ |
+
| 246 | ++ |
+ # Check whether the initial choices filter out some values of x and set the flag in case.+ |
+
| 247 | ++ |
+ set_is_choice_limited = function(xl, choices = NULL) {
+ |
+
| 248 | +23x | +
+ private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE))+ |
+
| 249 | +23x | +
+ invisible(NULL)+ |
+
| 250 | ++ |
+ },+ |
+
| 251 | ++ |
+ validate_selection = function(value) {
+ |
+
| 252 | +30x | +
+ if (!(is(value, "POSIXct") || is(value, "POSIXlt"))) {
+ |
+
| 253 | +! | +
+ stop(+ |
+
| 254 | +! | +
+ sprintf(+ |
+
| 255 | +! | +
+ "value of the selection for `%s` in `%s` should be a POSIXct or POSIXlt",+ |
+
| 256 | +! | +
+ private$get_varname(),+ |
+
| 257 | +! | +
+ private$get_dataname()+ |
+
| 258 | ++ |
+ )+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | ++ | + + | +
| 262 | +30x | +
+ pre_msg <- sprintf(+ |
+
| 263 | +30x | +
+ "dataset '%s', variable '%s': ",+ |
+
| 264 | +30x | +
+ private$get_dataname(),+ |
+
| 265 | +30x | +
+ private$get_varname()+ |
+
| 266 | ++ |
+ )+ |
+
| 267 | +30x | +
+ check_in_range(value, private$get_choices(), pre_msg = pre_msg)+ |
+
| 268 | ++ |
+ },+ |
+
| 269 | ++ |
+ cast_and_validate = function(values) {
+ |
+
| 270 | +34x | +
+ tryCatch(+ |
+
| 271 | +34x | +
+ expr = {
+ |
+
| 272 | +34x | +
+ values <- as.POSIXct(values, origin = "1970-01-01 00:00:00")+ |
+
| 273 | +! | +
+ if (any(is.na(values))) stop()+ |
+
| 274 | ++ |
+ },+ |
+
| 275 | +34x | +
+ error = function(error) stop("The array of set values must contain values coercible to POSIX.")
+ |
+
| 276 | ++ |
+ )+ |
+
| 277 | +1x | +
+ if (length(values) != 2) stop("The array of set values must have length two.")
+ |
+
| 278 | +30x | +
+ values+ |
+
| 279 | ++ |
+ },+ |
+
| 280 | ++ |
+ remove_out_of_bound_values = function(values) {
+ |
+
| 281 | +30x | +
+ choices <- private$get_choices()+ |
+
| 282 | +30x | +
+ if (values[1] < choices[1L] || values[1] > choices[2L]) {
+ |
+
| 283 | +5x | +
+ warning(+ |
+
| 284 | +5x | +
+ sprintf(+ |
+
| 285 | +5x | +
+ "Value: %s is outside of the range for the column '%s' in dataset '%s', setting minimum possible value.",+ |
+
| 286 | +5x | +
+ values[1], private$get_varname(), toString(private$get_dataname())+ |
+
| 287 | ++ |
+ )+ |
+
| 288 | ++ |
+ )+ |
+
| 289 | +5x | +
+ values[1] <- choices[1L]+ |
+
| 290 | ++ |
+ }+ |
+
| 291 | ++ | + + | +
| 292 | +30x | +
+ if (values[2] > choices[2L] | values[2] < choices[1L]) {
+ |
+
| 293 | +5x | +
+ warning(+ |
+
| 294 | +5x | +
+ sprintf(+ |
+
| 295 | +5x | +
+ "Value: '%s' is outside of the range for the column '%s' in dataset '%s', setting maximum possible value.",+ |
+
| 296 | +5x | +
+ values[2], private$get_varname(), toString(private$get_dataname())+ |
+
| 297 | ++ |
+ )+ |
+
| 298 | ++ |
+ )+ |
+
| 299 | +5x | +
+ values[2] <- choices[2L]+ |
+
| 300 | ++ |
+ }+ |
+
| 301 | ++ | + + | +
| 302 | +30x | +
+ if (values[1] > values[2]) {
+ |
+
| 303 | +1x | +
+ warning(+ |
+
| 304 | +1x | +
+ sprintf(+ |
+
| 305 | +1x | +
+ "Start date '%s' is set after the end date '%s', the values will be replaced by a default datetime range.",+ |
+
| 306 | +1x | +
+ values[1], values[2]+ |
+
| 307 | ++ |
+ )+ |
+
| 308 | ++ |
+ )+ |
+
| 309 | +1x | +
+ values <- c(choices[1L], choices[2L])+ |
+
| 310 | ++ |
+ }+ |
+
| 311 | +30x | +
+ values+ |
+
| 312 | ++ |
+ },+ |
+
| 313 | ++ | + + | +
| 314 | ++ |
+ # shiny modules ----+ |
+
| 315 | ++ | + + | +
| 316 | ++ |
+ # @description+ |
+
| 317 | ++ |
+ # UI Module for `DatetimeFilterState`.+ |
+
| 318 | ++ |
+ # This UI element contains two date-time selections for `min` and `max`+ |
+
| 319 | ++ |
+ # of the range and a checkbox whether to keep the `NA` values.+ |
+
| 320 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 321 | ++ |
+ # id of shiny element+ |
+
| 322 | ++ |
+ ui_inputs = function(id) {
+ |
+
| 323 | +! | +
+ ns <- NS(id)+ |
+
| 324 | ++ | + + | +
| 325 | +! | +
+ shiny::isolate({
+ |
+
| 326 | +! | +
+ ui_input_1 <- shinyWidgets::airDatepickerInput(+ |
+
| 327 | +! | +
+ inputId = ns("selection_start"),
+ |
+
| 328 | +! | +
+ value = private$get_selected()[1],+ |
+
| 329 | +! | +
+ startView = private$get_selected()[1],+ |
+
| 330 | +! | +
+ timepicker = TRUE,+ |
+
| 331 | +! | +
+ minDate = private$get_choices()[1L],+ |
+
| 332 | +! | +
+ maxDate = private$get_choices()[2L],+ |
+
| 333 | +! | +
+ update_on = "close",+ |
+
| 334 | +! | +
+ addon = "none",+ |
+
| 335 | +! | +
+ position = "bottom right"+ |
+
| 336 | ++ |
+ )+ |
+
| 337 | +! | +
+ ui_input_2 <- shinyWidgets::airDatepickerInput(+ |
+
| 338 | +! | +
+ inputId = ns("selection_end"),
+ |
+
| 339 | +! | +
+ value = private$get_selected()[2],+ |
+
| 340 | +! | +
+ startView = private$get_selected()[2],+ |
+
| 341 | +! | +
+ timepicker = TRUE,+ |
+
| 342 | +! | +
+ minDate = private$get_choices()[1L],+ |
+
| 343 | +! | +
+ maxDate = private$get_choices()[2L],+ |
+
| 344 | +! | +
+ update_on = "close",+ |
+
| 345 | +! | +
+ addon = "none",+ |
+
| 346 | +! | +
+ position = "bottom right"+ |
+
| 347 | ++ |
+ )+ |
+
| 348 | +! | +
+ ui_reset_1 <- actionButton(+ |
+
| 349 | +! | +
+ class = "date_reset_button",+ |
+
| 350 | +! | +
+ inputId = ns("start_date_reset"),
+ |
+
| 351 | +! | +
+ label = NULL,+ |
+
| 352 | +! | +
+ icon = icon("fas fa-undo")
+ |
+
| 353 | ++ |
+ )+ |
+
| 354 | +! | +
+ ui_reset_2 <- actionButton(+ |
+
| 355 | +! | +
+ class = "date_reset_button",+ |
+
| 356 | +! | +
+ inputId = ns("end_date_reset"),
+ |
+
| 357 | +! | +
+ label = NULL,+ |
+
| 358 | +! | +
+ icon = icon("fas fa-undo")
+ |
+
| 359 | ++ |
+ )+ |
+
| 360 | +! | +
+ ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm"))+ |
+
| 361 | +! | +
+ ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm"))+ |
+
| 362 | ++ | + + | +
| 363 | +! | +
+ div(+ |
+
| 364 | +! | +
+ div(+ |
+
| 365 | +! | +
+ class = "flex",+ |
+
| 366 | +! | +
+ ui_reset_1,+ |
+
| 367 | +! | +
+ div(+ |
+
| 368 | +! | +
+ class = "flex w-80 filter_datelike_input",+ |
+
| 369 | +! | +
+ div(class = "w-45 text-center", ui_input_1),+ |
+
| 370 | +! | +
+ span(+ |
+
| 371 | +! | +
+ class = "input-group-addon w-10",+ |
+
| 372 | +! | +
+ span(class = "input-group-text w-100 justify-content-center", "to"),+ |
+
| 373 | +! | +
+ title = "Times are displayed in the local timezone and are converted to UTC in the analysis"+ |
+
| 374 | ++ |
+ ),+ |
+
| 375 | +! | +
+ div(class = "w-45 text-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)`)\cr+ |
+
| 387 | ++ |
+ # an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 388 | ++ |
+ # @return `moduleServer` function which returns `NULL`+ |
+
| 389 | ++ |
+ server_inputs = function(id) {
+ |
+
| 390 | +! | +
+ moduleServer(+ |
+
| 391 | +! | +
+ id = id,+ |
+
| 392 | +! | +
+ function(input, output, session) {
+ |
+
| 393 | +! | +
+ logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
+ |
+
| 394 | ++ |
+ # this observer is needed in the situation when teal_slice$selected has been+ |
+
| 395 | ++ |
+ # changed directly by the api - then it's needed to rerender UI element+ |
+
| 396 | ++ |
+ # to show relevant values+ |
+
| 397 | +! | +
+ private$observers$selection_api <- observeEvent(+ |
+
| 398 | +! | +
+ ignoreNULL = TRUE, # dates needs to be selected+ |
+
| 399 | +! | +
+ ignoreInit = TRUE, # on init selected == default, so no need to trigger+ |
+
| 400 | +! | +
+ eventExpr = private$get_selected(),+ |
+
| 401 | +! | +
+ handlerExpr = {
+ |
+
| 402 | +! | +
+ start_date <- input$selection_start+ |
+
| 403 | +! | +
+ end_date <- input$selection_end+ |
+
| 404 | +! | +
+ if (!all(private$get_selected() == c(start_date, end_date))) {
+ |
+
| 405 | +! | +
+ logger::log_trace("DatetimeFilterState$server@1 state changed, id: { private$get_id() }")
+ |
+
| 406 | +! | +
+ if (private$get_selected()[1] != start_date) {
+ |
+
| 407 | +! | +
+ shinyWidgets::updateAirDateInput(+ |
+
| 408 | +! | +
+ session = session,+ |
+
| 409 | +! | +
+ inputId = "selection_start",+ |
+
| 410 | +! | +
+ value = private$get_selected()[1]+ |
+
| 411 | ++ |
+ )+ |
+
| 412 | ++ |
+ }+ |
+
| 413 | ++ | + + | +
| 414 | +! | +
+ if (private$get_selected()[2] != end_date) {
+ |
+
| 415 | +! | +
+ shinyWidgets::updateAirDateInput(+ |
+
| 416 | +! | +
+ session = session,+ |
+
| 417 | +! | +
+ inputId = "selection_end",+ |
+
| 418 | +! | +
+ value = private$get_selected()[2]+ |
+
| 419 | ++ |
+ )+ |
+
| 420 | ++ |
+ }+ |
+
| 421 | ++ |
+ }+ |
+
| 422 | ++ |
+ }+ |
+
| 423 | ++ |
+ )+ |
+
| 424 | ++ | + + | +
| 425 | ++ | + + | +
| 426 | +! | +
+ private$observers$selection_start <- observeEvent(+ |
+
| 427 | +! | +
+ ignoreNULL = TRUE, # dates needs to be selected+ |
+
| 428 | +! | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 429 | +! | +
+ eventExpr = input$selection_start,+ |
+
| 430 | +! | +
+ handlerExpr = {
+ |
+
| 431 | +! | +
+ logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
+ |
+
| 432 | +! | +
+ start_date <- input$selection_start+ |
+
| 433 | +! | +
+ end_date <- private$get_selected()[[2]]+ |
+
| 434 | +! | +
+ tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))+ |
+
| 435 | +! | +
+ attr(start_date, "tzone") <- tzone+ |
+
| 436 | ++ | + + | +
| 437 | +! | +
+ if (start_date > end_date) {
+ |
+
| 438 | +! | +
+ showNotification(+ |
+
| 439 | +! | +
+ "Start date must not be greater than the end date. Ignoring selection.",+ |
+
| 440 | +! | +
+ type = "warning"+ |
+
| 441 | ++ |
+ )+ |
+
| 442 | +! | +
+ shinyWidgets::updateAirDateInput(+ |
+
| 443 | +! | +
+ session = session,+ |
+
| 444 | +! | +
+ inputId = "selection_start",+ |
+
| 445 | +! | +
+ value = private$get_selected()[1] # sets back to latest selected value+ |
+
| 446 | ++ |
+ )+ |
+
| 447 | +! | +
+ return(NULL)+ |
+
| 448 | ++ |
+ }+ |
+
| 449 | ++ | + + | +
| 450 | +! | +
+ private$set_selected(c(start_date, end_date))+ |
+
| 451 | ++ |
+ }+ |
+
| 452 | ++ |
+ )+ |
+
| 453 | ++ | + + | +
| 454 | +! | +
+ private$observers$selection_end <- observeEvent(+ |
+
| 455 | +! | +
+ ignoreNULL = TRUE, # dates needs to be selected+ |
+
| 456 | +! | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 457 | +! | +
+ eventExpr = input$selection_end,+ |
+
| 458 | +! | +
+ handlerExpr = {
+ |
+
| 459 | +! | +
+ start_date <- private$get_selected()[1]+ |
+
| 460 | +! | +
+ end_date <- input$selection_end+ |
+
| 461 | +! | +
+ tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))+ |
+
| 462 | +! | +
+ attr(end_date, "tzone") <- tzone+ |
+
| 463 | ++ | + + | +
| 464 | +! | +
+ if (start_date > end_date) {
+ |
+
| 465 | +! | +
+ showNotification(+ |
+
| 466 | +! | +
+ "End date must not be lower than the start date. Ignoring selection.",+ |
+
| 467 | +! | +
+ type = "warning"+ |
+
| 468 | ++ |
+ )+ |
+
| 469 | +! | +
+ shinyWidgets::updateAirDateInput(+ |
+
| 470 | +! | +
+ session = session,+ |
+
| 471 | +! | +
+ inputId = "selection_end",+ |
+
| 472 | +! | +
+ value = private$get_selected()[2] # sets back to latest selected value+ |
+
| 473 | ++ |
+ )+ |
+
| 474 | +! | +
+ return(NULL)+ |
+
| 475 | ++ |
+ }+ |
+
| 476 | ++ | + + | +
| 477 | +! | +
+ private$set_selected(c(start_date, end_date))+ |
+
| 478 | +! | +
+ logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
+ |
+
| 479 | ++ |
+ }+ |
+
| 480 | ++ |
+ )+ |
+
| 481 | ++ | + + | +
| 482 | +! | +
+ private$keep_na_srv("keep_na")
+ |
+
| 483 | ++ | + + | +
| 484 | +! | +
+ private$observers$reset1 <- observeEvent(+ |
+
| 485 | +! | +
+ ignoreInit = TRUE, # reset button shouldn't be trigger on init+ |
+
| 486 | +! | +
+ ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL+ |
+
| 487 | +! | +
+ input$start_date_reset,+ |
+
| 488 | ++ |
+ {
+ |
+
| 489 | +! | +
+ shinyWidgets::updateAirDateInput(+ |
+
| 490 | +! | +
+ session = session,+ |
+
| 491 | +! | +
+ inputId = "selection_start",+ |
+
| 492 | +! | +
+ value = private$get_choices()[1L]+ |
+
| 493 | ++ |
+ )+ |
+
| 494 | +! | +
+ logger::log_trace("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
+ |
+
| 495 | ++ |
+ }+ |
+
| 496 | ++ |
+ )+ |
+
| 497 | +! | +
+ private$observers$reset2 <- observeEvent(+ |
+
| 498 | +! | +
+ ignoreInit = TRUE, # reset button shouldn't be trigger on init+ |
+
| 499 | +! | +
+ ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL+ |
+
| 500 | +! | +
+ input$end_date_reset,+ |
+
| 501 | ++ |
+ {
+ |
+
| 502 | +! | +
+ shinyWidgets::updateAirDateInput(+ |
+
| 503 | +! | +
+ session = session,+ |
+
| 504 | +! | +
+ inputId = "selection_end",+ |
+
| 505 | +! | +
+ value = private$get_choices()[2L]+ |
+
| 506 | ++ |
+ )+ |
+
| 507 | +! | +
+ logger::log_trace("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
+ |
+
| 508 | ++ |
+ }+ |
+
| 509 | ++ |
+ )+ |
+
| 510 | ++ | + + | +
| 511 | +! | +
+ logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
+ |
+
| 512 | +! | +
+ NULL+ |
+
| 513 | ++ |
+ }+ |
+
| 514 | ++ |
+ )+ |
+
| 515 | ++ |
+ },+ |
+
| 516 | ++ |
+ server_inputs_fixed = function(id) {
+ |
+
| 517 | +! | +
+ moduleServer(+ |
+
| 518 | +! | +
+ id = id,+ |
+
| 519 | +! | +
+ function(input, output, session) {
+ |
+
| 520 | +! | +
+ logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
+ |
+
| 521 | ++ | + + | +
| 522 | +! | +
+ output$selection <- renderUI({
+ |
+
| 523 | +! | +
+ vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3)+ |
+
| 524 | +! | +
+ div(+ |
+
| 525 | +! | +
+ div(icon("clock"), vals[1]),
+ |
+
| 526 | +! | +
+ div(span(" - "), icon("clock"), vals[2])
+ |
+
| 527 | ++ |
+ )+ |
+
| 528 | ++ |
+ })+ |
+
| 529 | ++ | + + | +
| 530 | +! | +
+ logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
+ |
+
| 531 | +! | +
+ NULL+ |
+
| 532 | ++ |
+ }+ |
+
| 533 | ++ |
+ )+ |
+
| 534 | ++ |
+ },+ |
+
| 535 | ++ | + + | +
| 536 | ++ |
+ # @description+ |
+
| 537 | ++ |
+ # UI module to display filter summary+ |
+
| 538 | ++ |
+ # renders text describing selected date range and+ |
+
| 539 | ++ |
+ # if NA are included also+ |
+
| 540 | ++ |
+ content_summary = function(id) {
+ |
+
| 541 | +! | +
+ selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S")+ |
+
| 542 | +! | +
+ min <- selected[1]+ |
+
| 543 | +! | +
+ max <- selected[2]+ |
+
| 544 | +! | +
+ tagList(+ |
+
| 545 | +! | +
+ tags$span(+ |
+
| 546 | +! | +
+ class = "filter-card-summary-value",+ |
+
| 547 | +! | +
+ shiny::HTML(min, "–", max)+ |
+
| 548 | ++ |
+ ),+ |
+
| 549 | +! | +
+ tags$span(+ |
+
| 550 | +! | +
+ class = "filter-card-summary-controls",+ |
+
| 551 | +! | +
+ if (isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 552 | +! | +
+ tags$span(+ |
+
| 553 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 554 | +! | +
+ "NA",+ |
+
| 555 | +! | +
+ shiny::icon("check")
+ |
+
| 556 | ++ |
+ )+ |
+
| 557 | +! | +
+ } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 558 | +! | +
+ tags$span(+ |
+
| 559 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 560 | +! | +
+ "NA",+ |
+
| 561 | +! | +
+ shiny::icon("xmark")
+ |
+
| 562 | ++ |
+ )+ |
+
| 563 | ++ |
+ } else {
+ |
+
| 564 | +! | +
+ NULL+ |
+
| 565 | ++ |
+ }+ |
+
| 566 | ++ |
+ )+ |
+
| 567 | ++ |
+ )+ |
+
| 568 | ++ |
+ }+ |
+
| 569 | ++ |
+ )+ |
+
| 570 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Initializes `FilterState`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Initializes `FilterState` depending on a variable class.\cr+ |
+
| 4 | ++ |
+ #' @param x (`vector`)\cr+ |
+
| 5 | ++ |
+ #' values of the variable used in filter+ |
+
| 6 | ++ |
+ #' @param x_reactive (`reactive`)\cr+ |
+
| 7 | ++ |
+ #' returning vector of the same type as `x`. Is used to update+ |
+
| 8 | ++ |
+ #' counts following the change in values of the filtered dataset.+ |
+
| 9 | ++ |
+ #' If it is set to `reactive(NULL)` then counts based on filtered+ |
+
| 10 | ++ |
+ #' dataset are not shown.+ |
+
| 11 | ++ |
+ #' @param slice (`teal_slice`)\cr+ |
+
| 12 | ++ |
+ #' object created using [teal_slice()].+ |
+
| 13 | ++ |
+ #' @param extract_type (`character(0)`, `character(1)`)\cr+ |
+
| 14 | ++ |
+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ |
+
| 15 | ++ |
+ #' \itemize{
+ |
+
| 16 | ++ |
+ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
+ |
+
| 17 | ++ |
+ #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
+ |
+
| 18 | ++ |
+ #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
+ |
+
| 19 | ++ |
+ #' }+ |
+
| 20 | ++ |
+ #' @param ... additional arguments to be saved as a list in `private$extras` field+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @keywords internal+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examples+ |
+
| 25 | ++ |
+ #' filter_state <- teal.slice:::init_filter_state(+ |
+
| 26 | ++ |
+ #' x = c(1:10, NA, Inf),+ |
+
| 27 | ++ |
+ #' x_reactive = reactive(c(1:10, NA, Inf)),+ |
+
| 28 | ++ |
+ #' slice = teal_slice(+ |
+
| 29 | ++ |
+ #' varname = "x",+ |
+
| 30 | ++ |
+ #' dataname = "dataname"+ |
+
| 31 | ++ |
+ #' ),+ |
+
| 32 | ++ |
+ #' extract_type = "matrix"+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 36 | ++ |
+ #' app <- shinyApp(+ |
+
| 37 | ++ |
+ #' ui = fluidPage(+ |
+
| 38 | ++ |
+ #' filter_state$ui(id = "app"),+ |
+
| 39 | ++ |
+ #' verbatimTextOutput("call")
+ |
+
| 40 | ++ |
+ #' ),+ |
+
| 41 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 42 | ++ |
+ #' filter_state$server("app")
+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' output$call <- renderText(+ |
+
| 45 | ++ |
+ #' deparse1(filter_state$get_call(), collapse = "\n")+ |
+
| 46 | ++ |
+ #' )+ |
+
| 47 | ++ |
+ #' }+ |
+
| 48 | ++ |
+ #' )+ |
+
| 49 | ++ |
+ #' if (interactive()) {
+ |
+
| 50 | ++ |
+ #' runApp(app)+ |
+
| 51 | ++ |
+ #' }+ |
+
| 52 | ++ |
+ #' @return `FilterState` object+ |
+
| 53 | ++ |
+ init_filter_state <- function(x,+ |
+
| 54 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 55 | ++ |
+ slice,+ |
+
| 56 | ++ |
+ extract_type = character(0)) {
+ |
+
| 57 | +205x | +
+ checkmate::assert_class(x_reactive, "reactive")+ |
+
| 58 | +204x | +
+ checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)+ |
+
| 59 | +204x | +
+ checkmate::assert_class(slice, "teal_slice")+ |
+
| 60 | +203x | +
+ if (length(extract_type) == 1) {
+ |
+
| 61 | +49x | +
+ checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ | + + | +
| 64 | +202x | +
+ if (all(is.na(x))) {
+ |
+
| 65 | +1x | +
+ EmptyFilterState$new(+ |
+
| 66 | +1x | +
+ x = x,+ |
+
| 67 | +1x | +
+ x_reactive = x_reactive,+ |
+
| 68 | +1x | +
+ slice = slice,+ |
+
| 69 | +1x | +
+ extract_type = extract_type+ |
+
| 70 | ++ |
+ )+ |
+
| 71 | ++ |
+ } else {
+ |
+
| 72 | +201x | +
+ UseMethod("init_filter_state")
+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ #' @keywords internal+ |
+
| 77 | ++ |
+ #' @export+ |
+
| 78 | ++ |
+ init_filter_state.default <- function(x,+ |
+
| 79 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 80 | ++ |
+ slice,+ |
+
| 81 | ++ |
+ extract_type = character(0)) {
+ |
+
| 82 | +1x | +
+ args <- list(+ |
+
| 83 | +1x | +
+ x = x,+ |
+
| 84 | +1x | +
+ x_reactive = x_reactive,+ |
+
| 85 | +1x | +
+ extract_type = extract_type,+ |
+
| 86 | +1x | +
+ slice+ |
+
| 87 | ++ |
+ )+ |
+
| 88 | ++ | + + | +
| 89 | +1x | +
+ do.call(FilterState$new, args)+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ #' @keywords internal+ |
+
| 93 | ++ |
+ #' @export+ |
+
| 94 | ++ |
+ init_filter_state.logical <- function(x,+ |
+
| 95 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 96 | ++ |
+ slice,+ |
+
| 97 | ++ |
+ extract_type = character(0)) {
+ |
+
| 98 | +1x | +
+ LogicalFilterState$new(+ |
+
| 99 | +1x | +
+ x = x,+ |
+
| 100 | +1x | +
+ x_reactive = x_reactive,+ |
+
| 101 | +1x | +
+ slice = slice,+ |
+
| 102 | +1x | +
+ extract_type = extract_type+ |
+
| 103 | ++ |
+ )+ |
+
| 104 | ++ |
+ }+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ #' @keywords internal+ |
+
| 107 | ++ |
+ #' @export+ |
+
| 108 | ++ |
+ init_filter_state.numeric <- function(x,+ |
+
| 109 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 110 | ++ |
+ slice,+ |
+
| 111 | ++ |
+ extract_type = character(0)) {
+ |
+
| 112 | +125x | +
+ args <- list(+ |
+
| 113 | +125x | +
+ x = x,+ |
+
| 114 | +125x | +
+ x_reactive = x_reactive,+ |
+
| 115 | +125x | +
+ slice = slice,+ |
+
| 116 | +125x | +
+ extract_type = extract_type+ |
+
| 117 | ++ |
+ )+ |
+
| 118 | ++ | + + | +
| 119 | +125x | +
+ if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
+ |
+
| 120 | +28x | +
+ do.call(ChoicesFilterState$new, args)+ |
+
| 121 | ++ |
+ } else {
+ |
+
| 122 | +97x | +
+ do.call(RangeFilterState$new, args)+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | ++ | + + | +
| 126 | ++ |
+ #' @keywords internal+ |
+
| 127 | ++ |
+ #' @export+ |
+
| 128 | ++ |
+ init_filter_state.factor <- function(x,+ |
+
| 129 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 130 | ++ |
+ slice,+ |
+
| 131 | ++ |
+ extract_type = character(0)) {
+ |
+
| 132 | +32x | +
+ ChoicesFilterState$new(+ |
+
| 133 | +32x | +
+ x = x,+ |
+
| 134 | +32x | +
+ x_reactive = x_reactive,+ |
+
| 135 | +32x | +
+ slice = slice,+ |
+
| 136 | +32x | +
+ extract_type = extract_type+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ | + + | +
| 140 | ++ |
+ #' @keywords internal+ |
+
| 141 | ++ |
+ #' @export+ |
+
| 142 | ++ |
+ init_filter_state.character <- function(x,+ |
+
| 143 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 144 | ++ |
+ slice,+ |
+
| 145 | ++ |
+ extract_type = character(0)) {
+ |
+
| 146 | +36x | +
+ ChoicesFilterState$new(+ |
+
| 147 | +36x | +
+ x = x,+ |
+
| 148 | +36x | +
+ x_reactive = x_reactive,+ |
+
| 149 | +36x | +
+ slice = slice,+ |
+
| 150 | +36x | +
+ extract_type = extract_type+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ #' @keywords internal+ |
+
| 155 | ++ |
+ #' @export+ |
+
| 156 | ++ |
+ init_filter_state.Date <- function(x,+ |
+
| 157 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 158 | ++ |
+ slice,+ |
+
| 159 | ++ |
+ extract_type = character(0)) {
+ |
+
| 160 | +2x | +
+ args <- list(+ |
+
| 161 | +2x | +
+ x = x,+ |
+
| 162 | +2x | +
+ x_reactive = x_reactive,+ |
+
| 163 | +2x | +
+ slice = slice,+ |
+
| 164 | +2x | +
+ extract_type = extract_type+ |
+
| 165 | ++ |
+ )+ |
+
| 166 | ++ | + + | +
| 167 | +2x | +
+ if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
+ |
+
| 168 | +1x | +
+ do.call(ChoicesFilterState$new, args)+ |
+
| 169 | ++ |
+ } else {
+ |
+
| 170 | +1x | +
+ do.call(DateFilterState$new, args)+ |
+
| 171 | ++ |
+ }+ |
+
| 172 | ++ |
+ }+ |
+
| 173 | ++ | + + | +
| 174 | ++ |
+ #' @keywords internal+ |
+
| 175 | ++ |
+ #' @export+ |
+
| 176 | ++ |
+ init_filter_state.POSIXct <- function(x,+ |
+
| 177 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 178 | ++ |
+ slice,+ |
+
| 179 | ++ |
+ extract_type = character(0)) {
+ |
+
| 180 | +2x | +
+ args <- list(+ |
+
| 181 | +2x | +
+ x = x,+ |
+
| 182 | +2x | +
+ x_reactive = x_reactive,+ |
+
| 183 | +2x | +
+ slice = slice,+ |
+
| 184 | +2x | +
+ extract_type = extract_type+ |
+
| 185 | ++ |
+ )+ |
+
| 186 | ++ | + + | +
| 187 | +2x | +
+ if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
+ |
+
| 188 | +1x | +
+ do.call(ChoicesFilterState$new, args)+ |
+
| 189 | ++ |
+ } else {
+ |
+
| 190 | +1x | +
+ do.call(DatetimeFilterState$new, args)+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ | + + | +
| 194 | ++ |
+ #' @keywords internal+ |
+
| 195 | ++ |
+ #' @export+ |
+
| 196 | ++ |
+ init_filter_state.POSIXlt <- function(x,+ |
+
| 197 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 198 | ++ |
+ slice,+ |
+
| 199 | ++ |
+ extract_type = character(0)) {
+ |
+
| 200 | +2x | +
+ args <- list(+ |
+
| 201 | +2x | +
+ x = x,+ |
+
| 202 | +2x | +
+ x_reactive = x_reactive,+ |
+
| 203 | +2x | +
+ slice = slice,+ |
+
| 204 | +2x | +
+ extract_type = extract_type+ |
+
| 205 | ++ |
+ )+ |
+
| 206 | ++ | + + | +
| 207 | +2x | +
+ if (length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup")) {
+ |
+
| 208 | +1x | +
+ do.call(ChoicesFilterState$new, args)+ |
+
| 209 | ++ |
+ } else {
+ |
+
| 210 | +1x | +
+ do.call(DatetimeFilterState$new, args)+ |
+
| 211 | ++ |
+ }+ |
+
| 212 | ++ |
+ }+ |
+
| 213 | ++ | + + | +
| 214 | ++ | + + | +
| 215 | ++ |
+ #' Initialize a `FilterStateExpr` object+ |
+
| 216 | ++ |
+ #'+ |
+
| 217 | ++ |
+ #' Initialize a `FilterStateExpr` object+ |
+
| 218 | ++ |
+ #' @param slice (`teal_slice_expr`)\cr+ |
+
| 219 | ++ |
+ #' object created using [teal_slice()]. `teal_slice` is stored+ |
+
| 220 | ++ |
+ #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`+ |
+
| 221 | ++ |
+ #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`+ |
+
| 222 | ++ |
+ #' is a `reactiveValues` which means that changes in particular object are automatically+ |
+
| 223 | ++ |
+ #' reflected in all places which refer to the same `teal_slice`.+ |
+
| 224 | ++ |
+ #'+ |
+
| 225 | ++ |
+ #' @return `FilterStateExpr` object+ |
+
| 226 | ++ |
+ #' @keywords internal+ |
+
| 227 | ++ |
+ init_filter_state_expr <- function(slice) {
+ |
+
| 228 | +2x | +
+ FilterStateExpr$new(slice)+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | ++ | + + | +
| 231 | ++ |
+ #' Check that a given range is valid+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' @param subinterval (`numeric` or `date`)\cr vector of length 2 to be compared against the full range.+ |
+
| 234 | ++ |
+ #' @param range (`numeric` or `date`)\cr vector of length 2 containing the full range to validate against.+ |
+
| 235 | ++ |
+ #' @param pre_msg `character` message to print before error for additional context.+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' @return `NULL` if `subinterval` is a valid range or error with message otherwise.+ |
+
| 238 | ++ |
+ #' @keywords internal+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ #' @examples+ |
+
| 241 | ++ |
+ #' if (interactive()) {
+ |
+
| 242 | ++ |
+ #' teal.slice:::check_in_range(c(3, 1), c(1, 3))+ |
+
| 243 | ++ |
+ #' teal.slice:::check_in_range(c(0, 3), c(1, 3))+ |
+
| 244 | ++ |
+ #' teal.slice:::check_in_range(+ |
+
| 245 | ++ |
+ #' c(as.Date("2020-01-01"), as.Date("2020-01-20")),
+ |
+
| 246 | ++ |
+ #' c(as.Date("2020-01-01"), as.Date("2020-01-02"))
+ |
+
| 247 | ++ |
+ #' )+ |
+
| 248 | ++ |
+ #' }+ |
+
| 249 | ++ |
+ check_in_range <- function(subinterval, range, pre_msg = "") {
+ |
+
| 250 | +64x | +
+ epsilon <- .Machine$double.eps^0.5 # needed for floating point arithmetic; same value as in base::all.equal()+ |
+
| 251 | +64x | +
+ if ((length(subinterval) != 2)) {
+ |
+
| 252 | +2x | +
+ stop(+ |
+
| 253 | +2x | +
+ sprintf(+ |
+
| 254 | +2x | +
+ "%s range length should be 2 while it is %s",+ |
+
| 255 | +2x | +
+ pre_msg,+ |
+
| 256 | +2x | +
+ length(subinterval)+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | ++ |
+ )+ |
+
| 259 | ++ |
+ }+ |
+
| 260 | +62x | +
+ if (subinterval[[2]] + epsilon < subinterval[[1]]) {
+ |
+
| 261 | +1x | +
+ stop(sprintf(+ |
+
| 262 | +1x | +
+ "%s unexpected: the upper bound of the range lower than the lower bound \n %s < %s",+ |
+
| 263 | +1x | +
+ pre_msg,+ |
+
| 264 | +1x | +
+ subinterval[[2]],+ |
+
| 265 | +1x | +
+ subinterval[[1]]+ |
+
| 266 | ++ |
+ ))+ |
+
| 267 | ++ |
+ }+ |
+
| 268 | ++ | + + | +
| 269 | +61x | +
+ if ((subinterval[[1]] + epsilon < range[[1]]) || (subinterval[[2]] - epsilon > range[[2]])) {
+ |
+
| 270 | +1x | +
+ stop(+ |
+
| 271 | +1x | +
+ sprintf(+ |
+
| 272 | +1x | +
+ "%s range (%s) not valid for full range (%s)",+ |
+
| 273 | +1x | +
+ pre_msg, toString(subinterval), toString(range)+ |
+
| 274 | ++ |
+ )+ |
+
| 275 | ++ |
+ )+ |
+
| 276 | ++ |
+ }+ |
+
| 277 | ++ |
+ }+ |
+
| 278 | ++ | + + | +
| 279 | ++ |
+ #' Check that one set is a subset of another+ |
+
| 280 | ++ |
+ #'+ |
+
| 281 | ++ |
+ #' Raises an error message if not and says which elements are not in the allowed `choices`.+ |
+
| 282 | ++ |
+ #'+ |
+
| 283 | ++ |
+ #' @param subset,choices atomic vectors+ |
+
| 284 | ++ |
+ #' @param pre_msg `character` message to print before error should there be any errors+ |
+
| 285 | ++ |
+ #' @keywords internal+ |
+
| 286 | ++ |
+ #'+ |
+
| 287 | ++ |
+ #' @examples+ |
+
| 288 | ++ |
+ #' \donttest{
+ |
+
| 289 | ++ |
+ #' teal.slice:::check_in_subset(c("a", "b"), c("a", "b", "c"))
+ |
+
| 290 | ++ |
+ #' if (interactive()) {
+ |
+
| 291 | ++ |
+ #' teal.slice:::check_in_subset(c("a", "b"), c("b", "c"), pre_msg = "Error: ")
+ |
+
| 292 | ++ |
+ #' # truncated because too long+ |
+
| 293 | ++ |
+ #' teal.slice:::check_in_subset("a", LETTERS, pre_msg = "Error: ")
+ |
+
| 294 | ++ |
+ #' }+ |
+
| 295 | ++ |
+ #' }+ |
+
| 296 | ++ |
+ check_in_subset <- function(subset, choices, pre_msg = "") {
+ |
+
| 297 | +166x | +
+ checkmate::assert_atomic(subset)+ |
+
| 298 | +166x | +
+ checkmate::assert_atomic(choices)+ |
+
| 299 | +166x | +
+ checkmate::assert_string(pre_msg)+ |
+
| 300 | ++ | + + | +
| 301 | +166x | +
+ subset <- unique(subset)+ |
+
| 302 | +166x | +
+ choices <- unique(choices)+ |
+
| 303 | ++ | + + | +
| 304 | +166x | +
+ if (any(!(subset %in% choices))) {
+ |
+
| 305 | +2x | +
+ stop(paste0(+ |
+
| 306 | +2x | +
+ pre_msg,+ |
+
| 307 | +2x | +
+ "(", toString(subset[!(subset %in% choices)], width = 30), ")",
+ |
+
| 308 | +2x | +
+ " not in valid choices ",+ |
+
| 309 | +2x | +
+ "(", toString(choices, width = 30), ")"
+ |
+
| 310 | +2x | +
+ ), call. = FALSE)+ |
+
| 311 | ++ |
+ }+ |
+
| 312 | +164x | +
+ return(invisible(NULL))+ |
+
| 313 | ++ |
+ }+ |
+
| 314 | ++ | + + | +
| 315 | ++ | + + | +
| 316 | ++ |
+ #' Get hex code of the current Bootstrap theme color.+ |
+
| 317 | ++ |
+ #'+ |
+
| 318 | ++ |
+ #' Determines the color specification for the currently active Bootstrap color theme and returns one queried color.+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' @param color `character(1)` naming one of the available theme colors+ |
+
| 321 | ++ |
+ #' @param alpha either a `numeric(1)` or `character(1)` specifying transparency+ |
+
| 322 | ++ |
+ #' in the range of `0-1` or a hexadecimal value `00-ff`, respectively;+ |
+
| 323 | ++ |
+ #' set to NULL to omit adding the alpha channel+ |
+
| 324 | ++ |
+ #'+ |
+
| 325 | ++ |
+ #' @return Named `character(1)` containing a hexadecimal color representation.+ |
+
| 326 | ++ |
+ #'+ |
+
| 327 | ++ |
+ #' @examples+ |
+
| 328 | ++ |
+ #' teal.slice:::fetch_bs_color("primary")
+ |
+
| 329 | ++ |
+ #' teal.slice:::fetch_bs_color("danger", 0.35)
+ |
+
| 330 | ++ |
+ #' teal.slice:::fetch_bs_color("danger", "80")
+ |
+
| 331 | ++ |
+ #'+ |
+
| 332 | ++ |
+ #' @keywords internal+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ fetch_bs_color <- function(color, alpha = NULL) {
+ |
+
| 335 | +124x | +
+ checkmate::assert_string(color)+ |
+
| 336 | +124x | +
+ checkmate::assert(+ |
+
| 337 | +124x | +
+ checkmate::check_number(alpha, lower = 0, upper = 1, null.ok = TRUE),+ |
+
| 338 | +124x | +
+ checkmate::check_string(alpha, pattern = "[0-9a-f]{2}", null.ok = TRUE)
+ |
+
| 339 | ++ |
+ )+ |
+
| 340 | ++ | + + | +
| 341 | ++ |
+ # locate file that describes the current theme+ |
+
| 342 | ++ |
+ ## TODO this is not ideal+ |
+
| 343 | +124x | +
+ sass_file <- bslib::bs_theme()[["layers"]][[2]][["defaults"]][[1]]+ |
+
| 344 | +124x | +
+ sass_file <- attr(sass_file, "sass_file_path")+ |
+
| 345 | ++ | + + | +
| 346 | ++ |
+ # load scss file that encodes variables+ |
+
| 347 | +124x | +
+ variables_file <- readLines(sass_file)+ |
+
| 348 | ++ |
+ # locate theme color variables+ |
+
| 349 | +124x | +
+ ind <- grep("// scss-docs-(start|end) theme-color-variables", variables_file)
+ |
+
| 350 | +124x | +
+ color_definitions <- variables_file[(ind[1] + 1L):(ind[2] - 1L)]+ |
+
| 351 | ++ | + + | +
| 352 | ++ |
+ # extract colors names+ |
+
| 353 | +124x | +
+ color_names <- sub("(\\$)(\\w.+)(:.+)", "\\2", color_definitions)
+ |
+
| 354 | ++ | + + | +
| 355 | ++ |
+ # verify that an available color was requested+ |
+
| 356 | +124x | +
+ checkmate::assert_choice(color, color_names)+ |
+
| 357 | ++ | + + | +
| 358 | ++ |
+ # extract color references+ |
+
| 359 | +124x | +
+ color_references <- sub("(\\$)(\\w.+)(:\\s.+\\$)(\\w.+)(\\s.+)", "\\4", color_definitions)
+ |
+
| 360 | ++ | + + | +
| 361 | ++ |
+ # translate references to color codes+ |
+
| 362 | +124x | +
+ color_specification <- structure(color_references, names = color_names)+ |
+
| 363 | +124x | +
+ color_specification <- vapply(color_specification, function(x) {
+ |
+
| 364 | +992x | +
+ line <- grep(sprintf("^\\$%s:\\s+#\\w{6}\\s+!default", x), variables_file, value = TRUE)
+ |
+
| 365 | +992x | +
+ code <- sub("(.+)(#\\w{6})(\\s+.+)", "\\2", line)
+ |
+
| 366 | +992x | +
+ code+ |
+
| 367 | +124x | +
+ }, character(1L))+ |
+
| 368 | ++ | + + | +
| 369 | +124x | +
+ if (!is.null(alpha)) {
+ |
+
| 370 | +! | +
+ if (is.numeric(alpha)) alpha <- as.hexmode(ceiling(255 * alpha))+ |
+
| 371 | ++ |
+ }+ |
+
| 372 | ++ | + + | +
| 373 | +124x | +
+ paste0(color_specification[color], alpha)+ |
+
| 374 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @name RangeFilterState+ |
+
| 2 | ++ |
+ #' @title `FilterState` object for numeric variable+ |
+
| 3 | ++ |
+ #' @description Manages choosing a numeric range+ |
+
| 4 | ++ |
+ #' @docType class+ |
+
| 5 | ++ |
+ #' @keywords internal+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @examples+ |
+
| 9 | ++ |
+ #' filter_state <- teal.slice:::RangeFilterState$new(+ |
+
| 10 | ++ |
+ #' x = c(NA, Inf, seq(1:10)),+ |
+
| 11 | ++ |
+ #' slice = teal_slice(varname = "x", dataname = "data")+ |
+
| 12 | ++ |
+ #' )+ |
+
| 13 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 14 | ++ |
+ #' filter_state$set_state(+ |
+
| 15 | ++ |
+ #' teal_slice(+ |
+
| 16 | ++ |
+ #' dataname = "data",+ |
+
| 17 | ++ |
+ #' varname = "x",+ |
+
| 18 | ++ |
+ #' selected = c(3L, 8L),+ |
+
| 19 | ++ |
+ #' keep_na = TRUE,+ |
+
| 20 | ++ |
+ #' keep_inf = TRUE+ |
+
| 21 | ++ |
+ #' )+ |
+
| 22 | ++ |
+ #' )+ |
+
| 23 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' # working filter in an app+ |
+
| 26 | ++ |
+ #' library(shiny)+ |
+
| 27 | ++ |
+ #' library(shinyjs)+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' data_range <- c(runif(100, 0, 1), NA, Inf)+ |
+
| 30 | ++ |
+ #' fs <- teal.slice:::RangeFilterState$new(+ |
+
| 31 | ++ |
+ #' x = data_range,+ |
+
| 32 | ++ |
+ #' slice = teal_slice(+ |
+
| 33 | ++ |
+ #' dataname = "data",+ |
+
| 34 | ++ |
+ #' varname = "x",+ |
+
| 35 | ++ |
+ #' selected = c(0.15, 0.93),+ |
+
| 36 | ++ |
+ #' keep_na = TRUE,+ |
+
| 37 | ++ |
+ #' keep_inf = TRUE+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #' )+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' ui <- fluidPage(+ |
+
| 42 | ++ |
+ #' useShinyjs(),+ |
+
| 43 | ++ |
+ #' teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 44 | ++ |
+ #' teal.slice:::include_js_files(pattern = "count-bar-labels"),+ |
+
| 45 | ++ |
+ #' column(4, div(+ |
+
| 46 | ++ |
+ #' h4("RangeFilterState"),
+ |
+
| 47 | ++ |
+ #' fs$ui("fs")
+ |
+
| 48 | ++ |
+ #' )),+ |
+
| 49 | ++ |
+ #' column(4, div(+ |
+
| 50 | ++ |
+ #' id = "outputs", # div id is needed for toggling the element+ |
+
| 51 | ++ |
+ #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
+ |
+
| 52 | ++ |
+ #' textOutput("condition_range"), br(),
+ |
+
| 53 | ++ |
+ #' h4("Unformatted state"), # display raw filter state
+ |
+
| 54 | ++ |
+ #' textOutput("unformatted_range"), br(),
+ |
+
| 55 | ++ |
+ #' h4("Formatted state"), # display human readable filter state
+ |
+
| 56 | ++ |
+ #' textOutput("formatted_range"), br()
+ |
+
| 57 | ++ |
+ #' )),+ |
+
| 58 | ++ |
+ #' column(4, div(+ |
+
| 59 | ++ |
+ #' h4("Programmatic filter control"),
+ |
+
| 60 | ++ |
+ #' actionButton("button1_range", "set drop NA", width = "100%"), br(),
+ |
+
| 61 | ++ |
+ #' actionButton("button2_range", "set keep NA", width = "100%"), br(),
+ |
+
| 62 | ++ |
+ #' actionButton("button3_range", "set drop Inf", width = "100%"), br(),
+ |
+
| 63 | ++ |
+ #' actionButton("button4_range", "set keep Inf", width = "100%"), br(),
+ |
+
| 64 | ++ |
+ #' actionButton("button5_range", "set a range", width = "100%"), br(),
+ |
+
| 65 | ++ |
+ #' actionButton("button6_range", "set full range", width = "100%"), br(),
+ |
+
| 66 | ++ |
+ #' actionButton("button0_range", "set initial state", width = "100%"), br()
+ |
+
| 67 | ++ |
+ #' ))+ |
+
| 68 | ++ |
+ #' )+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 71 | ++ |
+ #' fs$server("fs")
+ |
+
| 72 | ++ |
+ #' output$condition_range <- renderPrint(fs$get_call())+ |
+
| 73 | ++ |
+ #' output$formatted_range <- renderText(fs$format())+ |
+
| 74 | ++ |
+ #' output$unformatted_range <- renderPrint(fs$get_state())+ |
+
| 75 | ++ |
+ #' # modify filter state programmatically+ |
+
| 76 | ++ |
+ #' observeEvent(+ |
+
| 77 | ++ |
+ #' input$button1_range,+ |
+
| 78 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))+ |
+
| 79 | ++ |
+ #' )+ |
+
| 80 | ++ |
+ #' observeEvent(+ |
+
| 81 | ++ |
+ #' input$button2_range,+ |
+
| 82 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ |
+
| 83 | ++ |
+ #' )+ |
+
| 84 | ++ |
+ #' observeEvent(+ |
+
| 85 | ++ |
+ #' input$button3_range,+ |
+
| 86 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = FALSE))+ |
+
| 87 | ++ |
+ #' )+ |
+
| 88 | ++ |
+ #' observeEvent(+ |
+
| 89 | ++ |
+ #' input$button4_range,+ |
+
| 90 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_inf = TRUE))+ |
+
| 91 | ++ |
+ #' )+ |
+
| 92 | ++ |
+ #' observeEvent(+ |
+
| 93 | ++ |
+ #' input$button5_range,+ |
+
| 94 | ++ |
+ #' fs$set_state(+ |
+
| 95 | ++ |
+ #' teal_slice(dataname = "data", varname = "x", selected = c(0.2, 0.74))+ |
+
| 96 | ++ |
+ #' )+ |
+
| 97 | ++ |
+ #' )+ |
+
| 98 | ++ |
+ #' observeEvent(+ |
+
| 99 | ++ |
+ #' input$button6_range,+ |
+
| 100 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = c(0, 1)))+ |
+
| 101 | ++ |
+ #' )+ |
+
| 102 | ++ |
+ #' observeEvent(+ |
+
| 103 | ++ |
+ #' input$button0_range,+ |
+
| 104 | ++ |
+ #' fs$set_state(+ |
+
| 105 | ++ |
+ #' teal_slice("data", "variable", selected = c(0.15, 0.93), keep_na = TRUE, keep_inf = TRUE)
+ |
+
| 106 | ++ |
+ #' )+ |
+
| 107 | ++ |
+ #' )+ |
+
| 108 | ++ |
+ #' }+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' if (interactive()) {
+ |
+
| 111 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 112 | ++ |
+ #' }+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ RangeFilterState <- R6::R6Class( # nolint+ |
+
| 115 | ++ |
+ "RangeFilterState",+ |
+
| 116 | ++ |
+ inherit = FilterState,+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ # public methods ----+ |
+
| 119 | ++ |
+ public = list(+ |
+
| 120 | ++ | + + | +
| 121 | ++ |
+ #' @description+ |
+
| 122 | ++ |
+ #' Initialize a `FilterState` object for range selection+ |
+
| 123 | ++ |
+ #' @param x (`numeric`)\cr+ |
+
| 124 | ++ |
+ #' values of the variable used in filter+ |
+
| 125 | ++ |
+ #' @param x_reactive (`reactive`)\cr+ |
+
| 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`)\cr+ |
+
| 131 | ++ |
+ #' object created using [teal_slice()]. `teal_slice` is stored+ |
+
| 132 | ++ |
+ #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`+ |
+
| 133 | ++ |
+ #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`+ |
+
| 134 | ++ |
+ #' is a `reactiveValues` which means that changes in particular object are automatically+ |
+
| 135 | ++ |
+ #' reflected in all places which refer to the same `teal_slice`.+ |
+
| 136 | ++ |
+ #' @param extract_type (`character(0)`, `character(1)`)\cr+ |
+
| 137 | ++ |
+ #' whether condition calls should be prefixed by `dataname`. Possible values:+ |
+
| 138 | ++ |
+ #' \itemize{
+ |
+
| 139 | ++ |
+ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
+ |
+
| 140 | ++ |
+ #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
+ |
+
| 141 | ++ |
+ #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
+ |
+
| 142 | ++ |
+ #' }+ |
+
| 143 | ++ |
+ #' @param ... additional arguments to be saved as a list in `private$extras` field+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ initialize = function(x,+ |
+
| 146 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 147 | ++ |
+ extract_type = character(0),+ |
+
| 148 | ++ |
+ slice) {
+ |
+
| 149 | +126x | +
+ shiny::isolate({
+ |
+
| 150 | +126x | +
+ checkmate::assert_numeric(x, all.missing = FALSE)+ |
+
| 151 | +2x | +
+ if (!any(is.finite(x))) stop("\"x\" contains no finite values")
+ |
+
| 152 | +123x | +
+ super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type)+ |
+
| 153 | +123x | +
+ private$is_integer <- checkmate::test_integerish(x)+ |
+
| 154 | +123x | +
+ private$inf_count <- sum(is.infinite(x))+ |
+
| 155 | +123x | +
+ private$inf_filtered_count <- reactive(+ |
+
| 156 | +123x | +
+ if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive()))+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | ++ | + + | +
| 159 | +123x | +
+ checkmate::assert_numeric(slice$choices, null.ok = TRUE)+ |
+
| 160 | +3x | +
+ if (is.null(slice$keep_inf) && any(is.infinite(x))) slice$keep_inf <- TRUE+ |
+
| 161 | ++ | + + | +
| 162 | +122x | +
+ private$set_choices(slice$choices)+ |
+
| 163 | +44x | +
+ if (is.null(slice$selected)) slice$selected <- slice$choices+ |
+
| 164 | +122x | +
+ private$set_selected(slice$selected)+ |
+
| 165 | ++ | + + | +
| 166 | +119x | +
+ private$is_integer <- checkmate::test_integerish(x)+ |
+
| 167 | +119x | +
+ private$inf_filtered_count <- reactive(+ |
+
| 168 | +119x | +
+ if (!is.null(private$x_reactive())) sum(is.infinite(private$x_reactive()))+ |
+
| 169 | ++ |
+ )+ |
+
| 170 | +119x | +
+ private$inf_count <- sum(is.infinite(x))+ |
+
| 171 | ++ | + + | +
| 172 | +119x | +
+ private$plot_data <- list(+ |
+
| 173 | +119x | +
+ type = "histogram",+ |
+
| 174 | +119x | +
+ nbinsx = 50,+ |
+
| 175 | +119x | +
+ x = Filter(Negate(is.na), Filter(is.finite, private$x)),+ |
+
| 176 | +119x | +
+ color = I(fetch_bs_color("secondary")),
+ |
+
| 177 | +119x | +
+ alpha = 0.2,+ |
+
| 178 | +119x | +
+ bingroup = 1,+ |
+
| 179 | +119x | +
+ showlegend = FALSE,+ |
+
| 180 | +119x | +
+ hoverinfo = "none"+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | +119x | +
+ private$plot_mask <- list(list(+ |
+
| 183 | +119x | +
+ type = "rect", fillcolor = rgb(1, 1, 1, .65), line = list(width = 0),+ |
+
| 184 | +119x | +
+ x0 = -0.5, x1 = 1.5, y0 = -0.5, y1 = 1.5, xref = "paper", yref = "paper"+ |
+
| 185 | ++ |
+ ))+ |
+
| 186 | +119x | +
+ private$plot_layout <- reactive({
+ |
+
| 187 | +5x | +
+ shapes <- private$get_shape_properties(private$get_selected())+ |
+
| 188 | +5x | +
+ list(+ |
+
| 189 | +5x | +
+ barmode = "overlay",+ |
+
| 190 | +5x | +
+ xaxis = list(+ |
+
| 191 | +5x | +
+ range = private$get_choices(),+ |
+
| 192 | +5x | +
+ rangeslider = list(thickness = 0),+ |
+
| 193 | +5x | +
+ showticklabels = TRUE,+ |
+
| 194 | +5x | +
+ ticks = "outside",+ |
+
| 195 | +5x | +
+ ticklen = 2,+ |
+
| 196 | +5x | +
+ tickmode = "auto",+ |
+
| 197 | +5x | +
+ nticks = 10+ |
+
| 198 | ++ |
+ ),+ |
+
| 199 | +5x | +
+ yaxis = list(showgrid = FALSE, showticklabels = FALSE),+ |
+
| 200 | +5x | +
+ margin = list(b = 17, l = 0, r = 0, t = 0, autoexpand = FALSE),+ |
+
| 201 | +5x | +
+ plot_bgcolor = "#FFFFFF00",+ |
+
| 202 | +5x | +
+ paper_bgcolor = "#FFFFFF00",+ |
+
| 203 | +5x | +
+ shapes = shapes+ |
+
| 204 | ++ |
+ )+ |
+
| 205 | ++ |
+ })+ |
+
| 206 | +119x | +
+ private$plot_config <- reactive({
+ |
+
| 207 | +5x | +
+ list(+ |
+
| 208 | +5x | +
+ doubleClick = "reset",+ |
+
| 209 | +5x | +
+ displayModeBar = FALSE,+ |
+
| 210 | +5x | +
+ edits = list(shapePosition = TRUE)+ |
+
| 211 | ++ |
+ )+ |
+
| 212 | ++ |
+ })+ |
+
| 213 | +119x | +
+ private$plot_filtered <- reactive({
+ |
+
| 214 | +5x | +
+ finite_values <- Filter(is.finite, private$x_reactive())+ |
+
| 215 | +5x | +
+ list(+ |
+
| 216 | +5x | +
+ x = finite_values,+ |
+
| 217 | +5x | +
+ bingroup = 1,+ |
+
| 218 | +5x | +
+ color = I(fetch_bs_color("primary"))
+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ |
+ })+ |
+
| 221 | +119x | +
+ invisible(self)+ |
+
| 222 | ++ |
+ })+ |
+
| 223 | ++ |
+ },+ |
+
| 224 | ++ | + + | +
| 225 | ++ |
+ #' @description+ |
+
| 226 | ++ |
+ #' Returns reproducible condition call for current selection.+ |
+
| 227 | ++ |
+ #' For this class returned call looks like+ |
+
| 228 | ++ |
+ #' `<varname> >= <min value> & <varname> <= <max value>` with+ |
+
| 229 | ++ |
+ #' optional `is.na(<varname>)` and `is.finite(<varname>)`.+ |
+
| 230 | ++ |
+ #' @param dataname name of data set; defaults to `private$get_dataname()`+ |
+
| 231 | ++ |
+ #' @return (`call`)+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ get_call = function(dataname) {
+ |
+
| 234 | +34x | +
+ if (isFALSE(private$is_any_filtered())) {
+ |
+
| 235 | +1x | +
+ return(NULL)+ |
+
| 236 | ++ |
+ }+ |
+
| 237 | +4x | +
+ if (missing(dataname)) dataname <- private$get_dataname()+ |
+
| 238 | +33x | +
+ filter_call <-+ |
+
| 239 | +33x | +
+ call(+ |
+
| 240 | ++ |
+ "&",+ |
+
| 241 | +33x | +
+ call(">=", private$get_varname_prefixed(dataname), private$get_selected()[1L]),
+ |
+
| 242 | +33x | +
+ call("<=", private$get_varname_prefixed(dataname), private$get_selected()[2L])
+ |
+
| 243 | ++ |
+ )+ |
+
| 244 | +33x | +
+ private$add_keep_na_call(private$add_keep_inf_call(filter_call, dataname), dataname)+ |
+
| 245 | ++ |
+ },+ |
+
| 246 | ++ | + + | +
| 247 | ++ |
+ #' @description+ |
+
| 248 | ++ |
+ #' Returns current `keep_inf` selection+ |
+
| 249 | ++ |
+ #' @return (`logical(1)`)+ |
+
| 250 | ++ |
+ get_keep_inf = function() {
+ |
+
| 251 | +! | +
+ private$teal_slice$keep_inf+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ |
+ ),+ |
+
| 254 | ++ | + + | +
| 255 | ++ |
+ # private fields----+ |
+
| 256 | ++ |
+ private = list(+ |
+
| 257 | ++ |
+ inf_count = integer(0),+ |
+
| 258 | ++ |
+ inf_filtered_count = NULL,+ |
+
| 259 | ++ |
+ is_integer = logical(0),+ |
+
| 260 | ++ |
+ numeric_step = numeric(0), # step for the slider input widget, calculated from input data (x)+ |
+
| 261 | ++ |
+ plot_data = NULL,+ |
+
| 262 | ++ |
+ plot_mask = list(),+ |
+
| 263 | ++ |
+ plot_layout = NULL,+ |
+
| 264 | ++ |
+ plot_config = NULL,+ |
+
| 265 | ++ |
+ plot_filtered = NULL,+ |
+
| 266 | ++ | + + | +
| 267 | ++ |
+ # private methods ----+ |
+
| 268 | ++ | + + | +
| 269 | ++ |
+ set_choices = function(choices) {
+ |
+
| 270 | +122x | +
+ x <- private$x[is.finite(private$x)]+ |
+
| 271 | +122x | +
+ if (is.null(choices)) {
+ |
+
| 272 | +110x | +
+ choices <- range(x)+ |
+
| 273 | ++ |
+ } else {
+ |
+
| 274 | +12x | +
+ choices_adjusted <- c(max(choices[1L], min(x)), min(choices[2L], max(x)))+ |
+
| 275 | +12x | +
+ if (any(choices != choices_adjusted)) {
+ |
+
| 276 | +1x | +
+ warning(sprintf(+ |
+
| 277 | +1x | +
+ "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",+ |
+
| 278 | +1x | +
+ private$get_varname(), private$get_dataname()+ |
+
| 279 | ++ |
+ ))+ |
+
| 280 | +1x | +
+ choices <- choices_adjusted+ |
+
| 281 | ++ |
+ }+ |
+
| 282 | +12x | +
+ if (choices[1L] > choices[2L]) {
+ |
+
| 283 | +1x | +
+ warning(sprintf(+ |
+
| 284 | +1x | +
+ "Invalid choices: lower is higher / equal to upper, or not in range of variable values.+ |
+
| 285 | +1x | +
+ Setting defaults. Varname: %s, dataname: %s.",+ |
+
| 286 | +1x | +
+ private$get_varname(), private$get_dataname()+ |
+
| 287 | ++ |
+ ))+ |
+
| 288 | +1x | +
+ choices <- range(x)+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | ++ |
+ }+ |
+
| 291 | ++ | + + | +
| 292 | +122x | +
+ private$set_is_choice_limited(private$x, choices)+ |
+
| 293 | +122x | +
+ private$x <- private$x[+ |
+
| 294 | +122x | +
+ (private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x) | !is.finite(private$x)+ |
+
| 295 | ++ |
+ ]+ |
+
| 296 | ++ | + + | +
| 297 | +122x | +
+ x_range <- range(private$x, finite = TRUE)+ |
+
| 298 | ++ | + + | +
| 299 | ++ |
+ # Required for displaying ticks on the slider, can modify choices!+ |
+
| 300 | +122x | +
+ if (identical(diff(x_range), 0)) {
+ |
+
| 301 | +2x | +
+ choices <- x_range+ |
+
| 302 | ++ |
+ } else {
+ |
+
| 303 | +120x | +
+ x_pretty <- pretty(x_range, 100L)+ |
+
| 304 | +120x | +
+ choices <- range(x_pretty)+ |
+
| 305 | +120x | +
+ private$numeric_step <- signif(private$get_pretty_range_step(x_pretty), digits = 10)+ |
+
| 306 | ++ |
+ }+ |
+
| 307 | +122x | +
+ private$teal_slice$choices <- choices+ |
+
| 308 | +122x | +
+ invisible(NULL)+ |
+
| 309 | ++ |
+ },+ |
+
| 310 | ++ | + + | +
| 311 | ++ |
+ # @description+ |
+
| 312 | ++ |
+ # Check whether the initial choices filter out some values of x and set the flag in case.+ |
+
| 313 | ++ |
+ set_is_choice_limited = function(xl, choices) {
+ |
+
| 314 | +122x | +
+ xl <- xl[!is.na(xl)]+ |
+
| 315 | +122x | +
+ xl <- xl[is.finite(xl)]+ |
+
| 316 | +122x | +
+ private$is_choice_limited <- (any(xl < choices[1L]) | any(xl > choices[2L]))+ |
+
| 317 | +122x | +
+ invisible(NULL)+ |
+
| 318 | ++ |
+ },+ |
+
| 319 | ++ | + + | +
| 320 | ++ |
+ # Adds is.infinite(varname) before existing condition calls if keep_inf is selected+ |
+
| 321 | ++ |
+ # returns a call+ |
+
| 322 | ++ |
+ add_keep_inf_call = function(filter_call, dataname) {
+ |
+
| 323 | +33x | +
+ if (isTRUE(private$get_keep_inf())) {
+ |
+
| 324 | +2x | +
+ call("|", call("is.infinite", private$get_varname_prefixed(dataname)), filter_call)
+ |
+
| 325 | ++ |
+ } else {
+ |
+
| 326 | +31x | +
+ filter_call+ |
+
| 327 | ++ |
+ }+ |
+
| 328 | ++ |
+ },+ |
+
| 329 | ++ | + + | +
| 330 | ++ |
+ # @description gets pretty step size for range slider+ |
+
| 331 | ++ |
+ # adaptation of shiny's method (see shiny/R/input-slider.R function findStepSize)+ |
+
| 332 | ++ |
+ # @param pretty_range (numeric(n)) vector of pretty values+ |
+
| 333 | ++ |
+ # @return numeric(1) pretty step size for the sliderInput+ |
+
| 334 | ++ |
+ get_pretty_range_step = function(pretty_range) {
+ |
+
| 335 | +122x | +
+ if (private$is_integer && diff(range(pretty_range) > 2)) {
+ |
+
| 336 | +45x | +
+ return(1L)+ |
+
| 337 | ++ |
+ } else {
+ |
+
| 338 | +77x | +
+ n_steps <- length(pretty_range) - 1+ |
+
| 339 | +77x | +
+ return(+ |
+
| 340 | +77x | +
+ signif(digits = 10, (max(pretty_range) - min(pretty_range)) / n_steps)+ |
+
| 341 | ++ |
+ )+ |
+
| 342 | ++ |
+ }+ |
+
| 343 | ++ |
+ },+ |
+
| 344 | ++ | + + | +
| 345 | ++ |
+ # overwrites superclass method+ |
+
| 346 | ++ |
+ validate_selection = function(value) {
+ |
+
| 347 | +130x | +
+ if (!is.numeric(value)) {
+ |
+
| 348 | +! | +
+ stop(+ |
+
| 349 | +! | +
+ sprintf(+ |
+
| 350 | +! | +
+ "value of the selection for `%s` in `%s` should be a numeric",+ |
+
| 351 | +! | +
+ private$get_varname(),+ |
+
| 352 | +! | +
+ private$get_dataname()+ |
+
| 353 | ++ |
+ )+ |
+
| 354 | ++ |
+ )+ |
+
| 355 | ++ |
+ }+ |
+
| 356 | +130x | +
+ invisible(NULL)+ |
+
| 357 | ++ |
+ },+ |
+
| 358 | ++ | + + | +
| 359 | ++ |
+ # overwrites superclass method+ |
+
| 360 | ++ |
+ # additionally adjusts progtammatic selection to existing slider ticks+ |
+
| 361 | ++ |
+ cast_and_validate = function(values) {
+ |
+
| 362 | +! | +
+ if (!is.atomic(values)) stop("Values to set must be an atomic vector.")
+ |
+
| 363 | +138x | +
+ values <- as.numeric(values)+ |
+
| 364 | +4x | +
+ if (any(is.na(values))) stop("Vector of set values must contain values coercible to numeric.")
+ |
+
| 365 | +2x | +
+ if (length(values) != 2) stop("Vector of set values must have length two.")
+ |
+
| 366 | +2x | +
+ if (values[1L] > values[2L]) stop("Vector of set values must be sorted.")
+ |
+
| 367 | ++ | + + | +
| 368 | +130x | +
+ values+ |
+
| 369 | ++ |
+ },+ |
+
| 370 | ++ |
+ # Trim selection to limits imposed by private$get_choices()+ |
+
| 371 | ++ |
+ remove_out_of_bound_values = function(values) {
+ |
+
| 372 | +2x | +
+ if (values[1L] < private$get_choices()[1L]) values[1L] <- private$get_choices()[1L]+ |
+
| 373 | +2x | +
+ if (values[2L] > private$get_choices()[2L]) values[2L] <- private$get_choices()[2L]+ |
+
| 374 | +130x | +
+ values+ |
+
| 375 | ++ |
+ },+ |
+
| 376 | ++ | + + | +
| 377 | ++ |
+ # Answers the question of whether the current settings and values selected actually filters out any values.+ |
+
| 378 | ++ |
+ # @return logical scalar+ |
+
| 379 | ++ |
+ is_any_filtered = function() {
+ |
+
| 380 | +34x | +
+ if (private$is_choice_limited) {
+ |
+
| 381 | +1x | +
+ TRUE+ |
+
| 382 | +33x | +
+ } else if (!isTRUE(all.equal(private$get_selected(), private$get_choices()))) {
+ |
+
| 383 | +31x | +
+ TRUE+ |
+
| 384 | +2x | +
+ } else if (!isTRUE(private$get_keep_inf()) && private$inf_count > 0) {
+ |
+
| 385 | +! | +
+ TRUE+ |
+
| 386 | +2x | +
+ } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 387 | +1x | +
+ TRUE+ |
+
| 388 | ++ |
+ } else {
+ |
+
| 389 | +1x | +
+ FALSE+ |
+
| 390 | ++ |
+ }+ |
+
| 391 | ++ |
+ },+ |
+
| 392 | ++ | + + | +
| 393 | ++ |
+ # obtain shape determination for histogram+ |
+
| 394 | ++ |
+ # returns a list that is passed to plotly's layout.shapes property+ |
+
| 395 | ++ |
+ get_shape_properties = function(values) {
+ |
+
| 396 | +5x | +
+ list(+ |
+
| 397 | +5x | +
+ list(type = "line", x0 = values[1], x1 = values[1], y0 = -100, y1 = 100, yref = "paper"),+ |
+
| 398 | +5x | +
+ list(type = "line", x0 = values[2], x1 = values[2], y0 = -100, y1 = 100, yref = "paper")+ |
+
| 399 | ++ |
+ )+ |
+
| 400 | ++ |
+ },+ |
+
| 401 | ++ | + + | +
| 402 | ++ |
+ # shiny modules ----+ |
+
| 403 | ++ | + + | +
| 404 | ++ |
+ # UI Module for `RangeFilterState`.+ |
+
| 405 | ++ |
+ # This UI element contains two values for `min` and `max`+ |
+
| 406 | ++ |
+ # of the range and two checkboxes whether to keep the `NA` or `Inf` values.+ |
+
| 407 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 408 | ++ |
+ # id of shiny element+ |
+
| 409 | ++ |
+ ui_inputs = function(id) {
+ |
+
| 410 | +5x | +
+ ns <- NS(id)+ |
+
| 411 | +5x | +
+ shiny::isolate({
+ |
+
| 412 | +5x | +
+ ui_input <- shinyWidgets::numericRangeInput(+ |
+
| 413 | +5x | +
+ inputId = ns("selection_manual"),
+ |
+
| 414 | +5x | +
+ label = NULL,+ |
+
| 415 | +5x | +
+ min = private$get_choices()[1L],+ |
+
| 416 | +5x | +
+ max = private$get_choices()[2L],+ |
+
| 417 | +5x | +
+ value = private$get_selected(),+ |
+
| 418 | +5x | +
+ step = private$numeric_step,+ |
+
| 419 | +5x | +
+ width = "100%"+ |
+
| 420 | ++ |
+ )+ |
+
| 421 | +5x | +
+ tagList(+ |
+
| 422 | +5x | +
+ div(+ |
+
| 423 | +5x | +
+ class = "choices_state",+ |
+
| 424 | +5x | +
+ tags$head(tags$script(+ |
+
| 425 | ++ |
+ # Inline JS code for popover functionality.+ |
+
| 426 | ++ |
+ # Adding the script inline because when added from a file with include_js_files(),+ |
+
| 427 | ++ |
+ # it only works in the first info_button instance and not others.+ |
+
| 428 | +5x | +
+ HTML(+ |
+
| 429 | +5x | +
+ '$(document).ready(function() {
+ |
+
| 430 | +5x | +
+ $("[data-toggle=\'popover\']").popover();
+ |
+
| 431 | ++ | + + | +
| 432 | +5x | +
+ $(document).on("click", function (e) {
+ |
+
| 433 | +5x | +
+ if (!$("[data-toggle=\'popover\']").is(e.target) &&
+ |
+
| 434 | +5x | +
+ $("[data-toggle=\'popover\']").has(e.target).length === 0 &&
+ |
+
| 435 | +5x | +
+ $(".popover").has(e.target).length === 0) {
+ |
+
| 436 | +5x | +
+ $("[data-toggle=\'popover\']").popover("hide");
+ |
+
| 437 | ++ |
+ }+ |
+
| 438 | ++ |
+ });+ |
+
| 439 | ++ |
+ });'+ |
+
| 440 | ++ |
+ )+ |
+
| 441 | ++ |
+ )),+ |
+
| 442 | +5x | +
+ div(+ |
+
| 443 | +5x | +
+ actionLink(+ |
+
| 444 | +5x | +
+ ns("plotly_info"),
+ |
+
| 445 | +5x | +
+ label = NULL,+ |
+
| 446 | +5x | +
+ icon = icon("question-circle"),
+ |
+
| 447 | +5x | +
+ "data-toggle" = "popover",+ |
+
| 448 | +5x | +
+ "data-html" = "true",+ |
+
| 449 | +5x | +
+ "data-placement" = "left",+ |
+
| 450 | +5x | +
+ "data-trigger" = "click",+ |
+
| 451 | +5x | +
+ "data-title" = "Plot actions",+ |
+
| 452 | +5x | +
+ "data-content" = "<p>+ |
+
| 453 | +5x | +
+ Drag vertical lines to set selection.<br>+ |
+
| 454 | +5x | +
+ Drag across plot to zoom in.<br>+ |
+
| 455 | +5x | +
+ Drag axis to pan.<br>+ |
+
| 456 | +5x | +
+ Double click to zoom out."+ |
+
| 457 | ++ |
+ ),+ |
+
| 458 | +5x | +
+ style = "text-align: right; font-size: 0.7em; margin-bottom: -1em; position: relative; z-index: 9;"+ |
+
| 459 | ++ |
+ ),+ |
+
| 460 | +5x | +
+ shinycssloaders::withSpinner(+ |
+
| 461 | +5x | +
+ plotly::plotlyOutput(ns("plot"), height = "50px"),
+ |
+
| 462 | +5x | +
+ type = 4,+ |
+
| 463 | +5x | +
+ size = 0.25,+ |
+
| 464 | +5x | +
+ hide.ui = FALSE+ |
+
| 465 | ++ |
+ ),+ |
+
| 466 | +5x | +
+ ui_input+ |
+
| 467 | ++ |
+ ),+ |
+
| 468 | +5x | +
+ div(+ |
+
| 469 | +5x | +
+ class = "filter-card-body-keep-na-inf",+ |
+
| 470 | +5x | +
+ private$keep_inf_ui(ns("keep_inf")),
+ |
+
| 471 | +5x | +
+ private$keep_na_ui(ns("keep_na"))
+ |
+
| 472 | ++ |
+ )+ |
+
| 473 | ++ |
+ )+ |
+
| 474 | ++ |
+ })+ |
+
| 475 | ++ |
+ },+ |
+
| 476 | ++ | + + | +
| 477 | ++ |
+ # @description+ |
+
| 478 | ++ |
+ # Server module+ |
+
| 479 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 480 | ++ |
+ # an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 481 | ++ |
+ # return `moduleServer` function which returns `NULL`+ |
+
| 482 | ++ |
+ server_inputs = function(id) {
+ |
+
| 483 | +5x | +
+ moduleServer(+ |
+
| 484 | +5x | +
+ id = id,+ |
+
| 485 | +5x | +
+ function(input, output, session) {
+ |
+
| 486 | +5x | +
+ logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }")
+ |
+
| 487 | ++ | + + | +
| 488 | ++ |
+ # Capture manual input with debounce.+ |
+
| 489 | +5x | +
+ selection_manual <- debounce(reactive(input$selection_manual), 200)+ |
+
| 490 | ++ | + + | +
| 491 | ++ |
+ # Prepare for histogram construction.+ |
+
| 492 | +5x | +
+ plot_data <- c(private$plot_data, source = session$ns("histogram_plot"))
+ |
+
| 493 | ++ | + + | +
| 494 | ++ |
+ # Display histogram, adding a second trace that contains filtered data.+ |
+
| 495 | +5x | +
+ output$plot <- plotly::renderPlotly({
+ |
+
| 496 | +5x | +
+ histogram <- do.call(plotly::plot_ly, plot_data)+ |
+
| 497 | +5x | +
+ histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout()))+ |
+
| 498 | +5x | +
+ histogram <- do.call(plotly::config, c(list(p = histogram), private$plot_config()))+ |
+
| 499 | +5x | +
+ histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered()))+ |
+
| 500 | +5x | +
+ histogram+ |
+
| 501 | ++ |
+ })+ |
+
| 502 | ++ | + + | +
| 503 | ++ |
+ # Dragging shapes (lines) on plot updates selection.+ |
+
| 504 | +5x | +
+ private$observers$relayout <-+ |
+
| 505 | +5x | +
+ observeEvent(+ |
+
| 506 | +5x | +
+ ignoreNULL = FALSE,+ |
+
| 507 | +5x | +
+ ignoreInit = TRUE,+ |
+
| 508 | +5x | +
+ eventExpr = plotly::event_data("plotly_relayout", source = session$ns("histogram_plot")),
+ |
+
| 509 | +5x | +
+ handlerExpr = {
+ |
+
| 510 | +1x | +
+ logger::log_trace("RangeFilterState$server@1 selection changed, id: { private$get_id() }")
+ |
+
| 511 | +1x | +
+ event <- plotly::event_data("plotly_relayout", source = session$ns("histogram_plot"))
+ |
+
| 512 | +1x | +
+ if (any(grepl("shapes", names(event)))) {
+ |
+
| 513 | +! | +
+ line_positions <- private$get_selected()+ |
+
| 514 | +! | +
+ if (any(grepl("shapes[0]", names(event), fixed = TRUE))) {
+ |
+
| 515 | +! | +
+ line_positions[1] <- event[["shapes[0].x0"]]+ |
+
| 516 | +! | +
+ } else if (any(grepl("shapes[1]", names(event), fixed = TRUE))) {
+ |
+
| 517 | +! | +
+ line_positions[2] <- event[["shapes[1].x0"]]+ |
+
| 518 | ++ |
+ }+ |
+
| 519 | ++ |
+ # If one line was dragged past the other, abort action and reset lines.+ |
+
| 520 | +! | +
+ if (line_positions[1] > line_positions[2]) {
+ |
+
| 521 | +! | +
+ showNotification(+ |
+
| 522 | +! | +
+ "Numeric range start value must be less than end value.",+ |
+
| 523 | +! | +
+ type = "warning"+ |
+
| 524 | ++ |
+ )+ |
+
| 525 | +! | +
+ plotly::plotlyProxyInvoke(+ |
+
| 526 | +! | +
+ plotly::plotlyProxy("plot"),
+ |
+
| 527 | +! | +
+ "relayout",+ |
+
| 528 | +! | +
+ shapes = private$get_shape_properties(private$get_selected())+ |
+
| 529 | ++ |
+ )+ |
+
| 530 | +! | +
+ return(NULL)+ |
+
| 531 | ++ |
+ }+ |
+
| 532 | ++ | + + | +
| 533 | +! | +
+ private$set_selected(signif(line_positions, digits = 4L))+ |
+
| 534 | ++ |
+ }+ |
+
| 535 | ++ |
+ }+ |
+
| 536 | ++ |
+ )+ |
+
| 537 | ++ | + + | +
| 538 | ++ |
+ # Change in selection updates shapes (lines) on plot and numeric input.+ |
+
| 539 | +5x | +
+ private$observers$selection_api <-+ |
+
| 540 | +5x | +
+ observeEvent(+ |
+
| 541 | +5x | +
+ ignoreNULL = FALSE,+ |
+
| 542 | +5x | +
+ ignoreInit = TRUE,+ |
+
| 543 | +5x | +
+ eventExpr = private$get_selected(),+ |
+
| 544 | +5x | +
+ handlerExpr = {
+ |
+
| 545 | +! | +
+ logger::log_trace("RangeFilterState$server@2 state changed, id: {private$get_id() }")
+ |
+
| 546 | +! | +
+ if (!isTRUE(all.equal(private$get_selected(), selection_manual()))) {
+ |
+
| 547 | +! | +
+ shinyWidgets::updateNumericRangeInput(+ |
+
| 548 | +! | +
+ session = session,+ |
+
| 549 | +! | +
+ inputId = "selection_manual",+ |
+
| 550 | +! | +
+ value = private$get_selected()+ |
+
| 551 | ++ |
+ )+ |
+
| 552 | ++ |
+ }+ |
+
| 553 | ++ |
+ }+ |
+
| 554 | ++ |
+ )+ |
+
| 555 | ++ | + + | +
| 556 | ++ |
+ # Manual input updates selection.+ |
+
| 557 | +5x | +
+ private$observers$selection_manual <- observeEvent(+ |
+
| 558 | +5x | +
+ ignoreNULL = FALSE,+ |
+
| 559 | +5x | +
+ ignoreInit = TRUE,+ |
+
| 560 | +5x | +
+ eventExpr = selection_manual(),+ |
+
| 561 | +5x | +
+ handlerExpr = {
+ |
+
| 562 | +! | +
+ selection <- selection_manual()+ |
+
| 563 | ++ |
+ # Abort and reset if non-numeric values is entered.+ |
+
| 564 | +! | +
+ if (any(is.na(selection))) {
+ |
+
| 565 | +! | +
+ showNotification(+ |
+
| 566 | +! | +
+ "Numeric range values must be numbers.",+ |
+
| 567 | +! | +
+ type = "warning"+ |
+
| 568 | ++ |
+ )+ |
+
| 569 | +! | +
+ shinyWidgets::updateNumericRangeInput(+ |
+
| 570 | +! | +
+ session = session,+ |
+
| 571 | +! | +
+ inputId = "selection_manual",+ |
+
| 572 | +! | +
+ value = private$get_selected()+ |
+
| 573 | ++ |
+ )+ |
+
| 574 | +! | +
+ return(NULL)+ |
+
| 575 | ++ |
+ }+ |
+
| 576 | ++ | + + | +
| 577 | ++ |
+ # Abort and reset if reversed choices are specified.+ |
+
| 578 | +! | +
+ if (selection[1] > selection[2]) {
+ |
+
| 579 | +! | +
+ showNotification(+ |
+
| 580 | +! | +
+ "Numeric range start value must be less than end value.",+ |
+
| 581 | +! | +
+ type = "warning"+ |
+
| 582 | ++ |
+ )+ |
+
| 583 | +! | +
+ shinyWidgets::updateNumericRangeInput(+ |
+
| 584 | +! | +
+ session = session,+ |
+
| 585 | +! | +
+ inputId = "selection_manual",+ |
+
| 586 | +! | +
+ value = private$get_selected()+ |
+
| 587 | ++ |
+ )+ |
+
| 588 | +! | +
+ return(NULL)+ |
+
| 589 | ++ |
+ }+ |
+
| 590 | ++ | + + | +
| 591 | ++ | + + | +
| 592 | +! | +
+ if (!isTRUE(all.equal(selection, private$get_selected()))) {
+ |
+
| 593 | +! | +
+ logger::log_trace("RangeFilterState$server@3 manual selection changed, id: { private$get_id() }")
+ |
+
| 594 | +! | +
+ private$set_selected(selection)+ |
+
| 595 | ++ |
+ }+ |
+
| 596 | ++ |
+ }+ |
+
| 597 | ++ |
+ )+ |
+
| 598 | ++ | + + | +
| 599 | +5x | +
+ private$keep_inf_srv("keep_inf")
+ |
+
| 600 | +5x | +
+ private$keep_na_srv("keep_na")
+ |
+
| 601 | ++ | + + | +
| 602 | +5x | +
+ logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
+ |
+
| 603 | +5x | +
+ NULL+ |
+
| 604 | ++ |
+ }+ |
+
| 605 | ++ |
+ )+ |
+
| 606 | ++ |
+ },+ |
+
| 607 | ++ |
+ server_inputs_fixed = function(id) {
+ |
+
| 608 | +! | +
+ moduleServer(+ |
+
| 609 | +! | +
+ id = id,+ |
+
| 610 | +! | +
+ function(input, output, session) {
+ |
+
| 611 | +! | +
+ logger::log_trace("RangeFilterState$server initializing, id: { private$get_id() }")
+ |
+
| 612 | ++ | + + | +
| 613 | +! | +
+ plot_config <- private$plot_config()+ |
+
| 614 | +! | +
+ plot_config$staticPlot <- TRUE+ |
+
| 615 | ++ | + + | +
| 616 | +! | +
+ output$plot <- plotly::renderPlotly({
+ |
+
| 617 | +! | +
+ histogram <- do.call(plotly::plot_ly, private$plot_data)+ |
+
| 618 | +! | +
+ histogram <- do.call(plotly::layout, c(list(p = histogram), private$plot_layout()))+ |
+
| 619 | +! | +
+ histogram <- do.call(plotly::config, c(list(p = histogram), plot_config))+ |
+
| 620 | +! | +
+ histogram <- do.call(plotly::add_histogram, c(list(p = histogram), private$plot_filtered()))+ |
+
| 621 | +! | +
+ histogram+ |
+
| 622 | ++ |
+ })+ |
+
| 623 | ++ | + + | +
| 624 | +! | +
+ output$selection <- renderUI({
+ |
+
| 625 | +! | +
+ shinycssloaders::withSpinner(+ |
+
| 626 | +! | +
+ plotly::plotlyOutput(session$ns("plot"), height = "50px"),
+ |
+
| 627 | +! | +
+ type = 4,+ |
+
| 628 | +! | +
+ size = 0.25+ |
+
| 629 | ++ |
+ )+ |
+
| 630 | ++ |
+ })+ |
+
| 631 | ++ | + + | +
| 632 | +! | +
+ logger::log_trace("RangeFilterState$server initialized, id: { private$get_id() }")
+ |
+
| 633 | +! | +
+ NULL+ |
+
| 634 | ++ |
+ }+ |
+
| 635 | ++ |
+ )+ |
+
| 636 | ++ |
+ },+ |
+
| 637 | ++ | + + | +
| 638 | ++ |
+ # @description+ |
+
| 639 | ++ |
+ # Server module to display filter summary+ |
+
| 640 | ++ |
+ # renders text describing selected range and+ |
+
| 641 | ++ |
+ # if NA or Inf are included also+ |
+
| 642 | ++ |
+ # @return `shiny.tag` to include in the `ui_summary`+ |
+
| 643 | ++ |
+ content_summary = function() {
+ |
+
| 644 | +5x | +
+ selection <- private$get_selected()+ |
+
| 645 | +5x | +
+ tagList(+ |
+
| 646 | +5x | +
+ tags$span(shiny::HTML(selection[1], "–", selection[2]), class = "filter-card-summary-value"),+ |
+
| 647 | +5x | +
+ tags$span(+ |
+
| 648 | +5x | +
+ class = "filter-card-summary-controls",+ |
+
| 649 | +5x | +
+ if (isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 650 | +! | +
+ tags$span(+ |
+
| 651 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 652 | +! | +
+ "NA",+ |
+
| 653 | +! | +
+ shiny::icon("check")
+ |
+
| 654 | ++ |
+ )+ |
+
| 655 | +5x | +
+ } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 656 | +! | +
+ tags$span(+ |
+
| 657 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 658 | +! | +
+ "NA",+ |
+
| 659 | +! | +
+ shiny::icon("xmark")
+ |
+
| 660 | ++ |
+ )+ |
+
| 661 | ++ |
+ } else {
+ |
+
| 662 | +5x | +
+ NULL+ |
+
| 663 | ++ |
+ },+ |
+
| 664 | +5x | +
+ if (isTRUE(private$get_keep_inf()) && private$inf_count > 0) {
+ |
+
| 665 | +! | +
+ tags$span(+ |
+
| 666 | +! | +
+ class = "filter-card-summary-inf",+ |
+
| 667 | +! | +
+ "Inf",+ |
+
| 668 | +! | +
+ shiny::icon("check")
+ |
+
| 669 | ++ |
+ )+ |
+
| 670 | +5x | +
+ } else if (isFALSE(private$get_keep_inf()) && private$inf_count > 0) {
+ |
+
| 671 | +! | +
+ tags$span(+ |
+
| 672 | +! | +
+ class = "filter-card-summary-inf",+ |
+
| 673 | +! | +
+ "Inf",+ |
+
| 674 | +! | +
+ shiny::icon("xmark")
+ |
+
| 675 | ++ |
+ )+ |
+
| 676 | ++ |
+ } else {
+ |
+
| 677 | +5x | +
+ NULL+ |
+
| 678 | ++ |
+ }+ |
+
| 679 | ++ |
+ )+ |
+
| 680 | ++ |
+ )+ |
+
| 681 | ++ |
+ },+ |
+
| 682 | ++ | + + | +
| 683 | ++ |
+ # @description+ |
+
| 684 | ++ |
+ # module displaying input to keep or remove Inf in the FilterState call+ |
+
| 685 | ++ |
+ # @param id `shiny` id parameter+ |
+
| 686 | ++ |
+ # renders checkbox input only when variable from which FilterState has+ |
+
| 687 | ++ |
+ # been created has some Inf values.+ |
+
| 688 | ++ |
+ keep_inf_ui = function(id) {
+ |
+
| 689 | +5x | +
+ ns <- NS(id)+ |
+
| 690 | ++ | + + | +
| 691 | +5x | +
+ if (private$inf_count > 0) {
+ |
+
| 692 | +! | +
+ countmax <- private$na_count+ |
+
| 693 | +! | +
+ countnow <- isolate(private$filtered_na_count())+ |
+
| 694 | +! | +
+ ui_input <- checkboxInput(+ |
+
| 695 | +! | +
+ inputId = ns("value"),
+ |
+
| 696 | +! | +
+ label = tags$span(+ |
+
| 697 | +! | +
+ id = ns("count_label"),
+ |
+
| 698 | +! | +
+ make_count_text(+ |
+
| 699 | +! | +
+ label = "Keep Inf",+ |
+
| 700 | +! | +
+ countmax = countmax,+ |
+
| 701 | +! | +
+ countnow = countnow+ |
+
| 702 | ++ |
+ )+ |
+
| 703 | ++ |
+ ),+ |
+
| 704 | +! | +
+ value = isolate(private$get_keep_inf())+ |
+
| 705 | ++ |
+ )+ |
+
| 706 | +! | +
+ div(+ |
+
| 707 | +! | +
+ uiOutput(ns("trigger_visible"), inline = TRUE),
+ |
+
| 708 | +! | +
+ ui_input+ |
+
| 709 | ++ |
+ )+ |
+
| 710 | ++ |
+ } else {
+ |
+
| 711 | +5x | +
+ NULL+ |
+
| 712 | ++ |
+ }+ |
+
| 713 | ++ |
+ },+ |
+
| 714 | ++ | + + | +
| 715 | ++ |
+ # @description+ |
+
| 716 | ++ |
+ # module to handle Inf values in the FilterState+ |
+
| 717 | ++ |
+ # @param shiny `id` parametr passed to moduleServer+ |
+
| 718 | ++ |
+ # module sets `private$teal_slice$keep_inf` according to the selection.+ |
+
| 719 | ++ |
+ # Module also updates a UI element if the `private$teal_slice$keep_inf` has been+ |
+
| 720 | ++ |
+ # changed through the api+ |
+
| 721 | ++ |
+ keep_inf_srv = function(id) {
+ |
+
| 722 | +5x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 723 | ++ |
+ # 1. renderUI is used here as an observer which triggers only if output is visible+ |
+
| 724 | ++ |
+ # and if the reactive changes - reactive triggers only if the output is visible.+ |
+
| 725 | ++ |
+ # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)+ |
+
| 726 | +5x | +
+ output$trigger_visible <- renderUI({
+ |
+
| 727 | +5x | +
+ updateCountText(+ |
+
| 728 | +5x | +
+ inputId = "count_label",+ |
+
| 729 | +5x | +
+ label = "Keep Inf",+ |
+
| 730 | +5x | +
+ countmax = private$inf_count,+ |
+
| 731 | +5x | +
+ countnow = private$inf_filtered_count()+ |
+
| 732 | ++ |
+ )+ |
+
| 733 | +5x | +
+ NULL+ |
+
| 734 | ++ |
+ })+ |
+
| 735 | ++ | + + | +
| 736 | ++ |
+ # this observer is needed in the situation when private$teal_slice$keep_inf has been+ |
+
| 737 | ++ |
+ # changed directly by the api - then it's needed to rerender UI element+ |
+
| 738 | ++ |
+ # to show relevant values+ |
+
| 739 | +5x | +
+ private$observers$keep_inf_api <- observeEvent(+ |
+
| 740 | +5x | +
+ ignoreNULL = TRUE, # its not possible for range that NULL is selected+ |
+
| 741 | +5x | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 742 | +5x | +
+ eventExpr = private$get_keep_inf(),+ |
+
| 743 | +5x | +
+ handlerExpr = {
+ |
+
| 744 | +! | +
+ if (!setequal(private$get_keep_inf(), input$value)) {
+ |
+
| 745 | +! | +
+ logger::log_trace("RangeFilterState$keep_inf_srv@1 changed reactive value, id: { private$get_id() }")
+ |
+
| 746 | +! | +
+ updateCheckboxInput(+ |
+
| 747 | +! | +
+ inputId = "value",+ |
+
| 748 | +! | +
+ value = private$get_keep_inf()+ |
+
| 749 | ++ |
+ )+ |
+
| 750 | ++ |
+ }+ |
+
| 751 | ++ |
+ }+ |
+
| 752 | ++ |
+ )+ |
+
| 753 | ++ | + + | +
| 754 | +5x | +
+ private$observers$keep_inf <- observeEvent(+ |
+
| 755 | +5x | +
+ ignoreNULL = TRUE, # it's not possible for range that NULL is selected+ |
+
| 756 | +5x | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 757 | +5x | +
+ eventExpr = input$value,+ |
+
| 758 | +5x | +
+ handlerExpr = {
+ |
+
| 759 | +! | +
+ logger::log_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
+ |
+
| 760 | +! | +
+ keep_inf <- input$value+ |
+
| 761 | +! | +
+ private$set_keep_inf(keep_inf)+ |
+
| 762 | ++ |
+ }+ |
+
| 763 | ++ |
+ )+ |
+
| 764 | ++ | + + | +
| 765 | +5x | +
+ invisible(NULL)+ |
+
| 766 | ++ |
+ })+ |
+
| 767 | ++ |
+ }+ |
+
| 768 | ++ |
+ )+ |
+
| 769 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' @name FilterState+ |
+
| 2 | ++ |
+ #' @docType class+ |
+
| 3 | ++ |
+ #'+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @title `FilterState` Abstract Class+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @description Abstract class to encapsulate single filter state+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @details+ |
+
| 10 | ++ |
+ #' This class is responsible for managing single filter item within+ |
+
| 11 | ++ |
+ #' `FilteredData` class. Filter states depend on the variable type:+ |
+
| 12 | ++ |
+ #' (`logical`, `integer`, `numeric`, `factor`, `character`, `Date`, `POSIXct`, `POSIXlt`)+ |
+
| 13 | ++ |
+ #' and returns `FilterState` object with class corresponding to input variable.+ |
+
| 14 | ++ |
+ #' Class controls single filter entry in `module_single_filter_item` and returns+ |
+
| 15 | ++ |
+ #' code relevant to selected values.+ |
+
| 16 | ++ |
+ #' - `factor`, `character`: `class = ChoicesFilterState`+ |
+
| 17 | ++ |
+ #' - `numeric`: `class = RangeFilterState`+ |
+
| 18 | ++ |
+ #' - `logical`: `class = LogicalFilterState`+ |
+
| 19 | ++ |
+ #' - `Date`: `class = DateFilterState`+ |
+
| 20 | ++ |
+ #' - `POSIXct`, `POSIXlt`: `class = DatetimeFilterState`+ |
+
| 21 | ++ |
+ #' - all `NA` entries: `class: FilterState`, cannot be filtered+ |
+
| 22 | ++ |
+ #' - default: `FilterState`, cannot be filtered+ |
+
| 23 | ++ |
+ #' \cr+ |
+
| 24 | ++ |
+ #' Each variable's filter state is an `R6` object which contains `choices`,+ |
+
| 25 | ++ |
+ #' `selected`, `varname`, `dataname`, `labels`, `na_count`, `keep_na` and other+ |
+
| 26 | ++ |
+ #' variable type specific fields (`keep_inf`, `inf_count`, `timezone`).+ |
+
| 27 | ++ |
+ #' Object contains also shiny module (`ui` and `server`) which manages+ |
+
| 28 | ++ |
+ #' state of the filter through reactive values `selected`, `keep_na`, `keep_inf`+ |
+
| 29 | ++ |
+ #' which trigger `get_call()` and every R function call up in reactive chain.+ |
+
| 30 | ++ |
+ #' \cr+ |
+
| 31 | ++ |
+ #' \cr+ |
+
| 32 | ++ |
+ #' @section Modifying state:+ |
+
| 33 | ++ |
+ #' Modifying a `FilterState` object is possible in three scenarios:+ |
+
| 34 | ++ |
+ #' * In the interactive session by passing an appropriate `teal_slice`+ |
+
| 35 | ++ |
+ #' to the `set_state` method, or using+ |
+
| 36 | ++ |
+ #' `set_selected`, `set_keep_na` or `set_keep_inf` methods.+ |
+
| 37 | ++ |
+ #' * In a running application by changing appropriate inputs.+ |
+
| 38 | ++ |
+ #' * In a running application by using [filter_state_api] which directly uses+ |
+
| 39 | ++ |
+ #' `set_state` method of the `InteractiveFilterState` object.+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @keywords internal+ |
+
| 42 | ++ |
+ FilterState <- R6::R6Class( # nolint+ |
+
| 43 | ++ |
+ "FilterState",+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ # public methods ----+ |
+
| 46 | ++ |
+ public = list(+ |
+
| 47 | ++ | + + | +
| 48 | ++ |
+ #' @description+ |
+
| 49 | ++ |
+ #' Initialize a `FilterState` object+ |
+
| 50 | ++ |
+ #' @param x (`vector`)\cr+ |
+
| 51 | ++ |
+ #' values of the variable used in filter+ |
+
| 52 | ++ |
+ #' @param x_reactive (`reactive`)\cr+ |
+
| 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`)\cr+ |
+
| 58 | ++ |
+ #' object created by [teal_slice()]+ |
+
| 59 | ++ |
+ #' @param extract_type (`character(0)`, `character(1)`)\cr+ |
+
| 60 | ++ |
+ #' specifying whether condition calls should be prefixed by `dataname`. Possible values:+ |
+
| 61 | ++ |
+ #' \itemize{
+ |
+
| 62 | ++ |
+ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
+ |
+
| 63 | ++ |
+ #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
+ |
+
| 64 | ++ |
+ #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
+ |
+
| 65 | ++ |
+ #' }+ |
+
| 66 | ++ |
+ #' @param ... additional arguments to be saved as a list in `private$extras` field+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' @return self invisibly+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ initialize = function(x,+ |
+
| 71 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 72 | ++ |
+ slice,+ |
+
| 73 | ++ |
+ extract_type = character(0)) {
+ |
+
| 74 | +356x | +
+ checkmate::assert_class(x_reactive, "reactive")+ |
+
| 75 | +355x | +
+ checkmate::assert_class(slice, "teal_slice")+ |
+
| 76 | +353x | +
+ checkmate::assert_character(extract_type, max.len = 1, any.missing = FALSE)+ |
+
| 77 | +353x | +
+ if (length(extract_type) == 1) {
+ |
+
| 78 | +59x | +
+ checkmate::assert_choice(extract_type, choices = c("list", "matrix"))
+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | ++ | + + | +
| 81 | ++ |
+ # Set data properties.+ |
+
| 82 | +352x | +
+ private$x <- x+ |
+
| 83 | +352x | +
+ private$x_reactive <- x_reactive+ |
+
| 84 | ++ |
+ # Set derived data properties.+ |
+
| 85 | +352x | +
+ private$na_count <- sum(is.na(x))+ |
+
| 86 | +352x | +
+ private$filtered_na_count <- reactive(+ |
+
| 87 | +352x | +
+ if (!is.null(private$x_reactive())) {
+ |
+
| 88 | +! | +
+ sum(is.na(private$x_reactive()))+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | ++ |
+ # Set extract type.+ |
+
| 92 | +352x | +
+ private$extract_type <- extract_type+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ # Set state properties.+ |
+
| 95 | +14x | +
+ if (is.null(shiny::isolate(slice$keep_na)) && anyNA(x)) slice$keep_na <- TRUE+ |
+
| 96 | +352x | +
+ private$teal_slice <- slice+ |
+
| 97 | ++ |
+ # Obtain variable label.+ |
+
| 98 | +352x | +
+ varlabel <- attr(x, "label")+ |
+
| 99 | ++ |
+ # Display only when different from varname.+ |
+
| 100 | +352x | +
+ private$varlabel <-+ |
+
| 101 | +352x | +
+ if (is.null(varlabel) || identical(varlabel, private$get_varname())) {
+ |
+
| 102 | +351x | +
+ character(0)+ |
+
| 103 | ++ |
+ } else {
+ |
+
| 104 | +1x | +
+ varlabel+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ | + + | +
| 107 | +352x | +
+ logger::log_trace("Instantiated FilterState object id: { private$get_id() }")
+ |
+
| 108 | ++ | + + | +
| 109 | +352x | +
+ invisible(self)+ |
+
| 110 | ++ |
+ },+ |
+
| 111 | ++ | + + | +
| 112 | ++ |
+ #' @description+ |
+
| 113 | ++ |
+ #' Returns a formatted string representing this `FilterState` object.+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' @param show_all `logical(1)` passed to `format.teal_slice`+ |
+
| 116 | ++ |
+ #' @param trim_lines `logical(1)` passed to `format.teal_slice`+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' @return `character(1)` the formatted string+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ format = function(show_all = FALSE, trim_lines = TRUE) {
+ |
+
| 121 | +68x | +
+ sprintf(+ |
+
| 122 | +68x | +
+ "%s:\n%s",+ |
+
| 123 | +68x | +
+ class(self)[1],+ |
+
| 124 | +68x | +
+ format(self$get_state(), show_all = show_all, trim_lines = trim_lines)+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | ++ |
+ },+ |
+
| 127 | ++ | + + | +
| 128 | ++ |
+ #' @description+ |
+
| 129 | ++ |
+ #' Prints this `FilterState` object.+ |
+
| 130 | ++ |
+ #'+ |
+
| 131 | ++ |
+ #' @param ... additional arguments+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ print = function(...) {
+ |
+
| 134 | +14x | +
+ cat(shiny::isolate(self$format(...)))+ |
+
| 135 | ++ |
+ },+ |
+
| 136 | ++ | + + | +
| 137 | ++ |
+ #' @description+ |
+
| 138 | ++ |
+ #' Sets filtering state.+ |
+
| 139 | ++ |
+ #' - `fixed` state is prevented from changing state+ |
+
| 140 | ++ |
+ #' - `locked` state is prevented from removing state+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' @param state a `teal_slice` object+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' @return `self` invisibly+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ set_state = function(state) {
+ |
+
| 147 | +83x | +
+ checkmate::assert_class(state, "teal_slice")+ |
+
| 148 | +82x | +
+ if (private$is_fixed()) {
+ |
+
| 149 | +1x | +
+ logger::log_warn("attempt to set state on fixed filter aborted id: { private$get_id() }")
+ |
+
| 150 | ++ |
+ } else {
+ |
+
| 151 | +81x | +
+ logger::log_trace("{ class(self)[1] }$set_state setting state of filter id: { private$get_id() }")
+ |
+
| 152 | +81x | +
+ shiny::isolate({
+ |
+
| 153 | +81x | +
+ if (!is.null(state$selected)) {
+ |
+
| 154 | +72x | +
+ private$set_selected(state$selected)+ |
+
| 155 | ++ |
+ }+ |
+
| 156 | +69x | +
+ if (!is.null(state$keep_na)) {
+ |
+
| 157 | +16x | +
+ private$set_keep_na(state$keep_na)+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | +69x | +
+ if (!is.null(state$keep_inf)) {
+ |
+
| 160 | +9x | +
+ private$set_keep_inf(state$keep_inf)+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | +69x | +
+ current_state <- sprintf(+ |
+
| 163 | +69x | +
+ "selected: %s; keep_na: %s; keep_inf: %s",+ |
+
| 164 | +69x | +
+ toString(private$get_selected()),+ |
+
| 165 | +69x | +
+ private$get_keep_na(),+ |
+
| 166 | +69x | +
+ private$get_keep_inf()+ |
+
| 167 | ++ |
+ )+ |
+
| 168 | ++ |
+ })+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | ++ | + + | +
| 171 | +70x | +
+ invisible(self)+ |
+
| 172 | ++ |
+ },+ |
+
| 173 | ++ | + + | +
| 174 | ++ | + + | +
| 175 | ++ |
+ #' @description+ |
+
| 176 | ++ |
+ #' Returns filtering state.+ |
+
| 177 | ++ |
+ #'+ |
+
| 178 | ++ |
+ #' @return A `teal_slice` object.+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ get_state = function() {
+ |
+
| 181 | +747x | +
+ private$teal_slice+ |
+
| 182 | ++ |
+ },+ |
+
| 183 | ++ | + + | +
| 184 | ++ |
+ #' @description+ |
+
| 185 | ++ |
+ #' Returns reproducible condition call for current selection relevant+ |
+
| 186 | ++ |
+ #' for selected variable type.+ |
+
| 187 | ++ |
+ #' Method is using internal reactive values which makes it reactive+ |
+
| 188 | ++ |
+ #' and must be executed in reactive or isolated context.+ |
+
| 189 | ++ |
+ #'+ |
+
| 190 | ++ |
+ get_call = function() {
+ |
+
| 191 | +1x | +
+ stop("this is a virtual method")
+ |
+
| 192 | ++ |
+ },+ |
+
| 193 | ++ | + + | +
| 194 | ++ |
+ #' @description+ |
+
| 195 | ++ |
+ #' Shiny module server.+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 198 | ++ |
+ #' shiny module instance id+ |
+
| 199 | ++ |
+ #'+ |
+
| 200 | ++ |
+ #' @return `moduleServer` function which returns reactive value+ |
+
| 201 | ++ |
+ #' signaling that remove button has been clicked+ |
+
| 202 | ++ |
+ #'+ |
+
| 203 | ++ |
+ server = function(id) {
+ |
+
| 204 | +12x | +
+ moduleServer(+ |
+
| 205 | +12x | +
+ id = id,+ |
+
| 206 | +12x | +
+ function(input, output, session) {
+ |
+
| 207 | +12x | +
+ logger::log_trace("FilterState$server initializing module for slice: { private$get_id() } ")
+ |
+
| 208 | +12x | +
+ private$server_summary("summary")
+ |
+
| 209 | +12x | +
+ if (private$is_fixed()) {
+ |
+
| 210 | +! | +
+ private$server_inputs_fixed("inputs")
+ |
+
| 211 | ++ |
+ } else {
+ |
+
| 212 | +12x | +
+ private$server_inputs("inputs")
+ |
+
| 213 | ++ |
+ }+ |
+
| 214 | ++ | + + | +
| 215 | +12x | +
+ private$destroy_shiny <- function() {
+ |
+
| 216 | +8x | +
+ logger::log_trace("Destroying FilterState inputs and observers; id: { private$get_id() }")
+ |
+
| 217 | ++ |
+ # remove values from the input list+ |
+
| 218 | +8x | +
+ lapply(session$ns(names(input)), .subset2(input, "impl")$.values$remove)+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ # remove observers+ |
+
| 221 | +8x | +
+ lapply(private$observers, function(x) x$destroy())+ |
+
| 222 | ++ |
+ }+ |
+
| 223 | ++ | + + | +
| 224 | +12x | +
+ reactive(input$remove)+ |
+
| 225 | ++ |
+ }+ |
+
| 226 | ++ |
+ )+ |
+
| 227 | ++ |
+ },+ |
+
| 228 | ++ | + + | +
| 229 | ++ |
+ #' @description+ |
+
| 230 | ++ |
+ #' Shiny module UI.+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 233 | ++ |
+ #' shiny element (module instance) id;+ |
+
| 234 | ++ |
+ #' the UI for this class contains simple message stating that it is not supported+ |
+
| 235 | ++ |
+ #' @param parent_id (`character(1)`) id of the `FilterStates` card container+ |
+
| 236 | ++ |
+ ui = function(id, parent_id = "cards") {
+ |
+
| 237 | +12x | +
+ ns <- NS(id)+ |
+
| 238 | ++ | + + | +
| 239 | +12x | +
+ tags$div(+ |
+
| 240 | +12x | +
+ id = id,+ |
+
| 241 | +12x | +
+ class = "panel filter-card",+ |
+
| 242 | +12x | +
+ include_js_files("count-bar-labels.js"),
+ |
+
| 243 | +12x | +
+ tags$div(+ |
+
| 244 | +12x | +
+ class = "filter-card-header",+ |
+
| 245 | +12x | +
+ tags$div(+ |
+
| 246 | ++ |
+ # header properties+ |
+
| 247 | +12x | +
+ class = "filter-card-title",+ |
+
| 248 | +12x | +
+ `data-toggle` = "collapse",+ |
+
| 249 | +12x | +
+ `data-bs-toggle` = "collapse",+ |
+
| 250 | +12x | +
+ href = paste0("#", ns("body")),
+ |
+
| 251 | ++ |
+ # header elements+ |
+
| 252 | +12x | +
+ if (private$is_locked()) icon("lock") else NULL,
+ |
+
| 253 | +12x | +
+ if (private$is_fixed()) icon("burst") else NULL,
+ |
+
| 254 | +12x | +
+ tags$span(tags$strong(private$get_varname())),+ |
+
| 255 | +12x | +
+ tags$span(private$get_varlabel(), class = "filter-card-varlabel")+ |
+
| 256 | ++ |
+ ),+ |
+
| 257 | +12x | +
+ if (isFALSE(private$is_locked())) {
+ |
+
| 258 | +12x | +
+ actionLink(+ |
+
| 259 | +12x | +
+ inputId = ns("remove"),
+ |
+
| 260 | +12x | +
+ label = icon("circle-xmark", lib = "font-awesome"),
+ |
+
| 261 | +12x | +
+ class = "filter-card-remove"+ |
+
| 262 | ++ |
+ )+ |
+
| 263 | ++ |
+ },+ |
+
| 264 | +12x | +
+ tags$div(+ |
+
| 265 | +12x | +
+ class = "filter-card-summary",+ |
+
| 266 | +12x | +
+ `data-toggle` = "collapse",+ |
+
| 267 | +12x | +
+ `data-bs-toggle` = "collapse",+ |
+
| 268 | +12x | +
+ href = paste0("#", ns("body")),
+ |
+
| 269 | +12x | +
+ private$ui_summary(ns("summary"))
+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | ++ |
+ ),+ |
+
| 272 | +12x | +
+ tags$div(+ |
+
| 273 | +12x | +
+ id = ns("body"),
+ |
+
| 274 | +12x | +
+ class = "collapse out",+ |
+
| 275 | +12x | +
+ `data-parent` = paste0("#", parent_id),
+ |
+
| 276 | +12x | +
+ `data-bs-parent` = paste0("#", parent_id),
+ |
+
| 277 | +12x | +
+ tags$div(+ |
+
| 278 | +12x | +
+ class = "filter-card-body",+ |
+
| 279 | +12x | +
+ if (private$is_fixed()) {
+ |
+
| 280 | +! | +
+ private$ui_inputs_fixed(ns("inputs"))
+ |
+
| 281 | ++ |
+ } else {
+ |
+
| 282 | +12x | +
+ private$ui_inputs(ns("inputs"))
+ |
+
| 283 | ++ |
+ }+ |
+
| 284 | ++ |
+ )+ |
+
| 285 | ++ |
+ )+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | ++ |
+ },+ |
+
| 288 | ++ | + + | +
| 289 | ++ |
+ #' @description+ |
+
| 290 | ++ |
+ #' Destroy observers stored in `private$observers`.+ |
+
| 291 | ++ |
+ #'+ |
+
| 292 | ++ |
+ #' @return NULL invisibly+ |
+
| 293 | ++ |
+ #'+ |
+
| 294 | ++ |
+ destroy_observers = function() {
+ |
+
| 295 | +47x | +
+ if (!is.null(private$destroy_shiny)) {
+ |
+
| 296 | +8x | +
+ private$destroy_shiny()+ |
+
| 297 | ++ |
+ }+ |
+
| 298 | ++ |
+ }+ |
+
| 299 | ++ |
+ ),+ |
+
| 300 | ++ | + + | +
| 301 | ++ |
+ # private members ----+ |
+
| 302 | ++ |
+ private = list(+ |
+
| 303 | ++ |
+ # set by constructor+ |
+
| 304 | ++ |
+ x = NULL, # the filtered variable+ |
+
| 305 | ++ |
+ x_reactive = NULL, # reactive containing the filtered variable, used for updating counts and histograms+ |
+
| 306 | ++ |
+ teal_slice = shiny::reactiveValues(), # stores all transferable properties of this filter state+ |
+
| 307 | ++ |
+ extract_type = character(0), # used by private$get_varname_prefixed+ |
+
| 308 | ++ |
+ na_count = integer(0),+ |
+
| 309 | ++ |
+ filtered_na_count = NULL, # reactive containing the count of NA in the filtered dataset+ |
+
| 310 | ++ |
+ varlabel = character(0), # taken from variable labels in data; displayed in filter cards+ |
+
| 311 | ++ |
+ destroy_shiny = NULL, # function is set in server+ |
+
| 312 | ++ |
+ # other+ |
+
| 313 | ++ |
+ is_choice_limited = FALSE, # flag whether number of possible choices was limited when specifying filter+ |
+
| 314 | ++ |
+ na_rm = FALSE,+ |
+
| 315 | ++ |
+ observers = list(), # stores observers+ |
+
| 316 | ++ | + + | +
| 317 | ++ |
+ # private methods ----+ |
+
| 318 | ++ | + + | +
| 319 | ++ |
+ ## setters for state features ----+ |
+
| 320 | ++ | + + | +
| 321 | ++ |
+ # @description+ |
+
| 322 | ++ |
+ # Set values that can be selected from.+ |
+
| 323 | ++ |
+ set_choices = function(choices) {
+ |
+
| 324 | +! | +
+ stop("this is a virtual method")
+ |
+
| 325 | ++ |
+ },+ |
+
| 326 | ++ | + + | +
| 327 | ++ |
+ # @description+ |
+
| 328 | ++ |
+ # Set selection.+ |
+
| 329 | ++ |
+ #+ |
+
| 330 | ++ |
+ # @param value (`vector`)\cr+ |
+
| 331 | ++ |
+ # value(s) that come from filter selection; values are set in the+ |
+
| 332 | ++ |
+ # module server after a selection is made in the app interface;+ |
+
| 333 | ++ |
+ # values are stored in `teal_slice$selected` which is reactive;+ |
+
| 334 | ++ |
+ # value types have to be the same as `private$get_choices()`+ |
+
| 335 | ++ |
+ #+ |
+
| 336 | ++ |
+ # @return NULL invisibly+ |
+
| 337 | ++ |
+ set_selected = function(value) {
+ |
+
| 338 | +400x | +
+ logger::log_trace(+ |
+
| 339 | +400x | +
+ sprintf(+ |
+
| 340 | +400x | +
+ "%s$set_selected setting selection of id: %s",+ |
+
| 341 | +400x | +
+ class(self)[1],+ |
+
| 342 | +400x | +
+ private$get_id()+ |
+
| 343 | ++ |
+ )+ |
+
| 344 | ++ |
+ )+ |
+
| 345 | +400x | +
+ shiny::isolate({
+ |
+
| 346 | +400x | +
+ value <- private$cast_and_validate(value)+ |
+
| 347 | +383x | +
+ value <- private$remove_out_of_bound_values(value)+ |
+
| 348 | +383x | +
+ value <- private$check_multiple(value)+ |
+
| 349 | +383x | +
+ private$validate_selection(value)+ |
+
| 350 | +383x | +
+ private$teal_slice$selected <- value+ |
+
| 351 | ++ |
+ })+ |
+
| 352 | +383x | +
+ logger::log_trace(+ |
+
| 353 | +383x | +
+ sprintf(+ |
+
| 354 | +383x | +
+ "%s$set_selected selection of id: %s",+ |
+
| 355 | +383x | +
+ class(self)[1],+ |
+
| 356 | +383x | +
+ private$get_id()+ |
+
| 357 | ++ |
+ )+ |
+
| 358 | ++ |
+ )+ |
+
| 359 | ++ | + + | +
| 360 | +383x | +
+ invisible(NULL)+ |
+
| 361 | ++ |
+ },+ |
+
| 362 | ++ | + + | +
| 363 | ++ |
+ # @description+ |
+
| 364 | ++ |
+ # Set whether to keep NAs.+ |
+
| 365 | ++ |
+ #+ |
+
| 366 | ++ |
+ # @param value `logical(1)`\cr+ |
+
| 367 | ++ |
+ # value(s) which come from the filter selection. Value is set in `server`+ |
+
| 368 | ++ |
+ # modules after selecting check-box-input in the shiny interface. Values are set to+ |
+
| 369 | ++ |
+ # `private$teal_slice$keep_na`+ |
+
| 370 | ++ |
+ #+ |
+
| 371 | ++ |
+ # @return NULL invisibly+ |
+
| 372 | ++ |
+ #+ |
+
| 373 | ++ |
+ set_keep_na = function(value) {
+ |
+
| 374 | +16x | +
+ checkmate::assert_flag(value)+ |
+
| 375 | +16x | +
+ private$teal_slice$keep_na <- value+ |
+
| 376 | +16x | +
+ logger::log_trace(+ |
+
| 377 | +16x | +
+ sprintf(+ |
+
| 378 | +16x | +
+ "%s$set_keep_na set for filter %s to %s.",+ |
+
| 379 | +16x | +
+ class(self)[1],+ |
+
| 380 | +16x | +
+ private$get_id(),+ |
+
| 381 | +16x | +
+ value+ |
+
| 382 | ++ |
+ )+ |
+
| 383 | ++ |
+ )+ |
+
| 384 | +16x | +
+ private$set_na_rm(!value)+ |
+
| 385 | +16x | +
+ invisible(NULL)+ |
+
| 386 | ++ |
+ },+ |
+
| 387 | ++ | + + | +
| 388 | ++ |
+ # @description+ |
+
| 389 | ++ |
+ # Set whether to keep Infs+ |
+
| 390 | ++ |
+ #+ |
+
| 391 | ++ |
+ # @param value (`logical(1)`)\cr+ |
+
| 392 | ++ |
+ # Value(s) which come from the filter selection. Value is set in `server`+ |
+
| 393 | ++ |
+ # modules after selecting check-box-input in the shiny interface. Values are set to+ |
+
| 394 | ++ |
+ # `private$teal_slice$keep_inf`+ |
+
| 395 | ++ |
+ #+ |
+
| 396 | ++ |
+ set_keep_inf = function(value) {
+ |
+
| 397 | +9x | +
+ checkmate::assert_flag(value)+ |
+
| 398 | +9x | +
+ private$teal_slice$keep_inf <- value+ |
+
| 399 | +9x | +
+ logger::log_trace(+ |
+
| 400 | +9x | +
+ sprintf(+ |
+
| 401 | +9x | +
+ "%s$set_keep_inf of filter %s set to %s",+ |
+
| 402 | +9x | +
+ class(self)[1],+ |
+
| 403 | +9x | +
+ private$get_id(),+ |
+
| 404 | +9x | +
+ value+ |
+
| 405 | ++ |
+ )+ |
+
| 406 | ++ |
+ )+ |
+
| 407 | ++ | + + | +
| 408 | +9x | +
+ invisible(NULL)+ |
+
| 409 | ++ |
+ },+ |
+
| 410 | ++ | + + | +
| 411 | ++ |
+ # @description+ |
+
| 412 | ++ |
+ # Some methods need an additional `!is.na(varame)` condition to drop+ |
+
| 413 | ++ |
+ # missing values. When `private$na_rm = TRUE`, `self$get_call` returns+ |
+
| 414 | ++ |
+ # condition extended by `!is.na`.+ |
+
| 415 | ++ |
+ #+ |
+
| 416 | ++ |
+ # @param value `logical(1)`\cr+ |
+
| 417 | ++ |
+ # when `TRUE`, `FilterState$get_call` appends an expression+ |
+
| 418 | ++ |
+ # removing `NA` values to the filter expression returned by `get_call`+ |
+
| 419 | ++ |
+ #+ |
+
| 420 | ++ |
+ # @return NULL invisibly+ |
+
| 421 | ++ |
+ #+ |
+
| 422 | ++ |
+ set_na_rm = function(value) {
+ |
+
| 423 | +16x | +
+ checkmate::assert_flag(value)+ |
+
| 424 | +16x | +
+ private$na_rm <- value+ |
+
| 425 | +16x | +
+ invisible(NULL)+ |
+
| 426 | ++ |
+ },+ |
+
| 427 | ++ | + + | +
| 428 | ++ |
+ ## getters for state features ----+ |
+
| 429 | ++ | + + | +
| 430 | ++ |
+ # @description+ |
+
| 431 | ++ |
+ # Returns dataname.+ |
+
| 432 | ++ |
+ # @return `character(1)`+ |
+
| 433 | ++ |
+ get_dataname = function() {
+ |
+
| 434 | +288x | +
+ shiny::isolate(private$teal_slice$dataname)+ |
+
| 435 | ++ |
+ },+ |
+
| 436 | ++ | + + | +
| 437 | ++ |
+ # @description+ |
+
| 438 | ++ |
+ # Get variable name.+ |
+
| 439 | ++ |
+ # @return `character(1)`+ |
+
| 440 | ++ |
+ get_varname = function() {
+ |
+
| 441 | +434x | +
+ shiny::isolate(private$teal_slice$varname)+ |
+
| 442 | ++ |
+ },+ |
+
| 443 | ++ | + + | +
| 444 | ++ |
+ # @description+ |
+
| 445 | ++ |
+ # Get id of the teal_slice.+ |
+
| 446 | ++ |
+ # @return `character(1)`+ |
+
| 447 | ++ |
+ get_id = function() {
+ |
+
| 448 | +4x | +
+ shiny::isolate(private$teal_slice$id)+ |
+
| 449 | ++ |
+ },+ |
+
| 450 | ++ | + + | +
| 451 | ++ |
+ # @description+ |
+
| 452 | ++ |
+ # Get allowed values from `FilterState`.+ |
+
| 453 | ++ |
+ # @return class of the returned object depends of class of the `FilterState`+ |
+
| 454 | ++ |
+ get_choices = function() {
+ |
+
| 455 | +1030x | +
+ shiny::isolate(private$teal_slice$choices)+ |
+
| 456 | ++ |
+ },+ |
+
| 457 | ++ | + + | +
| 458 | ++ |
+ # @description+ |
+
| 459 | ++ |
+ # Get selected values from `FilterState`.+ |
+
| 460 | ++ |
+ # @return class of the returned object depends of class of the `FilterState`+ |
+
| 461 | ++ |
+ get_selected = function() {
+ |
+
| 462 | +307x | +
+ private$teal_slice$selected+ |
+
| 463 | ++ |
+ },+ |
+
| 464 | ++ | + + | +
| 465 | ++ |
+ # @description+ |
+
| 466 | ++ |
+ # Returns current `keep_na` selection.+ |
+
| 467 | ++ |
+ # @return `logical(1)`+ |
+
| 468 | ++ |
+ get_keep_na = function() {
+ |
+
| 469 | +198x | +
+ private$teal_slice$keep_na+ |
+
| 470 | ++ |
+ },+ |
+
| 471 | ++ | + + | +
| 472 | ++ |
+ # @description+ |
+
| 473 | ++ |
+ # Returns current `keep_inf` selection.+ |
+
| 474 | ++ |
+ # @return (`logical(1)`)+ |
+
| 475 | ++ |
+ get_keep_inf = function() {
+ |
+
| 476 | +116x | +
+ private$teal_slice$keep_inf+ |
+
| 477 | ++ |
+ },+ |
+
| 478 | ++ | + + | +
| 479 | ++ |
+ # Check whether this filter is fixed (cannot be changed).+ |
+
| 480 | ++ |
+ # @return `logical(1)`+ |
+
| 481 | ++ |
+ is_fixed = function() {
+ |
+
| 482 | +118x | +
+ shiny::isolate(isTRUE(private$teal_slice$fixed))+ |
+
| 483 | ++ |
+ },+ |
+
| 484 | ++ | + + | +
| 485 | ++ |
+ # Check whether this filter is locked (cannot be removed).+ |
+
| 486 | ++ |
+ # @return `logical(1)`+ |
+
| 487 | ++ |
+ is_locked = function() {
+ |
+
| 488 | +24x | +
+ shiny::isolate(isTRUE(private$teal_slice$locked))+ |
+
| 489 | ++ |
+ },+ |
+
| 490 | ++ | + + | +
| 491 | ++ |
+ # Check whether this filter is capable of selecting multiple values.+ |
+
| 492 | ++ |
+ # @return `logical(1)`+ |
+
| 493 | ++ |
+ is_multiple = function() {
+ |
+
| 494 | +192x | +
+ shiny::isolate(isTRUE(private$teal_slice$multiple))+ |
+
| 495 | ++ |
+ },+ |
+
| 496 | ++ | + + | +
| 497 | ++ |
+ ## other ----+ |
+
| 498 | ++ | + + | +
| 499 | ++ |
+ # @description+ |
+
| 500 | ++ |
+ # Returns variable label.+ |
+
| 501 | ++ |
+ # @return `character(1)`+ |
+
| 502 | ++ |
+ get_varlabel = function() {
+ |
+
| 503 | +12x | +
+ private$varlabel+ |
+
| 504 | ++ |
+ },+ |
+
| 505 | ++ | + + | +
| 506 | ++ |
+ # @description+ |
+
| 507 | ++ |
+ # Return variable name prefixed by `dataname` to be evaluated as extracted object,+ |
+
| 508 | ++ |
+ # for example `data$var`+ |
+
| 509 | ++ |
+ # @return a character string representation of a subset call+ |
+
| 510 | ++ |
+ # that extracts the variable from the dataset+ |
+
| 511 | ++ |
+ get_varname_prefixed = function(dataname) {
+ |
+
| 512 | +155x | +
+ ans <-+ |
+
| 513 | +155x | +
+ if (isTRUE(private$extract_type == "list")) {
+ |
+
| 514 | +29x | +
+ sprintf("%s$%s", dataname, private$get_varname())
+ |
+
| 515 | +155x | +
+ } else if (isTRUE(private$extract_type == "matrix")) {
+ |
+
| 516 | +13x | +
+ sprintf("%s[, \"%s\"]", dataname, private$get_varname())
+ |
+
| 517 | ++ |
+ } else {
+ |
+
| 518 | +113x | +
+ private$get_varname()+ |
+
| 519 | ++ |
+ }+ |
+
| 520 | +155x | +
+ str2lang(ans)+ |
+
| 521 | ++ |
+ },+ |
+
| 522 | ++ | + + | +
| 523 | ++ |
+ # @description+ |
+
| 524 | ++ |
+ # Adds `is.na(varname)` before existing condition calls if `keep_na` is selected.+ |
+
| 525 | ++ |
+ # Otherwise, if missing values are found in the variable `!is.na` will be added+ |
+
| 526 | ++ |
+ # only if `private$na_rm = TRUE`+ |
+
| 527 | ++ |
+ # @param filter_call `call` raw filter call, as defined by selection+ |
+
| 528 | ++ |
+ # @param dataname `character(1)` name of data set to prepend to variables+ |
+
| 529 | ++ |
+ # @return a `call`+ |
+
| 530 | ++ |
+ add_keep_na_call = function(filter_call, dataname) {
+ |
+
| 531 | +89x | +
+ if (isTRUE(private$get_keep_na())) {
+ |
+
| 532 | +15x | +
+ call("|", call("is.na", private$get_varname_prefixed(dataname)), filter_call)
+ |
+
| 533 | +74x | +
+ } else if (isTRUE(private$na_rm) && private$na_count > 0L) {
+ |
+
| 534 | +1x | +
+ call(+ |
+
| 535 | ++ |
+ "&",+ |
+
| 536 | +1x | +
+ call("!", call("is.na", private$get_varname_prefixed(dataname))),
+ |
+
| 537 | +1x | +
+ filter_call+ |
+
| 538 | ++ |
+ )+ |
+
| 539 | ++ |
+ } else {
+ |
+
| 540 | +73x | +
+ filter_call+ |
+
| 541 | ++ |
+ }+ |
+
| 542 | ++ |
+ },+ |
+
| 543 | ++ | + + | +
| 544 | ++ |
+ # Converts values to the type fitting this `FilterState` and validates+ |
+
| 545 | ++ |
+ # whether the elements of the resulting vector satisfy the requirements of this `FilterState`.+ |
+
| 546 | ++ |
+ # Raises error if casting does not execute successfully.+ |
+
| 547 | ++ |
+ #+ |
+
| 548 | ++ |
+ # @param values vector of values+ |
+
| 549 | ++ |
+ #+ |
+
| 550 | ++ |
+ # @return vector converted to appropriate class+ |
+
| 551 | ++ |
+ cast_and_validate = function(values) {
+ |
+
| 552 | +11x | +
+ values+ |
+
| 553 | ++ |
+ },+ |
+
| 554 | ++ | + + | +
| 555 | ++ |
+ # Filters out erroneous values from vector.+ |
+
| 556 | ++ |
+ #+ |
+
| 557 | ++ |
+ # @param values vector of values+ |
+
| 558 | ++ |
+ #+ |
+
| 559 | ++ |
+ # @return vector in which values that cannot be set in this FilterState have been dropped+ |
+
| 560 | ++ |
+ remove_out_of_bound_values = function(values) {
+ |
+
| 561 | +31x | +
+ values+ |
+
| 562 | ++ |
+ },+ |
+
| 563 | ++ | + + | +
| 564 | ++ |
+ # Checks whether multiple choices are allowed.+ |
+
| 565 | ++ |
+ # If not value is of length 2 or more, drops all but first item with a warning.+ |
+
| 566 | ++ |
+ check_multiple = function(value) {
+ |
+
| 567 | +200x | +
+ value+ |
+
| 568 | ++ |
+ },+ |
+
| 569 | ++ | + + | +
| 570 | ++ |
+ # Checks if the selection is valid in terms of class and length.+ |
+
| 571 | ++ |
+ # It should not return anything but raise an error if selection+ |
+
| 572 | ++ |
+ # has a wrong class or is outside of possible choices+ |
+
| 573 | ++ |
+ validate_selection = function(value) {
+ |
+
| 574 | +11x | +
+ invisible(NULL)+ |
+
| 575 | ++ |
+ },+ |
+
| 576 | ++ | + + | +
| 577 | ++ |
+ # @description+ |
+
| 578 | ++ |
+ # Answers the question of whether the current settings and values selected actually filters out any values.+ |
+
| 579 | ++ |
+ # @return logical scalar+ |
+
| 580 | ++ |
+ is_any_filtered = function() {
+ |
+
| 581 | +50x | +
+ if (private$is_choice_limited) {
+ |
+
| 582 | +3x | +
+ TRUE+ |
+
| 583 | +47x | +
+ } else if (!setequal(private$get_selected(), private$get_choices())) {
+ |
+
| 584 | +40x | +
+ TRUE+ |
+
| 585 | +7x | +
+ } else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 586 | +3x | +
+ TRUE+ |
+
| 587 | ++ |
+ } else {
+ |
+
| 588 | +4x | +
+ FALSE+ |
+
| 589 | ++ |
+ }+ |
+
| 590 | ++ |
+ },+ |
+
| 591 | ++ | + + | +
| 592 | ++ |
+ ## shiny modules -----+ |
+
| 593 | ++ | + + | +
| 594 | ++ |
+ # @description+ |
+
| 595 | ++ |
+ # Server module to display filter summary+ |
+
| 596 | ++ |
+ # @param id `shiny` id parameter+ |
+
| 597 | ++ |
+ ui_summary = function(id) {
+ |
+
| 598 | +12x | +
+ ns <- NS(id)+ |
+
| 599 | +12x | +
+ uiOutput(ns("summary"), class = "filter-card-summary")
+ |
+
| 600 | ++ |
+ },+ |
+
| 601 | ++ | + + | +
| 602 | ++ |
+ # @description+ |
+
| 603 | ++ |
+ # UI module to display filter summary+ |
+
| 604 | ++ |
+ # @param shiny `id` parameter passed to `moduleServer`+ |
+
| 605 | ++ |
+ # renders text describing current state+ |
+
| 606 | ++ |
+ server_summary = function(id) {
+ |
+
| 607 | +12x | +
+ moduleServer(+ |
+
| 608 | +12x | +
+ id = id,+ |
+
| 609 | +12x | +
+ function(input, output, session) {
+ |
+
| 610 | +12x | +
+ output$summary <- renderUI(private$content_summary())+ |
+
| 611 | ++ |
+ }+ |
+
| 612 | ++ |
+ )+ |
+
| 613 | ++ |
+ },+ |
+
| 614 | ++ | + + | +
| 615 | ++ |
+ # module with inputs+ |
+
| 616 | ++ |
+ ui_inputs = function(id) {
+ |
+
| 617 | +! | +
+ stop("abstract class")
+ |
+
| 618 | ++ |
+ },+ |
+
| 619 | ++ |
+ # module with inputs+ |
+
| 620 | ++ |
+ server_inputs = function(id) {
+ |
+
| 621 | +! | +
+ stop("abstract class")
+ |
+
| 622 | ++ |
+ },+ |
+
| 623 | ++ | + + | +
| 624 | ++ |
+ # @description+ |
+
| 625 | ++ |
+ # module displaying inputs in a fixed filter state+ |
+
| 626 | ++ |
+ # there are no input widgets, only selection visualizations+ |
+
| 627 | ++ |
+ # @param id+ |
+
| 628 | ++ |
+ # character string specifying this `shiny` module instance+ |
+
| 629 | ++ |
+ ui_inputs_fixed = function(id) {
+ |
+
| 630 | +! | +
+ ns <- NS(id)+ |
+
| 631 | +! | +
+ div(+ |
+
| 632 | +! | +
+ class = "choices_state",+ |
+
| 633 | +! | +
+ uiOutput(ns("selection"))
+ |
+
| 634 | ++ |
+ )+ |
+
| 635 | ++ |
+ },+ |
+
| 636 | ++ | + + | +
| 637 | ++ |
+ # @description+ |
+
| 638 | ++ |
+ # module creating the display of a fixed filter state+ |
+
| 639 | ++ |
+ # @param id+ |
+
| 640 | ++ |
+ # character string specifying this `shiny` module instance+ |
+
| 641 | ++ |
+ server_inputs_fixed = function(id) {
+ |
+
| 642 | +! | +
+ stop("abstract class")
+ |
+
| 643 | ++ |
+ },+ |
+
| 644 | ++ | + + | +
| 645 | ++ |
+ # @description+ |
+
| 646 | ++ |
+ # module displaying input to keep or remove NA in the FilterState call+ |
+
| 647 | ++ |
+ # @param id `shiny` id parameter+ |
+
| 648 | ++ |
+ # renders checkbox input only when variable from which FilterState has+ |
+
| 649 | ++ |
+ # been created has some NA values.+ |
+
| 650 | ++ |
+ keep_na_ui = function(id) {
+ |
+
| 651 | +12x | +
+ ns <- NS(id)+ |
+
| 652 | +12x | +
+ if (private$na_count > 0) {
+ |
+
| 653 | +! | +
+ shiny::isolate({
+ |
+
| 654 | +! | +
+ countmax <- private$na_count+ |
+
| 655 | +! | +
+ countnow <- private$filtered_na_count()+ |
+
| 656 | +! | +
+ ui_input <- checkboxInput(+ |
+
| 657 | +! | +
+ inputId = ns("value"),
+ |
+
| 658 | +! | +
+ label = tags$span(+ |
+
| 659 | +! | +
+ id = ns("count_label"),
+ |
+
| 660 | +! | +
+ make_count_text(+ |
+
| 661 | +! | +
+ label = "Keep NA",+ |
+
| 662 | +! | +
+ countmax = countmax,+ |
+
| 663 | +! | +
+ countnow = countnow+ |
+
| 664 | ++ |
+ )+ |
+
| 665 | ++ |
+ ),+ |
+
| 666 | +! | +
+ value = private$get_keep_na()+ |
+
| 667 | ++ |
+ )+ |
+
| 668 | +! | +
+ div(+ |
+
| 669 | +! | +
+ uiOutput(ns("trigger_visible"), inline = TRUE),
+ |
+
| 670 | +! | +
+ ui_input+ |
+
| 671 | ++ |
+ )+ |
+
| 672 | ++ |
+ })+ |
+
| 673 | ++ |
+ } else {
+ |
+
| 674 | +12x | +
+ NULL+ |
+
| 675 | ++ |
+ }+ |
+
| 676 | ++ |
+ },+ |
+
| 677 | ++ | + + | +
| 678 | ++ |
+ # @description+ |
+
| 679 | ++ |
+ # module to handle NA values in the FilterState+ |
+
| 680 | ++ |
+ # @param shiny `id` parameter passed to moduleServer+ |
+
| 681 | ++ |
+ # module sets `private$keep_na` according to the selection.+ |
+
| 682 | ++ |
+ # Module also updates a UI element if the `private$keep_na` has been+ |
+
| 683 | ++ |
+ # changed through the api+ |
+
| 684 | ++ |
+ keep_na_srv = function(id) {
+ |
+
| 685 | +12x | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 686 | ++ |
+ # 1. renderUI is used here as an observer which triggers only if output is visible+ |
+
| 687 | ++ |
+ # and if the reactive changes - reactive triggers only if the output is visible.+ |
+
| 688 | ++ |
+ # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)+ |
+
| 689 | +12x | +
+ output$trigger_visible <- renderUI({
+ |
+
| 690 | +12x | +
+ updateCountText(+ |
+
| 691 | +12x | +
+ inputId = "count_label",+ |
+
| 692 | +12x | +
+ label = "Keep NA",+ |
+
| 693 | +12x | +
+ countmax = private$na_count,+ |
+
| 694 | +12x | +
+ countnow = private$filtered_na_count()+ |
+
| 695 | ++ |
+ )+ |
+
| 696 | +12x | +
+ NULL+ |
+
| 697 | ++ |
+ })+ |
+
| 698 | ++ | + + | +
| 699 | ++ |
+ # this observer is needed in the situation when private$keep_inf has been+ |
+
| 700 | ++ |
+ # changed directly by the api - then it's needed to rerender UI element+ |
+
| 701 | ++ |
+ # to show relevant values+ |
+
| 702 | +12x | +
+ private$observers$keep_na_api <- observeEvent(+ |
+
| 703 | +12x | +
+ eventExpr = private$get_keep_na(),+ |
+
| 704 | +12x | +
+ ignoreNULL = FALSE, # nothing selected is possible for NA+ |
+
| 705 | +12x | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 706 | +12x | +
+ handlerExpr = {
+ |
+
| 707 | +! | +
+ if (!setequal(private$get_keep_na(), input$value)) {
+ |
+
| 708 | +! | +
+ logger::log_trace("FilterState$keep_na_srv@1 changed reactive value, id: { private$get_id() }")
+ |
+
| 709 | +! | +
+ updateCheckboxInput(+ |
+
| 710 | +! | +
+ inputId = "value",+ |
+
| 711 | +! | +
+ label = sprintf("Keep NA (%s/%s)", private$filtered_na_count(), private$na_count),
+ |
+
| 712 | +! | +
+ value = private$get_keep_na()+ |
+
| 713 | ++ |
+ )+ |
+
| 714 | ++ |
+ }+ |
+
| 715 | ++ |
+ }+ |
+
| 716 | ++ |
+ )+ |
+
| 717 | +12x | +
+ private$observers$keep_na <- observeEvent(+ |
+
| 718 | +12x | +
+ ignoreNULL = FALSE, # ignoreNULL: we don't want to ignore NULL when nothing is selected in the `selectInput`+ |
+
| 719 | +12x | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 720 | +12x | +
+ eventExpr = input$value,+ |
+
| 721 | +12x | +
+ handlerExpr = {
+ |
+
| 722 | +! | +
+ logger::log_trace("FilterState$keep_na_srv@2 changed input, id: { private$get_id() }")
+ |
+
| 723 | +! | +
+ keep_na <- if (is.null(input$value)) {
+ |
+
| 724 | +! | +
+ FALSE+ |
+
| 725 | ++ |
+ } else {
+ |
+
| 726 | +! | +
+ input$value+ |
+
| 727 | ++ |
+ }+ |
+
| 728 | +! | +
+ private$set_keep_na(keep_na)+ |
+
| 729 | ++ |
+ }+ |
+
| 730 | ++ |
+ )+ |
+
| 731 | +12x | +
+ invisible(NULL)+ |
+
| 732 | ++ |
+ })+ |
+
| 733 | ++ |
+ }+ |
+
| 734 | ++ |
+ )+ |
+
| 735 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Set "`<choice>:<label>`" type of Names+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #' This is often useful for as it marks up the drop-down boxes for [shiny::selectInput()].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param choices a character / numeric / logical vector+ |
+
| 7 | ++ |
+ #' @param labels character vector containing labels to be applied to `choices`. If `NA` then+ |
+
| 8 | ++ |
+ #' "Label Missing" will be used.+ |
+
| 9 | ++ |
+ #' @param subset a vector that is a subset of `choices`. This is useful if+ |
+
| 10 | ++ |
+ #' only a few variables need to be named. If this argument is used, the returned vector will+ |
+
| 11 | ++ |
+ #' match its order.+ |
+
| 12 | ++ |
+ #' @param types vector containing the types of the columns.+ |
+
| 13 | ++ |
+ #' @details If either `choices` or `labels` are factors, they are coerced to character.+ |
+
| 14 | ++ |
+ #' Duplicated elements from `choices` get removed.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return a named character vector+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @keywords internal+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ choices_labeled <- function(choices, labels, subset = NULL, types = NULL) {
+ |
+
| 21 | +9x | +
+ if (is.factor(choices)) {
+ |
+
| 22 | +! | +
+ choices <- as.character(choices)+ |
+
| 23 | ++ |
+ }+ |
+
| 24 | ++ | + + | +
| 25 | +9x | +
+ stopifnot(+ |
+
| 26 | +9x | +
+ is.character(choices) ||+ |
+
| 27 | +9x | +
+ is.numeric(choices) ||+ |
+
| 28 | +9x | +
+ is.logical(choices) ||+ |
+
| 29 | +9x | +
+ (length(choices) == 1 && is.na(choices))+ |
+
| 30 | ++ |
+ )+ |
+
| 31 | ++ | + + | +
| 32 | +9x | +
+ if (is.factor(labels)) {
+ |
+
| 33 | +! | +
+ labels <- as.character(labels)+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | ++ | + + | +
| 36 | +9x | +
+ checkmate::assert_character(labels[!is.na(labels)], any.missing = FALSE)+ |
+
| 37 | +9x | +
+ if (length(choices) != length(labels)) {
+ |
+
| 38 | +! | +
+ stop("length of choices must be the same as labels")
+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | +9x | +
+ stopifnot(is.null(subset) || is.vector(subset))+ |
+
| 41 | +9x | +
+ stopifnot(is.null(types) || is.vector(types))+ |
+
| 42 | ++ | + + | +
| 43 | +9x | +
+ if (is.vector(types)) {
+ |
+
| 44 | +9x | +
+ stopifnot(length(choices) == length(types))+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | ++ | + + | +
| 47 | +9x | +
+ if (!is.null(subset)) {
+ |
+
| 48 | +! | +
+ if (!all(subset %in% choices)) {
+ |
+
| 49 | +! | +
+ stop("all of subset variables must be in choices")
+ |
+
| 50 | ++ |
+ }+ |
+
| 51 | +! | +
+ labels <- labels[choices %in% subset]+ |
+
| 52 | +! | +
+ types <- types[choices %in% subset]+ |
+
| 53 | +! | +
+ choices <- choices[choices %in% subset]+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | ++ | + + | +
| 56 | +9x | +
+ is_dupl <- duplicated(choices)+ |
+
| 57 | +9x | +
+ choices <- choices[!is_dupl]+ |
+
| 58 | +9x | +
+ labels <- labels[!is_dupl]+ |
+
| 59 | +9x | +
+ types <- types[!is_dupl]+ |
+
| 60 | +9x | +
+ labels[is.na(labels)] <- "Label Missing"+ |
+
| 61 | +9x | +
+ raw_labels <- labels+ |
+
| 62 | +9x | +
+ combined_labels <- if (length(choices) > 0) {
+ |
+
| 63 | +9x | +
+ paste0(choices, ": ", labels)+ |
+
| 64 | ++ |
+ } else {
+ |
+
| 65 | +! | +
+ character(0)+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ | + + | +
| 68 | +9x | +
+ if (!is.null(subset)) {
+ |
+
| 69 | +! | +
+ ord <- match(subset, choices)+ |
+
| 70 | +! | +
+ choices <- choices[ord]+ |
+
| 71 | +! | +
+ raw_labels <- raw_labels[ord]+ |
+
| 72 | +! | +
+ combined_labels <- combined_labels[ord]+ |
+
| 73 | +! | +
+ types <- types[ord]+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | +9x | +
+ choices <- structure(+ |
+
| 76 | +9x | +
+ choices,+ |
+
| 77 | +9x | +
+ names = combined_labels,+ |
+
| 78 | +9x | +
+ raw_labels = raw_labels,+ |
+
| 79 | +9x | +
+ combined_labels = combined_labels,+ |
+
| 80 | +9x | +
+ class = c("choices_labeled", "character"),
+ |
+
| 81 | +9x | +
+ types = types+ |
+
| 82 | ++ |
+ )+ |
+
| 83 | ++ | + + | +
| 84 | +9x | +
+ return(choices)+ |
+
| 85 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Managing `FilteredData` states+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #' Set, get and remove filter states of `FilteredData` object+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @name filter_state_api+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param datasets (`FilteredData`)\cr+ |
+
| 9 | ++ |
+ #' object to store filter state and filtered datasets, shared across modules\cr+ |
+
| 10 | ++ |
+ #' see [`FilteredData`] for details+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @param filter (`teal_slices`)\cr+ |
+
| 13 | ++ |
+ #' specify filters in place on app start-up+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @return+ |
+
| 16 | ++ |
+ #' - `set_*`, `remove_*` and `clear_filter_state` return `NULL` invisibly+ |
+
| 17 | ++ |
+ #' - `get_filter_state` returns a named `teal_slices` object+ |
+
| 18 | ++ |
+ #' containing a `teal_slice` for every existing `FilterState`+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @seealso [`teal_slice`]+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @examples+ |
+
| 23 | ++ |
+ #' utils::data(miniACC, package = "MultiAssayExperiment")+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' datasets <- init_filtered_data(+ |
+
| 26 | ++ |
+ #' x = list(+ |
+
| 27 | ++ |
+ #' iris = list(dataset = iris),+ |
+
| 28 | ++ |
+ #' mae = list(dataset = miniACC)+ |
+
| 29 | ++ |
+ #' )+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #' fs <- teal_slices(+ |
+
| 32 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", selected = c("setosa", "versicolor")),
+ |
+
| 33 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)),+ |
+
| 34 | ++ |
+ #' teal_slice(+ |
+
| 35 | ++ |
+ #' dataname = "mae", varname = "years_to_birth", selected = c(30, 50),+ |
+
| 36 | ++ |
+ #' keep_na = TRUE, keep_inf = FALSE+ |
+
| 37 | ++ |
+ #' ),+ |
+
| 38 | ++ |
+ #' teal_slice(+ |
+
| 39 | ++ |
+ #' dataname = "mae", varname = "vital_status", selected = "1",+ |
+
| 40 | ++ |
+ #' keep_na = FALSE+ |
+
| 41 | ++ |
+ #' ),+ |
+
| 42 | ++ |
+ #' teal_slice(+ |
+
| 43 | ++ |
+ #' dataname = "mae", varname = "gender", selected = "female",+ |
+
| 44 | ++ |
+ #' keep_na = TRUE+ |
+
| 45 | ++ |
+ #' ),+ |
+
| 46 | ++ |
+ #' teal_slice(+ |
+
| 47 | ++ |
+ #' dataname = "mae", varname = "ARRAY_TYPE", selected = "",+ |
+
| 48 | ++ |
+ #' keep_na = TRUE, experiment = "RPPAArray", arg = "subset"+ |
+
| 49 | ++ |
+ #' )+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' # set initial filter state+ |
+
| 53 | ++ |
+ #' set_filter_state(datasets, filter = fs)+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' # get filter state+ |
+
| 56 | ++ |
+ #' get_filter_state(datasets)+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' # modify filter state+ |
+
| 59 | ++ |
+ #' set_filter_state(+ |
+
| 60 | ++ |
+ #' datasets,+ |
+
| 61 | ++ |
+ #' teal_slices(+ |
+
| 62 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)+ |
+
| 63 | ++ |
+ #' )+ |
+
| 64 | ++ |
+ #' )+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' # remove specific filters+ |
+
| 67 | ++ |
+ #' remove_filter_state(+ |
+
| 68 | ++ |
+ #' datasets,+ |
+
| 69 | ++ |
+ #' teal_slices(+ |
+
| 70 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species"),+ |
+
| 71 | ++ |
+ #' teal_slice(dataname = "mae", varname = "years_to_birth"),+ |
+
| 72 | ++ |
+ #' teal_slice(dataname = "mae", varname = "vital_status")+ |
+
| 73 | ++ |
+ #' )+ |
+
| 74 | ++ |
+ #' )+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' # remove all states+ |
+
| 77 | ++ |
+ #' clear_filter_states(datasets)+ |
+
| 78 | ++ |
+ NULL+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ #' @rdname filter_state_api+ |
+
| 81 | ++ |
+ #' @export+ |
+
| 82 | ++ |
+ set_filter_state <- function(datasets, filter) {
+ |
+
| 83 | +3x | +
+ checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ |
+
| 84 | +3x | +
+ checkmate::assert(+ |
+
| 85 | +3x | +
+ checkmate::check_class(filter, "teal_slices"),+ |
+
| 86 | +3x | +
+ checkmate::check_list(filter, min.len = 0, null.ok = TRUE)+ |
+
| 87 | ++ |
+ )+ |
+
| 88 | +3x | +
+ if (!is.teal_slices(filter)) {
+ |
+
| 89 | +! | +
+ filter <- as.teal_slices(filter)+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | ++ | + + | +
| 92 | +3x | +
+ datasets$set_filter_state(filter)+ |
+
| 93 | +3x | +
+ invisible(NULL)+ |
+
| 94 | ++ |
+ }+ |
+
| 95 | ++ | + + | +
| 96 | ++ |
+ #' @rdname filter_state_api+ |
+
| 97 | ++ |
+ #' @export+ |
+
| 98 | ++ |
+ get_filter_state <- function(datasets) {
+ |
+
| 99 | +4x | +
+ checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ |
+
| 100 | +4x | +
+ if (shiny::isRunning()) {
+ |
+
| 101 | +! | +
+ datasets$get_filter_state()+ |
+
| 102 | ++ |
+ } else {
+ |
+
| 103 | +4x | +
+ shiny::isolate(datasets$get_filter_state())+ |
+
| 104 | ++ |
+ }+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ #' @rdname filter_state_api+ |
+
| 108 | ++ |
+ #' @export+ |
+
| 109 | ++ |
+ remove_filter_state <- function(datasets, filter) {
+ |
+
| 110 | +1x | +
+ checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ |
+
| 111 | +1x | +
+ checkmate::assert(+ |
+
| 112 | +1x | +
+ checkmate::check_class(filter, "teal_slices"),+ |
+
| 113 | +1x | +
+ checkmate::check_list(filter, min.len = 0, null.ok = TRUE)+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ | + + | +
| 116 | +1x | +
+ datasets$remove_filter_state(filter)+ |
+
| 117 | +1x | +
+ invisible(NULL)+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | ++ | + + | +
| 120 | ++ |
+ #' @rdname filter_state_api+ |
+
| 121 | ++ |
+ #' @export+ |
+
| 122 | ++ |
+ clear_filter_states <- function(datasets) {
+ |
+
| 123 | +1x | +
+ checkmate::assert_multi_class(datasets, c("FilteredData", "FilterPanelAPI"))
+ |
+
| 124 | +1x | +
+ datasets$clear_filter_states()+ |
+
| 125 | +1x | +
+ invisible(NULL)+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | ++ | + + | +
| 128 | ++ |
+ #' Gets filter expression for multiple `datanames` taking into account its order.+ |
+
| 129 | ++ |
+ #'+ |
+
| 130 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 131 | ++ |
+ #' To be used in show R code button.+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' @param datasets (`FilteredData`)+ |
+
| 134 | ++ |
+ #' @param datanames (`character`) vector of dataset names+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' @export+ |
+
| 137 | ++ |
+ #'+ |
+
| 138 | ++ |
+ #' @return (`expression`)+ |
+
| 139 | ++ |
+ get_filter_expr <- function(datasets, datanames = datasets$datanames()) {
+ |
+
| 140 | +2x | +
+ checkmate::assert_character(datanames, min.len = 1, any.missing = FALSE)+ |
+
| 141 | +2x | +
+ stopifnot(+ |
+
| 142 | +2x | +
+ is(datasets, "FilteredData"),+ |
+
| 143 | +2x | +
+ all(datanames %in% datasets$datanames())+ |
+
| 144 | ++ |
+ )+ |
+
| 145 | ++ | + + | +
| 146 | +2x | +
+ paste(+ |
+
| 147 | +2x | +
+ unlist(lapply(+ |
+
| 148 | +2x | +
+ datanames,+ |
+
| 149 | +2x | +
+ function(dataname) {
+ |
+
| 150 | +4x | +
+ datasets$get_call(dataname)+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ |
+ )),+ |
+
| 153 | +2x | +
+ collapse = "\n"+ |
+
| 154 | ++ |
+ )+ |
+
| 155 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @title `FilterStates` R6 class+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Abstract class that manages adding and removing `FilterState` objects+ |
+
| 5 | ++ |
+ #' and builds a \emph{subset expression}.
+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' A `FilterStates` object tracks all subsetting expressions+ |
+
| 8 | ++ |
+ #' (logical predicates that limit observations) associated with a given dataset+ |
+
| 9 | ++ |
+ #' and composes them into a single reproducible R expression+ |
+
| 10 | ++ |
+ #' that will assign a subset of the original data to a new variable.+ |
+
| 11 | ++ |
+ #' This expression is hereafter referred to as \emph{subset expression}.
+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' The \emph{subset expression} is constructed differently for different
+ |
+
| 14 | ++ |
+ #' classes of the underlying data object and `FilterStates` sub-classes.+ |
+
| 15 | ++ |
+ #' Currently implemented for `data.frame`, `matrix`,+ |
+
| 16 | ++ |
+ #' `SummarizedExperiment`, and `MultiAssayExperiment`.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @keywords internal+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ FilterStates <- R6::R6Class( # nolint+ |
+
| 21 | ++ |
+ classname = "FilterStates",+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ # public members ----+ |
+
| 24 | ++ |
+ public = list(+ |
+
| 25 | ++ |
+ #' @description+ |
+
| 26 | ++ |
+ #' Initializes `FilterStates` object.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' Initializes `FilterStates` object by setting+ |
+
| 29 | ++ |
+ #' `dataname`, and `datalabel`.+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr+ |
+
| 32 | ++ |
+ #' the R object which `subset` function is applied on.+ |
+
| 33 | ++ |
+ #' @param data_reactive (`function(sid)`)\cr+ |
+
| 34 | ++ |
+ #' should return an object of the same type as `data` object or `NULL`.+ |
+
| 35 | ++ |
+ #' This object is needed for the `FilterState` counts being updated+ |
+
| 36 | ++ |
+ #' on a change in filters. If function returns `NULL` then filtered counts are not shown.+ |
+
| 37 | ++ |
+ #' Function has to have `sid` argument being a character.+ |
+
| 38 | ++ |
+ #' @param dataname (`character(1)`)\cr+ |
+
| 39 | ++ |
+ #' name of the data used in the expression+ |
+
| 40 | ++ |
+ #' specified to the function argument attached to this `FilterStates`+ |
+
| 41 | ++ |
+ #' @param datalabel (`NULL` or `character(1)`)\cr+ |
+
| 42 | ++ |
+ #' text label value+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @return+ |
+
| 45 | ++ |
+ #' self invisibly+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ initialize = function(data,+ |
+
| 48 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 49 | ++ |
+ dataname,+ |
+
| 50 | ++ |
+ datalabel = NULL) {
+ |
+
| 51 | +296x | +
+ checkmate::assert_string(dataname)+ |
+
| 52 | +294x | +
+ logger::log_trace("Instantiating { class(self)[1] }, dataname: { dataname }")
+ |
+
| 53 | +294x | +
+ checkmate::assert_function(data_reactive, args = "sid")+ |
+
| 54 | +294x | +
+ checkmate::assert_string(datalabel, null.ok = TRUE)+ |
+
| 55 | ++ | + + | +
| 56 | +294x | +
+ private$dataname <- dataname+ |
+
| 57 | +294x | +
+ private$datalabel <- datalabel+ |
+
| 58 | +294x | +
+ private$dataname_prefixed <- dataname+ |
+
| 59 | +294x | +
+ private$data <- data+ |
+
| 60 | +294x | +
+ private$data_reactive <- data_reactive+ |
+
| 61 | +294x | +
+ private$state_list <- reactiveVal()+ |
+
| 62 | ++ | + + | +
| 63 | +294x | +
+ logger::log_trace("Instantiated { class(self)[1] }, dataname: { private$dataname }")
+ |
+
| 64 | +294x | +
+ invisible(self)+ |
+
| 65 | ++ |
+ },+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ #' @description+ |
+
| 68 | ++ |
+ #' Returns a formatted string representing this `FilterStates` object.+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @param show_all `logical(1)` passed to `format.teal_slices`+ |
+
| 71 | ++ |
+ #' @param trim_lines `logical(1)` passed to `format.teal_slices`+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @return `character(1)` the formatted string+ |
+
| 74 | ++ |
+ #'+ |
+
| 75 | ++ |
+ format = function(show_all = FALSE, trim_lines = TRUE) {
+ |
+
| 76 | +! | +
+ sprintf(+ |
+
| 77 | +! | +
+ "%s:\n%s",+ |
+
| 78 | +! | +
+ class(self)[1],+ |
+
| 79 | +! | +
+ format(self$get_filter_state(), show_all = show_all, trim_lines = trim_lines)+ |
+
| 80 | ++ |
+ )+ |
+
| 81 | ++ |
+ },+ |
+
| 82 | ++ | + + | +
| 83 | ++ |
+ #' @description+ |
+
| 84 | ++ |
+ #' Filter call+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' Builds \emph{subset expression} from condition calls generated by `FilterState`.
+ |
+
| 87 | ++ |
+ #' The `lhs` of the expression is a `dataname_prefixed`, where word prefixed refers to+ |
+
| 88 | ++ |
+ #' situation when call is evaluated on elements of the original data, for example `dataname[[x]]`.+ |
+
| 89 | ++ |
+ #' By default `dataname_prefixed = dataname` and it's not alterable through class methods.+ |
+
| 90 | ++ |
+ #' Customization of `private$dataname_prefixed` is done through inheriting classes.+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' The `rhs` is a call to `private$fun` with following arguments:+ |
+
| 93 | ++ |
+ #' - `dataname_prefixed`+ |
+
| 94 | ++ |
+ #' - list of logical expressions generated by `FilterState` objects+ |
+
| 95 | ++ |
+ #' stored in `private$state_list`. Each logical predicate is combined with `&` operator.+ |
+
| 96 | ++ |
+ #' Variables in these logical expressions by default are not prefixed but this can be changed+ |
+
| 97 | ++ |
+ #' by setting `private$extract_type` (change in the similar way as `dataname_prefixed`)+ |
+
| 98 | ++ |
+ #' Possible call outputs depending on a custom fields/options:+ |
+
| 99 | ++ |
+ #' ```+ |
+
| 100 | ++ |
+ #' # default+ |
+
| 101 | ++ |
+ #' dataname <- subset(dataname, col == "x")+ |
+
| 102 | ++ |
+ #'+ |
+
| 103 | ++ |
+ #' # fun = dplyr::filter+ |
+
| 104 | ++ |
+ #' dataname <- dplyr::filter(dataname, col == "x")+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' # fun = MultiAssayExperiment::subsetByColData; extract_type = "list"+ |
+
| 107 | ++ |
+ #' dataname <- MultiAssayExperiment::subsetByColData(dataname, dataname$col == "x")+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' # teal_slice objects having `arg = "subset"` and `arg = "select"`+ |
+
| 110 | ++ |
+ #' dataname <- subset(dataname, subset = row_col == "x", select = col_col == "x")+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' # dataname = dataname[[element]]+ |
+
| 113 | ++ |
+ #' dataname[[element]] <- subset(dataname[[element]], subset = col == "x")+ |
+
| 114 | ++ |
+ #' ```+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' If no filters are applied, `NULL` is returned to avoid no-op calls such as `dataname <- dataname`.+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' @param sid (`character`)\cr+ |
+
| 119 | ++ |
+ #' when specified then method returns code containing filter conditions of+ |
+
| 120 | ++ |
+ #' `FilterState` objects which `"sid"` attribute is different than this `sid` argument.+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ #' @return `call` or `NULL`+ |
+
| 123 | ++ |
+ #'+ |
+
| 124 | ++ |
+ get_call = function(sid = "") {
+ |
+
| 125 | +82x | +
+ logger::log_trace("FilterStates$get_call initializing")
+ |
+
| 126 | ++ | + + | +
| 127 | ++ |
+ # `arg` must be the same as argument of the function where+ |
+
| 128 | ++ |
+ # predicate is passed to.+ |
+
| 129 | ++ |
+ # For unnamed arguments state_list should have `arg = NULL`+ |
+
| 130 | +82x | +
+ states_list <- private$state_list_get()+ |
+
| 131 | +82x | +
+ if (length(states_list) == 0) {
+ |
+
| 132 | +47x | +
+ return(NULL)+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | +35x | +
+ args <- vapply(+ |
+
| 135 | +35x | +
+ states_list,+ |
+
| 136 | +35x | +
+ function(x) {
+ |
+
| 137 | +56x | +
+ arg <- x$get_state()$arg+ |
+
| 138 | +7x | +
+ `if`(is.null(arg), "", arg) # converting NULL -> "" to enable tapply.+ |
+
| 139 | ++ |
+ },+ |
+
| 140 | +35x | +
+ character(1)+ |
+
| 141 | ++ |
+ )+ |
+
| 142 | ++ | + + | +
| 143 | +35x | +
+ filter_items <- tapply(+ |
+
| 144 | +35x | +
+ X = states_list,+ |
+
| 145 | +35x | +
+ INDEX = args,+ |
+
| 146 | +35x | +
+ simplify = FALSE,+ |
+
| 147 | +35x | +
+ function(items) {
+ |
+
| 148 | ++ |
+ # removing filters identified by sid+ |
+
| 149 | +37x | +
+ other_filter_idx <- !names(items) %in% sid+ |
+
| 150 | +37x | +
+ filtered_items <- items[other_filter_idx]+ |
+
| 151 | ++ | + + | +
| 152 | +37x | +
+ calls <- Filter(+ |
+
| 153 | +37x | +
+ Negate(is.null),+ |
+
| 154 | +37x | +
+ lapply(+ |
+
| 155 | +37x | +
+ filtered_items,+ |
+
| 156 | +37x | +
+ function(state) {
+ |
+
| 157 | +50x | +
+ state$get_call(dataname = private$dataname_prefixed)+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ |
+ )+ |
+
| 161 | +37x | +
+ calls_combine_by(calls, operator = "&")+ |
+
| 162 | ++ |
+ }+ |
+
| 163 | ++ |
+ )+ |
+
| 164 | +35x | +
+ filter_items <- Filter(+ |
+
| 165 | +35x | +
+ x = filter_items,+ |
+
| 166 | +35x | +
+ f = Negate(is.null)+ |
+
| 167 | ++ |
+ )+ |
+
| 168 | +35x | +
+ if (length(filter_items) > 0L) {
+ |
+
| 169 | +34x | +
+ filter_function <- private$fun+ |
+
| 170 | +34x | +
+ data_name <- str2lang(private$dataname_prefixed)+ |
+
| 171 | +34x | +
+ substitute(+ |
+
| 172 | +34x | +
+ env = list(+ |
+
| 173 | +34x | +
+ lhs = data_name,+ |
+
| 174 | +34x | +
+ rhs = as.call(c(filter_function, c(list(data_name), filter_items)))+ |
+
| 175 | ++ |
+ ),+ |
+
| 176 | +34x | +
+ expr = lhs <- rhs+ |
+
| 177 | ++ |
+ )+ |
+
| 178 | ++ |
+ } else {
+ |
+
| 179 | ++ |
+ # return NULL to avoid no-op call+ |
+
| 180 | +1x | +
+ NULL+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ |
+ },+ |
+
| 183 | ++ | + + | +
| 184 | ++ |
+ #' @description+ |
+
| 185 | ++ |
+ #' Prints this `FilterStates` object.+ |
+
| 186 | ++ |
+ #'+ |
+
| 187 | ++ |
+ #' @param ... additional arguments+ |
+
| 188 | ++ |
+ print = function(...) {
+ |
+
| 189 | +! | +
+ cat(shiny::isolate(self$format(...)), "\n")+ |
+
| 190 | ++ |
+ },+ |
+
| 191 | ++ | + + | +
| 192 | ++ |
+ #' @description+ |
+
| 193 | ++ |
+ #' Remove one or more `FilterState`s from the `state_list` along with their UI elements.+ |
+
| 194 | ++ |
+ #'+ |
+
| 195 | ++ |
+ #' @param state (`teal_slices`)\cr+ |
+
| 196 | ++ |
+ #' specifying `FilterState` objects to remove;+ |
+
| 197 | ++ |
+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored+ |
+
| 198 | ++ |
+ #'+ |
+
| 199 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 200 | ++ |
+ #'+ |
+
| 201 | ++ |
+ remove_filter_state = function(state) {
+ |
+
| 202 | +17x | +
+ shiny::isolate({
+ |
+
| 203 | +17x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 204 | +17x | +
+ state_ids <- vapply(state, `[[`, character(1), "id")+ |
+
| 205 | +17x | +
+ logger::log_trace("{ class(self)[1] }$remove_filter_state removing filters, state_id: { toString(state_ids) }")
+ |
+
| 206 | +17x | +
+ private$state_list_remove(state_ids)+ |
+
| 207 | +17x | +
+ invisible(NULL)+ |
+
| 208 | ++ |
+ })+ |
+
| 209 | ++ |
+ },+ |
+
| 210 | ++ | + + | +
| 211 | ++ |
+ #' @description+ |
+
| 212 | ++ |
+ #' Gets reactive values from active `FilterState` objects.+ |
+
| 213 | ++ |
+ #'+ |
+
| 214 | ++ |
+ #' Get active filter state from `FilterState` objects stored in `state_list`(s).+ |
+
| 215 | ++ |
+ #' The output is a list compatible with input to `self$set_filter_state`.+ |
+
| 216 | ++ |
+ #'+ |
+
| 217 | ++ |
+ #' @return `list` containing `list` per `FilterState` in the `state_list`+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ get_filter_state = function() {
+ |
+
| 220 | +370x | +
+ slices <- unname(lapply(private$state_list(), function(x) x$get_state()))+ |
+
| 221 | +370x | +
+ fs <- do.call(teal_slices, c(slices, list(count_type = private$count_type)))+ |
+
| 222 | ++ | + + | +
| 223 | +370x | +
+ include_varnames <- private$include_varnames+ |
+
| 224 | +370x | +
+ if (length(include_varnames)) {
+ |
+
| 225 | +211x | +
+ attr(fs, "include_varnames") <- structure(+ |
+
| 226 | +211x | +
+ list(include_varnames),+ |
+
| 227 | +211x | +
+ names = private$dataname+ |
+
| 228 | ++ |
+ )+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | ++ | + + | +
| 231 | +370x | +
+ exclude_varnames <- private$exclude_varnames+ |
+
| 232 | +370x | +
+ if (length(exclude_varnames)) {
+ |
+
| 233 | +8x | +
+ attr(fs, "exclude_varnames") <- structure(+ |
+
| 234 | +8x | +
+ list(exclude_varnames),+ |
+
| 235 | +8x | +
+ names = private$dataname+ |
+
| 236 | ++ |
+ )+ |
+
| 237 | ++ |
+ }+ |
+
| 238 | ++ | + + | +
| 239 | +370x | +
+ return(fs)+ |
+
| 240 | ++ |
+ },+ |
+
| 241 | ++ | + + | +
| 242 | ++ |
+ #' @description+ |
+
| 243 | ++ |
+ #' Sets active `FilterState` objects.+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 246 | ++ |
+ #' data which are supposed to be filtered+ |
+
| 247 | ++ |
+ #' @param state (`named list`)\cr+ |
+
| 248 | ++ |
+ #' should contain values which are initial selection in the `FilterState`.+ |
+
| 249 | ++ |
+ #' Names of the `list` element should correspond to the name of the+ |
+
| 250 | ++ |
+ #' column in `data`.+ |
+
| 251 | ++ |
+ #' @return function which throws an error+ |
+
| 252 | ++ |
+ set_filter_state = function(state) {
+ |
+
| 253 | +131x | +
+ shiny::isolate({
+ |
+
| 254 | +131x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
+ |
+
| 255 | +131x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 256 | +131x | +
+ lapply(state, function(x) {
+ |
+
| 257 | +179x | +
+ checkmate::assert_true(+ |
+
| 258 | +179x | +
+ x$dataname == private$dataname,+ |
+
| 259 | +179x | +
+ .var.name = "dataname matches private$dataname"+ |
+
| 260 | ++ |
+ )+ |
+
| 261 | ++ |
+ })+ |
+
| 262 | ++ | + + | +
| 263 | +131x | +
+ private$set_filterable_varnames(+ |
+
| 264 | +131x | +
+ include_varnames = attr(state, "include_varnames")[[private$dataname]],+ |
+
| 265 | +131x | +
+ exclude_varnames = attr(state, "exclude_varnames")[[private$dataname]]+ |
+
| 266 | ++ |
+ )+ |
+
| 267 | ++ | + + | +
| 268 | +131x | +
+ count_type <- attr(state, "count_type")+ |
+
| 269 | +131x | +
+ if (length(count_type)) {
+ |
+
| 270 | +19x | +
+ private$count_type <- count_type+ |
+
| 271 | ++ |
+ }+ |
+
| 272 | ++ | + + | +
| 273 | ++ |
+ # Drop teal_slices that refer to excluded variables.+ |
+
| 274 | +131x | +
+ varnames <- slices_field(state, "varname")+ |
+
| 275 | +131x | +
+ excluded_varnames <- setdiff(varnames, private$get_filterable_varnames())+ |
+
| 276 | +131x | +
+ if (length(excluded_varnames)) {
+ |
+
| 277 | +1x | +
+ state <- Filter(function(x) !x$varname %in% excluded_varnames, state)+ |
+
| 278 | +1x | +
+ logger::log_warn("filters for columns: { toString(excluded_varnames) } excluded from { private$dataname }")
+ |
+
| 279 | ++ |
+ }+ |
+
| 280 | ++ | + + | +
| 281 | +131x | +
+ if (length(state) > 0) {
+ |
+
| 282 | +92x | +
+ private$set_filter_state_impl(+ |
+
| 283 | +92x | +
+ state = state,+ |
+
| 284 | +92x | +
+ data = private$data,+ |
+
| 285 | +92x | +
+ data_reactive = private$data_reactive+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | ++ |
+ }+ |
+
| 288 | +131x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
+ |
+
| 289 | ++ | + + | +
| 290 | +131x | +
+ invisible(NULL)+ |
+
| 291 | ++ |
+ })+ |
+
| 292 | ++ |
+ },+ |
+
| 293 | ++ | + + | +
| 294 | ++ |
+ #' @description+ |
+
| 295 | ++ |
+ #' Remove all `FilterState` objects from this `FilterStates` object.+ |
+
| 296 | ++ |
+ #'+ |
+
| 297 | ++ |
+ #' @return NULL+ |
+
| 298 | ++ |
+ #'+ |
+
| 299 | ++ |
+ clear_filter_states = function() {
+ |
+
| 300 | +25x | +
+ private$state_list_empty()+ |
+
| 301 | ++ |
+ },+ |
+
| 302 | ++ | + + | +
| 303 | ++ |
+ # shiny modules ----+ |
+
| 304 | ++ | + + | +
| 305 | ++ |
+ #' @description+ |
+
| 306 | ++ |
+ #' Shiny module UI+ |
+
| 307 | ++ |
+ #'+ |
+
| 308 | ++ |
+ #' Shiny UI element that stores `FilterState` UI elements.+ |
+
| 309 | ++ |
+ #' Populated with elements created with `renderUI` in the module server.+ |
+
| 310 | ++ |
+ #'+ |
+
| 311 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 312 | ++ |
+ #' shiny element (module instance) id+ |
+
| 313 | ++ |
+ #'+ |
+
| 314 | ++ |
+ #' @return `shiny.tag`+ |
+
| 315 | ++ |
+ #'+ |
+
| 316 | ++ |
+ ui_active = function(id) {
+ |
+
| 317 | +! | +
+ ns <- NS(id)+ |
+
| 318 | +! | +
+ tagList(+ |
+
| 319 | +! | +
+ teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 320 | +! | +
+ uiOutput(ns("trigger_visible_state_change"), inline = TRUE),
+ |
+
| 321 | +! | +
+ uiOutput(+ |
+
| 322 | +! | +
+ ns("cards"),
+ |
+
| 323 | +! | +
+ class = "accordion",+ |
+
| 324 | +! | +
+ `data-label` = ifelse(length(private$datalabel), paste0("> ", private$datalabel), ""),
+ |
+
| 325 | ++ |
+ )+ |
+
| 326 | ++ |
+ )+ |
+
| 327 | ++ |
+ },+ |
+
| 328 | ++ | + + | +
| 329 | ++ |
+ #' @description+ |
+
| 330 | ++ |
+ #' Shiny server module.+ |
+
| 331 | ++ |
+ #'+ |
+
| 332 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 333 | ++ |
+ #' shiny module instance id+ |
+
| 334 | ++ |
+ #'+ |
+
| 335 | ++ |
+ #' @return `moduleServer` function which returns `NULL`+ |
+
| 336 | ++ |
+ #'+ |
+
| 337 | ++ |
+ srv_active = function(id) {
+ |
+
| 338 | +12x | +
+ moduleServer(+ |
+
| 339 | +12x | +
+ id = id,+ |
+
| 340 | +12x | +
+ function(input, output, session) {
+ |
+
| 341 | +12x | +
+ logger::log_trace("FilterState$srv_active initializing, dataname: { private$dataname }")
+ |
+
| 342 | +12x | +
+ current_state <- reactive(private$state_list_get())+ |
+
| 343 | +12x | +
+ previous_state <- reactiveVal(NULL) # FilterState list+ |
+
| 344 | +12x | +
+ added_states <- reactiveVal(NULL) # FilterState list+ |
+
| 345 | ++ | + + | +
| 346 | ++ |
+ # gives a valid shiny ns based on a default slice id+ |
+
| 347 | +12x | +
+ fs_to_shiny_ns <- function(x) {
+ |
+
| 348 | +24x | +
+ checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
+ |
+
| 349 | +24x | +
+ gsub("[^[:alnum:]]+", "_", get_default_slice_id(x$get_state()))
+ |
+
| 350 | ++ |
+ }+ |
+
| 351 | ++ | + + | +
| 352 | +12x | +
+ output$trigger_visible_state_change <- renderUI({
+ |
+
| 353 | +14x | +
+ current_state()+ |
+
| 354 | +14x | +
+ isolate({
+ |
+
| 355 | +14x | +
+ logger::log_trace("FilterStates$srv_active@1 determining added and removed filter states")
+ |
+
| 356 | ++ |
+ # Be aware this returns a list because `current_state` is a list and not `teal_slices`.+ |
+
| 357 | +14x | +
+ added_states(setdiff_teal_slices(current_state(), previous_state()))+ |
+
| 358 | +14x | +
+ previous_state(current_state())+ |
+
| 359 | +14x | +
+ NULL+ |
+
| 360 | ++ |
+ })+ |
+
| 361 | ++ |
+ })+ |
+
| 362 | ++ | + + | +
| 363 | +12x | +
+ output[["cards"]] <- shiny::renderUI({
+ |
+
| 364 | +14x | +
+ lapply(+ |
+
| 365 | +14x | +
+ current_state(), # observes only if added/removed+ |
+
| 366 | +14x | +
+ function(state) {
+ |
+
| 367 | +12x | +
+ shiny::isolate( # isolates when existing state changes+ |
+
| 368 | +12x | +
+ state$ui(id = session$ns(fs_to_shiny_ns(state)), parent_id = session$ns("cards"))
+ |
+
| 369 | ++ |
+ )+ |
+
| 370 | ++ |
+ }+ |
+
| 371 | ++ |
+ )+ |
+
| 372 | ++ |
+ })+ |
+
| 373 | ++ | + + | +
| 374 | +12x | +
+ observeEvent(+ |
+
| 375 | +12x | +
+ added_states(), # we want to call FilterState module only once when it's added+ |
+
| 376 | +12x | +
+ ignoreNULL = TRUE,+ |
+
| 377 | ++ |
+ {
+ |
+
| 378 | +10x | +
+ added_state_names <- vapply(added_states(), function(x) x$get_state()$id, character(1L))+ |
+
| 379 | +10x | +
+ logger::log_trace("FilterStates$srv_active@2 triggered by added states: { toString(added_state_names) }")
+ |
+
| 380 | +10x | +
+ lapply(added_states(), function(state) {
+ |
+
| 381 | +12x | +
+ fs_callback <- state$server(id = fs_to_shiny_ns(state))+ |
+
| 382 | +12x | +
+ observeEvent(+ |
+
| 383 | +12x | +
+ eventExpr = fs_callback(), # when remove button is clicked in the FilterState ui+ |
+
| 384 | +12x | +
+ once = TRUE, # remove button can be called once, should be destroyed afterwards+ |
+
| 385 | +12x | +
+ handlerExpr = private$state_list_remove(state$get_state()$id)+ |
+
| 386 | ++ |
+ )+ |
+
| 387 | ++ |
+ })+ |
+
| 388 | +10x | +
+ added_states(NULL)+ |
+
| 389 | ++ |
+ }+ |
+
| 390 | ++ |
+ )+ |
+
| 391 | ++ | + + | +
| 392 | +12x | +
+ NULL+ |
+
| 393 | ++ |
+ }+ |
+
| 394 | ++ |
+ )+ |
+
| 395 | ++ |
+ },+ |
+
| 396 | ++ | + + | +
| 397 | ++ |
+ #' @description+ |
+
| 398 | ++ |
+ #' Shiny UI module to add filter variable.+ |
+
| 399 | ++ |
+ #'+ |
+
| 400 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 401 | ++ |
+ #' shiny element (module instance) id+ |
+
| 402 | ++ |
+ #'+ |
+
| 403 | ++ |
+ #' @return `shiny.tag`+ |
+
| 404 | ++ |
+ #'+ |
+
| 405 | ++ |
+ ui_add = function(id) {
+ |
+
| 406 | +1x | +
+ checkmate::assert_string(id)+ |
+
| 407 | +1x | +
+ data <- private$data+ |
+
| 408 | ++ | + + | +
| 409 | +1x | +
+ ns <- NS(id)+ |
+
| 410 | ++ | + + | +
| 411 | +1x | +
+ if (ncol(data) == 0) {
+ |
+
| 412 | +1x | +
+ div("no sample variables available")
+ |
+
| 413 | +! | +
+ } else if (nrow(data) == 0) {
+ |
+
| 414 | +! | +
+ div("no samples available")
+ |
+
| 415 | ++ |
+ } else {
+ |
+
| 416 | +! | +
+ uiOutput(ns("add_filter"))
+ |
+
| 417 | ++ |
+ }+ |
+
| 418 | ++ |
+ },+ |
+
| 419 | ++ | + + | +
| 420 | ++ |
+ #' @description+ |
+
| 421 | ++ |
+ #' Shiny server module to add filter variable.+ |
+
| 422 | ++ |
+ #'+ |
+
| 423 | ++ |
+ #' This module controls available choices to select as a filter variable.+ |
+
| 424 | ++ |
+ #' Once selected, a variable is removed from available choices.+ |
+
| 425 | ++ |
+ #' Removing a filter variable adds it back to available choices.+ |
+
| 426 | ++ |
+ #'+ |
+
| 427 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 428 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 429 | ++ |
+ #'+ |
+
| 430 | ++ |
+ #' @return `moduleServer` function which returns `NULL`+ |
+
| 431 | ++ |
+ srv_add = function(id) {
+ |
+
| 432 | +8x | +
+ moduleServer(+ |
+
| 433 | +8x | +
+ id = id,+ |
+
| 434 | +8x | +
+ function(input, output, session) {
+ |
+
| 435 | +8x | +
+ logger::log_trace("FilterStates$srv_add initializing, dataname: { private$dataname }")
+ |
+
| 436 | ++ | + + | +
| 437 | ++ |
+ # available choices to display+ |
+
| 438 | +8x | +
+ avail_column_choices <- reactive({
+ |
+
| 439 | +9x | +
+ data <- private$data+ |
+
| 440 | +9x | +
+ vars_include <- private$get_filterable_varnames()+ |
+
| 441 | +9x | +
+ active_filter_vars <- slices_field(self$get_filter_state(), "varname")+ |
+
| 442 | +9x | +
+ choices <- setdiff(vars_include, active_filter_vars)+ |
+
| 443 | +9x | +
+ varlabels <- get_varlabels(data)+ |
+
| 444 | ++ | + + | +
| 445 | +9x | +
+ data_choices_labeled(+ |
+
| 446 | +9x | +
+ data = data,+ |
+
| 447 | +9x | +
+ choices = choices,+ |
+
| 448 | +9x | +
+ varlabels = varlabels,+ |
+
| 449 | +9x | +
+ keys = private$keys+ |
+
| 450 | ++ |
+ )+ |
+
| 451 | ++ |
+ })+ |
+
| 452 | ++ | + + | +
| 453 | ++ | + + | +
| 454 | +8x | +
+ output$add_filter <- renderUI({
+ |
+
| 455 | +6x | +
+ logger::log_trace(+ |
+
| 456 | +6x | +
+ "FilterStates$srv_add@1 updating available column choices, dataname: { private$dataname }"
+ |
+
| 457 | ++ |
+ )+ |
+
| 458 | +6x | +
+ if (length(avail_column_choices()) == 0) {
+ |
+
| 459 | +! | +
+ span("No available columns to add.")
+ |
+
| 460 | ++ |
+ } else {
+ |
+
| 461 | +6x | +
+ div(+ |
+
| 462 | +6x | +
+ teal.widgets::optionalSelectInput(+ |
+
| 463 | +6x | +
+ session$ns("var_to_add"),
+ |
+
| 464 | +6x | +
+ choices = avail_column_choices(),+ |
+
| 465 | +6x | +
+ selected = NULL,+ |
+
| 466 | +6x | +
+ options = shinyWidgets::pickerOptions(+ |
+
| 467 | +6x | +
+ liveSearch = TRUE,+ |
+
| 468 | +6x | +
+ noneSelectedText = "Select variable to filter"+ |
+
| 469 | ++ |
+ )+ |
+
| 470 | ++ |
+ )+ |
+
| 471 | ++ |
+ )+ |
+
| 472 | ++ |
+ }+ |
+
| 473 | ++ |
+ })+ |
+
| 474 | ++ | + + | +
| 475 | +8x | +
+ observeEvent(+ |
+
| 476 | +8x | +
+ eventExpr = input$var_to_add,+ |
+
| 477 | +8x | +
+ handlerExpr = {
+ |
+
| 478 | +3x | +
+ logger::log_trace(+ |
+
| 479 | +3x | +
+ sprintf(+ |
+
| 480 | +3x | +
+ "FilterStates$srv_add@2 adding FilterState of variable %s, dataname: %s",+ |
+
| 481 | +3x | +
+ input$var_to_add,+ |
+
| 482 | +3x | +
+ private$dataname+ |
+
| 483 | ++ |
+ )+ |
+
| 484 | ++ |
+ )+ |
+
| 485 | +3x | +
+ self$set_filter_state(+ |
+
| 486 | +3x | +
+ teal_slices(+ |
+
| 487 | +3x | +
+ teal_slice(dataname = private$dataname, varname = input$var_to_add)+ |
+
| 488 | ++ |
+ )+ |
+
| 489 | ++ |
+ )+ |
+
| 490 | +3x | +
+ logger::log_trace(+ |
+
| 491 | +3x | +
+ sprintf(+ |
+
| 492 | +3x | +
+ "FilterStates$srv_add@2 added FilterState of variable %s, dataname: %s",+ |
+
| 493 | +3x | +
+ input$var_to_add,+ |
+
| 494 | +3x | +
+ private$dataname+ |
+
| 495 | ++ |
+ )+ |
+
| 496 | ++ |
+ )+ |
+
| 497 | ++ |
+ }+ |
+
| 498 | ++ |
+ )+ |
+
| 499 | ++ | + + | +
| 500 | +8x | +
+ logger::log_trace("FilterStates$srv_add initialized, dataname: { private$dataname }")
+ |
+
| 501 | +8x | +
+ NULL+ |
+
| 502 | ++ |
+ }+ |
+
| 503 | ++ |
+ )+ |
+
| 504 | ++ |
+ }+ |
+
| 505 | ++ |
+ ),+ |
+
| 506 | ++ |
+ private = list(+ |
+
| 507 | ++ |
+ # private fields ----+ |
+
| 508 | ++ |
+ count_type = "none", # specifies how observation numbers are displayed in filter cards,+ |
+
| 509 | ++ |
+ data = NULL, # data.frame, MAE, SE or matrix+ |
+
| 510 | ++ |
+ data_reactive = NULL, # reactive+ |
+
| 511 | ++ |
+ datalabel = NULL, # to follow default `experiment = NULL` in `teal_slice`+ |
+
| 512 | ++ |
+ dataname = NULL, # because it holds object of class name+ |
+
| 513 | ++ |
+ dataname_prefixed = character(0), # name used in call returned from get_call+ |
+
| 514 | ++ |
+ exclude_varnames = character(0), # holds column names+ |
+
| 515 | ++ |
+ include_varnames = character(0), # holds column names+ |
+
| 516 | ++ |
+ extract_type = character(0), # type of the prefix in a subset call (eg. "list": x$var; "matrix": x[["var"]])+ |
+
| 517 | ++ |
+ fun = quote(subset), # function used to generate subset call+ |
+
| 518 | ++ |
+ keys = character(0),+ |
+
| 519 | ++ |
+ ns = NULL, # shiny ns()+ |
+
| 520 | ++ |
+ observers = list(), # observers+ |
+
| 521 | ++ |
+ state_list = NULL, # list of `reactiveVal`s initialized by init methods of child classes,+ |
+
| 522 | ++ | + + | +
| 523 | ++ |
+ # private methods ----+ |
+
| 524 | ++ | + + | +
| 525 | ++ |
+ # @description+ |
+
| 526 | ++ |
+ # Set the allowed filterable variables+ |
+
| 527 | ++ |
+ # @param include_varnames (`character`) Names of variables included in filtering.+ |
+
| 528 | ++ |
+ # @param exclude_varnames (`character`) Names of variables excluded from filtering.+ |
+
| 529 | ++ |
+ #+ |
+
| 530 | ++ |
+ # @details When retrieving the filtered variables only+ |
+
| 531 | ++ |
+ # those which have filtering supported (i.e. are of the permitted types).+ |
+
| 532 | ++ |
+ # Only one from `include_varnames` and `exclude_varnames` can be used in one call. When `exclude_varnames`+ |
+
| 533 | ++ |
+ # is called `include_varnames` is cleared - same otherwise.+ |
+
| 534 | ++ |
+ # are included.+ |
+
| 535 | ++ |
+ #+ |
+
| 536 | ++ |
+ # @return NULL invisibly+ |
+
| 537 | ++ |
+ set_filterable_varnames = function(include_varnames = character(0), exclude_varnames = character(0)) {
+ |
+
| 538 | +300x | +
+ if ((length(include_varnames) + length(exclude_varnames)) == 0L) {
+ |
+
| 539 | +110x | +
+ return(invisible(NULL))+ |
+
| 540 | ++ |
+ }+ |
+
| 541 | +190x | +
+ checkmate::assert_character(include_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE)+ |
+
| 542 | +190x | +
+ checkmate::assert_character(exclude_varnames, any.missing = FALSE, min.len = 0L, null.ok = TRUE)+ |
+
| 543 | +190x | +
+ if (length(include_varnames) && length(exclude_varnames)) {
+ |
+
| 544 | +! | +
+ stop(+ |
+
| 545 | +! | +
+ "`include_varnames` and `exclude_varnames` has been both specified for",+ |
+
| 546 | +! | +
+ private$dataname,+ |
+
| 547 | +! | +
+ ". Only one per dataset is allowed.",+ |
+
| 548 | ++ |
+ )+ |
+
| 549 | ++ |
+ }+ |
+
| 550 | +190x | +
+ supported_vars <- get_supported_filter_varnames(private$data)+ |
+
| 551 | +190x | +
+ if (length(include_varnames)) {
+ |
+
| 552 | +181x | +
+ private$include_varnames <- intersect(include_varnames, supported_vars)+ |
+
| 553 | +181x | +
+ private$exclude_varnames <- character(0)+ |
+
| 554 | ++ |
+ } else {
+ |
+
| 555 | +9x | +
+ private$exclude_varnames <- exclude_varnames+ |
+
| 556 | +9x | +
+ private$include_varnames <- character(0)+ |
+
| 557 | ++ |
+ }+ |
+
| 558 | +190x | +
+ invisible(NULL)+ |
+
| 559 | ++ |
+ },+ |
+
| 560 | ++ | + + | +
| 561 | ++ |
+ # @description+ |
+
| 562 | ++ |
+ # Get vector of filterable varnames+ |
+
| 563 | ++ |
+ #+ |
+
| 564 | ++ |
+ # @details+ |
+
| 565 | ++ |
+ # These are the only columns which can be used in the filter panel+ |
+
| 566 | ++ |
+ #+ |
+
| 567 | ++ |
+ # @return character vector with names of the columns+ |
+
| 568 | ++ |
+ get_filterable_varnames = function() {
+ |
+
| 569 | +140x | +
+ if (length(private$include_varnames)) {
+ |
+
| 570 | +98x | +
+ private$include_varnames+ |
+
| 571 | ++ |
+ } else {
+ |
+
| 572 | +42x | +
+ supported_varnames <- get_supported_filter_varnames(private$data)+ |
+
| 573 | +42x | +
+ setdiff(supported_varnames, private$exclude_varnames)+ |
+
| 574 | ++ |
+ }+ |
+
| 575 | ++ |
+ },+ |
+
| 576 | ++ | + + | +
| 577 | ++ |
+ # state_list methods ----+ |
+
| 578 | ++ | + + | +
| 579 | ++ |
+ # @description+ |
+
| 580 | ++ |
+ # Returns a list of `FilterState` objects stored in this `FilterStates`.+ |
+
| 581 | ++ |
+ #+ |
+
| 582 | ++ |
+ # @param state_id (`character(1)`)\cr+ |
+
| 583 | ++ |
+ # name of element in a filter state (which is a `reactiveVal` containing a list)+ |
+
| 584 | ++ |
+ #+ |
+
| 585 | ++ |
+ # @return `list` of `FilterState` objects+ |
+
| 586 | ++ |
+ #+ |
+
| 587 | ++ |
+ state_list_get = function(state_id = NULL) {
+ |
+
| 588 | +207x | +
+ checkmate::assert_string(state_id, null.ok = TRUE)+ |
+
| 589 | ++ | + + | +
| 590 | +207x | +
+ if (is.null(state_id)) {
+ |
+
| 591 | +207x | +
+ private$state_list()+ |
+
| 592 | ++ |
+ } else {
+ |
+
| 593 | +! | +
+ private$state_list()[[state_id]]+ |
+
| 594 | ++ |
+ }+ |
+
| 595 | ++ |
+ },+ |
+
| 596 | ++ | + + | +
| 597 | ++ |
+ # @description+ |
+
| 598 | ++ |
+ # Adds a new `FilterState` object to this `FilterStates`.\cr+ |
+
| 599 | ++ |
+ # Raises error if the length of `x` does not match the length of `state_id`.+ |
+
| 600 | ++ |
+ #+ |
+
| 601 | ++ |
+ # @param x (`FilterState`)\cr+ |
+
| 602 | ++ |
+ # object to be added to filter state list+ |
+
| 603 | ++ |
+ # @param state_id (`character(1)`)\cr+ |
+
| 604 | ++ |
+ # name of element in a filter state (which is a `reactiveVal` containing a list)+ |
+
| 605 | ++ |
+ #+ |
+
| 606 | ++ |
+ # @return NULL+ |
+
| 607 | ++ |
+ #+ |
+
| 608 | ++ |
+ state_list_push = function(x, state_id) {
+ |
+
| 609 | +189x | +
+ logger::log_trace("{ class(self)[1] } pushing into state_list, dataname: { private$dataname }")
+ |
+
| 610 | +189x | +
+ checkmate::assert_string(state_id)+ |
+
| 611 | +189x | +
+ checkmate::assert_multi_class(x, c("FilterState", "FilterStateExpr"))
+ |
+
| 612 | +189x | +
+ state <- stats::setNames(list(x), state_id)+ |
+
| 613 | +189x | +
+ new_state_list <- c(+ |
+
| 614 | +189x | +
+ shiny::isolate(private$state_list()),+ |
+
| 615 | +189x | +
+ state+ |
+
| 616 | ++ |
+ )+ |
+
| 617 | +189x | +
+ shiny::isolate(private$state_list(new_state_list))+ |
+
| 618 | ++ | + + | +
| 619 | +189x | +
+ logger::log_trace("{ class(self)[1] } pushed into queue, dataname: { private$dataname }")
+ |
+
| 620 | +189x | +
+ invisible(NULL)+ |
+
| 621 | ++ |
+ },+ |
+
| 622 | ++ | + + | +
| 623 | ++ |
+ # @description+ |
+
| 624 | ++ |
+ # Removes a single filter state with all associated shiny elements:\cr+ |
+
| 625 | ++ |
+ # * specified `FilterState` from `private$state_list`+ |
+
| 626 | ++ |
+ # * UI card created for this filter+ |
+
| 627 | ++ |
+ # * observers tracking the selection and remove button+ |
+
| 628 | ++ |
+ #+ |
+
| 629 | ++ |
+ # @param state_id (`character`)\cr+ |
+
| 630 | ++ |
+ # names of element in a filter state (which is a `reactiveVal` containing a list)+ |
+
| 631 | ++ |
+ #+ |
+
| 632 | ++ |
+ # @return NULL+ |
+
| 633 | ++ |
+ #+ |
+
| 634 | ++ |
+ state_list_remove = function(state_id) {
+ |
+
| 635 | +32x | +
+ shiny::isolate({
+ |
+
| 636 | +32x | +
+ logger::log_trace("{ class(self)[1] } removing a filter, state_id: { state_id }")
+ |
+
| 637 | +32x | +
+ checkmate::assert_character(state_id)+ |
+
| 638 | +32x | +
+ new_state_list <- private$state_list()+ |
+
| 639 | +32x | +
+ current_state_ids <- vapply(private$state_list(), function(x) x$get_state()$id, character(1))+ |
+
| 640 | +32x | +
+ to_remove <- state_id %in% current_state_ids+ |
+
| 641 | +32x | +
+ if (any(to_remove)) {
+ |
+
| 642 | +31x | +
+ new_state_list <- Filter(+ |
+
| 643 | +31x | +
+ function(state) {
+ |
+
| 644 | +68x | +
+ if (state$get_state()$id %in% state_id && !state$get_state()$locked) {
+ |
+
| 645 | +47x | +
+ state$destroy_observers()+ |
+
| 646 | +47x | +
+ FALSE+ |
+
| 647 | ++ |
+ } else {
+ |
+
| 648 | +21x | +
+ TRUE+ |
+
| 649 | ++ |
+ }+ |
+
| 650 | ++ |
+ },+ |
+
| 651 | +31x | +
+ private$state_list()+ |
+
| 652 | ++ |
+ )+ |
+
| 653 | +31x | +
+ private$state_list(new_state_list)+ |
+
| 654 | ++ |
+ } else {
+ |
+
| 655 | +1x | +
+ warning(sprintf("\"%s\" not found in state list", state_id))
+ |
+
| 656 | ++ |
+ }+ |
+
| 657 | +32x | +
+ invisible(NULL)+ |
+
| 658 | ++ |
+ })+ |
+
| 659 | ++ |
+ },+ |
+
| 660 | ++ | + + | +
| 661 | ++ |
+ # @description+ |
+
| 662 | ++ |
+ # Remove all `FilterState` objects from this `FilterStates` object.+ |
+
| 663 | ++ |
+ #+ |
+
| 664 | ++ |
+ # @return invisible NULL+ |
+
| 665 | ++ |
+ #+ |
+
| 666 | ++ |
+ state_list_empty = function() {
+ |
+
| 667 | +25x | +
+ shiny::isolate({
+ |
+
| 668 | +25x | +
+ logger::log_trace(+ |
+
| 669 | +25x | +
+ "{ class(self)[1] }$state_list_empty removing all non-locked filters for dataname: { private$dataname }"
+ |
+
| 670 | ++ |
+ )+ |
+
| 671 | ++ | + + | +
| 672 | +25x | +
+ state_list <- private$state_list()+ |
+
| 673 | +25x | +
+ if (length(state_list)) {
+ |
+
| 674 | +15x | +
+ state_list_ids <- vapply(state_list, function(x) x$get_state()$id, character(1))+ |
+
| 675 | +15x | +
+ private$state_list_remove(state_list_ids)+ |
+
| 676 | ++ |
+ }+ |
+
| 677 | +25x | +
+ invisible(NULL)+ |
+
| 678 | ++ |
+ })+ |
+
| 679 | ++ |
+ },+ |
+
| 680 | ++ | + + | +
| 681 | ++ |
+ # @description+ |
+
| 682 | ++ |
+ # Set filter state+ |
+
| 683 | ++ |
+ #+ |
+
| 684 | ++ |
+ # Utility method for `set_filter_state` to create or modify `FilterState` using a single+ |
+
| 685 | ++ |
+ # `teal_slice`.+ |
+
| 686 | ++ |
+ # @param state (`teal_slices`)+ |
+
| 687 | ++ |
+ # @param data (`data.frame`, `matrix` or `DataFrame`)+ |
+
| 688 | ++ |
+ # @param data_reactive (`function`)+ |
+
| 689 | ++ |
+ # function having `sid` as argument+ |
+
| 690 | ++ |
+ #+ |
+
| 691 | ++ |
+ # @return invisible NULL+ |
+
| 692 | ++ |
+ #+ |
+
| 693 | ++ |
+ set_filter_state_impl = function(state,+ |
+
| 694 | ++ |
+ data,+ |
+
| 695 | ++ |
+ data_reactive) {
+ |
+
| 696 | +226x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 697 | +226x | +
+ checkmate::assert_multi_class(data, c("data.frame", "matrix", "DataFrame", "HermesData"))
+ |
+
| 698 | +226x | +
+ checkmate::assert_function(data_reactive, args = "sid")+ |
+
| 699 | +226x | +
+ if (length(state) == 0L) {
+ |
+
| 700 | +115x | +
+ return(invisible(NULL))+ |
+
| 701 | ++ |
+ }+ |
+
| 702 | ++ | + + | +
| 703 | +111x | +
+ slices_hashed <- vapply(state, `[[`, character(1L), "id")+ |
+
| 704 | +111x | +
+ if (any(duplicated(slices_hashed))) {
+ |
+
| 705 | +! | +
+ stop(+ |
+
| 706 | +! | +
+ "Some of the teal_slice objects refer to the same filter. ",+ |
+
| 707 | +! | +
+ "Please specify different 'id' when calling teal_slice"+ |
+
| 708 | ++ |
+ )+ |
+
| 709 | ++ |
+ }+ |
+
| 710 | ++ | + + | +
| 711 | +111x | +
+ state_list <- shiny::isolate(private$state_list_get())+ |
+
| 712 | +111x | +
+ lapply(state, function(slice) {
+ |
+
| 713 | +197x | +
+ state_id <- slice$id+ |
+
| 714 | +197x | +
+ if (state_id %in% names(state_list)) {
+ |
+
| 715 | ++ |
+ # Modify existing filter states.+ |
+
| 716 | +8x | +
+ state_list[[state_id]]$set_state(slice)+ |
+
| 717 | ++ |
+ } else {
+ |
+
| 718 | +189x | +
+ if (inherits(slice, "teal_slice_expr")) {
+ |
+
| 719 | ++ |
+ # create a new FilterStateExpr+ |
+
| 720 | +2x | +
+ fstate <- init_filter_state_expr(slice)+ |
+
| 721 | +2x | +
+ private$state_list_push(x = fstate, state_id = state_id)+ |
+
| 722 | ++ |
+ } else {
+ |
+
| 723 | ++ |
+ # create a new FilterState+ |
+
| 724 | +187x | +
+ fstate <- init_filter_state(+ |
+
| 725 | +187x | +
+ x = data[, slice$varname, drop = TRUE],+ |
+
| 726 | ++ |
+ # data_reactive is a function which eventually calls get_call(sid).+ |
+
| 727 | ++ |
+ # This chain of calls returns column from the data filtered by everything+ |
+
| 728 | ++ |
+ # but filter identified by the sid argument. FilterState then get x_reactive+ |
+
| 729 | ++ |
+ # and this no longer needs to be a function to pass sid. reactive in the FilterState+ |
+
| 730 | ++ |
+ # is also beneficial as it can be cached and retriger filter counts only if+ |
+
| 731 | ++ |
+ # returned vector is different.+ |
+
| 732 | +187x | +
+ x_reactive = if (private$count_type == "none") {
+ |
+
| 733 | +181x | +
+ reactive(NULL)+ |
+
| 734 | ++ |
+ } else {
+ |
+
| 735 | +6x | +
+ reactive(data_reactive(state_id)[, slice$varname, drop = TRUE])+ |
+
| 736 | ++ |
+ },+ |
+
| 737 | +187x | +
+ slice = slice,+ |
+
| 738 | +187x | +
+ extract_type = private$extract_type+ |
+
| 739 | ++ |
+ )+ |
+
| 740 | +187x | +
+ private$state_list_push(x = fstate, state_id = state_id)+ |
+
| 741 | ++ |
+ }+ |
+
| 742 | ++ |
+ }+ |
+
| 743 | ++ |
+ })+ |
+
| 744 | ++ | + + | +
| 745 | +111x | +
+ invisible(NULL)+ |
+
| 746 | ++ |
+ }+ |
+
| 747 | ++ |
+ )+ |
+
| 748 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' @name FilterStateExpr+ |
+
| 2 | ++ |
+ #' @docType class+ |
+
| 3 | ++ |
+ #'+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @title `FilterStateExpr` Class+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @description Class to handle filter expression.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @details+ |
+
| 11 | ++ |
+ #' This class is responsible for displaying filter card and returning filter expression+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @keywords internal+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' filter_state <- teal.slice:::FilterStateExpr$new(+ |
+
| 17 | ++ |
+ #' slice = teal_slice(+ |
+
| 18 | ++ |
+ #' dataname = "x",+ |
+
| 19 | ++ |
+ #' id = "FA",+ |
+
| 20 | ++ |
+ #' title = "Adult females",+ |
+
| 21 | ++ |
+ #' expr = "sex == 'F' & age >= 18"+ |
+
| 22 | ++ |
+ #' )+ |
+
| 23 | ++ |
+ #' )+ |
+
| 24 | ++ |
+ #' filter_state$get_call()+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' # working filter in an app+ |
+
| 27 | ++ |
+ #' library(shiny)+ |
+
| 28 | ++ |
+ #' library(shinyjs)+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' ui <- fluidPage(+ |
+
| 31 | ++ |
+ #' useShinyjs(),+ |
+
| 32 | ++ |
+ #' teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 33 | ++ |
+ #' teal.slice:::include_js_files(pattern = "count-bar-labels"),+ |
+
| 34 | ++ |
+ #' column(4, div(+ |
+
| 35 | ++ |
+ #' h4("ChoicesFilterState"),
+ |
+
| 36 | ++ |
+ #' filter_state$ui("fs")
+ |
+
| 37 | ++ |
+ #' )),+ |
+
| 38 | ++ |
+ #' column(8, div(+ |
+
| 39 | ++ |
+ #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
+ |
+
| 40 | ++ |
+ #' textOutput("condition_choices"), br(),
+ |
+
| 41 | ++ |
+ #' h4("Unformatted state"), # display raw filter state
+ |
+
| 42 | ++ |
+ #' textOutput("unformatted_choices"), br(),
+ |
+
| 43 | ++ |
+ #' h4("Formatted state"), # display human readable filter state
+ |
+
| 44 | ++ |
+ #' textOutput("formatted_choices"), br()
+ |
+
| 45 | ++ |
+ #' ))+ |
+
| 46 | ++ |
+ #' )+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 49 | ++ |
+ #' filter_state$server("fs")
+ |
+
| 50 | ++ |
+ #' output$condition_choices <- renderPrint(filter_state$get_call())+ |
+
| 51 | ++ |
+ #' output$formatted_choices <- renderText(filter_state$format())+ |
+
| 52 | ++ |
+ #' output$unformatted_choices <- renderPrint(filter_state$get_state())+ |
+
| 53 | ++ |
+ #' }+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' if (interactive()) {
+ |
+
| 56 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 57 | ++ |
+ #' }+ |
+
| 58 | ++ |
+ FilterStateExpr <- R6::R6Class( # nolint+ |
+
| 59 | ++ |
+ classname = "FilterStateExpr",+ |
+
| 60 | ++ |
+ # public methods ----+ |
+
| 61 | ++ |
+ public = list(+ |
+
| 62 | ++ |
+ #' @description+ |
+
| 63 | ++ |
+ #' Initialize a `FilterStateExpr` object+ |
+
| 64 | ++ |
+ #' @param slice (`teal_slice_expr`)\cr+ |
+
| 65 | ++ |
+ #' object created by [teal_slice()]+ |
+
| 66 | ++ |
+ #' @return `FilterStateExpr`+ |
+
| 67 | ++ |
+ initialize = function(slice) {
+ |
+
| 68 | +11x | +
+ checkmate::assert_class(slice, "teal_slice_expr")+ |
+
| 69 | +10x | +
+ private$teal_slice <- slice+ |
+
| 70 | +10x | +
+ invisible(self)+ |
+
| 71 | ++ |
+ },+ |
+
| 72 | ++ | + + | +
| 73 | ++ |
+ #' @description+ |
+
| 74 | ++ |
+ #' Returns a formatted string representing this `FilterStateExpr` object.+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @param show_all `logical(1)` passed to `format.teal_slice`+ |
+
| 77 | ++ |
+ #' @param trim_lines `logical(1)` passed to `format.teal_slice`+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @return `character(1)` the formatted string+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ format = function(show_all = FALSE, trim_lines = TRUE) {
+ |
+
| 82 | +12x | +
+ sprintf(+ |
+
| 83 | +12x | +
+ "%s:\n%s",+ |
+
| 84 | +12x | +
+ class(self)[1],+ |
+
| 85 | +12x | +
+ format(self$get_state(), show_all = show_all, trim_lines = trim_lines)+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | ++ |
+ },+ |
+
| 88 | ++ | + + | +
| 89 | ++ |
+ #' @description+ |
+
| 90 | ++ |
+ #' Prints this `FilterStateExpr` object.+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @param ... additional arguments+ |
+
| 93 | ++ |
+ print = function(...) {
+ |
+
| 94 | +1x | +
+ cat(shiny::isolate(self$format(...)))+ |
+
| 95 | ++ |
+ },+ |
+
| 96 | ++ | + + | +
| 97 | ++ |
+ #' @description+ |
+
| 98 | ++ |
+ #' Returns filtering state.+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #' @return A `teal_slice` object.+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ get_state = function() {
+ |
+
| 103 | +18x | +
+ private$teal_slice+ |
+
| 104 | ++ |
+ },+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ #' @description+ |
+
| 107 | ++ |
+ #' Sets filtering state.+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' @param state a `teal_slice` object+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @return `self` invisibly+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ set_state = function(state) {
+ |
+
| 114 | +1x | +
+ checkmate::assert_class(state, "teal_slice_expr")+ |
+
| 115 | +1x | +
+ invisible(NULL)+ |
+
| 116 | ++ |
+ },+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ #' @description+ |
+
| 119 | ++ |
+ #' Get reproducible call+ |
+
| 120 | ++ |
+ #'+ |
+
| 121 | ++ |
+ #' @param dataname (`ignored`) for a consistency with `FilterState`+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' Returns reproducible condition call for current selection relevant+ |
+
| 124 | ++ |
+ #' for selected variable type.+ |
+
| 125 | ++ |
+ #' Method is using internal reactive values which makes it reactive+ |
+
| 126 | ++ |
+ #' and must be executed in reactive or isolated context.+ |
+
| 127 | ++ |
+ #' @return `language`+ |
+
| 128 | ++ |
+ get_call = function(dataname) {
+ |
+
| 129 | +2x | +
+ shiny::isolate(str2lang(private$teal_slice$expr))+ |
+
| 130 | ++ |
+ },+ |
+
| 131 | ++ | + + | +
| 132 | ++ |
+ #' @description+ |
+
| 133 | ++ |
+ #' Destroy observers stored in `private$observers`.+ |
+
| 134 | ++ |
+ #'+ |
+
| 135 | ++ |
+ #' @return NULL invisibly+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ destroy_observers = function() {
+ |
+
| 138 | +! | +
+ lapply(private$observers, function(x) x$destroy())+ |
+
| 139 | +! | +
+ invisible(NULL)+ |
+
| 140 | ++ |
+ },+ |
+
| 141 | ++ | + + | +
| 142 | ++ |
+ # public shiny modules ----+ |
+
| 143 | ++ | + + | +
| 144 | ++ |
+ #' @description+ |
+
| 145 | ++ |
+ #' Shiny module server.+ |
+
| 146 | ++ |
+ #'+ |
+
| 147 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 148 | ++ |
+ #' shiny module instance id+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #' @return `moduleServer` function which returns reactive value+ |
+
| 151 | ++ |
+ #' signaling that remove button has been clicked+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ server = function(id) {
+ |
+
| 154 | +! | +
+ moduleServer(+ |
+
| 155 | +! | +
+ id = id,+ |
+
| 156 | +! | +
+ function(input, output, session) {
+ |
+
| 157 | +! | +
+ private$server_summary("summary")
+ |
+
| 158 | +! | +
+ out <- reactive(input$remove) # back to parent to remove self+ |
+
| 159 | +! | +
+ out+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ |
+ )+ |
+
| 162 | ++ |
+ },+ |
+
| 163 | ++ | + + | +
| 164 | ++ |
+ #' @description+ |
+
| 165 | ++ |
+ #' Shiny module UI.+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 168 | ++ |
+ #' shiny element (module instance) id;+ |
+
| 169 | ++ |
+ #' the UI for this class contains simple message stating that it is not supported+ |
+
| 170 | ++ |
+ #' @param parent_id (`character(1)`) id of the `FilterStates` card container+ |
+
| 171 | ++ |
+ ui = function(id, parent_id = "cards") {
+ |
+
| 172 | +! | +
+ ns <- NS(id)+ |
+
| 173 | +! | +
+ shiny::isolate({
+ |
+
| 174 | +! | +
+ tags$div(+ |
+
| 175 | +! | +
+ id = id,+ |
+
| 176 | +! | +
+ class = "panel filter-card",+ |
+
| 177 | +! | +
+ include_js_files("count-bar-labels.js"),
+ |
+
| 178 | +! | +
+ tags$div(+ |
+
| 179 | +! | +
+ class = "filter-card-header",+ |
+
| 180 | +! | +
+ tags$div(+ |
+
| 181 | +! | +
+ class = "filter-card-title",+ |
+
| 182 | +! | +
+ icon("lock"),
+ |
+
| 183 | +! | +
+ tags$span(tags$strong(private$teal_slice$id)),+ |
+
| 184 | +! | +
+ tags$span(private$teal_slice$title, class = "filter-card-varlabel")+ |
+
| 185 | ++ |
+ ),+ |
+
| 186 | +! | +
+ tags$div(+ |
+
| 187 | +! | +
+ class = "filter-card-controls",+ |
+
| 188 | +! | +
+ actionLink(+ |
+
| 189 | +! | +
+ inputId = ns("remove"),
+ |
+
| 190 | +! | +
+ label = icon("circle-xmark", lib = "font-awesome"),
+ |
+
| 191 | +! | +
+ class = "filter-card-remove"+ |
+
| 192 | ++ |
+ )+ |
+
| 193 | ++ |
+ ),+ |
+
| 194 | +! | +
+ tags$div(+ |
+
| 195 | +! | +
+ class = "filter-card-summary",+ |
+
| 196 | +! | +
+ private$ui_summary(ns("summary"))
+ |
+
| 197 | ++ |
+ )+ |
+
| 198 | ++ |
+ )+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | ++ |
+ })+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ |
+ ),+ |
+
| 203 | ++ | + + | +
| 204 | ++ |
+ # private members ----+ |
+
| 205 | ++ | + + | +
| 206 | ++ |
+ private = list(+ |
+
| 207 | ++ |
+ observers = NULL, # stores observers+ |
+
| 208 | ++ |
+ teal_slice = NULL, # stores reactiveValues+ |
+
| 209 | ++ | + + | +
| 210 | ++ |
+ # @description+ |
+
| 211 | ++ |
+ # Server module to display filter summary+ |
+
| 212 | ++ |
+ # @param id `shiny` id parameter+ |
+
| 213 | ++ |
+ ui_summary = function(id) {
+ |
+
| 214 | +! | +
+ ns <- NS(id)+ |
+
| 215 | +! | +
+ uiOutput(ns("summary"), class = "filter-card-summary")
+ |
+
| 216 | ++ |
+ },+ |
+
| 217 | ++ | + + | +
| 218 | ++ |
+ # @description+ |
+
| 219 | ++ |
+ # UI module to display filter summary+ |
+
| 220 | ++ |
+ # @param shiny `id` parametr passed to moduleServer+ |
+
| 221 | ++ |
+ # renders text describing current state+ |
+
| 222 | ++ |
+ server_summary = function(id) {
+ |
+
| 223 | +! | +
+ moduleServer(+ |
+
| 224 | +! | +
+ id = id,+ |
+
| 225 | +! | +
+ function(input, output, session) {
+ |
+
| 226 | +! | +
+ private$content_summary()+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | ++ |
+ )+ |
+
| 229 | ++ |
+ },+ |
+
| 230 | ++ |
+ content_summary = function() {
+ |
+
| 231 | +! | +
+ shiny::isolate(private$teal_slice$expr)+ |
+
| 232 | ++ |
+ }+ |
+
| 233 | ++ |
+ )+ |
+
| 234 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' @name DateFilterState+ |
+
| 2 | ++ |
+ #' @title `FilterState` object for Date variable+ |
+
| 3 | ++ |
+ #' @description Manages choosing a range of Dates+ |
+
| 4 | ++ |
+ #' @docType class+ |
+
| 5 | ++ |
+ #' @keywords internal+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @examples+ |
+
| 9 | ++ |
+ #' filter_state <- teal.slice:::DateFilterState$new(+ |
+
| 10 | ++ |
+ #' x = c(Sys.Date() + seq(1:10), NA),+ |
+
| 11 | ++ |
+ #' slice = teal_slice(varname = "x", dataname = "data"),+ |
+
| 12 | ++ |
+ #' extract_type = character(0)+ |
+
| 13 | ++ |
+ #' )+ |
+
| 14 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 15 | ++ |
+ #' filter_state$set_state(+ |
+
| 16 | ++ |
+ #' teal_slice(+ |
+
| 17 | ++ |
+ #' dataname = "data",+ |
+
| 18 | ++ |
+ #' varname = "x",+ |
+
| 19 | ++ |
+ #' selected = c(Sys.Date() + 3L, Sys.Date() + 8L),+ |
+
| 20 | ++ |
+ #' keep_na = TRUE+ |
+
| 21 | ++ |
+ #' )+ |
+
| 22 | ++ |
+ #' )+ |
+
| 23 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' # working filter in an app+ |
+
| 26 | ++ |
+ #' library(shiny)+ |
+
| 27 | ++ |
+ #' library(shinyjs)+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' dates <- c(Sys.Date() - 100, Sys.Date())+ |
+
| 30 | ++ |
+ #' data_date <- c(seq(from = dates[1], to = dates[2], length.out = 100), NA)+ |
+
| 31 | ++ |
+ #' fs <- teal.slice:::DateFilterState$new(+ |
+
| 32 | ++ |
+ #' x = data_date,+ |
+
| 33 | ++ |
+ #' slice = teal_slice(+ |
+
| 34 | ++ |
+ #' dataname = "data", varname = "x", selected = data_date[c(47, 98)], keep_na = TRUE+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' ui <- fluidPage(+ |
+
| 39 | ++ |
+ #' useShinyjs(),+ |
+
| 40 | ++ |
+ #' teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 41 | ++ |
+ #' teal.slice:::include_js_files(pattern = "count-bar-labels"),+ |
+
| 42 | ++ |
+ #' column(4, div(+ |
+
| 43 | ++ |
+ #' h4("DateFilterState"),
+ |
+
| 44 | ++ |
+ #' fs$ui("fs")
+ |
+
| 45 | ++ |
+ #' )),+ |
+
| 46 | ++ |
+ #' column(4, div(+ |
+
| 47 | ++ |
+ #' id = "outputs", # div id is needed for toggling the element+ |
+
| 48 | ++ |
+ #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterState
+ |
+
| 49 | ++ |
+ #' textOutput("condition_date"), br(),
+ |
+
| 50 | ++ |
+ #' h4("Unformatted state"), # display raw filter state
+ |
+
| 51 | ++ |
+ #' textOutput("unformatted_date"), br(),
+ |
+
| 52 | ++ |
+ #' h4("Formatted state"), # display human readable filter state
+ |
+
| 53 | ++ |
+ #' textOutput("formatted_date"), br()
+ |
+
| 54 | ++ |
+ #' )),+ |
+
| 55 | ++ |
+ #' column(4, div(+ |
+
| 56 | ++ |
+ #' h4("Programmatic filter control"),
+ |
+
| 57 | ++ |
+ #' actionButton("button1_date", "set drop NA", width = "100%"), br(),
+ |
+
| 58 | ++ |
+ #' actionButton("button2_date", "set keep NA", width = "100%"), br(),
+ |
+
| 59 | ++ |
+ #' actionButton("button3_date", "set a range", width = "100%"), br(),
+ |
+
| 60 | ++ |
+ #' actionButton("button4_date", "set full range", width = "100%"), br(),
+ |
+
| 61 | ++ |
+ #' actionButton("button0_date", "set initial state", width = "100%"), br()
+ |
+
| 62 | ++ |
+ #' ))+ |
+
| 63 | ++ |
+ #' )+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 66 | ++ |
+ #' fs$server("fs")
+ |
+
| 67 | ++ |
+ #' output$condition_date <- renderPrint(fs$get_call())+ |
+
| 68 | ++ |
+ #' output$formatted_date <- renderText(fs$format())+ |
+
| 69 | ++ |
+ #' output$unformatted_date <- renderPrint(fs$get_state())+ |
+
| 70 | ++ |
+ #' # modify filter state programmatically+ |
+
| 71 | ++ |
+ #' observeEvent(+ |
+
| 72 | ++ |
+ #' input$button1_date,+ |
+
| 73 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))+ |
+
| 74 | ++ |
+ #' )+ |
+
| 75 | ++ |
+ #' observeEvent(+ |
+
| 76 | ++ |
+ #' input$button2_date,+ |
+
| 77 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ |
+
| 78 | ++ |
+ #' )+ |
+
| 79 | ++ |
+ #' observeEvent(+ |
+
| 80 | ++ |
+ #' input$button3_date,+ |
+
| 81 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = data_date[c(34, 56)]))+ |
+
| 82 | ++ |
+ #' )+ |
+
| 83 | ++ |
+ #' observeEvent(+ |
+
| 84 | ++ |
+ #' input$button4_date,+ |
+
| 85 | ++ |
+ #' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = dates))+ |
+
| 86 | ++ |
+ #' )+ |
+
| 87 | ++ |
+ #' observeEvent(+ |
+
| 88 | ++ |
+ #' input$button0_date,+ |
+
| 89 | ++ |
+ #' fs$set_state(+ |
+
| 90 | ++ |
+ #' teal_slice("data", "variable", selected = data_date[c(47, 98)], keep_na = TRUE)
+ |
+
| 91 | ++ |
+ #' )+ |
+
| 92 | ++ |
+ #' )+ |
+
| 93 | ++ |
+ #' }+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ #' if (interactive()) {
+ |
+
| 96 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 97 | ++ |
+ #' }+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ DateFilterState <- R6::R6Class( # nolint+ |
+
| 100 | ++ |
+ "DateFilterState",+ |
+
| 101 | ++ |
+ inherit = FilterState,+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ # public methods ----+ |
+
| 104 | ++ | + + | +
| 105 | ++ |
+ public = list(+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ #' @description+ |
+
| 108 | ++ |
+ #' Initialize a `FilterState` object+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @param x (`Date`)\cr+ |
+
| 111 | ++ |
+ #' values of the variable used in filter+ |
+
| 112 | ++ |
+ #' @param x_reactive (`reactive`)\cr+ |
+
| 113 | ++ |
+ #' returning vector of the same type as `x`. Is used to update+ |
+
| 114 | ++ |
+ #' counts following the change in values of the filtered dataset.+ |
+
| 115 | ++ |
+ #' If it is set to `reactive(NULL)` then counts based on filtered+ |
+
| 116 | ++ |
+ #' dataset are not shown.+ |
+
| 117 | ++ |
+ #' @param slice (`teal_slice`)\cr+ |
+
| 118 | ++ |
+ #' object created using [teal_slice()]. `teal_slice` is stored+ |
+
| 119 | ++ |
+ #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`+ |
+
| 120 | ++ |
+ #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`+ |
+
| 121 | ++ |
+ #' is a `reactiveValues` which means that changes in particular object are automatically+ |
+
| 122 | ++ |
+ #' reflected in all places which refer to the same `teal_slice`.+ |
+
| 123 | ++ |
+ #' @param extract_type (`character(0)`, `character(1)`)\cr+ |
+
| 124 | ++ |
+ #' whether condition calls should be prefixed by `dataname`. Possible values:+ |
+
| 125 | ++ |
+ #' \itemize{
+ |
+
| 126 | ++ |
+ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
+ |
+
| 127 | ++ |
+ #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
+ |
+
| 128 | ++ |
+ #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
+ |
+
| 129 | ++ |
+ #' }+ |
+
| 130 | ++ |
+ #' @param ... additional arguments to be saved as a list in `private$extras` field+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ initialize = function(x,+ |
+
| 133 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 134 | ++ |
+ slice,+ |
+
| 135 | ++ |
+ extract_type = character(0)) {
+ |
+
| 136 | +24x | +
+ shiny::isolate({
+ |
+
| 137 | +24x | +
+ checkmate::assert_date(x)+ |
+
| 138 | +23x | +
+ checkmate::assert_class(x_reactive, "reactive")+ |
+
| 139 | ++ | + + | +
| 140 | +23x | +
+ super$initialize(+ |
+
| 141 | +23x | +
+ x = x,+ |
+
| 142 | +23x | +
+ x_reactive = x_reactive,+ |
+
| 143 | +23x | +
+ slice = slice,+ |
+
| 144 | +23x | +
+ extract_type = extract_type+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | +23x | +
+ checkmate::assert_date(slice$choices, null.ok = TRUE)+ |
+
| 147 | +22x | +
+ private$set_choices(slice$choices)+ |
+
| 148 | +14x | +
+ if (is.null(slice$selected)) slice$selected <- slice$choices+ |
+
| 149 | +22x | +
+ private$set_selected(slice$selected)+ |
+
| 150 | ++ |
+ })+ |
+
| 151 | ++ | + + | +
| 152 | +21x | +
+ invisible(self)+ |
+
| 153 | ++ |
+ },+ |
+
| 154 | ++ | + + | +
| 155 | ++ |
+ #' @description+ |
+
| 156 | ++ |
+ #' Returns reproducible condition call for current selection.+ |
+
| 157 | ++ |
+ #' For this class returned call looks like+ |
+
| 158 | ++ |
+ #' `<varname> >= <min value> & <varname> <= <max value>` with+ |
+
| 159 | ++ |
+ #' optional `is.na(<varname>)`.+ |
+
| 160 | ++ |
+ #' @param dataname `character(1)` containing possibly prefixed name of data set+ |
+
| 161 | ++ |
+ #' @return (`call`)+ |
+
| 162 | ++ |
+ #'+ |
+
| 163 | ++ |
+ get_call = function(dataname) {
+ |
+
| 164 | +7x | +
+ if (isFALSE(private$is_any_filtered())) {
+ |
+
| 165 | +1x | +
+ return(NULL)+ |
+
| 166 | ++ |
+ }+ |
+
| 167 | +6x | +
+ choices <- as.character(private$get_selected())+ |
+
| 168 | +6x | +
+ filter_call <-+ |
+
| 169 | +6x | +
+ call(+ |
+
| 170 | ++ |
+ "&",+ |
+
| 171 | +6x | +
+ call(">=", private$get_varname_prefixed(dataname), call("as.Date", choices[1L])),
+ |
+
| 172 | +6x | +
+ call("<=", private$get_varname_prefixed(dataname), call("as.Date", choices[2L]))
+ |
+
| 173 | ++ |
+ )+ |
+
| 174 | +6x | +
+ private$add_keep_na_call(filter_call)+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ |
+ ),+ |
+
| 177 | ++ | + + | +
| 178 | ++ |
+ # private methods ----+ |
+
| 179 | ++ | + + | +
| 180 | ++ |
+ private = list(+ |
+
| 181 | ++ |
+ set_choices = function(choices) {
+ |
+
| 182 | +22x | +
+ if (is.null(choices)) {
+ |
+
| 183 | +19x | +
+ choices <- range(private$x, na.rm = TRUE)+ |
+
| 184 | ++ |
+ } else {
+ |
+
| 185 | +3x | +
+ choices_adjusted <- c(max(choices[1L], min(private$x)), min(choices[2L], max(private$x)))+ |
+
| 186 | +3x | +
+ if (any(choices != choices_adjusted)) {
+ |
+
| 187 | +1x | +
+ warning(sprintf(+ |
+
| 188 | +1x | +
+ "Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",+ |
+
| 189 | +1x | +
+ private$get_varname(), private$get_dataname()+ |
+
| 190 | ++ |
+ ))+ |
+
| 191 | +1x | +
+ choices <- choices_adjusted+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | +3x | +
+ if (choices[1L] >= choices[2L]) {
+ |
+
| 194 | +1x | +
+ warning(sprintf(+ |
+
| 195 | +1x | +
+ "Invalid choices: lower is higher / equal to upper, or not in range of variable values.+ |
+
| 196 | +1x | +
+ Setting defaults. Varname: %s, dataname: %s.",+ |
+
| 197 | +1x | +
+ private$get_varname(), private$get_dataname()+ |
+
| 198 | ++ |
+ ))+ |
+
| 199 | +1x | +
+ choices <- range(private$x, na.rm = TRUE)+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | +22x | +
+ private$set_is_choice_limited(private$x, choices)+ |
+
| 203 | +22x | +
+ private$x <- private$x[(private$x >= choices[1L] & private$x <= choices[2L]) | is.na(private$x)]+ |
+
| 204 | +22x | +
+ private$teal_slice$choices <- choices+ |
+
| 205 | +22x | +
+ invisible(NULL)+ |
+
| 206 | ++ |
+ },+ |
+
| 207 | ++ | + + | +
| 208 | ++ |
+ # @description+ |
+
| 209 | ++ |
+ # Check whether the initial choices filter out some values of x and set the flag in case.+ |
+
| 210 | ++ |
+ set_is_choice_limited = function(xl, choices) {
+ |
+
| 211 | +22x | +
+ private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE))+ |
+
| 212 | +22x | +
+ invisible(NULL)+ |
+
| 213 | ++ |
+ },+ |
+
| 214 | ++ |
+ validate_selection = function(value) {
+ |
+
| 215 | +29x | +
+ if (!is(value, "Date")) {
+ |
+
| 216 | +! | +
+ stop(+ |
+
| 217 | +! | +
+ sprintf(+ |
+
| 218 | +! | +
+ "value of the selection for `%s` in `%s` should be a Date",+ |
+
| 219 | +! | +
+ private$get_varname(),+ |
+
| 220 | +! | +
+ private$get_dataname()+ |
+
| 221 | ++ |
+ )+ |
+
| 222 | ++ |
+ )+ |
+
| 223 | ++ |
+ }+ |
+
| 224 | +29x | +
+ pre_msg <- sprintf(+ |
+
| 225 | +29x | +
+ "dataset '%s', variable '%s': ",+ |
+
| 226 | +29x | +
+ private$get_dataname(),+ |
+
| 227 | +29x | +
+ private$get_varname()+ |
+
| 228 | ++ |
+ )+ |
+
| 229 | +29x | +
+ check_in_range(value, private$get_choices(), pre_msg = pre_msg)+ |
+
| 230 | ++ |
+ },+ |
+
| 231 | ++ |
+ cast_and_validate = function(values) {
+ |
+
| 232 | +33x | +
+ tryCatch(+ |
+
| 233 | +33x | +
+ expr = {
+ |
+
| 234 | +33x | +
+ values <- as.Date(values, origin = "1970-01-01")+ |
+
| 235 | +! | +
+ if (any(is.na(values))) stop()+ |
+
| 236 | ++ |
+ },+ |
+
| 237 | +33x | +
+ error = function(error) stop("The array of set values must contain values coercible to Date.")
+ |
+
| 238 | ++ |
+ )+ |
+
| 239 | +1x | +
+ if (length(values) != 2) stop("The array of set values must have length two.")
+ |
+
| 240 | +29x | +
+ values+ |
+
| 241 | ++ |
+ },+ |
+
| 242 | ++ |
+ remove_out_of_bound_values = function(values) {
+ |
+
| 243 | +29x | +
+ choices <- private$get_choices()+ |
+
| 244 | +29x | +
+ if (values[1] < choices[1L] | values[1] > choices[2L]) {
+ |
+
| 245 | +5x | +
+ warning(+ |
+
| 246 | +5x | +
+ sprintf(+ |
+
| 247 | +5x | +
+ "Value: %s is outside of the possible range for column %s of dataset %s, setting minimum possible value.",+ |
+
| 248 | +5x | +
+ values[1], private$get_varname(), private$get_dataname()+ |
+
| 249 | ++ |
+ )+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | +5x | +
+ values[1] <- choices[1L]+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ | + + | +
| 254 | +29x | +
+ if (values[2] > choices[2L] | values[2] < choices[1L]) {
+ |
+
| 255 | +5x | +
+ warning(+ |
+
| 256 | +5x | +
+ sprintf(+ |
+
| 257 | +5x | +
+ "Value: %s is outside of the possible range for column %s of dataset %s, setting maximum possible value.",+ |
+
| 258 | +5x | +
+ values[2], private$get_varname(), private$get_dataname()+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | ++ |
+ )+ |
+
| 261 | +5x | +
+ values[2] <- choices[2L]+ |
+
| 262 | ++ |
+ }+ |
+
| 263 | ++ | + + | +
| 264 | +29x | +
+ if (values[1] > values[2]) {
+ |
+
| 265 | +1x | +
+ warning(+ |
+
| 266 | +1x | +
+ sprintf(+ |
+
| 267 | +1x | +
+ "Start date %s is set after the end date %s, the values will be replaced with a default date range.",+ |
+
| 268 | +1x | +
+ values[1], values[2]+ |
+
| 269 | ++ |
+ )+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | +1x | +
+ values <- c(choices[1L], choices[2L])+ |
+
| 272 | ++ |
+ }+ |
+
| 273 | +29x | +
+ values+ |
+
| 274 | ++ |
+ },+ |
+
| 275 | ++ | + + | +
| 276 | ++ |
+ # shiny modules ----+ |
+
| 277 | ++ | + + | +
| 278 | ++ |
+ # @description+ |
+
| 279 | ++ |
+ # UI Module for `DateFilterState`.+ |
+
| 280 | ++ |
+ # This UI element contains two date selections for `min` and `max`+ |
+
| 281 | ++ |
+ # of the range and a checkbox whether to keep the `NA` values.+ |
+
| 282 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 283 | ++ |
+ # id of shiny element+ |
+
| 284 | ++ |
+ ui_inputs = function(id) {
+ |
+
| 285 | +! | +
+ ns <- NS(id)+ |
+
| 286 | +! | +
+ shiny::isolate({
+ |
+
| 287 | +! | +
+ div(+ |
+
| 288 | +! | +
+ div(+ |
+
| 289 | +! | +
+ class = "flex",+ |
+
| 290 | +! | +
+ actionButton(+ |
+
| 291 | +! | +
+ class = "date_reset_button",+ |
+
| 292 | +! | +
+ inputId = ns("start_date_reset"),
+ |
+
| 293 | +! | +
+ label = NULL,+ |
+
| 294 | +! | +
+ icon = icon("fas fa-undo")
+ |
+
| 295 | ++ |
+ ),+ |
+
| 296 | +! | +
+ div(+ |
+
| 297 | +! | +
+ class = "w-80 filter_datelike_input",+ |
+
| 298 | +! | +
+ dateRangeInput(+ |
+
| 299 | +! | +
+ inputId = ns("selection"),
+ |
+
| 300 | +! | +
+ label = NULL,+ |
+
| 301 | +! | +
+ start = private$get_selected()[1],+ |
+
| 302 | +! | +
+ end = private$get_selected()[2],+ |
+
| 303 | +! | +
+ min = private$get_choices()[1L],+ |
+
| 304 | +! | +
+ max = private$get_choices()[2L],+ |
+
| 305 | +! | +
+ width = "100%"+ |
+
| 306 | ++ |
+ )+ |
+
| 307 | ++ |
+ ),+ |
+
| 308 | +! | +
+ actionButton(+ |
+
| 309 | +! | +
+ class = "date_reset_button",+ |
+
| 310 | +! | +
+ inputId = ns("end_date_reset"),
+ |
+
| 311 | +! | +
+ label = NULL,+ |
+
| 312 | +! | +
+ icon = icon("fas fa-undo")
+ |
+
| 313 | ++ |
+ )+ |
+
| 314 | ++ |
+ ),+ |
+
| 315 | +! | +
+ private$keep_na_ui(ns("keep_na"))
+ |
+
| 316 | ++ |
+ )+ |
+
| 317 | ++ |
+ })+ |
+
| 318 | ++ |
+ },+ |
+
| 319 | ++ | + + | +
| 320 | ++ |
+ # @description+ |
+
| 321 | ++ |
+ # Server module+ |
+
| 322 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 323 | ++ |
+ # an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 324 | ++ |
+ # @return `moduleServer` function which returns `NULL`+ |
+
| 325 | ++ |
+ server_inputs = function(id) {
+ |
+
| 326 | +! | +
+ moduleServer(+ |
+
| 327 | +! | +
+ id = id,+ |
+
| 328 | +! | +
+ function(input, output, session) {
+ |
+
| 329 | +! | +
+ logger::log_trace("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 | +! | +
+ private$observers$seletion_api <- observeEvent(+ |
+
| 335 | +! | +
+ ignoreNULL = TRUE, # dates needs to be selected+ |
+
| 336 | +! | +
+ ignoreInit = TRUE,+ |
+
| 337 | +! | +
+ eventExpr = private$get_selected(),+ |
+
| 338 | +! | +
+ handlerExpr = {
+ |
+
| 339 | +! | +
+ if (!setequal(private$get_selected(), input$selection)) {
+ |
+
| 340 | +! | +
+ logger::log_trace("DateFilterState$server@1 state changed, id: { private$get_id() }")
+ |
+
| 341 | +! | +
+ updateDateRangeInput(+ |
+
| 342 | +! | +
+ session = session,+ |
+
| 343 | +! | +
+ inputId = "selection",+ |
+
| 344 | +! | +
+ start = private$get_selected()[1],+ |
+
| 345 | +! | +
+ end = private$get_selected()[2]+ |
+
| 346 | ++ |
+ )+ |
+
| 347 | ++ |
+ }+ |
+
| 348 | ++ |
+ }+ |
+
| 349 | ++ |
+ )+ |
+
| 350 | ++ | + + | +
| 351 | +! | +
+ private$observers$selection <- observeEvent(+ |
+
| 352 | +! | +
+ ignoreNULL = TRUE, # dates needs to be selected+ |
+
| 353 | +! | +
+ ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state+ |
+
| 354 | +! | +
+ eventExpr = input$selection,+ |
+
| 355 | +! | +
+ handlerExpr = {
+ |
+
| 356 | +! | +
+ logger::log_trace("DateFilterState$server@2 selection changed, id: { private$get_id() }")
+ |
+
| 357 | +! | +
+ start_date <- input$selection[1]+ |
+
| 358 | +! | +
+ end_date <- input$selection[2]+ |
+
| 359 | +! | +
+ if (start_date > end_date) {
+ |
+
| 360 | +! | +
+ showNotification(+ |
+
| 361 | +! | +
+ "Start date must not be greater than the end date. Setting back to default values.",+ |
+
| 362 | +! | +
+ type = "warning"+ |
+
| 363 | ++ |
+ )+ |
+
| 364 | ++ |
+ }+ |
+
| 365 | +! | +
+ private$set_selected(c(start_date, end_date))+ |
+
| 366 | ++ |
+ }+ |
+
| 367 | ++ |
+ )+ |
+
| 368 | ++ | + + | +
| 369 | ++ | + + | +
| 370 | +! | +
+ private$keep_na_srv("keep_na")
+ |
+
| 371 | ++ | + + | +
| 372 | +! | +
+ private$observers$reset1 <- observeEvent(input$start_date_reset, {
+ |
+
| 373 | +! | +
+ logger::log_trace("DateFilterState$server@3 reset start date, id: { private$get_id() }")
+ |
+
| 374 | +! | +
+ updateDateRangeInput(+ |
+
| 375 | +! | +
+ session = session,+ |
+
| 376 | +! | +
+ inputId = "selection",+ |
+
| 377 | +! | +
+ start = private$get_choices()[1L]+ |
+
| 378 | ++ |
+ )+ |
+
| 379 | ++ |
+ })+ |
+
| 380 | ++ | + + | +
| 381 | +! | +
+ private$observers$reset2 <- observeEvent(input$end_date_reset, {
+ |
+
| 382 | +! | +
+ logger::log_trace("DateFilterState$server@4 reset end date, id: { private$get_id() }")
+ |
+
| 383 | +! | +
+ updateDateRangeInput(+ |
+
| 384 | +! | +
+ session = session,+ |
+
| 385 | +! | +
+ inputId = "selection",+ |
+
| 386 | +! | +
+ end = private$get_choices()[2L]+ |
+
| 387 | ++ |
+ )+ |
+
| 388 | ++ |
+ })+ |
+
| 389 | ++ | + + | +
| 390 | +! | +
+ logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
+ |
+
| 391 | +! | +
+ NULL+ |
+
| 392 | ++ |
+ }+ |
+
| 393 | ++ |
+ )+ |
+
| 394 | ++ |
+ },+ |
+
| 395 | ++ |
+ server_inputs_fixed = function(id) {
+ |
+
| 396 | +! | +
+ moduleServer(+ |
+
| 397 | +! | +
+ id = id,+ |
+
| 398 | +! | +
+ function(input, output, session) {
+ |
+
| 399 | +! | +
+ logger::log_trace("DateFilterState$server initializing, id: { private$get_id() }")
+ |
+
| 400 | ++ | + + | +
| 401 | +! | +
+ output$selection <- renderUI({
+ |
+
| 402 | +! | +
+ vals <- format(private$get_selected(), nsmall = 3)+ |
+
| 403 | +! | +
+ div(+ |
+
| 404 | +! | +
+ div(icon("calendar-days"), vals[1]),
+ |
+
| 405 | +! | +
+ div(span(" - "), icon("calendar-days"), vals[2])
+ |
+
| 406 | ++ |
+ )+ |
+
| 407 | ++ |
+ })+ |
+
| 408 | ++ | + + | +
| 409 | +! | +
+ logger::log_trace("DateFilterState$server initialized, id: { private$get_id() }")
+ |
+
| 410 | +! | +
+ NULL+ |
+
| 411 | ++ |
+ }+ |
+
| 412 | ++ |
+ )+ |
+
| 413 | ++ |
+ },+ |
+
| 414 | ++ | + + | +
| 415 | ++ |
+ # @description+ |
+
| 416 | ++ |
+ # Server module to display filter summary+ |
+
| 417 | ++ |
+ # renders text describing selected date range and+ |
+
| 418 | ++ |
+ # if NA are included also+ |
+
| 419 | ++ |
+ content_summary = function(id) {
+ |
+
| 420 | +! | +
+ selected <- as.character(private$get_selected())+ |
+
| 421 | +! | +
+ min <- selected[1]+ |
+
| 422 | +! | +
+ max <- selected[2]+ |
+
| 423 | +! | +
+ tagList(+ |
+
| 424 | +! | +
+ tags$span(+ |
+
| 425 | +! | +
+ class = "filter-card-summary-value",+ |
+
| 426 | +! | +
+ shiny::HTML(min, "–", max)+ |
+
| 427 | ++ |
+ ),+ |
+
| 428 | +! | +
+ tags$span(+ |
+
| 429 | +! | +
+ class = "filter-card-summary-controls",+ |
+
| 430 | +! | +
+ if (isTRUE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 431 | +! | +
+ tags$span(+ |
+
| 432 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 433 | +! | +
+ "NA",+ |
+
| 434 | +! | +
+ shiny::icon("check")
+ |
+
| 435 | ++ |
+ )+ |
+
| 436 | +! | +
+ } else if (isFALSE(private$get_keep_na()) && private$na_count > 0) {
+ |
+
| 437 | +! | +
+ tags$span(+ |
+
| 438 | +! | +
+ class = "filter-card-summary-na",+ |
+
| 439 | +! | +
+ "NA",+ |
+
| 440 | +! | +
+ shiny::icon("xmark")
+ |
+
| 441 | ++ |
+ )+ |
+
| 442 | ++ |
+ } else {
+ |
+
| 443 | +! | +
+ NULL+ |
+
| 444 | ++ |
+ }+ |
+
| 445 | ++ |
+ )+ |
+
| 446 | ++ |
+ )+ |
+
| 447 | ++ |
+ }+ |
+
| 448 | ++ |
+ )+ |
+
| 449 | ++ |
+ )+ |
+
| 1 | ++ |
+ # DefaultFilteredDataset ------+ |
+
| 2 | ++ |
+ #' @title The `DefaultFilteredDataset` R6 class+ |
+
| 3 | ++ |
+ #' @keywords internal+ |
+
| 4 | ++ |
+ #' @examples+ |
+
| 5 | ++ |
+ #' library(shiny)+ |
+
| 6 | ++ |
+ #' ds <- teal.slice:::DefaultFilteredDataset$new(iris, "iris")+ |
+
| 7 | ++ |
+ #' ds$set_filter_state(+ |
+
| 8 | ++ |
+ #' teal_slices(+ |
+
| 9 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),+ |
+
| 10 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))+ |
+
| 11 | ++ |
+ #' )+ |
+
| 12 | ++ |
+ #' )+ |
+
| 13 | ++ |
+ #' isolate(ds$get_filter_state())+ |
+
| 14 | ++ |
+ #' isolate(ds$get_call())+ |
+
| 15 | ++ |
+ DefaultFilteredDataset <- R6::R6Class( # nolint+ |
+
| 16 | ++ |
+ classname = "DefaultFilteredDataset",+ |
+
| 17 | ++ |
+ inherit = FilteredDataset,+ |
+
| 18 | ++ |
+ public = list(+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ #' @description+ |
+
| 21 | ++ |
+ #' Initializes this `DefaultFilteredDataset` object+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @param dataset (`data.frame`)\cr+ |
+
| 24 | ++ |
+ #' single data.frame for which filters are rendered+ |
+
| 25 | ++ |
+ #' @param dataname (`character`)\cr+ |
+
| 26 | ++ |
+ #' A given name for the dataset it may not contain spaces+ |
+
| 27 | ++ |
+ #' @param keys optional, (`character`)\cr+ |
+
| 28 | ++ |
+ #' Vector with primary keys+ |
+
| 29 | ++ |
+ #' @param parent_name (`character(1)`)\cr+ |
+
| 30 | ++ |
+ #' Name of the parent dataset+ |
+
| 31 | ++ |
+ #' @param parent (`reactive`)\cr+ |
+
| 32 | ++ |
+ #' object returned by this reactive is a filtered `data.frame` from other `FilteredDataset`+ |
+
| 33 | ++ |
+ #' named `parent_name`. Consequence of passing `parent` is a `reactive` link which causes+ |
+
| 34 | ++ |
+ #' causing re-filtering of this `dataset` based on the changes in `parent`.+ |
+
| 35 | ++ |
+ #' @param join_keys (`character`)\cr+ |
+
| 36 | ++ |
+ #' Name of the columns in this dataset to join with `parent`+ |
+
| 37 | ++ |
+ #' dataset. If the column names are different if both datasets+ |
+
| 38 | ++ |
+ #' then the names of the vector define the `parent` columns.+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @param label (`character`)\cr+ |
+
| 41 | ++ |
+ #' Label to describe the dataset+ |
+
| 42 | ++ |
+ #' @param metadata (named `list` or `NULL`) \cr+ |
+
| 43 | ++ |
+ #' Field containing metadata about the dataset. Each element of the list+ |
+
| 44 | ++ |
+ #' should be atomic and length one.+ |
+
| 45 | ++ |
+ initialize = function(dataset,+ |
+
| 46 | ++ |
+ dataname,+ |
+
| 47 | ++ |
+ keys = character(0),+ |
+
| 48 | ++ |
+ parent_name = character(0),+ |
+
| 49 | ++ |
+ parent = NULL,+ |
+
| 50 | ++ |
+ join_keys = character(0),+ |
+
| 51 | ++ |
+ label = character(0),+ |
+
| 52 | ++ |
+ metadata = NULL) {
+ |
+
| 53 | +115x | +
+ checkmate::assert_data_frame(dataset)+ |
+
| 54 | +113x | +
+ super$initialize(dataset, dataname, keys, label, metadata)+ |
+
| 55 | ++ | + + | +
| 56 | ++ |
+ # overwrite filtered_data if there is relationship with parent dataset+ |
+
| 57 | +111x | +
+ if (!is.null(parent)) {
+ |
+
| 58 | +7x | +
+ checkmate::assert_character(parent_name, len = 1)+ |
+
| 59 | +7x | +
+ checkmate::assert_character(join_keys, min.len = 1)+ |
+
| 60 | ++ | + + | +
| 61 | +7x | +
+ private$parent_name <- parent_name+ |
+
| 62 | +7x | +
+ private$join_keys <- join_keys+ |
+
| 63 | ++ | + + | +
| 64 | +7x | +
+ private$data_filtered_fun <- function(sid = "") {
+ |
+
| 65 | +5x | +
+ checkmate::assert_character(sid)+ |
+
| 66 | +5x | +
+ if (length(sid)) {
+ |
+
| 67 | +5x | +
+ logger::log_trace("filtering data dataname: { dataname }, sid: { sid }")
+ |
+
| 68 | ++ |
+ } else {
+ |
+
| 69 | +! | +
+ logger::log_trace("filtering data dataname: { private$dataname }")
+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | +5x | +
+ env <- new.env(parent = parent.env(globalenv()))+ |
+
| 72 | +5x | +
+ env[[dataname]] <- private$dataset+ |
+
| 73 | +5x | +
+ env[[parent_name]] <- parent()+ |
+
| 74 | +5x | +
+ filter_call <- self$get_call(sid)+ |
+
| 75 | +5x | +
+ eval_expr_with_msg(filter_call, env)+ |
+
| 76 | +5x | +
+ get(x = dataname, envir = env)+ |
+
| 77 | ++ |
+ }+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | +111x | +
+ private$add_filter_states(+ |
+
| 81 | +111x | +
+ filter_states = init_filter_states(+ |
+
| 82 | +111x | +
+ data = dataset,+ |
+
| 83 | +111x | +
+ data_reactive = private$data_filtered_fun,+ |
+
| 84 | +111x | +
+ dataname = dataname,+ |
+
| 85 | +111x | +
+ keys = self$get_keys()+ |
+
| 86 | ++ |
+ ),+ |
+
| 87 | +111x | +
+ id = "filter"+ |
+
| 88 | ++ |
+ )+ |
+
| 89 | ++ | + + | +
| 90 | ++ |
+ # todo: Should we make these defaults? It could be handled by the app developer+ |
+
| 91 | +111x | +
+ if (!is.null(parent)) {
+ |
+
| 92 | +7x | +
+ fs <- teal_slices(+ |
+
| 93 | +7x | +
+ exclude_varnames = structure(+ |
+
| 94 | +7x | +
+ list(intersect(colnames(dataset), colnames(isolate(parent())))),+ |
+
| 95 | +7x | +
+ names = private$dataname+ |
+
| 96 | ++ |
+ )+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | +7x | +
+ self$set_filter_state(fs)+ |
+
| 99 | ++ |
+ }+ |
+
| 100 | ++ | + + | +
| 101 | +111x | +
+ invisible(self)+ |
+
| 102 | ++ |
+ },+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ #' @description+ |
+
| 105 | ++ |
+ #' Gets the filter expression+ |
+
| 106 | ++ |
+ #'+ |
+
| 107 | ++ |
+ #' This functions returns filter calls equivalent to selected items+ |
+
| 108 | ++ |
+ #' within each of `filter_states`. Configuration of the calls is constant and+ |
+
| 109 | ++ |
+ #' depends on `filter_states` type and order which are set during initialization.+ |
+
| 110 | ++ |
+ #' This class contains single `FilterStates`+ |
+
| 111 | ++ |
+ #' which contains single `state_list` and all `FilterState` objects+ |
+
| 112 | ++ |
+ #' applies to one argument (`...`) in `dplyr::filter` call.+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' @param sid (`character`)\cr+ |
+
| 115 | ++ |
+ #' when specified then method returns code containing filter conditions of+ |
+
| 116 | ++ |
+ #' `FilterState` objects which `"sid"` attribute is different than this `sid` argument.+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' @return filter `call` or `list` of filter calls+ |
+
| 119 | ++ |
+ get_call = function(sid = "") {
+ |
+
| 120 | +36x | +
+ logger::log_trace("FilteredDatasetDefault$get_call initializing for dataname: { private$dataname }")
+ |
+
| 121 | +36x | +
+ filter_call <- super$get_call(sid)+ |
+
| 122 | +36x | +
+ dataname <- private$dataname+ |
+
| 123 | +36x | +
+ parent_dataname <- private$parent_name+ |
+
| 124 | ++ | + + | +
| 125 | +36x | +
+ if (!identical(parent_dataname, character(0))) {
+ |
+
| 126 | +6x | +
+ join_keys <- private$join_keys+ |
+
| 127 | +6x | +
+ parent_keys <- names(join_keys)+ |
+
| 128 | +6x | +
+ dataset_keys <- unname(join_keys)+ |
+
| 129 | ++ | + + | +
| 130 | +6x | +
+ y_arg <- if (length(parent_keys) == 0L) {
+ |
+
| 131 | +! | +
+ parent_dataname+ |
+
| 132 | ++ |
+ } else {
+ |
+
| 133 | +6x | +
+ sprintf(+ |
+
| 134 | +6x | +
+ "%s[, c(%s), drop = FALSE]",+ |
+
| 135 | +6x | +
+ parent_dataname,+ |
+
| 136 | +6x | +
+ toString(dQuote(parent_keys, q = FALSE))+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ | + + | +
| 140 | +6x | +
+ more_args <- if (length(parent_keys) == 0 || length(dataset_keys) == 0) {
+ |
+
| 141 | +! | +
+ list()+ |
+
| 142 | +6x | +
+ } else if (identical(parent_keys, dataset_keys)) {
+ |
+
| 143 | +6x | +
+ list(by = parent_keys)+ |
+
| 144 | ++ |
+ } else {
+ |
+
| 145 | +! | +
+ list(by = stats::setNames(parent_keys, dataset_keys))+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | +6x | +
+ merge_call <- call(+ |
+
| 149 | ++ |
+ "<-",+ |
+
| 150 | +6x | +
+ as.name(dataname),+ |
+
| 151 | +6x | +
+ as.call(+ |
+
| 152 | +6x | +
+ c(+ |
+
| 153 | +6x | +
+ str2lang("dplyr::inner_join"),
+ |
+
| 154 | +6x | +
+ x = as.name(dataname),+ |
+
| 155 | +6x | +
+ y = str2lang(y_arg),+ |
+
| 156 | +6x | +
+ more_args+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | ++ |
+ )+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ | + + | +
| 161 | +6x | +
+ filter_call <- c(filter_call, merge_call)+ |
+
| 162 | ++ |
+ }+ |
+
| 163 | +36x | +
+ logger::log_trace("FilteredDatasetDefault$get_call initializing for dataname: { private$dataname }")
+ |
+
| 164 | +36x | +
+ filter_call+ |
+
| 165 | ++ |
+ },+ |
+
| 166 | ++ | + + | +
| 167 | ++ |
+ #' @description+ |
+
| 168 | ++ |
+ #' Set filter state+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' @param state (`teal_slice`) object+ |
+
| 171 | ++ |
+ #'+ |
+
| 172 | ++ |
+ #' @examples+ |
+
| 173 | ++ |
+ #' dataset <- teal.slice:::DefaultFilteredDataset$new(iris, "iris")+ |
+
| 174 | ++ |
+ #' fs <- teal_slices(+ |
+
| 175 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", selected = "virginica"),+ |
+
| 176 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(2.0, 5))+ |
+
| 177 | ++ |
+ #' )+ |
+
| 178 | ++ |
+ #' dataset$set_filter_state(state = fs)+ |
+
| 179 | ++ |
+ #' shiny::isolate(dataset$get_filter_state())+ |
+
| 180 | ++ |
+ #'+ |
+
| 181 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 182 | ++ |
+ #'+ |
+
| 183 | ++ |
+ set_filter_state = function(state) {
+ |
+
| 184 | +75x | +
+ shiny::isolate({
+ |
+
| 185 | +75x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
+ |
+
| 186 | +75x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 187 | +74x | +
+ lapply(state, function(slice) {
+ |
+
| 188 | +100x | +
+ checkmate::assert_true(slice$dataname == private$dataname)+ |
+
| 189 | ++ |
+ })+ |
+
| 190 | +74x | +
+ private$get_filter_states()[[1L]]$set_filter_state(state = state)+ |
+
| 191 | +74x | +
+ invisible(NULL)+ |
+
| 192 | ++ |
+ })+ |
+
| 193 | ++ |
+ },+ |
+
| 194 | ++ | + + | +
| 195 | ++ |
+ #' @description+ |
+
| 196 | ++ |
+ #' Remove one or more `FilterState` form a `FilteredDataset`+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' @param state (`teal_slices`)\cr+ |
+
| 199 | ++ |
+ #' specifying `FilterState` objects to remove;+ |
+
| 200 | ++ |
+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 203 | ++ |
+ #'+ |
+
| 204 | ++ |
+ remove_filter_state = function(state) {
+ |
+
| 205 | +11x | +
+ shiny::isolate({
+ |
+
| 206 | +11x | +
+ logger::log_trace("{ class(self)[1] }$remove_filter_state removing filter(s), dataname: { private$dataname }")
+ |
+
| 207 | +11x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 208 | ++ | + + | +
| 209 | +11x | +
+ varnames <- slices_field(state, "varname")+ |
+
| 210 | +11x | +
+ private$get_filter_states()[[1]]$remove_filter_state(state)+ |
+
| 211 | ++ | + + | +
| 212 | +11x | +
+ logger::log_trace("{ class(self)[1] }$remove_filter_state removed filter(s), dataname: { private$dataname }")
+ |
+
| 213 | ++ | + + | +
| 214 | +11x | +
+ invisible(NULL)+ |
+
| 215 | ++ |
+ })+ |
+
| 216 | ++ |
+ },+ |
+
| 217 | ++ | + + | +
| 218 | ++ |
+ #' @description+ |
+
| 219 | ++ |
+ #' UI module to add filter variable for this dataset+ |
+
| 220 | ++ |
+ #'+ |
+
| 221 | ++ |
+ #' UI module to add filter variable for this dataset+ |
+
| 222 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 223 | ++ |
+ #' identifier of the element - preferably containing dataset name+ |
+
| 224 | ++ |
+ #'+ |
+
| 225 | ++ |
+ #' @return function - shiny UI module+ |
+
| 226 | ++ |
+ ui_add = function(id) {
+ |
+
| 227 | +! | +
+ ns <- NS(id)+ |
+
| 228 | +! | +
+ tagList(+ |
+
| 229 | +! | +
+ tags$label("Add", tags$code(self$get_dataname()), "filter"),
+ |
+
| 230 | +! | +
+ private$get_filter_states()[["filter"]]$ui_add(id = ns("filter"))
+ |
+
| 231 | ++ |
+ )+ |
+
| 232 | ++ |
+ },+ |
+
| 233 | ++ | + + | +
| 234 | ++ |
+ #' @description+ |
+
| 235 | ++ |
+ #' Get number of observations based on given keys+ |
+
| 236 | ++ |
+ #' The output shows the comparison between `filtered_dataset`+ |
+
| 237 | ++ |
+ #' function parameter and the dataset inside self+ |
+
| 238 | ++ |
+ #' @return `list` containing character `#filtered/#not_filtered`+ |
+
| 239 | ++ |
+ get_filter_overview = function() {
+ |
+
| 240 | +12x | +
+ logger::log_trace("FilteredDataset$srv_filter_overview initialized")
+ |
+
| 241 | ++ |
+ # Gets filter overview subjects number and returns a list+ |
+
| 242 | ++ |
+ # of the number of subjects of filtered/non-filtered datasets+ |
+
| 243 | +12x | +
+ subject_keys <- if (length(private$parent_name) > 0) {
+ |
+
| 244 | +1x | +
+ private$join_keys+ |
+
| 245 | ++ |
+ } else {
+ |
+
| 246 | +11x | +
+ self$get_keys()+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | ++ | + + | +
| 249 | +12x | +
+ dataset <- self$get_dataset()+ |
+
| 250 | +12x | +
+ data_filtered <- self$get_dataset(TRUE)+ |
+
| 251 | +12x | +
+ if (length(subject_keys) == 0) {
+ |
+
| 252 | +10x | +
+ data.frame(+ |
+
| 253 | +10x | +
+ dataname = private$dataname,+ |
+
| 254 | +10x | +
+ obs = nrow(dataset),+ |
+
| 255 | +10x | +
+ obs_filtered = nrow(data_filtered())+ |
+
| 256 | ++ |
+ )+ |
+
| 257 | ++ |
+ } else {
+ |
+
| 258 | +2x | +
+ data.frame(+ |
+
| 259 | +2x | +
+ dataname = private$dataname,+ |
+
| 260 | +2x | +
+ obs = nrow(dataset),+ |
+
| 261 | +2x | +
+ obs_filtered = nrow(data_filtered()),+ |
+
| 262 | +2x | +
+ subjects = nrow(unique(dataset[subject_keys])),+ |
+
| 263 | +2x | +
+ subjects_filtered = nrow(unique(data_filtered()[subject_keys]))+ |
+
| 264 | ++ |
+ )+ |
+
| 265 | ++ |
+ }+ |
+
| 266 | ++ |
+ }+ |
+
| 267 | ++ |
+ ),+ |
+
| 268 | ++ |
+ private = list(+ |
+
| 269 | ++ |
+ parent_name = character(0),+ |
+
| 270 | ++ |
+ join_keys = character(0)+ |
+
| 271 | ++ |
+ )+ |
+
| 272 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' @name FilterPanelAPI+ |
+
| 2 | ++ |
+ #' @docType class+ |
+
| 3 | ++ |
+ #'+ |
+
| 4 | ++ |
+ #' @title Class to encapsulate the API of the filter panel of a teal app+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @details+ |
+
| 7 | ++ |
+ #' The purpose of this class is to encapsulate the API of the filter panel in a new class `FilterPanelAPI` so+ |
+
| 8 | ++ |
+ #' that it can be passed and used in the `server` call of any module instead of passing the whole `FilteredData`+ |
+
| 9 | ++ |
+ #' object.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' This class is supported by methods to set, get, remove filter states in the filter panel API.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @export+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' library(teal.slice)+ |
+
| 17 | ++ |
+ #' fd <- teal.slice::init_filtered_data(list(iris = list(dataset = iris)))+ |
+
| 18 | ++ |
+ #' fpa <- FilterPanelAPI$new(fd)+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' # get the actual filter state --> empty named list+ |
+
| 21 | ++ |
+ #' isolate(fpa$get_filter_state())+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' # set a filter state+ |
+
| 24 | ++ |
+ #' set_filter_state(+ |
+
| 25 | ++ |
+ #' fpa,+ |
+
| 26 | ++ |
+ #' teal_slices(+ |
+
| 27 | ++ |
+ #' teal_slice(dataname = "iris", varname = "Species", selected = "setosa", keep_na = TRUE)+ |
+
| 28 | ++ |
+ #' )+ |
+
| 29 | ++ |
+ #' )+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' # get the actual filter state --> named list with filters+ |
+
| 32 | ++ |
+ #' isolate(fpa$get_filter_state())+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' # remove all_filter_states+ |
+
| 35 | ++ |
+ #' fpa$clear_filter_states()+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' # get the actual filter state --> empty named list+ |
+
| 38 | ++ |
+ #' isolate(fpa$get_filter_state())+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ FilterPanelAPI <- R6::R6Class( # nolint+ |
+
| 41 | ++ |
+ "FilterPanelAPI",+ |
+
| 42 | ++ |
+ ## __Public Methods ====+ |
+
| 43 | ++ |
+ public = list(+ |
+
| 44 | ++ |
+ #' @description+ |
+
| 45 | ++ |
+ #' Initialize a `FilterPanelAPI` object+ |
+
| 46 | ++ |
+ #' @param datasets (`FilteredData`) object.+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ initialize = function(datasets) {
+ |
+
| 49 | +8x | +
+ checkmate::assert_class(datasets, "FilteredData")+ |
+
| 50 | +6x | +
+ private$filtered_data <- datasets+ |
+
| 51 | ++ |
+ },+ |
+
| 52 | ++ | + + | +
| 53 | ++ |
+ #' @description+ |
+
| 54 | ++ |
+ #' Gets the reactive values from the active `FilterState` objects of the `FilteredData` object.+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' Gets all active filters in the form of a nested list.+ |
+
| 57 | ++ |
+ #' The output list is a compatible input to `set_filter_state`.+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' @return `list` with named elements corresponding to `FilteredDataset` objects with active filters.+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ get_filter_state = function() {
+ |
+
| 62 | +8x | +
+ private$filtered_data$get_filter_state()+ |
+
| 63 | ++ |
+ },+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ #' @description+ |
+
| 66 | ++ |
+ #' Sets active filter states.+ |
+
| 67 | ++ |
+ #' @param filter (`teal_slices`)+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ set_filter_state = function(filter) {
+ |
+
| 72 | +5x | +
+ private$filtered_data$set_filter_state(filter)+ |
+
| 73 | +5x | +
+ invisible(NULL)+ |
+
| 74 | ++ |
+ },+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ #' @description+ |
+
| 77 | ++ |
+ #' Remove one or more `FilterState` of a `FilteredDataset` in the `FilteredData` object.+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @param filter (`teal_slices`)\cr+ |
+
| 80 | ++ |
+ #' specifying `FilterState` objects to remove;+ |
+
| 81 | ++ |
+ #' `teal_slice`s may contain only `dataname` and `varname`, other elements are ignored+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ remove_filter_state = function(filter) {
+ |
+
| 86 | +1x | +
+ private$filtered_data$remove_filter_state(filter)+ |
+
| 87 | +1x | +
+ invisible(NULL)+ |
+
| 88 | ++ |
+ },+ |
+
| 89 | ++ | + + | +
| 90 | ++ |
+ #' @description Remove all `FilterStates` of the `FilteredData` object.+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @param datanames (`character`)\cr+ |
+
| 93 | ++ |
+ #' `datanames` to remove their `FilterStates`;+ |
+
| 94 | ++ |
+ #' omit to remove all `FilterStates` in the `FilteredData` object+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ clear_filter_states = function(datanames) {
+ |
+
| 99 | +2x | +
+ datanames_to_remove <- if (missing(datanames)) private$filtered_data$datanames() else datanames+ |
+
| 100 | +2x | +
+ private$filtered_data$clear_filter_states(datanames = datanames_to_remove)+ |
+
| 101 | +2x | +
+ invisible(NULL)+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ |
+ ),+ |
+
| 104 | ++ |
+ ## __Private Methods ====+ |
+
| 105 | ++ |
+ private = list(+ |
+
| 106 | ++ |
+ filtered_data = NULL+ |
+
| 107 | ++ |
+ )+ |
+
| 108 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Complete filter specification.+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Create `teal_slices` object to package multiple filters and additional settings.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @details+ |
+
| 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 can be mutually exclusive in some cases, they cannot both be set in one `teal_slices` object.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @param ... any number of `teal_slice` objects. For `print` and `format`,+ |
+
| 16 | ++ |
+ #' additional arguments passed to other functions.+ |
+
| 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 (`character(1)`) string specifying how observations are tallied by these filter states.+ |
+
| 21 | ++ |
+ #' Possible options:+ |
+
| 22 | ++ |
+ #' - `"none"` (default) to have counts of single `FilterState` to show unfiltered number only.+ |
+
| 23 | ++ |
+ #' - `"all"` to have counts of single `FilterState` to show number of observation in filtered+ |
+
| 24 | ++ |
+ #' and unfiltered dataset. Note, that issues were reported when using this option with `MultiAssayExperiment`.+ |
+
| 25 | ++ |
+ #' Please make sure that adding new filters doesn't fail on target platform before deploying for production.+ |
+
| 26 | ++ |
+ #' @param module_add (`logical(1)`) logical flag specifying whether the user will be able to add new filters+ |
+
| 27 | ++ |
+ #' @param i (`character` or `numeric` or `logical`) indicating which elements to extract+ |
+
| 28 | ++ |
+ #' @param x (`teal_slices`) object.+ |
+
| 29 | ++ |
+ #' @return+ |
+
| 30 | ++ |
+ #' `teal_slices`, which is an unnamed list of `teal_slice` objects.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examples+ |
+
| 33 | ++ |
+ #' filter_1 <- teal_slice(+ |
+
| 34 | ++ |
+ #' dataname = "dataname1",+ |
+
| 35 | ++ |
+ #' varname = "varname1",+ |
+
| 36 | ++ |
+ #' choices = letters,+ |
+
| 37 | ++ |
+ #' selected = "b",+ |
+
| 38 | ++ |
+ #' keep_na = TRUE,+ |
+
| 39 | ++ |
+ #' fixed = FALSE,+ |
+
| 40 | ++ |
+ #' extra1 = "extraone"+ |
+
| 41 | ++ |
+ #' )+ |
+
| 42 | ++ |
+ #' filter_2 <- teal_slice(+ |
+
| 43 | ++ |
+ #' dataname = "dataname1",+ |
+
| 44 | ++ |
+ #' varname = "varname2",+ |
+
| 45 | ++ |
+ #' choices = 1:10,+ |
+
| 46 | ++ |
+ #' keep_na = TRUE,+ |
+
| 47 | ++ |
+ #' selected = 2,+ |
+
| 48 | ++ |
+ #' fixed = TRUE,+ |
+
| 49 | ++ |
+ #' locked = FALSE,+ |
+
| 50 | ++ |
+ #' extra2 = "extratwo"+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #' filter_3 <- teal_slice(+ |
+
| 53 | ++ |
+ #' dataname = "dataname2",+ |
+
| 54 | ++ |
+ #' varname = "varname3",+ |
+
| 55 | ++ |
+ #' choices = 1:10 / 10,+ |
+
| 56 | ++ |
+ #' keep_na = TRUE,+ |
+
| 57 | ++ |
+ #' selected = 0.2,+ |
+
| 58 | ++ |
+ #' fixed = TRUE,+ |
+
| 59 | ++ |
+ #' locked = FALSE,+ |
+
| 60 | ++ |
+ #' extra1 = "extraone",+ |
+
| 61 | ++ |
+ #' extra2 = "extratwo"+ |
+
| 62 | ++ |
+ #' )+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' all_filters <- teal_slices(+ |
+
| 65 | ++ |
+ #' filter_1,+ |
+
| 66 | ++ |
+ #' filter_2,+ |
+
| 67 | ++ |
+ #' filter_3,+ |
+
| 68 | ++ |
+ #' exclude_varnames = list(+ |
+
| 69 | ++ |
+ #' "dataname1" = "varname2"+ |
+
| 70 | ++ |
+ #' )+ |
+
| 71 | ++ |
+ #' )+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' is.teal_slices(all_filters)+ |
+
| 74 | ++ |
+ #' all_filters[1:2]+ |
+
| 75 | ++ |
+ #' c(all_filters[1], all_filters[2])+ |
+
| 76 | ++ |
+ #' print(all_filters)+ |
+
| 77 | ++ |
+ #' print(all_filters, trim_lines = FALSE)+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @seealso [`teal_slice`]+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @export+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ teal_slices <- function(...,+ |
+
| 84 | ++ |
+ exclude_varnames = NULL,+ |
+
| 85 | ++ |
+ include_varnames = NULL,+ |
+
| 86 | ++ |
+ count_type = NULL,+ |
+
| 87 | ++ |
+ module_add = TRUE) {
+ |
+
| 88 | +753x | +
+ slices <- list(...)+ |
+
| 89 | +753x | +
+ checkmate::assert_list(slices, types = "teal_slice", any.missing = FALSE)+ |
+
| 90 | +752x | +
+ slices_id <- shiny::isolate(vapply(slices, `[[`, character(1L), "id"))+ |
+
| 91 | +752x | +
+ if (any(duplicated(slices_id))) {
+ |
+
| 92 | +1x | +
+ stop(+ |
+
| 93 | +1x | +
+ "Some teal_slice objects have the same id:\n",+ |
+
| 94 | +1x | +
+ toString(unique(slices_id[duplicated(slices_id)]))+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | +751x | +
+ checkmate::assert_list(exclude_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)+ |
+
| 98 | +750x | +
+ checkmate::assert_list(include_varnames, names = "named", types = "character", null.ok = TRUE, min.len = 1)+ |
+
| 99 | +749x | +
+ checkmate::assert_character(count_type, len = 1, null.ok = TRUE)+ |
+
| 100 | +747x | +
+ checkmate::assert_subset(count_type, choices = c("all", "none"), empty.ok = TRUE)
+ |
+
| 101 | +746x | +
+ checkmate::assert_logical(module_add)+ |
+
| 102 | ++ | + + | +
| 103 | +745x | +
+ structure(+ |
+
| 104 | +745x | +
+ slices,+ |
+
| 105 | +745x | +
+ exclude_varnames = exclude_varnames,+ |
+
| 106 | +745x | +
+ include_varnames = include_varnames,+ |
+
| 107 | +745x | +
+ count_type = count_type,+ |
+
| 108 | +745x | +
+ module_add = module_add,+ |
+
| 109 | +745x | +
+ class = c("teal_slices", class(slices))
+ |
+
| 110 | ++ |
+ )+ |
+
| 111 | ++ |
+ }+ |
+
| 112 | ++ | + + | +
| 113 | ++ | + + | +
| 114 | ++ | + + | +
| 115 | ++ |
+ #' @rdname teal_slices+ |
+
| 116 | ++ |
+ #' @export+ |
+
| 117 | ++ |
+ #' @keywords internal+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ is.teal_slices <- function(x) { # nolint
+ |
+
| 120 | +511x | +
+ inherits(x, "teal_slices")+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | ++ | + + | +
| 123 | ++ |
+ #' @rdname teal_slices+ |
+
| 124 | ++ |
+ #' @export+ |
+
| 125 | ++ |
+ #' @keywords internal+ |
+
| 126 | ++ |
+ #'+ |
+
| 127 | ++ |
+ as.teal_slices <- function(x) { # nolint
+ |
+
| 128 | +1x | +
+ checkmate::assert_list(x, names = "named")+ |
+
| 129 | +1x | +
+ is_bottom <- function(x) {
+ |
+
| 130 | +10x | +
+ isTRUE(is.list(x) && any(names(x) %in% c("selected", "keep_na", "keep_inf"))) ||
+ |
+
| 131 | +10x | +
+ identical(x, list()) ||+ |
+
| 132 | +10x | +
+ is.atomic(x)+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | +1x | +
+ make_args <- function(object, dataname, varname, experiment = NULL, arg = NULL) {
+ |
+
| 135 | +7x | +
+ args <- list(+ |
+
| 136 | +7x | +
+ dataname = dataname,+ |
+
| 137 | +7x | +
+ varname = varname+ |
+
| 138 | ++ |
+ )+ |
+
| 139 | +1x | +
+ if (!is.null(experiment)) args$experiment <- experiment+ |
+
| 140 | +1x | +
+ if (!is.null(arg)) args$arg <- arg+ |
+
| 141 | +7x | +
+ if (is.list(object)) {
+ |
+
| 142 | +6x | +
+ args <- c(args, object)+ |
+
| 143 | +1x | +
+ } else if (is.atomic(object)) {
+ |
+
| 144 | +1x | +
+ args$selected <- object+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | +7x | +
+ args+ |
+
| 147 | ++ |
+ }+ |
+
| 148 | +1x | +
+ slices <- vector("list")
+ |
+
| 149 | ++ | + + | +
| 150 | +1x | +
+ for (dataname in names(x)) {
+ |
+
| 151 | +2x | +
+ item <- x[[dataname]]+ |
+
| 152 | +2x | +
+ for (name_i in names(item)) {
+ |
+
| 153 | +5x | +
+ subitem <- item[[name_i]]+ |
+
| 154 | +5x | +
+ if (is_bottom(subitem)) {
+ |
+
| 155 | +3x | +
+ args <- make_args(+ |
+
| 156 | +3x | +
+ subitem,+ |
+
| 157 | +3x | +
+ dataname = dataname,+ |
+
| 158 | +3x | +
+ varname = name_i+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | +3x | +
+ slices <- c(slices, list(as.teal_slice(args)))+ |
+
| 161 | ++ |
+ } else {
+ |
+
| 162 | ++ |
+ # MAE zone+ |
+
| 163 | +2x | +
+ for (name_ii in names(subitem)) {
+ |
+
| 164 | +4x | +
+ subsubitem <- subitem[[name_ii]]+ |
+
| 165 | +4x | +
+ if (is_bottom(subsubitem)) {
+ |
+
| 166 | +3x | +
+ args <- make_args(+ |
+
| 167 | +3x | +
+ subsubitem,+ |
+
| 168 | +3x | +
+ dataname = dataname,+ |
+
| 169 | +3x | +
+ experiment = if (name_i != "subjects") name_i,+ |
+
| 170 | +3x | +
+ varname = name_ii+ |
+
| 171 | ++ |
+ )+ |
+
| 172 | +3x | +
+ slices <- c(slices, list(as.teal_slice(args)))+ |
+
| 173 | ++ |
+ } else {
+ |
+
| 174 | +1x | +
+ for (name_iii in names(subsubitem)) {
+ |
+
| 175 | +1x | +
+ subsubsubitem <- subsubitem[[name_iii]]+ |
+
| 176 | +1x | +
+ if (is_bottom(subsubsubitem)) {
+ |
+
| 177 | +1x | +
+ args <- make_args(+ |
+
| 178 | +1x | +
+ subsubsubitem,+ |
+
| 179 | +1x | +
+ dataname = dataname,+ |
+
| 180 | +1x | +
+ experiment = name_i,+ |
+
| 181 | +1x | +
+ arg = name_ii,+ |
+
| 182 | +1x | +
+ varname = name_iii+ |
+
| 183 | ++ |
+ )+ |
+
| 184 | +1x | +
+ slices <- c(slices, list(as.teal_slice(args)))+ |
+
| 185 | ++ |
+ }+ |
+
| 186 | ++ |
+ }+ |
+
| 187 | ++ |
+ }+ |
+
| 188 | ++ |
+ }+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | +1x | +
+ if (length(slices) == 0L && length(x) != 0L) {
+ |
+
| 194 | +! | +
+ stop("conversion to filter_slices failed")
+ |
+
| 195 | ++ |
+ }+ |
+
| 196 | ++ | + + | +
| 197 | +1x | +
+ do.call(teal_slices, c(slices, list(include_varnames = attr(x, "filterable"))))+ |
+
| 198 | ++ |
+ }+ |
+
| 199 | ++ | + + | +
| 200 | ++ | + + | +
| 201 | ++ |
+ #' @rdname teal_slices+ |
+
| 202 | ++ |
+ #' @export+ |
+
| 203 | ++ |
+ #' @keywords internal+ |
+
| 204 | ++ |
+ #'+ |
+
| 205 | ++ |
+ `[.teal_slices` <- function(x, i) {
+ |
+
| 206 | +3x | +
+ if (missing(i)) i <- seq_along(x)+ |
+
| 207 | +547x | +
+ if (length(i) == 0L) {
+ |
+
| 208 | +197x | +
+ return(x[0])+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | +1x | +
+ if (is.logical(i) && length(i) > length(x)) stop("subscript out of bounds")
+ |
+
| 211 | +1x | +
+ if (is.numeric(i) && max(i) > length(x)) stop("subscript out of bounds")
+ |
+
| 212 | +348x | +
+ if (is.character(i)) {
+ |
+
| 213 | +1x | +
+ if (!all(is.element(i, names(x)))) stop("subscript out of bounds")
+ |
+
| 214 | +2x | +
+ i <- which(is.element(i, names(x)))+ |
+
| 215 | ++ |
+ }+ |
+
| 216 | ++ | + + | +
| 217 | +347x | +
+ y <- NextMethod("[")
+ |
+
| 218 | +347x | +
+ attrs <- attributes(x)+ |
+
| 219 | +347x | +
+ attrs$names <- attrs$names[i]+ |
+
| 220 | +347x | +
+ attributes(y) <- attrs+ |
+
| 221 | +347x | +
+ y+ |
+
| 222 | ++ |
+ }+ |
+
| 223 | ++ | + + | +
| 224 | ++ | + + | +
| 225 | ++ |
+ #' @rdname teal_slices+ |
+
| 226 | ++ |
+ #' @export+ |
+
| 227 | ++ |
+ #' @keywords internal+ |
+
| 228 | ++ |
+ #'+ |
+
| 229 | ++ |
+ c.teal_slices <- function(...) {
+ |
+
| 230 | +248x | +
+ x <- list(...)+ |
+
| 231 | +248x | +
+ checkmate::assert_true(all(vapply(x, is.teal_slices, logical(1L))), .var.name = "all arguments are teal_slices")+ |
+
| 232 | ++ | + + | +
| 233 | +247x | +
+ excludes <- lapply(x, attr, "exclude_varnames")+ |
+
| 234 | +247x | +
+ names(excludes) <- NULL+ |
+
| 235 | +247x | +
+ excludes <- unlist(excludes, recursive = FALSE)+ |
+
| 236 | +247x | +
+ excludes <- excludes[!duplicated(names(excludes))]+ |
+
| 237 | ++ | + + | +
| 238 | +247x | +
+ includes <- lapply(x, attr, "include_varnames")+ |
+
| 239 | +247x | +
+ names(includes) <- NULL+ |
+
| 240 | +247x | +
+ includes <- unlist(includes, recursive = FALSE)+ |
+
| 241 | +247x | +
+ includes <- includes[!duplicated(names(includes))]+ |
+
| 242 | ++ | + + | +
| 243 | +247x | +
+ count_types <- lapply(x, attr, "count_type")+ |
+
| 244 | +247x | +
+ count_types <- unique(unlist(count_types))+ |
+
| 245 | ++ | + + | +
| 246 | +247x | +
+ do.call(+ |
+
| 247 | +247x | +
+ teal_slices,+ |
+
| 248 | +247x | +
+ c(+ |
+
| 249 | +247x | +
+ unique(unlist(x, recursive = FALSE)),+ |
+
| 250 | +247x | +
+ list(+ |
+
| 251 | +247x | +
+ include_varnames = if (length(includes)) includes,+ |
+
| 252 | +247x | +
+ exclude_varnames = if (length(excludes)) excludes,+ |
+
| 253 | +247x | +
+ count_type = count_types+ |
+
| 254 | ++ |
+ )+ |
+
| 255 | ++ |
+ )+ |
+
| 256 | ++ |
+ )+ |
+
| 257 | ++ |
+ }+ |
+
| 258 | ++ | + + | +
| 259 | ++ | + + | +
| 260 | ++ |
+ #' @rdname teal_slices+ |
+
| 261 | ++ |
+ #' @param show_all (`logical(1)`) whether to display non-null elements of constituent `teal_slice` objects+ |
+
| 262 | ++ |
+ #' @param trim_lines (`logical(1)`) whether to trim lines+ |
+
| 263 | ++ |
+ #' @export+ |
+
| 264 | ++ |
+ #' @keywords internal+ |
+
| 265 | ++ |
+ #'+ |
+
| 266 | ++ |
+ format.teal_slices <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
+ |
+
| 267 | +49x | +
+ checkmate::assert_flag(show_all)+ |
+
| 268 | +49x | +
+ checkmate::assert_flag(trim_lines)+ |
+
| 269 | ++ | + + | +
| 270 | +49x | +
+ slices_list <- slices_to_list(x)+ |
+
| 271 | ++ | + + | +
| 272 | +22x | +
+ if (!show_all) slices_list$slices <- lapply(slices_list$slices, function(slice) Filter(Negate(is.null), slice))+ |
+
| 273 | ++ | + + | +
| 274 | +49x | +
+ jsonify(slices_list, trim_lines)+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | ++ | + + | +
| 277 | ++ |
+ #' @rdname teal_slices+ |
+
| 278 | ++ |
+ #' @export+ |
+
| 279 | ++ |
+ #' @keywords internal+ |
+
| 280 | ++ |
+ #'+ |
+
| 281 | ++ |
+ print.teal_slices <- function(x, ...) {
+ |
+
| 282 | +5x | +
+ cat(format(x, ...), "\n")+ |
+
| 283 | ++ |
+ }+ |
+
| 284 | ++ | + + | +
| 285 | ++ |
+ #' Extract unique values from field of `teal_slice` Objects.+ |
+
| 286 | ++ |
+ #' @param tss (`teal_slices`) object+ |
+
| 287 | ++ |
+ #' @param field (`character(1)`) `teal_slice` field name+ |
+
| 288 | ++ |
+ #' @return A vector of unique values. Type conversion may occur (silently).+ |
+
| 289 | ++ |
+ #' @keywords internal+ |
+
| 290 | ++ |
+ #'+ |
+
| 291 | ++ |
+ slices_field <- function(tss, field) {
+ |
+
| 292 | +192x | +
+ checkmate::assert_string(field)+ |
+
| 293 | +191x | +
+ checkmate::assert_class(tss, "teal_slices")+ |
+
| 294 | +191x | +
+ unique(unlist(lapply(tss, function(x) x[[field]])))+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | ++ | + + | +
| 297 | ++ |
+ #' Convert `teal_slices` to list+ |
+
| 298 | ++ |
+ #' @param tss (`teal_slices`) object+ |
+
| 299 | ++ |
+ #' @return A list of length 2, the first element holding all `teal_slice` contained in `tss`+ |
+
| 300 | ++ |
+ #' (converted to list) and the second element holding the all non-NULL attributes of `tss`.+ |
+
| 301 | ++ |
+ #' @keywords internal+ |
+
| 302 | ++ |
+ #'+ |
+
| 303 | ++ |
+ slices_to_list <- function(tss) {
+ |
+
| 304 | +49x | +
+ slices_list <- lapply(tss, as.list)+ |
+
| 305 | +49x | +
+ attrs <- attributes(unclass(tss))+ |
+
| 306 | +49x | +
+ tss_list <- list(slices = slices_list, attributes = attrs)+ |
+
| 307 | +49x | +
+ Filter(Negate(is.null), tss_list) # drop attributes if empty+ |
+
| 308 | ++ |
+ }+ |
+
| 309 | ++ | + + | +
| 310 | ++ |
+ #' `setdiff` method for `teal_slices`+ |
+
| 311 | ++ |
+ #'+ |
+
| 312 | ++ |
+ #' Compare two teal slices objects and return `teal_slices` containing slices present in `x` but not in `y`.+ |
+
| 313 | ++ |
+ #' @param x,y `teal_slices` objects+ |
+
| 314 | ++ |
+ #' @return `teal_slices`+ |
+
| 315 | ++ |
+ #' @keywords internal+ |
+
| 316 | ++ |
+ #'+ |
+
| 317 | ++ |
+ setdiff_teal_slices <- function(x, y) {
+ |
+
| 318 | +14x | +
+ Filter(+ |
+
| 319 | +14x | +
+ function(xx) {
+ |
+
| 320 | +12x | +
+ !any(vapply(y, function(yy) identical(yy, xx), logical(1)))+ |
+
| 321 | ++ |
+ },+ |
+
| 322 | +14x | +
+ x+ |
+
| 323 | ++ |
+ )+ |
+
| 324 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Progress bars with labels+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' `shiny` element showing progress bar counts. Each element can have an+ |
+
| 4 | ++ |
+ #' unique `id` attribute so each can be used independently.+ |
+
| 5 | ++ |
+ #' Progress bar size is dependent on the ratio `choicesnow[i] / countsmax[i]`.+ |
+
| 6 | ++ |
+ #' Label is `choices[i] (countsnow[i]/countsmax)`+ |
+
| 7 | ++ |
+ #' @param session (`session`) object passed to function given to `shinyServer`.+ |
+
| 8 | ++ |
+ #' @param inputId (`character(1)`) `shiny` id+ |
+
| 9 | ++ |
+ #' @param choices (`vector`) determines label text.+ |
+
| 10 | ++ |
+ #' @param countsmax (`numeric`) determining maximal count of each element.+ |
+
| 11 | ++ |
+ #' Length should be the same as `choices`.+ |
+
| 12 | ++ |
+ #' @param countsnow (`numeric`) actual counts of each element.+ |
+
| 13 | ++ |
+ #' Length should be the same as `choices`.+ |
+
| 14 | ++ |
+ #' @return list of `shiny.tag`+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' choices <- sample(as.factor(c("a", "b", "c")), size = 20, replace = TRUE)
+ |
+
| 18 | ++ |
+ #' counts <- table(choices)+ |
+
| 19 | ++ |
+ #' labels <- teal.slice:::countBars(+ |
+
| 20 | ++ |
+ #' inputId = "counts",+ |
+
| 21 | ++ |
+ #' choices = c("a", "b", "c"),
+ |
+
| 22 | ++ |
+ #' countsmax = counts,+ |
+
| 23 | ++ |
+ #' countsnow = unname(counts)+ |
+
| 24 | ++ |
+ #' )+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' app <- shinyApp(+ |
+
| 27 | ++ |
+ #' ui = fluidPage(+ |
+
| 28 | ++ |
+ #' div(+ |
+
| 29 | ++ |
+ #' class = "choices_state",+ |
+
| 30 | ++ |
+ #' teal.slice:::include_js_files("count-bar-labels.js"),
+ |
+
| 31 | ++ |
+ #' teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 32 | ++ |
+ #' checkboxGroupInput(+ |
+
| 33 | ++ |
+ #' inputId = "choices",+ |
+
| 34 | ++ |
+ #' selected = levels(choices),+ |
+
| 35 | ++ |
+ #' choiceNames = labels,+ |
+
| 36 | ++ |
+ #' choiceValues = levels(choices),+ |
+
| 37 | ++ |
+ #' label = NULL+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #' )+ |
+
| 40 | ++ |
+ #' ),+ |
+
| 41 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 42 | ++ |
+ #' observeEvent(input$choices, {
+ |
+
| 43 | ++ |
+ #' new_counts <- counts+ |
+
| 44 | ++ |
+ #' new_counts[!names(new_counts) %in% input$choices] <- 0+ |
+
| 45 | ++ |
+ #' teal.slice:::updateCountBars(+ |
+
| 46 | ++ |
+ #' inputId = "counts",+ |
+
| 47 | ++ |
+ #' choices = levels(choices),+ |
+
| 48 | ++ |
+ #' countsmax = counts,+ |
+
| 49 | ++ |
+ #' countsnow = unname(new_counts)+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #' })+ |
+
| 52 | ++ |
+ #' }+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #' if (interactive()) {
+ |
+
| 55 | ++ |
+ #' runApp(app)+ |
+
| 56 | ++ |
+ #' }+ |
+
| 57 | ++ |
+ #' @keywords internal+ |
+
| 58 | ++ |
+ countBars <- function(inputId, choices, countsmax, countsnow = NULL) { # nolint
+ |
+
| 59 | +25x | +
+ checkmate::assert_string(inputId)+ |
+
| 60 | +21x | +
+ checkmate::assert_vector(choices)+ |
+
| 61 | +20x | +
+ checkmate::assert_numeric(countsmax, len = length(choices))+ |
+
| 62 | +17x | +
+ checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)+ |
+
| 63 | +15x | +
+ if (!is.null(countsnow)) {
+ |
+
| 64 | +7x | +
+ checkmate::assert_true(all(countsnow <= countsmax))+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | +14x | +
+ ns <- NS(inputId)+ |
+
| 68 | +14x | +
+ counttotal <- sum(countsmax)+ |
+
| 69 | ++ | + + | +
| 70 | +14x | +
+ mapply(+ |
+
| 71 | +14x | +
+ countBar,+ |
+
| 72 | +14x | +
+ inputId = ns(seq_along(choices)),+ |
+
| 73 | +14x | +
+ label = as.character(choices),+ |
+
| 74 | +14x | +
+ countmax = countsmax,+ |
+
| 75 | +14x | +
+ countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,+ |
+
| 76 | +14x | +
+ MoreArgs = list(+ |
+
| 77 | +14x | +
+ counttotal = sum(countsmax)+ |
+
| 78 | ++ |
+ ),+ |
+
| 79 | +14x | +
+ SIMPLIFY = FALSE, USE.NAMES = FALSE+ |
+
| 80 | ++ |
+ )+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ | + + | +
| 83 | ++ |
+ #' Progress bar with label+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' Progress bar with label+ |
+
| 86 | ++ |
+ #' @param session (`session`) object passed to function given to `shinyServer`.+ |
+
| 87 | ++ |
+ #' @param inputId (`character(1)`) `shiny` id+ |
+
| 88 | ++ |
+ #' @param label (`character(1)`) Text to display followed by counts+ |
+
| 89 | ++ |
+ #' @param countmax (`numeric(1)`) maximal possible count for a single item.+ |
+
| 90 | ++ |
+ #' @param countnow (`numeric(1)`) current count of a single item.+ |
+
| 91 | ++ |
+ #' @param counttotal (`numeric(1)`) total count to make whole progress bar+ |
+
| 92 | ++ |
+ #' taking part of the container. Ratio between `countmax / counttotal`+ |
+
| 93 | ++ |
+ #' determines `<style="width: <countmax / counttotal>%""`.+ |
+
| 94 | ++ |
+ #' @return `shiny.tag` object with a progress bar and a label.+ |
+
| 95 | ++ |
+ #' @keywords internal+ |
+
| 96 | ++ |
+ countBar <- function(inputId, label, countmax, countnow = NULL, counttotal = countmax) { # nolint
+ |
+
| 97 | +62x | +
+ checkmate::assert_string(inputId)+ |
+
| 98 | +58x | +
+ checkmate::assert_string(label)+ |
+
| 99 | +55x | +
+ checkmate::assert_number(countmax)+ |
+
| 100 | +53x | +
+ checkmate::assert_number(countnow, null.ok = TRUE, upper = countmax)+ |
+
| 101 | +51x | +
+ checkmate::assert_number(counttotal, lower = countmax)+ |
+
| 102 | ++ | + + | +
| 103 | +49x | +
+ label <- make_count_text(label, countmax = countmax, countnow = countnow)+ |
+
| 104 | +49x | +
+ ns <- NS(inputId)+ |
+
| 105 | +26x | +
+ if (is.null(countnow)) countnow <- 0+ |
+
| 106 | +49x | +
+ tags$div(+ |
+
| 107 | +49x | +
+ class = "progress state-count-container",+ |
+
| 108 | ++ |
+ # * .9 to not exceed width of the parent html element+ |
+
| 109 | +49x | +
+ tags$div(+ |
+
| 110 | +49x | +
+ id = ns("count_bar_filtered"),
+ |
+
| 111 | +49x | +
+ class = "progress-bar state-count-bar-filtered",+ |
+
| 112 | +49x | +
+ style = sprintf("width: %s%%", countnow / counttotal * 100),
+ |
+
| 113 | +49x | +
+ role = "progressbar",+ |
+
| 114 | +49x | +
+ label+ |
+
| 115 | ++ |
+ ),+ |
+
| 116 | +49x | +
+ tags$div(+ |
+
| 117 | +49x | +
+ id = ns("count_bar_unfiltered"),
+ |
+
| 118 | +49x | +
+ class = "progress-bar state-count-bar-unfiltered",+ |
+
| 119 | +49x | +
+ style = sprintf("width: %s%%", (countmax - countnow) / counttotal * 100),
+ |
+
| 120 | +49x | +
+ role = "progressbar"+ |
+
| 121 | ++ |
+ )+ |
+
| 122 | ++ |
+ )+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | ++ |
+ #' @rdname countBars+ |
+
| 126 | ++ |
+ updateCountBars <- function(session = getDefaultReactiveDomain(), inputId, choices, # nolint+ |
+
| 127 | ++ |
+ countsmax, countsnow = NULL) {
+ |
+
| 128 | +7x | +
+ checkmate::assert_string(inputId)+ |
+
| 129 | +7x | +
+ checkmate::assert_vector(choices)+ |
+
| 130 | +7x | +
+ checkmate::assert_numeric(countsmax, len = length(choices))+ |
+
| 131 | +7x | +
+ checkmate::assert_numeric(countsnow, len = length(choices), null.ok = TRUE)+ |
+
| 132 | ++ | + + | +
| 133 | +7x | +
+ ns <- NS(inputId)+ |
+
| 134 | +7x | +
+ mapply(+ |
+
| 135 | +7x | +
+ updateCountBar,+ |
+
| 136 | +7x | +
+ inputId = ns(seq_along(choices)),+ |
+
| 137 | +7x | +
+ label = choices,+ |
+
| 138 | +7x | +
+ countmax = countsmax,+ |
+
| 139 | +7x | +
+ countnow = if (is.null(countsnow)) rep(list(NULL), length(choices)) else countsnow,+ |
+
| 140 | +7x | +
+ MoreArgs = list(+ |
+
| 141 | +7x | +
+ counttotal = sum(countsmax)+ |
+
| 142 | ++ |
+ )+ |
+
| 143 | ++ |
+ )+ |
+
| 144 | +7x | +
+ invisible(NULL)+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | ++ | + + | +
| 147 | ++ |
+ #' @rdname countBar+ |
+
| 148 | ++ |
+ updateCountBar <- function(session = getDefaultReactiveDomain(), inputId, label, # nolint+ |
+
| 149 | ++ |
+ countmax, countnow = NULL, counttotal) {
+ |
+
| 150 | +18x | +
+ checkmate::assert_string(inputId)+ |
+
| 151 | +18x | +
+ checkmate::assert_string(label)+ |
+
| 152 | +18x | +
+ checkmate::assert_number(countmax)+ |
+
| 153 | +18x | +
+ checkmate::assert_number(countnow, null.ok = TRUE)+ |
+
| 154 | +18x | +
+ checkmate::assert_number(counttotal)+ |
+
| 155 | ++ | + + | +
| 156 | +18x | +
+ label <- make_count_text(label, countmax = countmax, countnow = countnow)+ |
+
| 157 | +18x | +
+ if (is.null(countnow)) countnow <- countmax+ |
+
| 158 | +18x | +
+ session$sendCustomMessage(+ |
+
| 159 | +18x | +
+ type = "updateCountBar",+ |
+
| 160 | +18x | +
+ message = list(+ |
+
| 161 | +18x | +
+ id = session$ns(inputId),+ |
+
| 162 | +18x | +
+ label = label,+ |
+
| 163 | +18x | +
+ countmax = countmax,+ |
+
| 164 | +18x | +
+ countnow = countnow,+ |
+
| 165 | +18x | +
+ counttotal = counttotal+ |
+
| 166 | ++ |
+ )+ |
+
| 167 | ++ |
+ )+ |
+
| 168 | ++ | + + | +
| 169 | +18x | +
+ invisible(NULL)+ |
+
| 170 | ++ |
+ }+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ #' @rdname countBar+ |
+
| 173 | ++ |
+ updateCountText <- function(session = getDefaultReactiveDomain(), inputId, label, countmax, countnow) { # nolint
+ |
+
| 174 | +17x | +
+ checkmate::assert_string(inputId)+ |
+
| 175 | +17x | +
+ checkmate::assert_string(label)+ |
+
| 176 | +17x | +
+ checkmate::assert_number(countmax)+ |
+
| 177 | +17x | +
+ checkmate::assert_number(countnow, null.ok = TRUE)+ |
+
| 178 | +17x | +
+ label <- make_count_text(label, countmax = countmax, countnow = countnow)+ |
+
| 179 | +17x | +
+ session$sendCustomMessage(+ |
+
| 180 | +17x | +
+ type = "updateCountText",+ |
+
| 181 | +17x | +
+ message = list(+ |
+
| 182 | +17x | +
+ id = session$ns(inputId),+ |
+
| 183 | +17x | +
+ label = label+ |
+
| 184 | ++ |
+ )+ |
+
| 185 | ++ |
+ )+ |
+
| 186 | ++ |
+ }+ |
+
| 187 | ++ | + + | +
| 188 | ++ |
+ #' Make a count text+ |
+
| 189 | ++ |
+ #'+ |
+
| 190 | ++ |
+ #' Returns a text describing filtered counts. The text is composed in the following way:+ |
+
| 191 | ++ |
+ #' - when `countnow` is not `NULL`: `<label> (<countnow>/<countmax>)`+ |
+
| 192 | ++ |
+ #' - when `countnow` is `NULL`: `<label> (<countmax>)`+ |
+
| 193 | ++ |
+ #' @param label (`character(1)`) Text displayed before counts+ |
+
| 194 | ++ |
+ #' @param countnow (`numeric(1)`) filtered counts+ |
+
| 195 | ++ |
+ #' @param countmax (`numeric(1)`) unfiltered counts+ |
+
| 196 | ++ |
+ #' @return `character(1)`+ |
+
| 197 | ++ |
+ #' @keywords internal+ |
+
| 198 | ++ |
+ make_count_text <- function(label, countmax, countnow = NULL) {
+ |
+
| 199 | +96x | +
+ checkmate::assert_string(label)+ |
+
| 200 | +94x | +
+ checkmate::assert_number(countmax)+ |
+
| 201 | +92x | +
+ checkmate::assert_number(countnow, null.ok = TRUE)+ |
+
| 202 | +90x | +
+ sprintf(+ |
+
| 203 | +90x | +
+ "%s (%s%s)",+ |
+
| 204 | +90x | +
+ label,+ |
+
| 205 | +90x | +
+ if (is.null(countnow)) "" else sprintf("%s/", countnow),
+ |
+
| 206 | +90x | +
+ countmax+ |
+
| 207 | ++ |
+ )+ |
+
| 208 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Specify single filter.+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Create a `teal_slice` object that holds complete information on filtering one variable.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @details+ |
+
| 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 `locked` 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 `locked`.+ |
+
| 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 `locked = 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 (optional `vector`) specifying 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.+ |
+
| 62 | ++ |
+ #' @param selected (optional `vector`) of selected values from `choices`;+ |
+
| 63 | ++ |
+ #' Type and size depends on variable type.+ |
+
| 64 | ++ |
+ #' @param multiple (optional `logical(1)`) flag specifying whether more than one value can be selected;+ |
+
| 65 | ++ |
+ #' only applicable to `ChoicesFilterState` and `LogicalFilterState`+ |
+
| 66 | ++ |
+ #' @param keep_na (optional `logical(1)`) flag specifying whether to keep missing values+ |
+
| 67 | ++ |
+ #' @param keep_inf (optional `logical(1)`) 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 locked (`logical(1)`) flag specifying whether to lock this filter state (forbid removing and inactivating)+ |
+
| 70 | ++ |
+ #' @param title (optional `character(1)`) title of the filter. Ignored when `varname` is set.+ |
+
| 71 | ++ |
+ #' @param ... in `teal_slice` method these are additional arguments which can be handled by extensions+ |
+
| 72 | ++ |
+ #' of `teal.slice` classes. In other methods these are further arguments passed to or from other methods.+ |
+
| 73 | ++ |
+ #' @param x (`teal.slice`) object.+ |
+
| 74 | ++ |
+ #' @param show_all (`logical(1)`) indicating whether to show all fields. If set to `FALSE`,+ |
+
| 75 | ++ |
+ #' only non-NULL elements will be printed.+ |
+
| 76 | ++ |
+ #' @param trim_lines (`logical(1)`) indicating whether to trim lines when printing.+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @return A `teal.slice` object. Depending on whether `varname` or `expr` was specified, the resulting+ |
+
| 79 | ++ |
+ #' `teal_slice` also receives class `teal_slice_var` or `teal_slice_expr`, respectively.+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @examples+ |
+
| 82 | ++ |
+ #' x1 <- teal_slice(+ |
+
| 83 | ++ |
+ #' dataname = "data",+ |
+
| 84 | ++ |
+ #' id = "Female adults",+ |
+
| 85 | ++ |
+ #' expr = "SEX == 'F' & AGE >= 18",+ |
+
| 86 | ++ |
+ #' title = "Female adults"+ |
+
| 87 | ++ |
+ #' )+ |
+
| 88 | ++ |
+ #' x2 <- teal_slice(+ |
+
| 89 | ++ |
+ #' dataname = "data",+ |
+
| 90 | ++ |
+ #' varname = "var",+ |
+
| 91 | ++ |
+ #' choices = c("F", "M", "U"),
+ |
+
| 92 | ++ |
+ #' selected = "F",+ |
+
| 93 | ++ |
+ #' keep_na = TRUE,+ |
+
| 94 | ++ |
+ #' keep_inf = TRUE,+ |
+
| 95 | ++ |
+ #' fixed = FALSE,+ |
+
| 96 | ++ |
+ #' locked = FALSE,+ |
+
| 97 | ++ |
+ #' multiple = TRUE,+ |
+
| 98 | ++ |
+ #' id = "Gender",+ |
+
| 99 | ++ |
+ #' extra_arg = "extra"+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' is.teal_slice(x1)+ |
+
| 103 | ++ |
+ #' as.list(x1)+ |
+
| 104 | ++ |
+ #' as.teal_slice(list(dataname = "a", varname = "var"))+ |
+
| 105 | ++ |
+ #' format(x1)+ |
+
| 106 | ++ |
+ #' format(x1, show_all = TRUE, trim_lines = FALSE)+ |
+
| 107 | ++ |
+ #' print(x1)+ |
+
| 108 | ++ |
+ #' print(x1, show_all = TRUE, trim_lines = FALSE)+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @seealso [`teal_slices`]+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' @export+ |
+
| 113 | ++ |
+ teal_slice <- function(dataname,+ |
+
| 114 | ++ |
+ varname,+ |
+
| 115 | ++ |
+ id,+ |
+
| 116 | ++ |
+ expr,+ |
+
| 117 | ++ |
+ choices = NULL,+ |
+
| 118 | ++ |
+ selected = NULL,+ |
+
| 119 | ++ |
+ keep_na = NULL,+ |
+
| 120 | ++ |
+ keep_inf = NULL,+ |
+
| 121 | ++ |
+ fixed = FALSE,+ |
+
| 122 | ++ |
+ locked = FALSE,+ |
+
| 123 | ++ |
+ multiple = TRUE,+ |
+
| 124 | ++ |
+ title = NULL,+ |
+
| 125 | ++ |
+ ...) {
+ |
+
| 126 | +555x | +
+ checkmate::assert_string(dataname)+ |
+
| 127 | +548x | +
+ checkmate::assert_flag(fixed)+ |
+
| 128 | +546x | +
+ checkmate::assert_flag(locked)+ |
+
| 129 | ++ | + + | +
| 130 | +544x | +
+ formal_args <- as.list(environment())+ |
+
| 131 | +544x | +
+ if (!missing(expr) && !missing(varname)) {
+ |
+
| 132 | +! | +
+ stop("Must provide either `expr` or `varname`.")
+ |
+
| 133 | +544x | +
+ } else if (!missing(expr)) {
+ |
+
| 134 | +26x | +
+ fixed <- TRUE+ |
+
| 135 | +26x | +
+ ts_expr_args <- c("dataname", "id", "expr", "fixed", "locked", "title")
+ |
+
| 136 | +26x | +
+ formal_args <- formal_args[ts_expr_args]+ |
+
| 137 | +26x | +
+ checkmate::assert_string(id)+ |
+
| 138 | +23x | +
+ checkmate::assert_string(title)+ |
+
| 139 | +20x | +
+ checkmate::assert_string(expr)+ |
+
| 140 | +19x | +
+ ans <- do.call(shiny::reactiveValues, c(formal_args, list(...)))+ |
+
| 141 | +19x | +
+ class(ans) <- c("teal_slice_expr", "teal_slice", class(ans))
+ |
+
| 142 | +19x | +
+ ans+ |
+
| 143 | +518x | +
+ } else if (!missing(varname)) {
+ |
+
| 144 | +517x | +
+ ts_var_args <- c(+ |
+
| 145 | +517x | +
+ "dataname", "varname", "id", "choices", "selected", "keep_na", "keep_inf",+ |
+
| 146 | +517x | +
+ "fixed", "locked", "multiple"+ |
+
| 147 | ++ |
+ )+ |
+
| 148 | +517x | +
+ formal_args <- formal_args[ts_var_args]+ |
+
| 149 | +517x | +
+ args <- c(formal_args, list(...))+ |
+
| 150 | +517x | +
+ checkmate::assert_string(varname)+ |
+
| 151 | +514x | +
+ checkmate::assert_multi_class(choices, .filterable_class, null.ok = TRUE)+ |
+
| 152 | +513x | +
+ checkmate::assert_multi_class(selected, .filterable_class, null.ok = TRUE)+ |
+
| 153 | +511x | +
+ checkmate::assert_flag(keep_na, null.ok = TRUE)+ |
+
| 154 | +510x | +
+ checkmate::assert_flag(keep_inf, null.ok = TRUE)+ |
+
| 155 | +509x | +
+ checkmate::assert_flag(multiple)+ |
+
| 156 | +509x | +
+ if (missing(id)) {
+ |
+
| 157 | +500x | +
+ args$id <- get_default_slice_id(args)+ |
+
| 158 | ++ |
+ } else {
+ |
+
| 159 | +9x | +
+ checkmate::assert_string(id)+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | +506x | +
+ ans <- do.call(shiny::reactiveValues, args)+ |
+
| 162 | +506x | +
+ class(ans) <- c("teal_slice_var", "teal_slice", class(ans))
+ |
+
| 163 | +506x | +
+ ans+ |
+
| 164 | ++ |
+ } else {
+ |
+
| 165 | +1x | +
+ stop("Must provide either `expr` or `varname`.")
+ |
+
| 166 | ++ |
+ }+ |
+
| 167 | ++ |
+ }+ |
+
| 168 | ++ | + + | +
| 169 | ++ |
+ #' @rdname teal_slice+ |
+
| 170 | ++ |
+ #' @export+ |
+
| 171 | ++ |
+ #' @keywords internal+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ is.teal_slice <- function(x) { # nolint
+ |
+
| 174 | +4x | +
+ inherits(x, "teal_slice")+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ | + + | +
| 177 | ++ |
+ #' @rdname teal_slice+ |
+
| 178 | ++ |
+ #' @export+ |
+
| 179 | ++ |
+ #' @keywords internal+ |
+
| 180 | ++ |
+ #'+ |
+
| 181 | ++ |
+ as.teal_slice <- function(x) { # nolint
+ |
+
| 182 | +7x | +
+ checkmate::assert_list(x, names = "named")+ |
+
| 183 | +7x | +
+ do.call(teal_slice, x)+ |
+
| 184 | ++ |
+ }+ |
+
| 185 | ++ | + + | +
| 186 | ++ |
+ #' @rdname teal_slice+ |
+
| 187 | ++ |
+ #' @export+ |
+
| 188 | ++ |
+ #' @keywords internal+ |
+
| 189 | ++ |
+ #'+ |
+
| 190 | ++ |
+ as.list.teal_slice <- function(x, ...) {
+ |
+
| 191 | +303x | +
+ formal_args <- setdiff(names(formals(teal_slice)), "...")+ |
+
| 192 | ++ | + + | +
| 193 | +303x | +
+ x <- if (shiny::isRunning()) {
+ |
+
| 194 | +! | +
+ shiny::reactiveValuesToList(x)+ |
+
| 195 | ++ |
+ } else {
+ |
+
| 196 | +303x | +
+ shiny::isolate(shiny::reactiveValuesToList(x))+ |
+
| 197 | ++ |
+ }+ |
+
| 198 | ++ | + + | +
| 199 | +303x | +
+ formal_args <- intersect(formal_args, names(x))+ |
+
| 200 | +303x | +
+ extra_args <- rev(setdiff(names(x), formal_args))+ |
+
| 201 | ++ | + + | +
| 202 | +303x | +
+ x[c(formal_args, extra_args)]+ |
+
| 203 | ++ |
+ }+ |
+
| 204 | ++ | + + | +
| 205 | ++ | + + | +
| 206 | ++ |
+ #' @rdname teal_slice+ |
+
| 207 | ++ |
+ #' @export+ |
+
| 208 | ++ |
+ #' @keywords internal+ |
+
| 209 | ++ |
+ #'+ |
+
| 210 | ++ |
+ format.teal_slice <- function(x, show_all = FALSE, trim_lines = TRUE, ...) {
+ |
+
| 211 | +116x | +
+ checkmate::assert_flag(show_all)+ |
+
| 212 | +92x | +
+ checkmate::assert_flag(trim_lines)+ |
+
| 213 | ++ | + + | +
| 214 | +86x | +
+ x_list <- as.list(x)+ |
+
| 215 | +47x | +
+ if (!show_all) x_list <- Filter(Negate(is.null), x_list)+ |
+
| 216 | ++ | + + | +
| 217 | +86x | +
+ jsonify(x_list, trim_lines)+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ #' @rdname teal_slice+ |
+
| 221 | ++ |
+ #' @export+ |
+
| 222 | ++ |
+ #' @keywords internal+ |
+
| 223 | ++ |
+ #'+ |
+
| 224 | ++ |
+ print.teal_slice <- function(x, ...) {
+ |
+
| 225 | +15x | +
+ cat(format(x, ...))+ |
+
| 226 | ++ |
+ }+ |
+
| 227 | ++ | + + | +
| 228 | ++ | + + | +
| 229 | ++ |
+ # format utils -----+ |
+
| 230 | ++ | + + | +
| 231 | ++ |
+ #' Convert a list to a justified `JSON` string+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' This function takes a list and converts it to a `JSON` string.+ |
+
| 234 | ++ |
+ #' The resulting `JSON` string is then optionally justified to improve readability+ |
+
| 235 | ++ |
+ #' and trimmed to easier fit in the console when printing.+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' @param x (`list`), possibly recursive, obtained from `teal_slice` or `teal_slices`.+ |
+
| 238 | ++ |
+ #' @param trim_lines (`logical(1)`) flag specifying whether to trim lines of the `JSON` string.+ |
+
| 239 | ++ |
+ #' @return A `JSON` string representation of the input list.+ |
+
| 240 | ++ |
+ #' @keywords internal+ |
+
| 241 | ++ |
+ #'+ |
+
| 242 | ++ |
+ jsonify <- function(x, trim_lines) {
+ |
+
| 243 | +135x | +
+ checkmate::assert_list(x)+ |
+
| 244 | ++ | + + | +
| 245 | +135x | +
+ x_json <- to_json(x)+ |
+
| 246 | +135x | +
+ x_json_justified <- justify_json(x_json)+ |
+
| 247 | +123x | +
+ if (trim_lines) x_json_justified <- trim_lines_json(x_json_justified)+ |
+
| 248 | +135x | +
+ paste(x_json_justified, collapse = "\n")+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ | + + | +
| 251 | ++ |
+ #' Converts a list to a `JSON` string+ |
+
| 252 | ++ |
+ #'+ |
+
| 253 | ++ |
+ #' Converts a list representation of `teal_slice` or `teal_slices` into a `JSON` string.+ |
+
| 254 | ++ |
+ #' Ensures proper unboxing of list elements.+ |
+
| 255 | ++ |
+ #' This function is used by the `format` methods for `teal_slice` and `teal_slices`.+ |
+
| 256 | ++ |
+ #' @param x `list`, possibly recursive, obtained from `teal_slice` or `teal_slices`.+ |
+
| 257 | ++ |
+ #' @return A `JSON` string.+ |
+
| 258 | ++ |
+ #' @keywords internal+ |
+
| 259 | ++ |
+ #+ |
+
| 260 | ++ |
+ #' @param x (`list`) representation of `teal_slices` object.+ |
+
| 261 | ++ |
+ #' @keywords internal+ |
+
| 262 | ++ |
+ #'+ |
+
| 263 | ++ |
+ to_json <- function(x) {
+ |
+
| 264 | +135x | +
+ no_unbox <- function(x) {
+ |
+
| 265 | +2578x | +
+ vars <- c("selected", "choices")
+ |
+
| 266 | +2578x | +
+ if (is.list(x)) {
+ |
+
| 267 | +419x | +
+ for (var in vars) {
+ |
+
| 268 | +335x | +
+ if (!is.null(x[[var]])) x[[var]] <- I(x[[var]])+ |
+
| 269 | ++ |
+ }+ |
+
| 270 | +419x | +
+ lapply(x, no_unbox)+ |
+
| 271 | ++ |
+ } else {
+ |
+
| 272 | +2159x | +
+ x+ |
+
| 273 | ++ |
+ }+ |
+
| 274 | ++ |
+ }+ |
+
| 275 | ++ | + + | +
| 276 | +135x | +
+ jsonlite::toJSON(no_unbox(x), pretty = TRUE, auto_unbox = TRUE, digits = 16, null = "null")+ |
+
| 277 | ++ |
+ }+ |
+
| 278 | ++ | + + | +
| 279 | ++ |
+ #' Justify Colons in `JSON` String+ |
+
| 280 | ++ |
+ #'+ |
+
| 281 | ++ |
+ #' This function takes a `JSON` string as input, splits it into lines, and pads element names+ |
+
| 282 | ++ |
+ #' with spaces so that colons are justified between lines.+ |
+
| 283 | ++ |
+ #'+ |
+
| 284 | ++ |
+ #' @param json (`character(1)`) a `JSON` string.+ |
+
| 285 | ++ |
+ #'+ |
+
| 286 | ++ |
+ #' @return A list of character strings, which can be collapsed into a `JSON` string.+ |
+
| 287 | ++ |
+ #' @keywords internal+ |
+
| 288 | ++ |
+ justify_json <- function(json) {
+ |
+
| 289 | +135x | +
+ format_name <- function(name, name_width) {
+ |
+
| 290 | +2997x | +
+ if (nchar(name) == 1 || nchar(gsub("\\s", "", name)) <= 2) {
+ |
+
| 291 | +680x | +
+ return(name)+ |
+
| 292 | +2317x | +
+ } else if (grepl("slices|attributes", name)) {
+ |
+
| 293 | +98x | +
+ paste0(name, ":")+ |
+
| 294 | ++ |
+ } else {
+ |
+
| 295 | +2219x | +
+ paste(format(name, width = name_width), ":")+ |
+
| 296 | ++ |
+ }+ |
+
| 297 | ++ |
+ }+ |
+
| 298 | +135x | +
+ json_lines <- strsplit(json, "\n")[[1]]+ |
+
| 299 | +135x | +
+ json_lines_split <- regmatches(json_lines, regexpr(":", json_lines), invert = TRUE)
+ |
+
| 300 | +135x | +
+ name_width <- max(unlist(regexpr(":", json_lines))) - 1
+ |
+
| 301 | +135x | +
+ vapply(json_lines_split, function(x) paste0(format_name(x[1], name_width), stats::na.omit(x[2])), character(1))+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ | + + | +
| 304 | ++ |
+ #' Trim Lines in `JSON` String+ |
+
| 305 | ++ |
+ #'+ |
+
| 306 | ++ |
+ #' This function takes a `JSON` string as input and returns a modified version of the+ |
+
| 307 | ++ |
+ #' input where the values portion of each line is trimmed for a less messy console output.+ |
+
| 308 | ++ |
+ #'+ |
+
| 309 | ++ |
+ #' @param x A character string.+ |
+
| 310 | ++ |
+ #'+ |
+
| 311 | ++ |
+ #' @return A character string trimmed after a certain hard-coded number of characters in the value portion.+ |
+
| 312 | ++ |
+ #'+ |
+
| 313 | ++ |
+ #' @keywords internal+ |
+
| 314 | ++ |
+ #'+ |
+
| 315 | ++ |
+ trim_lines_json <- function(x) {
+ |
+
| 316 | +123x | +
+ name_width <- max(unlist(gregexpr(":", x))) - 1
+ |
+
| 317 | +123x | +
+ trim_position <- name_width + 17L+ |
+
| 318 | +123x | +
+ x_trim <- substr(x, 1, trim_position)+ |
+
| 319 | +123x | +
+ substr(x_trim, trim_position - 2, trim_position) <- "..."+ |
+
| 320 | +123x | +
+ x_trim+ |
+
| 321 | ++ |
+ }+ |
+
| 322 | ++ | + + | +
| 323 | ++ |
+ #' Default `teal_slice` id+ |
+
| 324 | ++ |
+ #'+ |
+
| 325 | ++ |
+ #' Function returns a default `id` for a `teal_slice` object which needs+ |
+
| 326 | ++ |
+ #' to be distinct from other `teal_slice` objects created for any+ |
+
| 327 | ++ |
+ #' `FilterStates` object. Returned `id` can be treated as a location of+ |
+
| 328 | ++ |
+ #' a vector on which `FilterState` is built:+ |
+
| 329 | ++ |
+ #' - for a `data.frame` `id` concatenates `dataname` and `varname`.+ |
+
| 330 | ++ |
+ #' - for a `MultiAssayExperiment` `id` concatenates `dataname`, `varname`,+ |
+
| 331 | ++ |
+ #' `experiment` and `arg`, so that one can add `teal_slice` for a `varname`+ |
+
| 332 | ++ |
+ #' which exists in multiple `SummarizedExperiment`s or exists in both `colData`+ |
+
| 333 | ++ |
+ #' and `rowData` of given experiment.+ |
+
| 334 | ++ |
+ #' @param x (`teal_slice` or `list`)+ |
+
| 335 | ++ |
+ #' @return (`character(1)`) `id` for a `teal_slice` object.+ |
+
| 336 | ++ |
+ #' @keywords internal+ |
+
| 337 | ++ |
+ get_default_slice_id <- function(x) {
+ |
+
| 338 | +589x | +
+ shiny::isolate({
+ |
+
| 339 | +589x | +
+ paste(+ |
+
| 340 | +589x | +
+ Filter(+ |
+
| 341 | +589x | +
+ length,+ |
+
| 342 | +589x | +
+ as.list(x)[c("dataname", "varname", "experiment", "arg")]
+ |
+
| 343 | ++ |
+ ),+ |
+
| 344 | +589x | +
+ collapse = " "+ |
+
| 345 | ++ |
+ )+ |
+
| 346 | ++ |
+ })+ |
+
| 347 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Get classes of selected columns from dataset+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @param data (`data.frame`) data to determine variable types from+ |
+
| 4 | ++ |
+ #' @param columns (atomic vector of `character` or `NULL`) column names chosen from `data`.+ |
+
| 5 | ++ |
+ #' The value of `NULL` will be interpreted to mean all columns.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @return (atomic vector of `character`) classes of `columns` from provided `data`+ |
+
| 8 | ++ |
+ #' @keywords internal+ |
+
| 9 | ++ |
+ #' @examples+ |
+
| 10 | ++ |
+ #' teal.slice:::variable_types(+ |
+
| 11 | ++ |
+ #' data.frame(+ |
+
| 12 | ++ |
+ #' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
+ |
+
| 13 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 14 | ++ |
+ #' ),+ |
+
| 15 | ++ |
+ #' "x"+ |
+
| 16 | ++ |
+ #' )+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' teal.slice:::variable_types(+ |
+
| 19 | ++ |
+ #' data.frame(+ |
+
| 20 | ++ |
+ #' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
+ |
+
| 21 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 22 | ++ |
+ #' ),+ |
+
| 23 | ++ |
+ #' c("x", "z")
+ |
+
| 24 | ++ |
+ #' )+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' teal.slice:::variable_types(+ |
+
| 27 | ++ |
+ #' data.frame(+ |
+
| 28 | ++ |
+ #' x = 1:3, y = factor(c("a", "b", "a")), z = c("h1", "h2", "h3"),
+ |
+
| 29 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #' )+ |
+
| 32 | ++ |
+ variable_types <- function(data, columns = NULL) {
+ |
+
| 33 | +9x | +
+ UseMethod("variable_types")
+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ #' @export+ |
+
| 37 | ++ |
+ variable_types.default <- function(data, columns = NULL) {
+ |
+
| 38 | +9x | +
+ checkmate::assert_character(columns, null.ok = TRUE, any.missing = FALSE)+ |
+
| 39 | ++ | + + | +
| 40 | +9x | +
+ res <- if (is.null(columns)) {
+ |
+
| 41 | +! | +
+ vapply(+ |
+
| 42 | +! | +
+ data,+ |
+
| 43 | +! | +
+ function(x) class(x)[[1]],+ |
+
| 44 | +! | +
+ character(1),+ |
+
| 45 | +! | +
+ USE.NAMES = FALSE+ |
+
| 46 | ++ |
+ )+ |
+
| 47 | +9x | +
+ } else if (checkmate::test_character(columns, any.missing = FALSE)) {
+ |
+
| 48 | +9x | +
+ stopifnot(all(columns %in% names(data) | vapply(columns, identical, logical(1L), "")))+ |
+
| 49 | +9x | +
+ vapply(+ |
+
| 50 | +9x | +
+ columns,+ |
+
| 51 | +9x | +
+ function(x) ifelse(x == "", "", class(data[[x]])[[1]]),+ |
+
| 52 | +9x | +
+ character(1),+ |
+
| 53 | +9x | +
+ USE.NAMES = FALSE+ |
+
| 54 | ++ |
+ )+ |
+
| 55 | ++ |
+ } else {
+ |
+
| 56 | +! | +
+ character(0)+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | ++ | + + | +
| 59 | +9x | +
+ return(res)+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ | + + | +
| 62 | ++ |
+ #' @export+ |
+
| 63 | ++ |
+ variable_types.data.frame <- function(data, columns = NULL) { # nolint: object_name_linter.
+ |
+
| 64 | +9x | +
+ variable_types.default(data, columns)+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ #' @export+ |
+
| 68 | ++ |
+ variable_types.DataTable <- function(data, columns = NULL) {
+ |
+
| 69 | +! | +
+ variable_types.default(data, columns)+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ #' @export+ |
+
| 73 | ++ |
+ variable_types.DFrame <- function(data, columns = NULL) {
+ |
+
| 74 | +! | +
+ variable_types.default(data, columns)+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | ++ | + + | +
| 77 | ++ |
+ #' @export+ |
+
| 78 | ++ |
+ variable_types.matrix <- function(data, columns = NULL) {
+ |
+
| 79 | +! | +
+ checkmate::assert_character(columns, null.ok = TRUE, any.missing = FALSE)+ |
+
| 80 | ++ | + + | +
| 81 | +! | +
+ res <- if (is.null(columns)) {
+ |
+
| 82 | +! | +
+ apply(+ |
+
| 83 | +! | +
+ data,+ |
+
| 84 | +! | +
+ 2,+ |
+
| 85 | +! | +
+ function(x) class(x)[1]+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | +! | +
+ } else if (checkmate::test_character(columns, any.missing = FALSE)) {
+ |
+
| 88 | +! | +
+ stopifnot(+ |
+
| 89 | +! | +
+ all(+ |
+
| 90 | +! | +
+ columns %in% colnames(data) |+ |
+
| 91 | +! | +
+ vapply(columns, identical, logical(1L), "")+ |
+
| 92 | ++ |
+ )+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | +! | +
+ vapply(+ |
+
| 95 | +! | +
+ columns,+ |
+
| 96 | +! | +
+ function(x) ifelse(x == "", "", class(data[, x])[1]),+ |
+
| 97 | +! | +
+ character(1),+ |
+
| 98 | +! | +
+ USE.NAMES = FALSE+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ |
+ } else {
+ |
+
| 101 | +! | +
+ character(0)+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ | + + | +
| 104 | +! | +
+ return(res)+ |
+
| 105 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Initialize `FilterStates` object+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Initialize `FilterStates` object+ |
+
| 4 | ++ |
+ #' @param data (`data.frame`, `MultiAssayExperiment`, `SummarizedExperiment`, `matrix`)\cr+ |
+
| 5 | ++ |
+ #' the R object which `subset` function is applied on.+ |
+
| 6 | ++ |
+ #' @param data_reactive (`function(sid)`)\cr+ |
+
| 7 | ++ |
+ #' should return an object of the same type as `data` or `NULL`.+ |
+
| 8 | ++ |
+ #' This object is needed for the `FilterState` shiny module to update+ |
+
| 9 | ++ |
+ #' counts if filtered data changes.+ |
+
| 10 | ++ |
+ #' If function returns `NULL` then filtered counts+ |
+
| 11 | ++ |
+ #' are not shown. Function has to have `sid` argument being a character which+ |
+
| 12 | ++ |
+ #' is related to `sid` argument in the `get_call` method.+ |
+
| 13 | ++ |
+ #' @param dataname (`character(1)`)\cr+ |
+
| 14 | ++ |
+ #' name of the data used in the expression+ |
+
| 15 | ++ |
+ #' specified to the function argument attached to this `FilterStates`.+ |
+
| 16 | ++ |
+ #' @param datalabel (`character(0)` or `character(1)`)\cr+ |
+
| 17 | ++ |
+ #' text label value.+ |
+
| 18 | ++ |
+ #' @param ... (optional)+ |
+
| 19 | ++ |
+ #' additional arguments for specific classes: keys.+ |
+
| 20 | ++ |
+ #' @keywords internal+ |
+
| 21 | ++ |
+ #' @export+ |
+
| 22 | ++ |
+ #' @examples+ |
+
| 23 | ++ |
+ #' library(shiny)+ |
+
| 24 | ++ |
+ #' df <- data.frame(+ |
+
| 25 | ++ |
+ #' character = letters,+ |
+
| 26 | ++ |
+ #' numeric = seq_along(letters),+ |
+
| 27 | ++ |
+ #' date = seq(Sys.Date(), length.out = length(letters), by = "1 day"),+ |
+
| 28 | ++ |
+ #' datetime = seq(Sys.time(), length.out = length(letters), by = "33.33 hours")+ |
+
| 29 | ++ |
+ #' )+ |
+
| 30 | ++ |
+ #' rf <- teal.slice:::init_filter_states(+ |
+
| 31 | ++ |
+ #' data = df,+ |
+
| 32 | ++ |
+ #' dataname = "DF"+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #' app <- shinyApp(+ |
+
| 35 | ++ |
+ #' ui = fluidPage(+ |
+
| 36 | ++ |
+ #' actionButton("clear", span(icon("xmark"), "Remove all filters")),
+ |
+
| 37 | ++ |
+ #' rf$ui_add(id = "add"),+ |
+
| 38 | ++ |
+ #' rf$ui_active("states"),
+ |
+
| 39 | ++ |
+ #' verbatimTextOutput("expr"),
+ |
+
| 40 | ++ |
+ #' ),+ |
+
| 41 | ++ |
+ #' server = function(input, output, session) {
+ |
+
| 42 | ++ |
+ #' rf$srv_add(id = "add")+ |
+
| 43 | ++ |
+ #' rf$srv_active(id = "states")+ |
+
| 44 | ++ |
+ #' output$expr <- renderText({
+ |
+
| 45 | ++ |
+ #' deparse1(rf$get_call(), collapse = "\n")+ |
+
| 46 | ++ |
+ #' })+ |
+
| 47 | ++ |
+ #' observeEvent(input$clear, rf$state_list_empty())+ |
+
| 48 | ++ |
+ #' }+ |
+
| 49 | ++ |
+ #' )+ |
+
| 50 | ++ |
+ #' if (interactive()) {
+ |
+
| 51 | ++ |
+ #' runApp(app)+ |
+
| 52 | ++ |
+ #' }+ |
+
| 53 | ++ |
+ init_filter_states <- function(data,+ |
+
| 54 | ++ |
+ data_reactive = reactive(NULL),+ |
+
| 55 | ++ |
+ dataname,+ |
+
| 56 | ++ |
+ datalabel = NULL,+ |
+
| 57 | ++ |
+ ...) {
+ |
+
| 58 | +253x | +
+ UseMethod("init_filter_states")
+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ | + + | +
| 61 | ++ |
+ #' @keywords internal+ |
+
| 62 | ++ |
+ #' @export+ |
+
| 63 | ++ |
+ init_filter_states.data.frame <- function(data, # nolint+ |
+
| 64 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 65 | ++ |
+ dataname,+ |
+
| 66 | ++ |
+ datalabel = NULL,+ |
+
| 67 | ++ |
+ keys = character(0),+ |
+
| 68 | ++ |
+ ...) {
+ |
+
| 69 | +112x | +
+ DFFilterStates$new(+ |
+
| 70 | +112x | +
+ data = data,+ |
+
| 71 | +112x | +
+ data_reactive = data_reactive,+ |
+
| 72 | +112x | +
+ dataname = dataname,+ |
+
| 73 | +112x | +
+ datalabel = datalabel,+ |
+
| 74 | +112x | +
+ keys = keys+ |
+
| 75 | ++ |
+ )+ |
+
| 76 | ++ |
+ }+ |
+
| 77 | ++ | + + | +
| 78 | ++ |
+ #' @keywords internal+ |
+
| 79 | ++ |
+ #' @export+ |
+
| 80 | ++ |
+ init_filter_states.matrix <- function(data, # nolint+ |
+
| 81 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 82 | ++ |
+ dataname,+ |
+
| 83 | ++ |
+ datalabel = NULL,+ |
+
| 84 | ++ |
+ ...) {
+ |
+
| 85 | +24x | +
+ MatrixFilterStates$new(+ |
+
| 86 | +24x | +
+ data = data,+ |
+
| 87 | +24x | +
+ data_reactive = data_reactive,+ |
+
| 88 | +24x | +
+ dataname = dataname,+ |
+
| 89 | +24x | +
+ datalabel = datalabel+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ | + + | +
| 93 | ++ |
+ #' @keywords internal+ |
+
| 94 | ++ |
+ #' @export+ |
+
| 95 | ++ |
+ init_filter_states.MultiAssayExperiment <- function(data, # nolint+ |
+
| 96 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 97 | ++ |
+ dataname,+ |
+
| 98 | ++ |
+ datalabel = "subjects",+ |
+
| 99 | ++ |
+ keys = character(0),+ |
+
| 100 | ++ |
+ ...) {
+ |
+
| 101 | +24x | +
+ if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ |
+
| 102 | +! | +
+ stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ |
+
| 103 | ++ |
+ }+ |
+
| 104 | +24x | +
+ MAEFilterStates$new(+ |
+
| 105 | +24x | +
+ data = data,+ |
+
| 106 | +24x | +
+ data_reactive = data_reactive,+ |
+
| 107 | +24x | +
+ dataname = dataname,+ |
+
| 108 | +24x | +
+ datalabel = datalabel,+ |
+
| 109 | +24x | +
+ keys = keys+ |
+
| 110 | ++ |
+ )+ |
+
| 111 | ++ |
+ }+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ #' @keywords internal+ |
+
| 114 | ++ |
+ #' @export+ |
+
| 115 | ++ |
+ init_filter_states.SummarizedExperiment <- function(data, # nolint+ |
+
| 116 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 117 | ++ |
+ dataname,+ |
+
| 118 | ++ |
+ datalabel = NULL,+ |
+
| 119 | ++ |
+ ...) {
+ |
+
| 120 | +93x | +
+ if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
+ |
+
| 121 | +! | +
+ stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
+ |
+
| 122 | ++ |
+ }+ |
+
| 123 | +93x | +
+ SEFilterStates$new(+ |
+
| 124 | +93x | +
+ data = data,+ |
+
| 125 | +93x | +
+ data_reactive = data_reactive,+ |
+
| 126 | +93x | +
+ dataname = dataname,+ |
+
| 127 | +93x | +
+ datalabel = datalabel+ |
+
| 128 | ++ |
+ )+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' Gets supported filterable variable names+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' Gets filterable variable names from a given object. The names match variables+ |
+
| 134 | ++ |
+ #' of classes in an array `teal.slice:::.filterable_class`.+ |
+
| 135 | ++ |
+ #' @param data (`object`)\cr+ |
+
| 136 | ++ |
+ #' the R object containing elements which class can be checked through `vapply` or `apply`.+ |
+
| 137 | ++ |
+ #'+ |
+
| 138 | ++ |
+ #' @examples+ |
+
| 139 | ++ |
+ #' df <- data.frame(+ |
+
| 140 | ++ |
+ #' a = letters[1:3],+ |
+
| 141 | ++ |
+ #' b = 1:3,+ |
+
| 142 | ++ |
+ #' c = Sys.Date() + 1:3,+ |
+
| 143 | ++ |
+ #' d = Sys.time() + 1:3,+ |
+
| 144 | ++ |
+ #' z = complex(3)+ |
+
| 145 | ++ |
+ #' )+ |
+
| 146 | ++ |
+ #' teal.slice:::get_supported_filter_varnames(df)+ |
+
| 147 | ++ |
+ #' @return `character` the array of the matched element names+ |
+
| 148 | ++ |
+ #' @keywords internal+ |
+
| 149 | ++ |
+ get_supported_filter_varnames <- function(data) {
+ |
+
| 150 | +237x | +
+ UseMethod("get_supported_filter_varnames")
+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ | + + | +
| 153 | ++ |
+ #' @keywords internal+ |
+
| 154 | ++ |
+ #' @export+ |
+
| 155 | ++ |
+ get_supported_filter_varnames.default <- function(data) { # nolint
+ |
+
| 156 | +202x | +
+ is_expected_class <- vapply(+ |
+
| 157 | +202x | +
+ X = data,+ |
+
| 158 | +202x | +
+ FUN = function(x) any(class(x) %in% .filterable_class),+ |
+
| 159 | +202x | +
+ FUN.VALUE = logical(1)+ |
+
| 160 | ++ |
+ )+ |
+
| 161 | +202x | +
+ names(is_expected_class[is_expected_class])+ |
+
| 162 | ++ |
+ }+ |
+
| 163 | ++ | + + | +
| 164 | ++ |
+ #' @keywords internal+ |
+
| 165 | ++ |
+ #' @export+ |
+
| 166 | ++ |
+ get_supported_filter_varnames.matrix <- function(data) { # nolint
+ |
+
| 167 | ++ |
+ # all columns are the same type in matrix+ |
+
| 168 | +35x | +
+ is_expected_class <- class(data[, 1]) %in% .filterable_class+ |
+
| 169 | +35x | +
+ if (is_expected_class && !is.null(colnames(data))) {
+ |
+
| 170 | +32x | +
+ colnames(data)+ |
+
| 171 | ++ |
+ } else {
+ |
+
| 172 | +3x | +
+ character(0)+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | ++ |
+ #' @keywords internal+ |
+
| 177 | ++ |
+ #' @export+ |
+
| 178 | ++ |
+ get_supported_filter_varnames.MultiAssayExperiment <- function(data) { # nolint
+ |
+
| 179 | +! | +
+ data <- SummarizedExperiment::colData(data)+ |
+
| 180 | ++ |
+ # all columns are the same type in matrix+ |
+
| 181 | +! | +
+ is_expected_class <- class(data[, 1]) %in% .filterable_class+ |
+
| 182 | +! | +
+ if (is_expected_class && !is.null(names(data))) {
+ |
+
| 183 | +! | +
+ names(data)+ |
+
| 184 | ++ |
+ } else {
+ |
+
| 185 | +! | +
+ character(0)+ |
+
| 186 | ++ |
+ }+ |
+
| 187 | ++ |
+ }+ |
+
| 188 | ++ | + + | +
| 189 | ++ |
+ #' @title Returns a `choices_labeled` object+ |
+
| 190 | ++ |
+ #'+ |
+
| 191 | ++ |
+ #' @param data (`data.frame`, `DFrame`, `list`)\cr+ |
+
| 192 | ++ |
+ #' where labels can be taken from in case when `varlabels` is not specified.+ |
+
| 193 | ++ |
+ #' `data` must be specified if `varlabels` is not specified.+ |
+
| 194 | ++ |
+ #' @param choices (`character`)\cr+ |
+
| 195 | ++ |
+ #' the array of chosen variables+ |
+
| 196 | ++ |
+ #' @param varlabels (`character`)\cr+ |
+
| 197 | ++ |
+ #' the labels of variables in data+ |
+
| 198 | ++ |
+ #' @param keys (`character`)\cr+ |
+
| 199 | ++ |
+ #' the names of the key columns in data+ |
+
| 200 | ++ |
+ #' @return `character(0)` if choices are empty; a `choices_labeled` object otherwise+ |
+
| 201 | ++ |
+ #' @keywords internal+ |
+
| 202 | ++ |
+ data_choices_labeled <- function(data,+ |
+
| 203 | ++ |
+ choices,+ |
+
| 204 | ++ |
+ varlabels = formatters::var_labels(data, fill = TRUE),+ |
+
| 205 | ++ |
+ keys = character(0)) {
+ |
+
| 206 | +9x | +
+ if (length(choices) == 0) {
+ |
+
| 207 | +! | +
+ return(character(0))+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | +9x | +
+ choice_types <- stats::setNames(variable_types(data = data, columns = choices), choices)+ |
+
| 210 | +9x | +
+ choice_types[keys] <- "primary_key"+ |
+
| 211 | ++ | + + | +
| 212 | +9x | +
+ choices_labeled(+ |
+
| 213 | +9x | +
+ choices = choices,+ |
+
| 214 | +9x | +
+ labels = unname(varlabels[choices]),+ |
+
| 215 | +9x | +
+ types = choice_types[choices]+ |
+
| 216 | ++ |
+ )+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ | + + | +
| 219 | ++ |
+ get_varlabels <- function(data) {
+ |
+
| 220 | +9x | +
+ if (!is.array(data)) {
+ |
+
| 221 | +9x | +
+ vapply(+ |
+
| 222 | +9x | +
+ colnames(data),+ |
+
| 223 | +9x | +
+ FUN = function(x) {
+ |
+
| 224 | +42x | +
+ label <- attr(data[[x]], "label")+ |
+
| 225 | +42x | +
+ if (is.null(label)) {
+ |
+
| 226 | +40x | +
+ x+ |
+
| 227 | ++ |
+ } else {
+ |
+
| 228 | +2x | +
+ label+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | ++ |
+ },+ |
+
| 231 | +9x | +
+ FUN.VALUE = character(1)+ |
+
| 232 | ++ |
+ )+ |
+
| 233 | ++ |
+ } else {
+ |
+
| 234 | +! | +
+ character(0)+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @name EmptyFilterState+ |
+
| 2 | ++ |
+ #' @title `FilterState` object for empty variable+ |
+
| 3 | ++ |
+ #' @description `FilterState` subclass representing an empty variable+ |
+
| 4 | ++ |
+ #' @docType class+ |
+
| 5 | ++ |
+ #' @keywords internal+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @examples+ |
+
| 9 | ++ |
+ #' filter_state <- teal.slice:::EmptyFilterState$new(+ |
+
| 10 | ++ |
+ #' x = NA,+ |
+
| 11 | ++ |
+ #' slice = teal_slice(varname = "x", dataname = "data"),+ |
+
| 12 | ++ |
+ #' extract_type = character(0)+ |
+
| 13 | ++ |
+ #' )+ |
+
| 14 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 15 | ++ |
+ #' filter_state$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))+ |
+
| 16 | ++ |
+ #' shiny::isolate(filter_state$get_call())+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ EmptyFilterState <- R6::R6Class( # nolint+ |
+
| 19 | ++ |
+ "EmptyFilterState",+ |
+
| 20 | ++ |
+ inherit = FilterState,+ |
+
| 21 | ++ | + + | +
| 22 | ++ |
+ # public methods ----+ |
+
| 23 | ++ |
+ public = list(+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ #' @description+ |
+
| 26 | ++ |
+ #' Initialize `EmptyFilterState` object.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @param x (`vector`)\cr+ |
+
| 29 | ++ |
+ #' values of the variable used in filter+ |
+
| 30 | ++ |
+ #' @param x_reactive (`reactive`)\cr+ |
+
| 31 | ++ |
+ #' returning vector of the same type as `x`. Is used to update+ |
+
| 32 | ++ |
+ #' counts following the change in values of the filtered dataset.+ |
+
| 33 | ++ |
+ #' If it is set to `reactive(NULL)` then counts based on filtered+ |
+
| 34 | ++ |
+ #' dataset are not shown.+ |
+
| 35 | ++ |
+ #' @param slice (`teal_slice`)\cr+ |
+
| 36 | ++ |
+ #' object created using [teal_slice()]. `teal_slice` is stored+ |
+
| 37 | ++ |
+ #' in the class and `set_state` directly manipulates values within `teal_slice`. `get_state`+ |
+
| 38 | ++ |
+ #' returns `teal_slice` object which can be reused in other places. Beware, that `teal_slice`+ |
+
| 39 | ++ |
+ #' is a `reactiveValues` which means that changes in particular object are automatically+ |
+
| 40 | ++ |
+ #' reflected in all places which refer to the same `teal_slice`.+ |
+
| 41 | ++ |
+ #' @param extract_type (`character(0)`, `character(1)`)\cr+ |
+
| 42 | ++ |
+ #' whether condition calls should be prefixed by `dataname`. Possible values:+ |
+
| 43 | ++ |
+ #' \itemize{
+ |
+
| 44 | ++ |
+ #' \item{`character(0)` (default)}{ `varname` in the condition call will not be prefixed}
+ |
+
| 45 | ++ |
+ #' \item{`"list"`}{ `varname` in the condition call will be returned as `<dataname>$<varname>`}
+ |
+
| 46 | ++ |
+ #' \item{`"matrix"`}{ `varname` in the condition call will be returned as `<dataname>[, <varname>]`}
+ |
+
| 47 | ++ |
+ #' }+ |
+
| 48 | ++ |
+ #' @param ... additional arguments to be saved as a list in `private$extras` field+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ initialize = function(x,+ |
+
| 51 | ++ |
+ x_reactive = reactive(NULL),+ |
+
| 52 | ++ |
+ extract_type = character(0),+ |
+
| 53 | ++ |
+ slice) {
+ |
+
| 54 | +6x | +
+ shiny::isolate({
+ |
+
| 55 | +6x | +
+ super$initialize(+ |
+
| 56 | +6x | +
+ x = x,+ |
+
| 57 | +6x | +
+ x_reactive = x_reactive,+ |
+
| 58 | +6x | +
+ slice = slice,+ |
+
| 59 | +6x | +
+ extract_type = extract_type+ |
+
| 60 | ++ |
+ )+ |
+
| 61 | +6x | +
+ private$set_choices(slice$choices)+ |
+
| 62 | +6x | +
+ private$set_selected(slice$selected)+ |
+
| 63 | ++ |
+ })+ |
+
| 64 | ++ | + + | +
| 65 | +6x | +
+ invisible(self)+ |
+
| 66 | ++ |
+ },+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ #' @description+ |
+
| 69 | ++ |
+ #' Returns reproducible condition call for current selection relevant+ |
+
| 70 | ++ |
+ #' for selected variable type.+ |
+
| 71 | ++ |
+ #' Uses internal reactive values, hence must be called+ |
+
| 72 | ++ |
+ #' in reactive or isolated context.+ |
+
| 73 | ++ |
+ #' @param dataname name of data set; defaults to `private$get_dataname()`+ |
+
| 74 | ++ |
+ #' @return `logical(1)`+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ get_call = function(dataname) {
+ |
+
| 77 | +2x | +
+ if (isFALSE(private$is_any_filtered())) {
+ |
+
| 78 | +1x | +
+ return(NULL)+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | +1x | +
+ if (missing(dataname)) dataname <- private$get_dataname()+ |
+
| 81 | +1x | +
+ filter_call <- if (isTRUE(private$get_keep_na())) {
+ |
+
| 82 | +! | +
+ call("is.na", private$get_varname_prefixed(dataname))
+ |
+
| 83 | ++ |
+ } else {
+ |
+
| 84 | +1x | +
+ substitute(!is.na(varname), list(varname = private$get_varname_prefixed(dataname)))+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ |
+ ),+ |
+
| 88 | ++ | + + | +
| 89 | ++ |
+ # private members ----+ |
+
| 90 | ++ |
+ private = list(+ |
+
| 91 | ++ |
+ cache_state = function() {
+ |
+
| 92 | +! | +
+ private$cache <- private$get_state()+ |
+
| 93 | +! | +
+ self$set_state(+ |
+
| 94 | +! | +
+ list(+ |
+
| 95 | +! | +
+ keep_na = NULL+ |
+
| 96 | ++ |
+ )+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | ++ |
+ },+ |
+
| 99 | ++ |
+ set_choices = function(choices) {
+ |
+
| 100 | +6x | +
+ private$teal_slice$choices <- choices+ |
+
| 101 | +6x | +
+ invisible(NULL)+ |
+
| 102 | ++ |
+ },+ |
+
| 103 | ++ | + + | +
| 104 | ++ | + + | +
| 105 | ++ |
+ # Reports whether the current state filters out any values.(?)+ |
+
| 106 | ++ |
+ #+ |
+
| 107 | ++ |
+ # @return `logical(1)`+ |
+
| 108 | ++ |
+ #+ |
+
| 109 | ++ |
+ is_any_filtered = function() {
+ |
+
| 110 | +2x | +
+ if (private$is_choice_limited) {
+ |
+
| 111 | +! | +
+ TRUE+ |
+
| 112 | ++ |
+ } else {
+ |
+
| 113 | +2x | +
+ !isTRUE(private$get_keep_na())+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ |
+ },+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ # @description+ |
+
| 118 | ++ |
+ # UI Module for `EmptyFilterState`.+ |
+
| 119 | ++ |
+ # This UI element contains a checkbox input to filter or keep missing values.+ |
+
| 120 | ++ |
+ #+ |
+
| 121 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 122 | ++ |
+ # shiny element (module instance) id+ |
+
| 123 | ++ |
+ #+ |
+
| 124 | ++ |
+ ui_inputs = function(id) {
+ |
+
| 125 | +! | +
+ ns <- NS(id)+ |
+
| 126 | +! | +
+ shiny::isolate({
+ |
+
| 127 | +! | +
+ fluidRow(+ |
+
| 128 | +! | +
+ div(+ |
+
| 129 | +! | +
+ class = "relative",+ |
+
| 130 | +! | +
+ div(+ |
+
| 131 | +! | +
+ span("Variable contains missing values only"),
+ |
+
| 132 | +! | +
+ private$keep_na_ui(ns("keep_na"))
+ |
+
| 133 | ++ |
+ )+ |
+
| 134 | ++ |
+ )+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ |
+ })+ |
+
| 137 | ++ |
+ },+ |
+
| 138 | ++ | + + | +
| 139 | ++ |
+ # @description+ |
+
| 140 | ++ |
+ # Controls state of the `keep_na` checkbox input.+ |
+
| 141 | ++ |
+ #+ |
+
| 142 | ++ |
+ # @param id (`character(1)`)\cr+ |
+
| 143 | ++ |
+ # shiny module instance id+ |
+
| 144 | ++ |
+ #+ |
+
| 145 | ++ |
+ # @return `moduleServer` function which returns `NULL`+ |
+
| 146 | ++ |
+ #+ |
+
| 147 | ++ |
+ server_inputs = function(id) {
+ |
+
| 148 | +! | +
+ moduleServer(+ |
+
| 149 | +! | +
+ id = id,+ |
+
| 150 | +! | +
+ function(input, output, session) {
+ |
+
| 151 | +! | +
+ private$keep_na_srv("keep_na")
+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ |
+ )+ |
+
| 154 | ++ |
+ },+ |
+
| 155 | ++ |
+ server_inputs_fixed = function(id) {
+ |
+
| 156 | +! | +
+ moduleServer(+ |
+
| 157 | +! | +
+ id = id,+ |
+
| 158 | +! | +
+ function(input, output, session) {
+ |
+
| 159 | +! | +
+ output$selection <- renderUI({
+ |
+
| 160 | +! | +
+ div(+ |
+
| 161 | +! | +
+ class = "relative",+ |
+
| 162 | +! | +
+ div(+ |
+
| 163 | +! | +
+ span("Variable contains missing values only")
+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | ++ |
+ )+ |
+
| 166 | ++ |
+ })+ |
+
| 167 | +! | +
+ NULL+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | ++ |
+ )+ |
+
| 170 | ++ |
+ },+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ # @description+ |
+
| 173 | ++ |
+ # Server module to display filter summary+ |
+
| 174 | ++ |
+ # Doesn't render anything+ |
+
| 175 | ++ |
+ content_summary = function(id) {
+ |
+
| 176 | +! | +
+ tags$span("All empty")
+ |
+
| 177 | ++ |
+ }+ |
+
| 178 | ++ |
+ )+ |
+
| 179 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Initialize `FilteredData`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Initialize `FilteredData`+ |
+
| 4 | ++ |
+ #' @param x (named `list` or `TealData`) In case of `TealData` see [teal.data::teal_data()].+ |
+
| 5 | ++ |
+ #' If the list is provided, it should contain `list`(s) containing following fields:+ |
+
| 6 | ++ |
+ #' - `dataset` data object object supported by [`FilteredDataset`].+ |
+
| 7 | ++ |
+ #' - `metatada` (optional) additional metadata attached to the `dataset`.+ |
+
| 8 | ++ |
+ #' - `keys` (optional) primary keys.+ |
+
| 9 | ++ |
+ #' - `datalabel` (optional) label describing the `dataset`.+ |
+
| 10 | ++ |
+ #' - `parent` (optional) which `dataset` is a parent of this one.+ |
+
| 11 | ++ |
+ #' @param join_keys (`JoinKeys`) see [teal.data::join_keys()].+ |
+
| 12 | ++ |
+ #' @param code (`CodeClass`) see [`teal.data::CodeClass`].+ |
+
| 13 | ++ |
+ #' @param check (`logical(1)`) whether data has been check against reproducibility.+ |
+
| 14 | ++ |
+ #' @examples+ |
+
| 15 | ++ |
+ #' library(shiny)+ |
+
| 16 | ++ |
+ #' datasets <- teal.slice::init_filtered_data(+ |
+
| 17 | ++ |
+ #' x = list(+ |
+
| 18 | ++ |
+ #' iris = list(dataset = iris),+ |
+
| 19 | ++ |
+ #' mtcars = list(dataset = mtcars, metadata = list(type = "training"))+ |
+
| 20 | ++ |
+ #' )+ |
+
| 21 | ++ |
+ #' )+ |
+
| 22 | ++ |
+ #' @export+ |
+
| 23 | ++ |
+ init_filtered_data <- function(x, join_keys, code, check) {
+ |
+
| 24 | +16x | +
+ UseMethod("init_filtered_data")
+ |
+
| 25 | ++ |
+ }+ |
+
| 26 | ++ | + + | +
| 27 | ++ |
+ #' @keywords internal+ |
+
| 28 | ++ |
+ #' @export+ |
+
| 29 | ++ |
+ init_filtered_data.TealData <- function(x, # nolint+ |
+
| 30 | ++ |
+ join_keys = x$get_join_keys(),+ |
+
| 31 | ++ |
+ code = x$get_code_class(),+ |
+
| 32 | ++ |
+ check = x$get_check()) {
+ |
+
| 33 | +2x | +
+ data_objects <- lapply(+ |
+
| 34 | +2x | +
+ x$get_datanames(),+ |
+
| 35 | +2x | +
+ function(dataname) {
+ |
+
| 36 | +3x | +
+ dataset <- x$get_dataset(dataname)+ |
+
| 37 | +3x | +
+ list(+ |
+
| 38 | +3x | +
+ dataset = dataset$get_raw_data(),+ |
+
| 39 | +3x | +
+ metadata = dataset$get_metadata(),+ |
+
| 40 | +3x | +
+ label = dataset$get_dataset_label()+ |
+
| 41 | ++ |
+ )+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | ++ |
+ )+ |
+
| 44 | +2x | +
+ names(data_objects) <- x$get_datanames()+ |
+
| 45 | ++ | + + | +
| 46 | +2x | +
+ init_filtered_data(+ |
+
| 47 | +2x | +
+ x = data_objects,+ |
+
| 48 | +2x | +
+ join_keys = join_keys,+ |
+
| 49 | +2x | +
+ code = code,+ |
+
| 50 | +2x | +
+ check = check+ |
+
| 51 | ++ |
+ )+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ #' @keywords internal+ |
+
| 55 | ++ |
+ #' @export+ |
+
| 56 | ++ |
+ init_filtered_data.default <- function(x, join_keys = teal.data::join_keys(), code = NULL, check = FALSE) { # nolint
+ |
+
| 57 | +14x | +
+ checkmate::assert_list(x, any.missing = FALSE, names = "unique")+ |
+
| 58 | +13x | +
+ mapply(validate_dataset_args, x, names(x))+ |
+
| 59 | +13x | +
+ checkmate::assert_class(code, "CodeClass", null.ok = TRUE)+ |
+
| 60 | +12x | +
+ checkmate::assert_class(join_keys, "JoinKeys")+ |
+
| 61 | +11x | +
+ checkmate::assert_flag(check)+ |
+
| 62 | +10x | +
+ FilteredData$new(x, join_keys = join_keys, code = code, check = check)+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ #' Validate dataset arguments+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' Validate dataset arguments+ |
+
| 68 | ++ |
+ #' @param dataset_args (`list`)\cr+ |
+
| 69 | ++ |
+ #' containing the arguments except (`dataname`)+ |
+
| 70 | ++ |
+ #' needed by `init_filtered_dataset`+ |
+
| 71 | ++ |
+ #' @param dataname (`character(1)`)\cr+ |
+
| 72 | ++ |
+ #' the name of the `dataset` to be added to this object+ |
+
| 73 | ++ |
+ #' @keywords internal+ |
+
| 74 | ++ |
+ #' @return (`NULL` or raises an error)+ |
+
| 75 | ++ |
+ validate_dataset_args <- function(dataset_args, dataname) {
+ |
+
| 76 | +118x | +
+ check_simple_name(dataname)+ |
+
| 77 | +118x | +
+ checkmate::assert_list(dataset_args, names = "unique")+ |
+
| 78 | ++ | + + | +
| 79 | +118x | +
+ allowed_names <- c("dataset", "label", "metadata")
+ |
+
| 80 | ++ | + + | +
| 81 | +118x | +
+ checkmate::assert_subset(names(dataset_args), choices = allowed_names)+ |
+
| 82 | +118x | +
+ checkmate::assert_multi_class(dataset_args[["dataset"]], classes = c("data.frame", "MultiAssayExperiment"))
+ |
+
| 83 | +117x | +
+ teal.data::validate_metadata(dataset_args[["metadata"]])+ |
+
| 84 | +117x | +
+ checkmate::assert_character(dataset_args[["label"]], null.ok = TRUE, min.len = 0, max.len = 1)+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ | + + | +
| 87 | ++ |
+ #' Evaluate expression with meaningful message+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' Method created for the `FilteredData` to execute filter call with+ |
+
| 90 | ++ |
+ #' meaningful message. After evaluation used environment should contain+ |
+
| 91 | ++ |
+ #' all necessary bindings.+ |
+
| 92 | ++ |
+ #' @param expr (`language`)+ |
+
| 93 | ++ |
+ #' @param env (`environment`) where expression is evaluated.+ |
+
| 94 | ++ |
+ #' @return invisible `NULL`.+ |
+
| 95 | ++ |
+ #' @keywords internal+ |
+
| 96 | ++ |
+ eval_expr_with_msg <- function(expr, env) {
+ |
+
| 97 | +26x | +
+ lapply(+ |
+
| 98 | +26x | +
+ expr,+ |
+
| 99 | +26x | +
+ function(x) {
+ |
+
| 100 | +15x | +
+ tryCatch(+ |
+
| 101 | +15x | +
+ eval(x, envir = env),+ |
+
| 102 | +15x | +
+ error = function(e) {
+ |
+
| 103 | +! | +
+ stop(+ |
+
| 104 | +! | +
+ sprintf(+ |
+
| 105 | +! | +
+ "Call execution failed:\n - call:\n %s\n - message:\n %s ",+ |
+
| 106 | +! | +
+ deparse1(x, collapse = "\n"), e+ |
+
| 107 | ++ |
+ )+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ |
+ }+ |
+
| 110 | ++ |
+ )+ |
+
| 111 | +15x | +
+ return(invisible(NULL))+ |
+
| 112 | ++ |
+ }+ |
+
| 113 | ++ |
+ )+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ | + + | +
| 116 | ++ | + + | +
| 117 | ++ |
+ #' Toggle button properties.+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' Switch between different icons or titles on a button.+ |
+
| 120 | ++ |
+ #'+ |
+
| 121 | ++ |
+ #' Wrapper functions that use `shinyjs::runjs` to change button properties in response to events,+ |
+
| 122 | ++ |
+ #' typically clicking those very buttons.+ |
+
| 123 | ++ |
+ #' `shiny`'s `actionButton` and `actionLink` create `<a>` tags,+ |
+
| 124 | ++ |
+ #' which may contain a child `<i>` tag that specifies an icon to be displayed.+ |
+
| 125 | ++ |
+ #' `toggle_icon` calls the `toggleClass` (when `one_way = FALSE`) or+ |
+
| 126 | ++ |
+ #' `removeClass` and `addClass` methods (when `one_way = TRUE`) to change icons.+ |
+
| 127 | ++ |
+ #' `toggle_title` calls the `attr` method to modify the `Title` attribute of the button.+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' @param input_id `character(1)` (name-spaced) id of the button+ |
+
| 130 | ++ |
+ #' @param icons,titles `character(2)` vector specifying values between which to toggle+ |
+
| 131 | ++ |
+ #' @param one_way `logical(1)` flag specifying whether to keep toggling;+ |
+
| 132 | ++ |
+ #' if TRUE, the target will be changed+ |
+
| 133 | ++ |
+ #' from the first element of `icons`/`titles` to the second+ |
+
| 134 | ++ |
+ #'+ |
+
| 135 | ++ |
+ #' @return Invisible NULL.+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @name toggle_button+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @examples+ |
+
| 140 | ++ |
+ #' library(shiny)+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' ui <- fluidPage(+ |
+
| 143 | ++ |
+ #' shinyjs::useShinyjs(),+ |
+
| 144 | ++ |
+ #' actionButton("hide_content", label = "hide", icon = icon("xmark")),
+ |
+
| 145 | ++ |
+ #' actionButton("show_content", label = "show", icon = icon("check")),
+ |
+
| 146 | ++ |
+ #' actionButton("toggle_content", label = "toggle", icon = icon("angle-down")),
+ |
+
| 147 | ++ |
+ #' br(),+ |
+
| 148 | ++ |
+ #' div(+ |
+
| 149 | ++ |
+ #' id = "content",+ |
+
| 150 | ++ |
+ #' verbatimTextOutput("printout")
+ |
+
| 151 | ++ |
+ #' )+ |
+
| 152 | ++ |
+ #' )+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 155 | ++ |
+ #' observeEvent(input$hide_content,+ |
+
| 156 | ++ |
+ #' {
+ |
+
| 157 | ++ |
+ #' shinyjs::hide("content")
+ |
+
| 158 | ++ |
+ #' toggle_icon("toggle_content", c("fa-angle-down", "fa-angle-right"), one_way = TRUE)
+ |
+
| 159 | ++ |
+ #' },+ |
+
| 160 | ++ |
+ #' ignoreInit = TRUE+ |
+
| 161 | ++ |
+ #' )+ |
+
| 162 | ++ |
+ #'+ |
+
| 163 | ++ |
+ #' observeEvent(input$show_content,+ |
+
| 164 | ++ |
+ #' {
+ |
+
| 165 | ++ |
+ #' shinyjs::show("content")
+ |
+
| 166 | ++ |
+ #' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"), one_way = TRUE)
+ |
+
| 167 | ++ |
+ #' },+ |
+
| 168 | ++ |
+ #' ignoreInit = TRUE+ |
+
| 169 | ++ |
+ #' )+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ #' observeEvent(input$toggle_content,+ |
+
| 172 | ++ |
+ #' {
+ |
+
| 173 | ++ |
+ #' shinyjs::toggle("content")
+ |
+
| 174 | ++ |
+ #' toggle_icon("toggle_content", c("fa-angle-right", "fa-angle-down"))
+ |
+
| 175 | ++ |
+ #' },+ |
+
| 176 | ++ |
+ #' ignoreInit = TRUE+ |
+
| 177 | ++ |
+ #' )+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' output$printout <- renderPrint({
+ |
+
| 180 | ++ |
+ #' head(faithful, 10)+ |
+
| 181 | ++ |
+ #' })+ |
+
| 182 | ++ |
+ #' }+ |
+
| 183 | ++ |
+ #' if (interactive()) {
+ |
+
| 184 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 185 | ++ |
+ #' }+ |
+
| 186 | ++ |
+ #'+ |
+
| 187 | ++ |
+ #' @rdname toggle_button+ |
+
| 188 | ++ |
+ #' @keywords internal+ |
+
| 189 | ++ |
+ toggle_icon <- function(input_id, icons, one_way = FALSE) {
+ |
+
| 190 | +3x | +
+ checkmate::assert_string(input_id)+ |
+
| 191 | +3x | +
+ checkmate::assert_character(icons, len = 2L)+ |
+
| 192 | +3x | +
+ checkmate::assert_flag(one_way)+ |
+
| 193 | ++ | + + | +
| 194 | +3x | +
+ expr <-+ |
+
| 195 | +3x | +
+ if (one_way) {
+ |
+
| 196 | +3x | +
+ sprintf(+ |
+
| 197 | +3x | +
+ "$('#%s i').removeClass('%s').addClass('%s');",
+ |
+
| 198 | +3x | +
+ input_id, icons[1], icons[2]+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | ++ |
+ } else {
+ |
+
| 201 | +! | +
+ sprintf("$('#%s i').toggleClass('%s');", input_id, paste(icons, collapse = " "))
+ |
+
| 202 | ++ |
+ }+ |
+
| 203 | ++ | + + | +
| 204 | +3x | +
+ shinyjs::runjs(expr)+ |
+
| 205 | ++ | + + | +
| 206 | +3x | +
+ invisible(NULL)+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | ++ | + + | +
| 209 | ++ |
+ #' @rdname toggle_button+ |
+
| 210 | ++ |
+ #' @keywords internal+ |
+
| 211 | ++ |
+ toggle_title <- function(input_id, titles, one_way = FALSE) {
+ |
+
| 212 | +3x | +
+ checkmate::assert_string(input_id)+ |
+
| 213 | +3x | +
+ checkmate::assert_character(titles, len = 2L)+ |
+
| 214 | +3x | +
+ checkmate::assert_flag(one_way)+ |
+
| 215 | ++ | + + | +
| 216 | +3x | +
+ expr <-+ |
+
| 217 | +3x | +
+ if (one_way) {
+ |
+
| 218 | +3x | +
+ sprintf(+ |
+
| 219 | +3x | +
+ "$('a#%s').attr('title', '%s');",
+ |
+
| 220 | +3x | +
+ input_id, titles[2]+ |
+
| 221 | ++ |
+ )+ |
+
| 222 | ++ |
+ } else {
+ |
+
| 223 | +! | +
+ sprintf(+ |
+
| 224 | +! | +
+ paste0(+ |
+
| 225 | +! | +
+ "var button_id = 'a#%1$s';",+ |
+
| 226 | +! | +
+ "var curr = $(button_id).attr('title');",
+ |
+
| 227 | +! | +
+ "if (curr == '%2$s') { $(button_id).attr('title', '%3$s');",
+ |
+
| 228 | +! | +
+ "} else { $(button_id).attr('title', '%2$s');",
+ |
+
| 229 | ++ |
+ "}"+ |
+
| 230 | ++ |
+ ),+ |
+
| 231 | +! | +
+ input_id, titles[1], titles[2]+ |
+
| 232 | ++ |
+ )+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | ++ | + + | +
| 235 | +3x | +
+ shinyjs::runjs(expr)+ |
+
| 236 | ++ | + + | +
| 237 | +3x | +
+ invisible(NULL)+ |
+
| 238 | ++ |
+ }+ |
+
| 239 | ++ | + + | +
| 240 | ++ |
+ #' Topological graph sort+ |
+
| 241 | ++ |
+ #'+ |
+
| 242 | ++ |
+ #' Graph is a list which for each node contains a vector of child nodes+ |
+
| 243 | ++ |
+ #' in the returned list, parents appear before their children.+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ #' Implementation of `Kahn` algorithm with a modification to maintain the order of input elements.+ |
+
| 246 | ++ |
+ #'+ |
+
| 247 | ++ |
+ #' @param graph (named `list`) list with node vector elements+ |
+
| 248 | ++ |
+ #' @keywords internal+ |
+
| 249 | ++ |
+ #'+ |
+
| 250 | ++ |
+ #' @examples+ |
+
| 251 | ++ |
+ #' teal.slice:::topological_sort(list(A = c(), B = c("A"), C = c("B"), D = c("A")))
+ |
+
| 252 | ++ |
+ #' teal.slice:::topological_sort(list(D = c("A"), A = c(), B = c("A"), C = c("B")))
+ |
+
| 253 | ++ |
+ #' teal.slice:::topological_sort(list(D = c("A"), B = c("A"), C = c("B"), A = c()))
+ |
+
| 254 | ++ |
+ topological_sort <- function(graph) {
+ |
+
| 255 | ++ |
+ # compute in-degrees+ |
+
| 256 | +65x | +
+ in_degrees <- list()+ |
+
| 257 | +65x | +
+ for (node in names(graph)) {
+ |
+
| 258 | +101x | +
+ in_degrees[[node]] <- 0+ |
+
| 259 | +101x | +
+ for (to_edge in graph[[node]]) {
+ |
+
| 260 | +9x | +
+ in_degrees[[to_edge]] <- 0+ |
+
| 261 | ++ |
+ }+ |
+
| 262 | ++ |
+ }+ |
+
| 263 | ++ | + + | +
| 264 | +65x | +
+ for (node in graph) {
+ |
+
| 265 | +101x | +
+ for (to_edge in node) {
+ |
+
| 266 | +9x | +
+ in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1+ |
+
| 267 | ++ |
+ }+ |
+
| 268 | ++ |
+ }+ |
+
| 269 | ++ | + + | +
| 270 | ++ |
+ # sort+ |
+
| 271 | +65x | +
+ visited <- 0+ |
+
| 272 | +65x | +
+ sorted <- list()+ |
+
| 273 | +65x | +
+ zero_in <- list()+ |
+
| 274 | +65x | +
+ for (node in names(in_degrees)) {
+ |
+
| 275 | +92x | +
+ if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node)+ |
+
| 276 | ++ |
+ }+ |
+
| 277 | +65x | +
+ zero_in <- rev(zero_in)+ |
+
| 278 | ++ | + + | +
| 279 | +65x | +
+ while (length(zero_in) != 0) {
+ |
+
| 280 | +98x | +
+ visited <- visited + 1+ |
+
| 281 | +98x | +
+ sorted <- c(zero_in[[1]], sorted)+ |
+
| 282 | +98x | +
+ for (edge_to in graph[[zero_in[[1]]]]) {
+ |
+
| 283 | +6x | +
+ in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1+ |
+
| 284 | +6x | +
+ if (in_degrees[[edge_to]] == 0) {
+ |
+
| 285 | +6x | +
+ zero_in <- append(zero_in, edge_to, 1)+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ |
+ }+ |
+
| 288 | +98x | +
+ zero_in[[1]] <- NULL+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | ++ | + + | +
| 291 | +65x | +
+ if (visited != length(in_degrees)) {
+ |
+
| 292 | +1x | +
+ stop(+ |
+
| 293 | +1x | +
+ "Graph is not a directed acyclic graph. Cycles involving nodes: ",+ |
+
| 294 | +1x | +
+ paste0(setdiff(names(in_degrees), sorted), collapse = " ")+ |
+
| 295 | ++ |
+ )+ |
+
| 296 | ++ |
+ } else {
+ |
+
| 297 | +64x | +
+ return(sorted)+ |
+
| 298 | ++ |
+ }+ |
+
| 299 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @title `FilterStates` subclass for `SummarizedExperiments`+ |
+
| 2 | ++ |
+ #' @description Handles filter states in a `SummaryExperiment`+ |
+
| 3 | ++ |
+ #' @keywords internal+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ SEFilterStates <- R6::R6Class( # nolint+ |
+
| 7 | ++ |
+ classname = "SEFilterStates",+ |
+
| 8 | ++ |
+ inherit = FilterStates,+ |
+
| 9 | ++ | + + | +
| 10 | ++ |
+ # public methods ----+ |
+
| 11 | ++ |
+ public = list(+ |
+
| 12 | ++ |
+ #' @description Initialize `SEFilterStates` object+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' Initialize `SEFilterStates` object+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param data (`SummarizedExperiment`)\cr+ |
+
| 17 | ++ |
+ #' the R object which `subset` function is applied on.+ |
+
| 18 | ++ |
+ #' @param data_reactive (`function(sid)`)\cr+ |
+
| 19 | ++ |
+ #' should return a `SummarizedExperiment` object or `NULL`.+ |
+
| 20 | ++ |
+ #' This object is needed for the `FilterState` counts being updated+ |
+
| 21 | ++ |
+ #' on a change in filters. If function returns `NULL` then filtered counts are not shown.+ |
+
| 22 | ++ |
+ #' Function has to have `sid` argument being a character.+ |
+
| 23 | ++ |
+ #' @param dataname (`character(1)`)\cr+ |
+
| 24 | ++ |
+ #' name of the data used in the expression+ |
+
| 25 | ++ |
+ #' specified to the function argument attached to this `FilterStates`.+ |
+
| 26 | ++ |
+ #' @param datalabel (`character(0)` or `character(1)`)\cr+ |
+
| 27 | ++ |
+ #' text label value. Should be a name of experiment+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ initialize = function(data,+ |
+
| 30 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 31 | ++ |
+ dataname,+ |
+
| 32 | ++ |
+ datalabel = NULL) {
+ |
+
| 33 | +100x | +
+ if (!requireNamespace("SummarizedExperiment", quietly = TRUE)) {
+ |
+
| 34 | +! | +
+ stop("Cannot load SummarizedExperiment - please install the package or restart your session.")
+ |
+
| 35 | ++ |
+ }+ |
+
| 36 | +100x | +
+ checkmate::assert_function(data_reactive, args = "sid")+ |
+
| 37 | +100x | +
+ checkmate::assert_class(data, "SummarizedExperiment")+ |
+
| 38 | +99x | +
+ super$initialize(data, data_reactive, dataname, datalabel)+ |
+
| 39 | +99x | +
+ if (!is.null(datalabel)) {
+ |
+
| 40 | +92x | +
+ private$dataname_prefixed <- sprintf("%s[['%s']]", dataname, datalabel)
+ |
+
| 41 | ++ |
+ }+ |
+
| 42 | ++ |
+ },+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' @description+ |
+
| 45 | ++ |
+ #' Set filter state+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @param state (`teal_slices`)\cr+ |
+
| 48 | ++ |
+ #' `teal_slice` objects should contain the field `arg %in% c("subset", "select")`
+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @return `NULL` invisibly+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ set_filter_state = function(state) {
+ |
+
| 53 | +69x | +
+ shiny::isolate({
+ |
+
| 54 | +69x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initializing, dataname: { private$dataname }")
+ |
+
| 55 | +69x | +
+ checkmate::assert_class(state, "teal_slices")+ |
+
| 56 | +67x | +
+ lapply(state, function(x) {
+ |
+
| 57 | +19x | +
+ checkmate::assert_choice(x$arg, choices = c("subset", "select"), null.ok = TRUE, .var.name = "teal_slice$arg")
+ |
+
| 58 | ++ |
+ })+ |
+
| 59 | +67x | +
+ count_type <- attr(state, "count_type")+ |
+
| 60 | +67x | +
+ if (length(count_type)) {
+ |
+
| 61 | +8x | +
+ private$count_type <- count_type+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ | + + | +
| 64 | +67x | +
+ subset_states <- Filter(function(x) x$arg == "subset", state)+ |
+
| 65 | +67x | +
+ private$set_filter_state_impl(+ |
+
| 66 | +67x | +
+ state = subset_states,+ |
+
| 67 | +67x | +
+ data = SummarizedExperiment::rowData(private$data),+ |
+
| 68 | +67x | +
+ data_reactive = function(sid = "") {
+ |
+
| 69 | +! | +
+ data <- private$data_reactive()+ |
+
| 70 | +! | +
+ if (!is.null(data)) {
+ |
+
| 71 | +! | +
+ SummarizedExperiment::rowData(data)+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | ++ |
+ )+ |
+
| 75 | ++ | + + | +
| 76 | +67x | +
+ select_states <- Filter(function(x) x$arg == "select", state)+ |
+
| 77 | +67x | +
+ private$set_filter_state_impl(+ |
+
| 78 | +67x | +
+ state = select_states,+ |
+
| 79 | +67x | +
+ data = SummarizedExperiment::colData(private$data),+ |
+
| 80 | +67x | +
+ data_reactive = function(sid = "") {
+ |
+
| 81 | +! | +
+ data <- private$data_reactive()+ |
+
| 82 | +! | +
+ if (!is.null(data)) {
+ |
+
| 83 | +! | +
+ SummarizedExperiment::colData(data)+ |
+
| 84 | ++ |
+ }+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | ++ | + + | +
| 88 | +67x | +
+ logger::log_trace("{ class(self)[1] }$set_filter_state initialized, dataname: { private$dataname }")
+ |
+
| 89 | +67x | +
+ invisible(NULL)+ |
+
| 90 | ++ |
+ })+ |
+
| 91 | ++ |
+ },+ |
+
| 92 | ++ | + + | +
| 93 | ++ |
+ #' @description+ |
+
| 94 | ++ |
+ #' Shiny UI module to add filter variable+ |
+
| 95 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 96 | ++ |
+ #' id of shiny module+ |
+
| 97 | ++ |
+ #' @return shiny.tag+ |
+
| 98 | ++ |
+ ui_add = function(id) {
+ |
+
| 99 | +2x | +
+ data <- private$data+ |
+
| 100 | +2x | +
+ checkmate::assert_string(id)+ |
+
| 101 | +2x | +
+ ns <- NS(id)+ |
+
| 102 | +2x | +
+ row_input <- if (ncol(SummarizedExperiment::rowData(data)) == 0) {
+ |
+
| 103 | +1x | +
+ div("no sample variables available")
+ |
+
| 104 | +2x | +
+ } else if (nrow(SummarizedExperiment::rowData(data)) == 0) {
+ |
+
| 105 | +1x | +
+ div("no samples available")
+ |
+
| 106 | ++ |
+ } else {
+ |
+
| 107 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 108 | +! | +
+ ns("row_to_add"),
+ |
+
| 109 | +! | +
+ choices = NULL,+ |
+
| 110 | +! | +
+ options = shinyWidgets::pickerOptions(+ |
+
| 111 | +! | +
+ liveSearch = TRUE,+ |
+
| 112 | +! | +
+ noneSelectedText = "Select gene variable"+ |
+
| 113 | ++ |
+ )+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | +2x | +
+ col_input <- if (ncol(SummarizedExperiment::colData(data)) == 0) {
+ |
+
| 118 | +1x | +
+ div("no sample variables available")
+ |
+
| 119 | +2x | +
+ } else if (nrow(SummarizedExperiment::colData(data)) == 0) {
+ |
+
| 120 | +1x | +
+ div("no samples available")
+ |
+
| 121 | ++ |
+ } else {
+ |
+
| 122 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 123 | +! | +
+ ns("col_to_add"),
+ |
+
| 124 | +! | +
+ choices = NULL,+ |
+
| 125 | +! | +
+ options = shinyWidgets::pickerOptions(+ |
+
| 126 | +! | +
+ liveSearch = TRUE,+ |
+
| 127 | +! | +
+ noneSelectedText = "Select sample variable"+ |
+
| 128 | ++ |
+ )+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ |
+ }+ |
+
| 131 | ++ | + + | +
| 132 | +2x | +
+ div(+ |
+
| 133 | +2x | +
+ row_input,+ |
+
| 134 | +2x | +
+ col_input+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ |
+ },+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ #' @description+ |
+
| 139 | ++ |
+ #' Shiny server module to add filter variable+ |
+
| 140 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' Module controls available choices to select as a filter variable.+ |
+
| 142 | ++ |
+ #' Selected filter variable is being removed from available choices.+ |
+
| 143 | ++ |
+ #' Removed filter variable gets back to available choices.+ |
+
| 144 | ++ |
+ #' This module unlike other `FilterStates` classes manages two+ |
+
| 145 | ++ |
+ #' sets of filter variables - one for `colData` and another for+ |
+
| 146 | ++ |
+ #' `rowData`.+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
| 149 | ++ |
+ #' an ID string that corresponds with the ID used to call the module's UI function.+ |
+
| 150 | ++ |
+ #' @return `moduleServer` function which returns `NULL`+ |
+
| 151 | ++ |
+ srv_add = function(id) {
+ |
+
| 152 | +! | +
+ data <- private$data+ |
+
| 153 | +! | +
+ data_reactive <- private$data_reactive+ |
+
| 154 | +! | +
+ moduleServer(+ |
+
| 155 | +! | +
+ id = id,+ |
+
| 156 | +! | +
+ function(input, output, session) {
+ |
+
| 157 | +! | +
+ logger::log_trace("SEFilterState$srv_add initializing, dataname: { private$dataname }")
+ |
+
| 158 | ++ | + + | +
| 159 | +! | +
+ row_data <- SummarizedExperiment::rowData(data)+ |
+
| 160 | +! | +
+ col_data <- SummarizedExperiment::colData(data)+ |
+
| 161 | ++ | + + | +
| 162 | +! | +
+ avail_row_data_choices <- reactive({
+ |
+
| 163 | +! | +
+ slices_for_subset <- Filter(function(x) x$arg == "subset", self$get_filter_state())+ |
+
| 164 | +! | +
+ active_filter_row_vars <- slices_field(slices_for_subset, "varname")+ |
+
| 165 | ++ | + + | +
| 166 | +! | +
+ choices <- setdiff(+ |
+
| 167 | +! | +
+ get_supported_filter_varnames(data = row_data),+ |
+
| 168 | +! | +
+ active_filter_row_vars+ |
+
| 169 | ++ |
+ )+ |
+
| 170 | ++ | + + | +
| 171 | +! | +
+ data_choices_labeled(+ |
+
| 172 | +! | +
+ data = row_data,+ |
+
| 173 | +! | +
+ choices = choices,+ |
+
| 174 | +! | +
+ varlabels = character(0),+ |
+
| 175 | +! | +
+ keys = NULL+ |
+
| 176 | ++ |
+ )+ |
+
| 177 | ++ |
+ })+ |
+
| 178 | ++ | + + | +
| 179 | +! | +
+ avail_col_data_choices <- reactive({
+ |
+
| 180 | +! | +
+ slices_for_select <- Filter(function(x) x$arg == "select", self$get_filter_state())+ |
+
| 181 | +! | +
+ active_filter_col_vars <- slices_field(slices_for_select, "varname")+ |
+
| 182 | ++ | + + | +
| 183 | +! | +
+ choices <- setdiff(+ |
+
| 184 | +! | +
+ get_supported_filter_varnames(data = col_data),+ |
+
| 185 | +! | +
+ active_filter_col_vars+ |
+
| 186 | ++ |
+ )+ |
+
| 187 | ++ | + + | +
| 188 | +! | +
+ data_choices_labeled(+ |
+
| 189 | +! | +
+ data = col_data,+ |
+
| 190 | +! | +
+ choices = choices,+ |
+
| 191 | +! | +
+ varlabels = character(0),+ |
+
| 192 | +! | +
+ keys = NULL+ |
+
| 193 | ++ |
+ )+ |
+
| 194 | ++ |
+ })+ |
+
| 195 | ++ | + + | +
| 196 | +! | +
+ observeEvent(+ |
+
| 197 | +! | +
+ avail_row_data_choices(),+ |
+
| 198 | +! | +
+ ignoreNULL = TRUE,+ |
+
| 199 | +! | +
+ handlerExpr = {
+ |
+
| 200 | +! | +
+ logger::log_trace(paste(+ |
+
| 201 | +! | +
+ "SEFilterStates$srv_add@1 updating available row data choices,",+ |
+
| 202 | +! | +
+ "dataname: { private$dataname }"
+ |
+
| 203 | ++ |
+ ))+ |
+
| 204 | +! | +
+ if (is.null(avail_row_data_choices())) {
+ |
+
| 205 | +! | +
+ shinyjs::hide("row_to_add")
+ |
+
| 206 | ++ |
+ } else {
+ |
+
| 207 | +! | +
+ shinyjs::show("row_to_add")
+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+
| 210 | +! | +
+ session,+ |
+
| 211 | +! | +
+ "row_to_add",+ |
+
| 212 | +! | +
+ choices = avail_row_data_choices()+ |
+
| 213 | ++ |
+ )+ |
+
| 214 | +! | +
+ logger::log_trace(paste(+ |
+
| 215 | +! | +
+ "SEFilterStates$srv_add@1 updated available row data choices,",+ |
+
| 216 | +! | +
+ "dataname: { private$dataname }"
+ |
+
| 217 | ++ |
+ ))+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ | + + | +
| 221 | +! | +
+ observeEvent(+ |
+
| 222 | +! | +
+ avail_col_data_choices(),+ |
+
| 223 | +! | +
+ ignoreNULL = TRUE,+ |
+
| 224 | +! | +
+ handlerExpr = {
+ |
+
| 225 | +! | +
+ logger::log_trace(paste(+ |
+
| 226 | +! | +
+ "SEFilterStates$srv_add@2 updating available col data choices,",+ |
+
| 227 | +! | +
+ "dataname: { private$dataname }"
+ |
+
| 228 | ++ |
+ ))+ |
+
| 229 | +! | +
+ if (is.null(avail_col_data_choices())) {
+ |
+
| 230 | +! | +
+ shinyjs::hide("col_to_add")
+ |
+
| 231 | ++ |
+ } else {
+ |
+
| 232 | +! | +
+ shinyjs::show("col_to_add")
+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+
| 235 | +! | +
+ session,+ |
+
| 236 | +! | +
+ "col_to_add",+ |
+
| 237 | +! | +
+ choices = avail_col_data_choices()+ |
+
| 238 | ++ |
+ )+ |
+
| 239 | +! | +
+ logger::log_trace(paste(+ |
+
| 240 | +! | +
+ "SEFilterStates$srv_add@2 updated available col data choices,",+ |
+
| 241 | +! | +
+ "dataname: { private$dataname }"
+ |
+
| 242 | ++ |
+ ))+ |
+
| 243 | ++ |
+ }+ |
+
| 244 | ++ |
+ )+ |
+
| 245 | ++ | + + | +
| 246 | +! | +
+ observeEvent(+ |
+
| 247 | +! | +
+ eventExpr = input$col_to_add,+ |
+
| 248 | +! | +
+ handlerExpr = {
+ |
+
| 249 | +! | +
+ logger::log_trace(+ |
+
| 250 | +! | +
+ sprintf(+ |
+
| 251 | +! | +
+ "SEFilterStates$srv_add@3 adding FilterState of column %s to col data, dataname: %s",+ |
+
| 252 | +! | +
+ deparse1(input$col_to_add),+ |
+
| 253 | +! | +
+ private$dataname+ |
+
| 254 | ++ |
+ )+ |
+
| 255 | ++ |
+ )+ |
+
| 256 | +! | +
+ varname <- input$col_to_add+ |
+
| 257 | +! | +
+ self$set_filter_state(teal_slices(+ |
+
| 258 | +! | +
+ teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "select")+ |
+
| 259 | ++ |
+ ))+ |
+
| 260 | ++ | + + | +
| 261 | +! | +
+ logger::log_trace(+ |
+
| 262 | +! | +
+ sprintf(+ |
+
| 263 | +! | +
+ "SEFilterStates$srv_add@3 added FilterState of column %s to col data, dataname: %s",+ |
+
| 264 | +! | +
+ deparse1(varname),+ |
+
| 265 | +! | +
+ private$dataname+ |
+
| 266 | ++ |
+ )+ |
+
| 267 | ++ |
+ )+ |
+
| 268 | ++ |
+ }+ |
+
| 269 | ++ |
+ )+ |
+
| 270 | ++ | + + | +
| 271 | ++ | + + | +
| 272 | +! | +
+ observeEvent(+ |
+
| 273 | +! | +
+ eventExpr = input$row_to_add,+ |
+
| 274 | +! | +
+ handlerExpr = {
+ |
+
| 275 | +! | +
+ logger::log_trace(+ |
+
| 276 | +! | +
+ sprintf(+ |
+
| 277 | +! | +
+ "SEFilterStates$srv_add@4 adding FilterState of variable %s to row data, dataname: %s",+ |
+
| 278 | +! | +
+ deparse1(input$row_to_add),+ |
+
| 279 | +! | +
+ private$dataname+ |
+
| 280 | ++ |
+ )+ |
+
| 281 | ++ |
+ )+ |
+
| 282 | +! | +
+ varname <- input$row_to_add+ |
+
| 283 | +! | +
+ self$set_filter_state(teal_slices(+ |
+
| 284 | +! | +
+ teal_slice(private$dataname, varname, experiment = private$datalabel, arg = "subset")+ |
+
| 285 | ++ |
+ ))+ |
+
| 286 | ++ | + + | +
| 287 | +! | +
+ logger::log_trace(+ |
+
| 288 | +! | +
+ sprintf(+ |
+
| 289 | +! | +
+ "SEFilterStates$srv_add@4 added FilterState of variable %s to row data, dataname: %s",+ |
+
| 290 | +! | +
+ deparse1(varname),+ |
+
| 291 | +! | +
+ private$dataname+ |
+
| 292 | ++ |
+ )+ |
+
| 293 | ++ |
+ )+ |
+
| 294 | ++ |
+ }+ |
+
| 295 | ++ |
+ )+ |
+
| 296 | ++ | + + | +
| 297 | +! | +
+ logger::log_trace("SEFilterState$srv_add initialized, dataname: { private$dataname }")
+ |
+
| 298 | +! | +
+ NULL+ |
+
| 299 | ++ |
+ }+ |
+
| 300 | ++ |
+ )+ |
+
| 301 | ++ |
+ }+ |
+
| 302 | ++ |
+ )+ |
+
| 303 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Ensure the ellipsis, ..., in method arguments are empty+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Ellipsis, ..., are needed as part of method arguments to allow for its arguments to be different from its generic's+ |
+
| 4 | ++ |
+ #' arguments and for this to pass check(). Hence, ..., should always be empty. This function will check for this+ |
+
| 5 | ++ |
+ #' condition.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param ... it should literally just be ...+ |
+
| 8 | ++ |
+ #' @param stop TRUE to raise an error; FALSE will output warning message+ |
+
| 9 | ++ |
+ #' @param allowed_args character vector naming arguments that are allowed in the \code{...}.
+ |
+
| 10 | ++ |
+ #' to allow for unnamed arguments, let "" be one of the elements in this character vector.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return \code{NULL} if ... is empty
+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @keywords internal+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @examples+ |
+
| 17 | ++ |
+ #' method.class <- function(a, b, c, ...) {
+ |
+
| 18 | ++ |
+ #' check_ellipsis(...)+ |
+
| 19 | ++ |
+ #' }+ |
+
| 20 | ++ |
+ #' method.class <- function(a, b, c, ...) {
+ |
+
| 21 | ++ |
+ #' check_ellipsis(..., allowed_args = c("y", "z"))
+ |
+
| 22 | ++ |
+ #' }+ |
+
| 23 | ++ |
+ check_ellipsis <- function(..., stop = FALSE, allowed_args = character(0)) {
+ |
+
| 24 | +18x | +
+ if (!missing(...)) {
+ |
+
| 25 | +16x | +
+ checkmate::assert_flag(stop)+ |
+
| 26 | +16x | +
+ checkmate::assert_character(allowed_args, min.len = 0, null.ok = TRUE, any.missing = FALSE)+ |
+
| 27 | +16x | +
+ args <- list(...)+ |
+
| 28 | +16x | +
+ arg_names <- names(args)+ |
+
| 29 | +16x | +
+ if (is.null(arg_names)) {
+ |
+
| 30 | +4x | +
+ arg_names <- rep("", length(args))
+ |
+
| 31 | ++ |
+ }+ |
+
| 32 | +16x | +
+ extra_args <- arg_names[!is.element(arg_names, allowed_args)]+ |
+
| 33 | +16x | +
+ if (length(extra_args) == 0) {
+ |
+
| 34 | +4x | +
+ return(invisible(NULL))+ |
+
| 35 | ++ |
+ }+ |
+
| 36 | +12x | +
+ message <- paste(length(extra_args), "total unused argument(s).")+ |
+
| 37 | ++ | + + | +
| 38 | +12x | +
+ named_extra_args <- extra_args[!vapply(extra_args, identical, logical(1), "")]+ |
+
| 39 | +12x | +
+ if (length(named_extra_args) > 0) {
+ |
+
| 40 | +9x | +
+ message <- paste0(+ |
+
| 41 | +9x | +
+ message,+ |
+
| 42 | ++ |
+ " ",+ |
+
| 43 | +9x | +
+ length(named_extra_args),+ |
+
| 44 | +9x | +
+ " with name(s): ",+ |
+
| 45 | +9x | +
+ paste(named_extra_args, collapse = ", "),+ |
+
| 46 | ++ |
+ "."+ |
+
| 47 | ++ |
+ )+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | +12x | +
+ if (stop) {
+ |
+
| 50 | +8x | +
+ stop(message)+ |
+
| 51 | ++ |
+ } else {
+ |
+
| 52 | +4x | +
+ warning(message)+ |
+
| 53 | ++ |
+ }+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | ++ |
+ }+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ #' Whether the variable name is good to use within Show R Code+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' Spaces are problematic because the variables must be escaped with backticks.+ |
+
| 60 | ++ |
+ #' Also, they should not start with a number as R may silently make it valid by changing it.+ |
+
| 61 | ++ |
+ #' Therefore, we only allow alphanumeric characters with underscores.+ |
+
| 62 | ++ |
+ #' The first character of the `name` must be an alphabetic character and can be followed by alphanumeric characters.+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @md+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @param name `character, single or vector` name to check+ |
+
| 67 | ++ |
+ #' @keywords internal+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' @examples+ |
+
| 70 | ++ |
+ #' teal.slice:::check_simple_name("aas2df")
+ |
+
| 71 | ++ |
+ #' teal.slice:::check_simple_name("ADSL")
+ |
+
| 72 | ++ |
+ #' teal.slice:::check_simple_name("ADSLmodified")
+ |
+
| 73 | ++ |
+ #' teal.slice:::check_simple_name("ADSL_modified")
+ |
+
| 74 | ++ |
+ #' teal.slice:::check_simple_name("ADSL_2")
+ |
+
| 75 | ++ |
+ #' teal.slice:::check_simple_name("a1")
+ |
+
| 76 | ++ |
+ #' # the following fail+ |
+
| 77 | ++ |
+ #' if (interactive()) {
+ |
+
| 78 | ++ |
+ #' teal.slice:::check_simple_name("1a")
+ |
+
| 79 | ++ |
+ #' teal.slice:::check_simple_name("ADSL.modified")
+ |
+
| 80 | ++ |
+ #' teal.slice:::check_simple_name("a1...")
+ |
+
| 81 | ++ |
+ #' }+ |
+
| 82 | ++ |
+ check_simple_name <- function(name) {
+ |
+
| 83 | +380x | +
+ checkmate::assert_character(name, min.len = 1, any.missing = FALSE)+ |
+
| 84 | +378x | +
+ if (!grepl("^[[:alpha:]][a-zA-Z0-9_]*$", name, perl = TRUE)) {
+ |
+
| 85 | +5x | +
+ stop(+ |
+
| 86 | +5x | +
+ "name '",+ |
+
| 87 | +5x | +
+ name,+ |
+
| 88 | +5x | +
+ "' must only contain alphanumeric characters (with underscores)",+ |
+
| 89 | +5x | +
+ " and the first character must be an alphabetic character"+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ }+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ #' Resolve the expected bootstrap theme+ |
+
| 95 | ++ |
+ #' @keywords internal+ |
+
| 96 | ++ |
+ get_teal_bs_theme <- function() {
+ |
+
| 97 | +2x | +
+ bs_theme <- getOption("teal.bs_theme")
+ |
+
| 98 | +2x | +
+ if (is.null(bs_theme)) {
+ |
+
| 99 | +1x | +
+ NULL+ |
+
| 100 | +1x | +
+ } else if (!inherits(bs_theme, "bs_theme")) {
+ |
+
| 101 | +! | +
+ warning("teal.bs_theme has to be of a bslib::bs_theme class, the default shiny bootstrap is used.")
+ |
+
| 102 | +! | +
+ NULL+ |
+
| 103 | ++ |
+ } else {
+ |
+
| 104 | +1x | +
+ bs_theme+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ |
+ }+ |
+
| 107 | ++ | + + | +
| 108 | ++ |
+ #' Include `JS` files from `/inst/js/` package directory to application header+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' `system.file` should not be used to access files in other packages, it does+ |
+
| 111 | ++ |
+ #' not work with `devtools`. Therefore, we redefine this method in each package+ |
+
| 112 | ++ |
+ #' as needed. Thus, we do not export this method+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ |
+
| 115 | ++ |
+ #' @param except (`character`) vector of basename filenames to be excluded+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ #' @return HTML code that includes `JS` files+ |
+
| 118 | ++ |
+ #' @keywords internal+ |
+
| 119 | ++ |
+ include_js_files <- function(pattern) {
+ |
+
| 120 | +12x | +
+ checkmate::assert_character(pattern, min.len = 1, null.ok = TRUE)+ |
+
| 121 | +12x | +
+ js_files <- list.files(+ |
+
| 122 | +12x | +
+ system.file("js", package = "teal.slice", mustWork = TRUE),
+ |
+
| 123 | +12x | +
+ pattern = pattern,+ |
+
| 124 | +12x | +
+ full.names = TRUE+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | +12x | +
+ return(singleton(lapply(js_files, includeScript)))+ |
+
| 127 | ++ |
+ }+ |
+
| 128 | ++ | + + | +
| 129 | ++ |
+ #' This function takes a vector of values and returns a `c` call. If the vector+ |
+
| 130 | ++ |
+ #' has only one element, the element is returned directly.+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ #' @param choices A vector of values.+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @return A `c` call.+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' @examples+ |
+
| 137 | ++ |
+ #' teal.slice:::make_c_call(1:3)+ |
+
| 138 | ++ |
+ #' # [1] 1 2 3+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' teal.slice:::make_c_call(1)+ |
+
| 141 | ++ |
+ #' # [1] 1+ |
+
| 142 | ++ |
+ #' @keywords internal+ |
+
| 143 | ++ |
+ make_c_call <- function(choices) {
+ |
+
| 144 | +37x | +
+ if (length(choices) > 1) {
+ |
+
| 145 | +16x | +
+ do.call("call", append(list("c"), choices))
+ |
+
| 146 | ++ |
+ } else {
+ |
+
| 147 | +21x | +
+ choices+ |
+
| 148 | ++ |
+ }+ |
+
| 149 | ++ |
+ }+ |
+
| 1 | ++ |
+ # This file contains helper functions used in unit tests.+ |
+
| 2 | ++ | + + | +
| 3 | ++ |
+ # compares specified fields between two `teal_slice` objects+ |
+
| 4 | ++ |
+ compare_slices <- function(ts1, ts2, fields) {
+ |
+
| 5 | +9x | +
+ shiny::isolate(+ |
+
| 6 | +9x | +
+ all(vapply(fields, function(x) identical(ts1[[x]], ts2[[x]]), logical(1L)))+ |
+
| 7 | ++ |
+ )+ |
+
| 8 | ++ |
+ }+ |
+
| 9 | ++ | + + | +
| 10 | ++ | + + | +
| 11 | ++ |
+ # compare two teal_slice+ |
+
| 12 | ++ |
+ expect_identical_slice <- function(x, y) {
+ |
+
| 13 | +33x | +
+ shiny::isolate({
+ |
+
| 14 | +33x | +
+ testthat::expect_true(+ |
+
| 15 | +33x | +
+ setequal(+ |
+
| 16 | +33x | +
+ reactiveValuesToList(x),+ |
+
| 17 | +33x | +
+ reactiveValuesToList(y)+ |
+
| 18 | ++ |
+ )+ |
+
| 19 | ++ |
+ )+ |
+
| 20 | ++ |
+ })+ |
+
| 21 | ++ |
+ }+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ # compare two teal_slices+ |
+
| 24 | ++ |
+ expect_identical_slices <- function(x, y) {
+ |
+
| 25 | +10x | +
+ shiny::isolate({
+ |
+
| 26 | +10x | +
+ mapply(+ |
+
| 27 | +10x | +
+ function(x, y) {
+ |
+
| 28 | +26x | +
+ expect_identical_slice(x, y)+ |
+
| 29 | ++ |
+ },+ |
+
| 30 | +10x | +
+ x = x,+ |
+
| 31 | +10x | +
+ y = y+ |
+
| 32 | ++ |
+ )+ |
+
| 33 | +10x | +
+ testthat::expect_identical(attributes(x), attributes(y))+ |
+
| 34 | ++ |
+ })+ |
+
| 35 | ++ |
+ }+ |
+
| 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 | ++ | + + | +
| 11 | +! | +
+ invisible()+ |
+
| 12 | ++ |
+ }+ |
+
| 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 | +! | +
+ lifecycle::badge+ |
+
| 42 | +! | +
+ logger::log_trace+ |
+
| 43 | +! | +
+ plotly::plot_ly+ |
+
| 44 | +! | +
+ shinycssloaders::withSpinner+ |
+
| 45 | +! | +
+ shinyWidgets::pickerOptions+ |
+
| 46 | +! | +
+ teal.widgets::optionalSelectInput+ |
+
| 47 | ++ |
+ }+ |
+
| 48 | ++ | + + | +
| 49 | ++ | + + | +
| 50 | ++ |
+ ### END ENSURE CHECK PASSES+ |
+
| 1 | ++ |
+ #' @title `FilterStates` subclass for data frames+ |
+
| 2 | ++ |
+ #' @description Handles filter states in a `data.frame`+ |
+
| 3 | ++ |
+ #' @keywords internal+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @examples+ |
+
| 7 | ++ |
+ #' # working filters in an app+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' library(shiny)+ |
+
| 10 | ++ |
+ #' library(shinyjs)+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' # create data frame to filter+ |
+
| 13 | ++ |
+ #' data_df <- data.frame(+ |
+
| 14 | ++ |
+ #' NUM1 = 1:100,+ |
+
| 15 | ++ |
+ #' NUM2 = round(runif(100, min = 20, max = 23)),+ |
+
| 16 | ++ |
+ #' CHAR1 = sample(LETTERS[1:6], size = 100, replace = TRUE),+ |
+
| 17 | ++ |
+ #' CHAR2 = sample(c("M", "F"), size = 100, replace = TRUE),
+ |
+
| 18 | ++ |
+ #' DATE = seq(as.Date("2020-01-01"), by = 1, length.out = 100),
+ |
+
| 19 | ++ |
+ #' DATETIME = as.POSIXct(seq(as.Date("2020-01-01"), by = 1, length.out = 100))
+ |
+
| 20 | ++ |
+ #' )+ |
+
| 21 | ++ |
+ #' data_na <- data.frame(+ |
+
| 22 | ++ |
+ #' NUM1 = NA,+ |
+
| 23 | ++ |
+ #' NUM2 = NA,+ |
+
| 24 | ++ |
+ #' CHAR1 = NA,+ |
+
| 25 | ++ |
+ #' CHAR2 = NA,+ |
+
| 26 | ++ |
+ #' DATE = NA,+ |
+
| 27 | ++ |
+ #' DATETIME = NA+ |
+
| 28 | ++ |
+ #' )+ |
+
| 29 | ++ |
+ #' data_df <- rbind(data_df, data_na)+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' # initiate `FilterStates` object+ |
+
| 33 | ++ |
+ #' filter_states_df <- init_filter_states(+ |
+
| 34 | ++ |
+ #' data = data_df,+ |
+
| 35 | ++ |
+ #' dataname = "dataset",+ |
+
| 36 | ++ |
+ #' datalabel = ("label")
+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' ui <- fluidPage(+ |
+
| 40 | ++ |
+ #' useShinyjs(),+ |
+
| 41 | ++ |
+ #' teal.slice:::include_css_files(pattern = "filter-panel"),+ |
+
| 42 | ++ |
+ #' teal.slice:::include_js_files(pattern = "count-bar-labels"),+ |
+
| 43 | ++ |
+ #' column(4, div(+ |
+
| 44 | ++ |
+ #' h4("Active filters"),
+ |
+
| 45 | ++ |
+ #' filter_states_df$ui_active("fsdf")
+ |
+
| 46 | ++ |
+ #' )),+ |
+
| 47 | ++ |
+ #' column(4, div(+ |
+
| 48 | ++ |
+ #' h4("Manual filter control"),
+ |
+
| 49 | ++ |
+ #' filter_states_df$ui_add("add_filters"), br(),
+ |
+
| 50 | ++ |
+ #' h4("Condition (i.e. call)"), # display the subsetting call generated by this FilterStates
+ |
+
| 51 | ++ |
+ #' textOutput("call_df"), br(),
+ |
+
| 52 | ++ |
+ #' h4("Formatted state"), # display human readable filter state
+ |
+
| 53 | ++ |
+ #' textOutput("formatted_df"), br()
+ |
+
| 54 | ++ |
+ #' )),+ |
+
| 55 | ++ |
+ #' column(4, div(+ |
+
| 56 | ++ |
+ #' h4("Programmatic filter control"),
+ |
+
| 57 | ++ |
+ #' actionButton("button1_df", "set NUM1 < 30", width = "100%"), br(),
+ |
+
| 58 | ++ |
+ #' actionButton("button2_df", "set NUM2 %in% c(20, 21)", width = "100%"), br(),
+ |
+
| 59 | ++ |
+ #' actionButton("button3_df", "set CHAR1 %in% c(\"B\", \"C\", \"D\")", width = "100%"), br(),
+ |
+
| 60 | ++ |
+ #' actionButton("button4_df", "set CHAR2 == \"F\"", width = "100%"), br(),
+ |
+
| 61 | ++ |
+ #' actionButton("button5_df", "set DATE <= 2020-02-02", width = "100%"), br(),
+ |
+
| 62 | ++ |
+ #' actionButton("button6_df", "set DATETIME <= 2020-02-02", width = "100%"), br(),
+ |
+
| 63 | ++ |
+ #' hr(),+ |
+
| 64 | ++ |
+ #' actionButton("button7_df", "remove NUM1", width = "100%"), br(),
+ |
+
| 65 | ++ |
+ #' actionButton("button8_df", "remove NUM2", width = "100%"), br(),
+ |
+
| 66 | ++ |
+ #' actionButton("button9_df", "remove CHAR1", width = "100%"), br(),
+ |
+
| 67 | ++ |
+ #' actionButton("button10_df", "remove CHAR2", width = "100%"), br(),
+ |
+
| 68 | ++ |
+ #' actionButton("button11_df", "remove DATE", width = "100%"), br(),
+ |
+
| 69 | ++ |
+ #' actionButton("button12_df", "remove DATETIME", width = "100%"), br(),
+ |
+
| 70 | ++ |
+ #' hr(),+ |
+
| 71 | ++ |
+ #' actionButton("button0_df", "clear all filters", width = "100%"), br()
+ |
+
| 72 | ++ |
+ #' ))+ |
+
| 73 | ++ |
+ #' )+ |
+
| 74 | ++ |
+ #'+ |
+
| 75 | ++ |
+ #' server <- function(input, output, session) {
+ |
+
| 76 | ++ |
+ #' filter_states_df$srv_add("add_filters")
+ |
+
| 77 | ++ |
+ #' filter_states_df$srv_active("fsdf")
+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' output$call_df <- renderPrint(filter_states_df$get_call())+ |
+
| 80 | ++ |
+ #' output$formatted_df <- renderText(filter_states_df$format())+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' observeEvent(input$button1_df, {
+ |
+
| 83 | ++ |
+ #' filter_state <- teal_slices(teal_slice("dataset", "NUM1", selected = c(0, 30)))
+ |
+
| 84 | ++ |
+ #' filter_states_df$set_filter_state(state = filter_state)+ |
+
| 85 | ++ |
+ #' })+ |
+
| 86 | ++ |
+ #' observeEvent(input$button2_df, {
+ |
+
| 87 | ++ |
+ #' filter_state <- teal_slices(teal_slice("dataset", "NUM2", selected = c(20, 21)))
+ |
+
| 88 | ++ |
+ #' filter_states_df$set_filter_state(state = filter_state)+ |
+
| 89 | ++ |
+ #' })+ |
+
| 90 | ++ |
+ #' observeEvent(input$button3_df, {
+ |
+
| 91 | ++ |
+ #' filter_state <- teal_slices(teal_slice("dataset", "CHAR1", selected = c("B", "C", "D")))
+ |
+
| 92 | ++ |
+ #' filter_states_df$set_filter_state(state = filter_state)+ |
+
| 93 | ++ |
+ #' })+ |
+
| 94 | ++ |
+ #' observeEvent(input$button4_df, {
+ |
+
| 95 | ++ |
+ #' filter_state <- teal_slices(teal_slice("dataset", "CHAR2", selected = c("F")))
+ |
+
| 96 | ++ |
+ #' filter_states_df$set_filter_state(state = filter_state)+ |
+
| 97 | ++ |
+ #' })+ |
+
| 98 | ++ |
+ #' observeEvent(input$button5_df, {
+ |
+
| 99 | ++ |
+ #' filter_state <- teal_slices(+ |
+
| 100 | ++ |
+ #' teal_slice("dataset", "DATE", selected = c("2020-01-01", "2020-02-02"))
+ |
+
| 101 | ++ |
+ #' )+ |
+
| 102 | ++ |
+ #' filter_states_df$set_filter_state(state = filter_state)+ |
+
| 103 | ++ |
+ #' })+ |
+
| 104 | ++ |
+ #' observeEvent(input$button6_df, {
+ |
+
| 105 | ++ |
+ #' filter_state <- teal_slices(+ |
+
| 106 | ++ |
+ #' teal_slice("dataset", "DATETIME", selected = as.POSIXct(c("2020-01-01", "2020-02-02")))
+ |
+
| 107 | ++ |
+ #' )+ |
+
| 108 | ++ |
+ #' filter_states_df$set_filter_state(state = filter_state)+ |
+
| 109 | ++ |
+ #' })+ |
+
| 110 | ++ |
+ #' observeEvent(input$button7_df, filter_states_df$remove_filter_state(state_id = "NUM1"))+ |
+
| 111 | ++ |
+ #' observeEvent(input$button8_df, filter_states_df$remove_filter_state(state_id = "NUM2"))+ |
+
| 112 | ++ |
+ #' observeEvent(input$button9_df, filter_states_df$remove_filter_state(state_id = "CHAR1"))+ |
+
| 113 | ++ |
+ #' observeEvent(input$button10_df, filter_states_df$remove_filter_state(state_id = "CHAR2"))+ |
+
| 114 | ++ |
+ #' observeEvent(input$button11_df, filter_states_df$remove_filter_state(state_id = "DATE"))+ |
+
| 115 | ++ |
+ #' observeEvent(input$button12_df, filter_states_df$remove_filter_state(state_id = "DATETIME"))+ |
+
| 116 | ++ |
+ #' observeEvent(input$button0_df, filter_states_df$clear_filter_states())+ |
+
| 117 | ++ |
+ #' }+ |
+
| 118 | ++ |
+ #' if (interactive()) {
+ |
+
| 119 | ++ |
+ #' shinyApp(ui, server)+ |
+
| 120 | ++ |
+ #' }+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ DFFilterStates <- R6::R6Class( # nolint+ |
+
| 123 | ++ |
+ classname = "DFFilterStates",+ |
+
| 124 | ++ |
+ inherit = FilterStates,+ |
+
| 125 | ++ | + + | +
| 126 | ++ |
+ # public methods ----+ |
+
| 127 | ++ |
+ public = list(+ |
+
| 128 | ++ |
+ #' @description Initializes `DFFilterStates` object.+ |
+
| 129 | ++ |
+ #'+ |
+
| 130 | ++ |
+ #' Initializes `DFFilterStates` object by setting `dataname`+ |
+
| 131 | ++ |
+ #' and initializing `state_list` (`shiny::reactiveVal`).+ |
+
| 132 | ++ |
+ #' This class contains a single `state_list` with no specified name,+ |
+
| 133 | ++ |
+ #' which means that when calling the subset function associated with this class+ |
+
| 134 | ++ |
+ #' (`dplyr::filter`), a list of conditions is passed to unnamed arguments (`...`).+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 137 | ++ |
+ #' the R object which `dplyr::filter` function is applied on.+ |
+
| 138 | ++ |
+ #' @param data_reactive (`function(sid)`)\cr+ |
+
| 139 | ++ |
+ #' should return a `data.frame` object or `NULL`.+ |
+
| 140 | ++ |
+ #' This object is needed for the `FilterState` counts being updated+ |
+
| 141 | ++ |
+ #' on a change in filters. If function returns `NULL` then filtered counts are not shown.+ |
+
| 142 | ++ |
+ #' Function has to have `sid` argument being a character.+ |
+
| 143 | ++ |
+ #' @param dataname (`character`)\cr+ |
+
| 144 | ++ |
+ #' name of the data used in the \emph{subset expression}
+ |
+
| 145 | ++ |
+ #' specified to the function argument attached to this `FilterStates`+ |
+
| 146 | ++ |
+ #' @param datalabel (`NULL` or `character(1)`)\cr+ |
+
| 147 | ++ |
+ #' text label value+ |
+
| 148 | ++ |
+ #' @param keys (`character`)\cr+ |
+
| 149 | ++ |
+ #' key columns names+ |
+
| 150 | ++ |
+ #'+ |
+
| 151 | ++ |
+ initialize = function(data,+ |
+
| 152 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 153 | ++ |
+ dataname,+ |
+
| 154 | ++ |
+ datalabel = NULL,+ |
+
| 155 | ++ |
+ keys = character(0)) {
+ |
+
| 156 | +115x | +
+ checkmate::assert_function(data_reactive, args = "sid")+ |
+
| 157 | +115x | +
+ checkmate::assert_data_frame(data)+ |
+
| 158 | +115x | +
+ super$initialize(data, data_reactive, dataname, datalabel)+ |
+
| 159 | +115x | +
+ private$keys <- keys+ |
+
| 160 | +115x | +
+ private$set_filterable_varnames(include_varnames = colnames(private$data))+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ |
+ ),+ |
+
| 163 | ++ | + + | +
| 164 | ++ |
+ # private members ----+ |
+
| 165 | ++ |
+ private = list(+ |
+
| 166 | ++ |
+ fun = quote(dplyr::filter)+ |
+
| 167 | ++ |
+ )+ |
+
| 168 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' @title `FilterStates` subclass for matrices+ |
+
| 2 | ++ |
+ #' @description Handles filter states in a `matrix`+ |
+
| 3 | ++ |
+ #' @keywords internal+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ MatrixFilterStates <- R6::R6Class( # nolint+ |
+
| 7 | ++ |
+ classname = "MatrixFilterStates",+ |
+
| 8 | ++ |
+ inherit = FilterStates,+ |
+
| 9 | ++ | + + | +
| 10 | ++ |
+ # public methods ----+ |
+
| 11 | ++ |
+ public = list(+ |
+
| 12 | ++ |
+ #' @description Initialize `MatrixFilterStates` object+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' Initialize `MatrixFilterStates` object+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param data (`matrix`)\cr+ |
+
| 17 | ++ |
+ #' the R object which `subset` function is applied on.+ |
+
| 18 | ++ |
+ #' @param data_reactive (`function(sid)`)\cr+ |
+
| 19 | ++ |
+ #' should return a `matrix` object or `NULL`.+ |
+
| 20 | ++ |
+ #' This object is needed for the `FilterState` counts being updated+ |
+
| 21 | ++ |
+ #' on a change in filters. If function returns `NULL` then filtered counts are not shown.+ |
+
| 22 | ++ |
+ #' Function has to have `sid` argument being a character.+ |
+
| 23 | ++ |
+ #' @param dataname (`character(1)`)\cr+ |
+
| 24 | ++ |
+ #' name of the data used in the expression+ |
+
| 25 | ++ |
+ #' specified to the function argument attached to this `FilterStates`.+ |
+
| 26 | ++ |
+ #' @param datalabel (`NULL` or `character(1)`)\cr+ |
+
| 27 | ++ |
+ #' text label value. Should be a name of experiment.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ initialize = function(data,+ |
+
| 30 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 31 | ++ |
+ dataname,+ |
+
| 32 | ++ |
+ datalabel = NULL) {
+ |
+
| 33 | +28x | +
+ checkmate::assert_matrix(data)+ |
+
| 34 | +27x | +
+ super$initialize(data, data_reactive, dataname, datalabel)+ |
+
| 35 | +27x | +
+ private$set_filterable_varnames(include_varnames = colnames(private$data))+ |
+
| 36 | ++ |
+ }+ |
+
| 37 | ++ |
+ ),+ |
+
| 38 | ++ |
+ private = list(+ |
+
| 39 | ++ |
+ extract_type = "matrix"+ |
+
| 40 | ++ |
+ )+ |
+
| 41 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Combine calls by operator+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Combine list of calls by specific operator+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @param calls (`list` of calls)\cr+ |
+
| 6 | ++ |
+ #' list containing calls to be combined by `operator`;+ |
+
| 7 | ++ |
+ #' if empty, NULL is returned+ |
+
| 8 | ++ |
+ #' @param operator (`character(1)`)\cr+ |
+
| 9 | ++ |
+ #' name/symbol of the operator passed as character string+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return call or NULL, if `calls` is an empty list+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @examples+ |
+
| 14 | ++ |
+ #' calls <- list(+ |
+
| 15 | ++ |
+ #' quote(SEX == "F"), # subsetting on factor+ |
+
| 16 | ++ |
+ #' quote(AGE >= 20 & AGE <= 50), # subsetting on range+ |
+
| 17 | ++ |
+ #' quote(!SURV) # subsetting on logical+ |
+
| 18 | ++ |
+ #' )+ |
+
| 19 | ++ |
+ #' teal.slice:::calls_combine_by(calls, "&")+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @return a combined `call`+ |
+
| 22 | ++ |
+ #' @keywords internal+ |
+
| 23 | ++ |
+ calls_combine_by <- function(calls, operator) {
+ |
+
| 24 | +46x | +
+ checkmate::assert_list(calls)+ |
+
| 25 | +44x | +
+ if (length(calls) > 0L) checkmate::assert_list(calls, types = c("call", "name"))
+ |
+
| 26 | +45x | +
+ checkmate::assert_string(operator)+ |
+
| 27 | ++ | + + | +
| 28 | +43x | +
+ calls <- Filter(x = calls, f = Negate(is.null))+ |
+
| 29 | ++ | + + | +
| 30 | +43x | +
+ Reduce(+ |
+
| 31 | +43x | +
+ x = calls,+ |
+
| 32 | +43x | +
+ f = function(x, y) call(operator, x, y)+ |
+
| 33 | ++ |
+ )+ |
+
| 34 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' @title `FilterStates` subclass for `MultiAssayExperiments`+ |
+
| 2 | ++ |
+ #' @description Handles filter states in a `MultiAssayExperiment`+ |
+
| 3 | ++ |
+ #' @keywords internal+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ MAEFilterStates <- R6::R6Class( # nolint+ |
+
| 7 | ++ |
+ classname = "MAEFilterStates",+ |
+
| 8 | ++ |
+ inherit = FilterStates,+ |
+
| 9 | ++ |
+ public = list(+ |
+
| 10 | ++ |
+ # public methods ----+ |
+
| 11 | ++ | + + | +
| 12 | ++ |
+ #' @description Initializes `MAEFilterStates` object+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' Initialize `MAEFilterStates` object+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param data (`MultiAssayExperiment`)\cr+ |
+
| 17 | ++ |
+ #' the R object which `MultiAssayExperiment::subsetByColData` function is applied on.+ |
+
| 18 | ++ |
+ #' @param data_reactive (`function(sid)`)\cr+ |
+
| 19 | ++ |
+ #' should return a `MultiAssayExperiment` object or `NULL`.+ |
+
| 20 | ++ |
+ #' This object is needed for the `FilterState` counts being updated+ |
+
| 21 | ++ |
+ #' on a change in filters. If function returns `NULL` then filtered counts are not shown.+ |
+
| 22 | ++ |
+ #' Function has to have `sid` argument being a character.+ |
+
| 23 | ++ |
+ #' @param dataname (`character(1)`)\cr+ |
+
| 24 | ++ |
+ #' name of the data used in the expression+ |
+
| 25 | ++ |
+ #' specified to the function argument attached to this `FilterStates`.+ |
+
| 26 | ++ |
+ #' @param datalabel (`NULL` or `character(1)`)\cr+ |
+
| 27 | ++ |
+ #' text label value+ |
+
| 28 | ++ |
+ #' @param varlabels (`character`)\cr+ |
+
| 29 | ++ |
+ #' labels of the variables used in this object+ |
+
| 30 | ++ |
+ #' @param keys (`character`)\cr+ |
+
| 31 | ++ |
+ #' key columns names+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ initialize = function(data,+ |
+
| 34 | ++ |
+ data_reactive = function(sid = "") NULL,+ |
+
| 35 | ++ |
+ dataname,+ |
+
| 36 | ++ |
+ datalabel = "subjects",+ |
+
| 37 | ++ |
+ keys = character(0)) {
+ |
+
| 38 | +28x | +
+ if (!requireNamespace("MultiAssayExperiment", quietly = TRUE)) {
+ |
+
| 39 | +! | +
+ stop("Cannot load MultiAssayExperiment - please install the package or restart your session.")
+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | +28x | +
+ checkmate::assert_function(data_reactive, args = "sid")+ |
+
| 42 | +28x | +
+ checkmate::assert_class(data, "MultiAssayExperiment")+ |
+
| 43 | +27x | +
+ data <- SummarizedExperiment::colData(data)+ |
+
| 44 | +27x | +
+ data_reactive <- function(sid = "") SummarizedExperiment::colData(data_reactive(sid = sid))+ |
+
| 45 | +27x | +
+ super$initialize(data, data_reactive, dataname, datalabel)+ |
+
| 46 | +27x | +
+ private$keys <- keys+ |
+
| 47 | +27x | +
+ private$set_filterable_varnames(include_varnames = colnames(data))+ |
+
| 48 | +27x | +
+ return(invisible(self))+ |
+
| 49 | ++ |
+ }+ |
+
| 50 | ++ |
+ ),+ |
+
| 51 | ++ | + + | +
| 52 | ++ |
+ # private fields ----+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ private = list(+ |
+
| 55 | ++ |
+ extract_type = "list",+ |
+
| 56 | ++ |
+ fun = quote(MultiAssayExperiment::subsetByColData)+ |
+
| 57 | ++ |
+ )+ |
+
| 58 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' Store teal_slices object to a file+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' This function takes a `teal_slices` object and saves it to a file in `JSON` format.+ |
+
| 4 | ++ |
+ #' The `teal_slices` object contains information about filter states and can be used to+ |
+
| 5 | ++ |
+ #' create, modify, and delete filter states. The saved file can be later loaded using+ |
+
| 6 | ++ |
+ #' the `slices_restore` function.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param tss (`teal_slices`) object to be stored.+ |
+
| 9 | ++ |
+ #' @param file (`character(1)`) The file path where `teal_slices` object will be saved.+ |
+
| 10 | ++ |
+ #' The file extension should be `".json"`.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return `NULL`, invisibly.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examples+ |
+
| 15 | ++ |
+ #' # Create a teal_slices object+ |
+
| 16 | ++ |
+ #' tss <- teal_slices(+ |
+
| 17 | ++ |
+ #' teal_slice(dataname = "data", varname = "var"),+ |
+
| 18 | ++ |
+ #' teal_slice(dataname = "data", expr = "x > 0", id = "positive_x", title = "Positive x")+ |
+
| 19 | ++ |
+ #' )+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' if (interactive()) {
+ |
+
| 22 | ++ |
+ #' # Store the teal_slices object to a file+ |
+
| 23 | ++ |
+ #' slices_store(tss, "path/to/file.json")+ |
+
| 24 | ++ |
+ #' }+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @export+ |
+
| 27 | ++ |
+ slices_store <- function(tss, file) {
+ |
+
| 28 | +! | +
+ checkmate::assert_class(tss, "teal_slices")+ |
+
| 29 | +! | +
+ checkmate::assert_path_for_output(file, overwrite = TRUE, extension = "json")+ |
+
| 30 | ++ | + + | +
| 31 | +! | +
+ cat(format(tss, trim_lines = FALSE), "\n", file = file)+ |
+
| 32 | ++ |
+ }+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ #' Restore teal_slices object from a file+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' This function takes a file path to a `JSON` file containing a `teal_slices` object+ |
+
| 37 | ++ |
+ #' and restores it to its original form. The restored `teal_slices` object can be used+ |
+
| 38 | ++ |
+ #' to access filter states and their corresponding attributes.+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @param file Path to file where `teal_slices` is stored. Must have a `.json` extension and read access.+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @return A `teal_slices` object restored from the file.+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @examples+ |
+
| 45 | ++ |
+ #' if (interactive()) {
+ |
+
| 46 | ++ |
+ #' # Restore a teal_slices object from a file+ |
+
| 47 | ++ |
+ #' tss_restored <- slices_restore("path/to/file.json")
+ |
+
| 48 | ++ |
+ #' }+ |
+
| 49 | ++ |
+ #' @export+ |
+
| 50 | ++ |
+ slices_restore <- function(file) {
+ |
+
| 51 | +! | +
+ checkmate::assert_file_exists(file, access = "r", extension = "json")+ |
+
| 52 | ++ | + + | +
| 53 | +! | +
+ tss_json <- jsonlite::fromJSON(file, simplifyDataFrame = FALSE)+ |
+
| 54 | ++ | + + | +
| 55 | +! | +
+ tss_elements <- lapply(tss_json$slices, as.teal_slice)+ |
+
| 56 | ++ | + + | +
| 57 | +! | +
+ do.call(teal_slices, c(tss_elements, tss_json$attributes))+ |
+
| 58 | ++ |
+ }+ |
+
"+y.value+"