Nothing
# LogicalFilterState ------
#' @name LogicalFilterState
#' @docType class
#'
#' @title `FilterState` object for logical data
#'
#' @description Manages choosing a logical state.
#'
#' @examples
#' # use non-exported function from teal.slice
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
#' LogicalFilterState <- getFromNamespace("LogicalFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- LogicalFilterState$new(
#' x = sample(c(TRUE, FALSE, NA), 10, replace = TRUE),
#' slice = teal_slice(varname = "x", dataname = "data")
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#' teal_slice(dataname = "data", varname = "x", selected = TRUE, keep_na = TRUE)
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' data_logical <- c(sample(c(TRUE, FALSE), 10, replace = TRUE), NA)
#' fs <- LogicalFilterState$new(
#' x = data_logical,
#' slice = teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)
#' )
#'
#' ui <- fluidPage(
#' useShinyjs(),
#' include_css_files(pattern = "filter-panel"),
#' include_js_files(pattern = "count-bar-labels"),
#' column(4, tags$div(
#' tags$h4("LogicalFilterState"),
#' fs$ui("fs")
#' )),
#' column(4, tags$div(
#' id = "outputs", # div id is needed for toggling the element
#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#' textOutput("condition_logical"), tags$br(),
#' tags$h4("Unformatted state"), # display raw filter state
#' textOutput("unformatted_logical"), tags$br(),
#' tags$h4("Formatted state"), # display human readable filter state
#' textOutput("formatted_logical"), tags$br()
#' )),
#' column(4, tags$div(
#' tags$h4("Programmatic filter control"),
#' actionButton("button1_logical", "set drop NA", width = "100%"), tags$br(),
#' actionButton("button2_logical", "set keep NA", width = "100%"), tags$br(),
#' actionButton("button3_logical", "set a selection", width = "100%"), tags$br(),
#' actionButton("button0_logical", "set initial state", width = "100%"), tags$br()
#' ))
#' )
#'
#' server <- function(input, output, session) {
#' fs$server("fs")
#' output$condition_logical <- renderPrint(fs$get_call())
#' output$formatted_logical <- renderText(fs$format())
#' output$unformatted_logical <- renderPrint(fs$get_state())
#' # modify filter state programmatically
#' observeEvent(
#' input$button1_logical,
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#' )
#' observeEvent(
#' input$button2_logical,
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#' )
#' observeEvent(
#' input$button3_logical,
#' fs$set_state(teal_slice(dataname = "data", varname = "x", selected = TRUE))
#' )
#' observeEvent(
#' input$button0_logical,
#' fs$set_state(
#' teal_slice(dataname = "data", varname = "x", selected = FALSE, keep_na = TRUE)
#' )
#' )
#' }
#'
#' if (interactive()) {
#' shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
LogicalFilterState <- R6::R6Class( # nolint
"LogicalFilterState",
inherit = FilterState,
# public methods ----
public = list(
#' @description
#' Initialize a `FilterState` object.
#'
#' @param x (`logical`)
#' variable to be filtered.
#' @param x_reactive (`reactive`)
#' returning vector of the same type as `x`. Is used to update
#' counts following the change in values of the filtered dataset.
#' If it is set to `reactive(NULL)` then counts based on filtered
#' dataset are not shown.
#' @param slice (`teal_slice`)
#' specification of this filter state.
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
#' `get_state` returns `teal_slice` object which can be reused in other places.
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
#' @param extract_type (`character`)
#' specifying whether condition calls should be prefixed by `dataname`. Possible values:
#' - `character(0)` (default) `varname` in the condition call will not be prefixed
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
#'
#' @return Object of class `LogicalFilterState`, invisibly.
#'
initialize = function(x,
x_reactive = reactive(NULL),
extract_type = character(0),
slice) {
isolate({
checkmate::assert_logical(x)
checkmate::assert_logical(slice$selected, null.ok = TRUE)
super$initialize(x = x, x_reactive = x_reactive, slice = slice, extract_type = extract_type)
private$set_choices(slice$choices)
if (is.null(slice$multiple)) slice$multiple <- FALSE
if (is.null(slice$selected) && slice$multiple) {
slice$selected <- private$get_choices()
} else if (length(slice$selected) != 1 && !slice$multiple) {
slice$selected <- TRUE
}
private$set_selected(slice$selected)
df <- factor(x, levels = c(TRUE, FALSE))
tbl <- table(df)
private$set_choices_counts(tbl)
})
invisible(self)
},
#' @description
#' Returns reproducible condition call for current selection.
#' For `LogicalFilterState` it's a `!<varname>` or `<varname>` and optionally `is.na(<varname>)`
#' @param dataname name of data set; defaults to `private$get_dataname()`
#' @return `call`
#'
get_call = function(dataname) {
if (isFALSE(private$is_any_filtered())) {
return(NULL)
}
if (missing(dataname)) dataname <- private$get_dataname()
varname <- private$get_varname_prefixed(dataname)
choices <- private$get_selected()
n_choices <- length(choices)
filter_call <-
if (n_choices == 1 && choices) {
varname
} else if (n_choices == 1 && !choices) {
call("!", varname)
} else {
call("%in%", varname, make_c_call(choices))
}
private$add_keep_na_call(filter_call, varname)
}
),
# private members ----
private = list(
choices_counts = integer(0),
# private methods ----
set_choices = function(choices) {
private$teal_slice$choices <- c(TRUE, FALSE)
invisible(NULL)
},
# @description
# Sets choices_counts private field
set_choices_counts = function(choices_counts) {
private$choices_counts <- choices_counts
invisible(NULL)
},
cast_and_validate = function(values) {
tryCatch(
expr = {
values <- as.logical(values)
if (anyNA(values)) stop()
values
},
error = function(e) stop("Vector of set values must contain values coercible to logical.")
)
},
# If multiple forbidden but selected, restores previous selection with warning.
check_length = function(values) {
if (!private$is_multiple() && length(values) > 1) {
warning(
sprintf("Selection: %s is not a vector of length one. ", toString(values, width = 360)),
"Maintaining previous selection."
)
values <- isolate(private$get_selected())
}
values
},
# Answers the question of whether the current settings and values selected actually filters out any values.
# @return logical scalar
is_any_filtered = function() {
if (private$is_choice_limited) {
TRUE
} else if (all(private$choices_counts > 0)) {
TRUE
} else if (
setequal(private$get_selected(), private$get_choices()) &&
!anyNA(private$get_selected(), private$get_choices())
) {
TRUE
} else if (!isTRUE(private$get_keep_na()) && private$na_count > 0) {
TRUE
} else {
FALSE
}
},
# shiny modules ----
# @description
# UI Module for `EmptyFilterState`.
# This UI element contains available choices selection and
# checkbox whether to keep or not keep the `NA` values.
# @param id (`character(1)`) `shiny` module instance id.
ui_inputs = function(id) {
ns <- NS(id)
isolate({
countsmax <- private$choices_counts
countsnow <- if (!is.null(private$x_reactive())) {
unname(table(factor(private$x_reactive(), levels = private$get_choices())))
} else {
NULL
}
labels <- countBars(
inputId = ns("labels"),
choices = as.character(private$get_choices()),
countsnow = countsnow,
countsmax = countsmax
)
ui_input <- if (private$is_multiple()) {
checkboxGroupInput(
inputId = ns("selection"),
label = NULL,
selected = isolate(as.character(private$get_selected())),
choiceNames = labels,
choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
width = "100%"
)
} else {
radioButtons(
inputId = ns("selection"),
label = NULL,
selected = isolate(as.character(private$get_selected())),
choiceNames = labels,
choiceValues = factor(as.character(private$get_choices()), levels = c("TRUE", "FALSE")),
width = "100%"
)
}
tags$div(
tags$div(
class = "choices_state",
uiOutput(ns("trigger_visible"), inline = TRUE),
ui_input
),
private$keep_na_ui(ns("keep_na"))
)
})
},
# @description
# Server module
# @param id (`character(1)`) `shiny` module instance id.
# @return `NULL`.
server_inputs = function(id) {
moduleServer(
id = id,
function(input, output, session) {
# this observer is needed in the situation when teal_slice$selected has been
# changed directly by the api - then it's needed to rerender UI element
# to show relevant values
non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))
output$trigger_visible <- renderUI({
logger::log_trace("LogicalFilterState$server@1 updating count labels, id: { private$get_id() }")
countsnow <- if (!is.null(private$x_reactive())) {
unname(table(factor(non_missing_values(), levels = private$get_choices())))
} else {
NULL
}
updateCountBars(
inputId = "labels",
choices = as.character(private$get_choices()),
countsmax = private$choices_counts,
countsnow = countsnow
)
NULL
})
private$observers$seleted_api <- observeEvent(
ignoreNULL = !private$is_multiple(),
ignoreInit = TRUE,
eventExpr = private$get_selected(),
handlerExpr = {
if (!setequal(private$get_selected(), input$selection)) {
logger::log_trace("LogicalFilterState$server@1 state changed, id: { private$get_id() }")
if (private$is_multiple()) {
updateCheckboxGroupInput(
inputId = "selection",
selected = private$get_selected()
)
} else {
updateRadioButtons(
inputId = "selection",
selected = private$get_selected()
)
}
}
}
)
private$observers$selection <- observeEvent(
ignoreNULL = FALSE,
ignoreInit = TRUE,
eventExpr = input$selection,
handlerExpr = {
logger::log_trace("LogicalFilterState$server@2 selection changed, id: { private$get_id() }")
# for private$is_multiple() == TRUE input$selection will always have value
if (is.null(input$selection) && isFALSE(private$is_multiple())) {
selection_state <- private$get_selected()
} else {
selection_state <- as.logical(input$selection)
}
if (is.null(selection_state)) {
selection_state <- logical(0)
}
private$set_selected(selection_state)
}
)
private$keep_na_srv("keep_na")
logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
NULL
}
)
},
server_inputs_fixed = function(id) {
moduleServer(
id = id,
function(input, output, session) {
logger::log_trace("LogicalFilterState$server initializing, id: { private$get_id() }")
output$selection <- renderUI({
countsnow <- unname(table(factor(private$x_reactive(), levels = private$get_choices())))
countsmax <- private$choices_counts
ind <- private$get_choices() %in% private$get_selected()
countBars(
inputId = session$ns("labels"),
choices = private$get_selected(),
countsnow = countsnow[ind],
countsmax = countsmax[ind]
)
})
logger::log_trace("LogicalFilterState$server initialized, id: { private$get_id() }")
NULL
}
)
},
# @description
# Server module to display filter summary
# renders text describing whether TRUE or FALSE is selected
# and if NA are included also
content_summary = function(id) {
tagList(
tags$span(
class = "filter-card-summary-value",
toString(private$get_selected())
),
tags$span(
class = "filter-card-summary-controls",
if (private$na_count > 0) {
tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
}
)
)
}
)
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.