R/FilterStateChoices.R

In teal.slice: Filter Module for 'teal' Applications

# ChoicesFilterState ------

#' @name ChoicesFilterState
#' @docType class
#'
#' @title `FilterState` object for categorical data
#'
#' @description Manages choosing elements from a set.
#'
#' @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")
#' ChoicesFilterState <- getFromNamespace("ChoicesFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- ChoicesFilterState$new(
#'   x = c(LETTERS, NA),
#'   slice = teal_slice(varname = "var", dataname = "data")
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#'   teal_slice(
#'     dataname = "data",
#'     varname = "var",
#'     selected = "A",
#'     keep_na = TRUE
#'   )
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' data_choices <- c(sample(letters[1:4], 100, replace = TRUE), NA)
#' attr(data_choices, "label") <- "lowercase letters"
#' fs <- ChoicesFilterState$new(
#'   x = data_choices,
#'   slice = teal_slice(
#'     dataname = "data", varname = "variable", selected = c("a", "c"), 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("ChoicesFilterState"),
#'     fs$ui("fs")
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#'     textOutput("condition_choices"), tags$br(),
#'     tags$h4("Unformatted state"), # display raw filter state
#'     textOutput("unformatted_choices"), tags$br(),
#'     tags$h4("Formatted state"), # display human readable filter state
#'     textOutput("formatted_choices"), tags$br()
#'   )),
#'   column(4, tags$div(
#'     tags$h4("Programmatic filter control"),
#'     actionButton("button1_choices", "set drop NA", width = "100%"), tags$br(),
#'     actionButton("button2_choices", "set keep NA", width = "100%"), tags$br(),
#'     actionButton("button3_choices", "set selection: a, b", width = "100%"), tags$br(),
#'     actionButton("button4_choices", "deselect all", width = "100%"), tags$br(),
#'     actionButton("button0_choices", "set initial state", width = "100%"), tags$br()
#'   ))
#' )
#'
#' server <- function(input, output, session) {
#'   fs$server("fs")
#'   output$condition_choices <- renderPrint(fs$get_call())
#'   output$formatted_choices <- renderText(fs$format())
#'   output$unformatted_choices <- renderPrint(fs$get_state())
#'   # modify filter state programmatically
#'   observeEvent(
#'     input$button1_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", keep_na = FALSE)
#'     )
#'   )
#'   observeEvent(
#'     input$button2_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", keep_na = TRUE)
#'     )
#'   )
#'   observeEvent(
#'     input$button3_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = c("a", "b"))
#'     )
#'   )
#'   observeEvent(
#'     input$button4_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = character(0), keep_na = TRUE)
#'     )
#'   )
#'   observeEvent(
#'     input$button0_choices,
#'     fs$set_state(
#'       teal_slice(dataname = "data", varname = "variable", selected = c("a", "c"), keep_na = TRUE)
#'     )
#'   )
#' }
#'
#' if (interactive()) {
#'   shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
ChoicesFilterState <- R6::R6Class( # nolint
  "ChoicesFilterState",
  inherit = FilterState,

  # public methods ----

  public = list(

    #' @description
    #' Initialize a `FilterState` object.
    #'
    #' @param x (`character`)
    #'   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 `ChoicesFilterState`, invisibly.
    #'
    initialize = function(x,
                          x_reactive = reactive(NULL),
                          slice,
                          extract_type = character(0)) {
      isolate({
        checkmate::assert(
          is.character(x),
          is.factor(x),
          length(unique(x[!is.na(x)])) < getOption("teal.threshold_slider_vs_checkboxgroup"),
          combine = "or"
        )
        super$initialize(
          x = x,
          x_reactive = x_reactive,
          slice = slice,
          extract_type = extract_type
        )
        private$set_choices(slice$choices)
        if (is.null(slice$selected) && slice$multiple) {
          slice$selected <- private$get_choices()
        } else if (is.null(slice$selected)) {
          slice$selected <- private$get_choices()[1]
        } else if (length(slice$selected) > 1 && !slice$multiple) {
          warning(
            "ChoicesFilterState allows \"selected\" to be of length 1 when \"multiple\" is FALSE. ",
            "Only the first value will be used."
          )
          slice$selected <- slice$selected[1]
        }
        private$set_selected(slice$selected)
        if (inherits(x, "POSIXt")) {
          private$tzone <- Find(function(x) x != "", attr(as.POSIXlt(x), "tzone"))
        }
      })
      invisible(self)
    },

    #' @description
    #' Returns reproducible condition call for current selection.
    #' For this class returned call looks like
    #' `<varname> %in% c(<values selected>)` with optional `is.na(<varname>)`.
    #' @param dataname (`character(1)`) name of data set; defaults to `private$get_dataname()`
    #' @return `call` or `NULL`
    #'
    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_choices()
      selected <- private$get_selected()
      fun_compare <- if (length(selected) == 1L) "==" else "%in%"
      filter_call <- if (length(selected) == 0) {
        call("!", call(fun_compare, varname, make_c_call(as.character(choices))))
      } else {
        if (setequal(selected, choices) && !private$is_choice_limited) {
          NULL
        } else if (inherits(private$x, "Date")) {
          call(fun_compare, varname, call("as.Date", make_c_call(as.character(selected))))
        } else if (inherits(private$x, c("POSIXct", "POSIXlt"))) {
          class <- class(private$x)[1L]
          date_fun <- as.name(
            switch(class,
              "POSIXct" = "as.POSIXct",
              "POSIXlt" = "as.POSIXlt"
            )
          )
          call(
            fun_compare,
            varname,
            as.call(list(date_fun, make_c_call(as.character(selected)), tz = private$tzone))
          )
        } else if (is.numeric(private$x)) {
          call(fun_compare, varname, make_c_call(as.numeric(selected)))
        } else {
          # This handles numerics, characters, and factors.
          call(fun_compare, varname, make_c_call(selected))
        }
      }
      private$add_keep_na_call(filter_call, varname)
    }
  ),

  # private members ----
  private = list(
    x = NULL,
    choices_counts = integer(0),
    tzone = character(0), # if x is a datetime, stores time zone so that it can be restored in $get_call

    # private methods ----

    # @description
    # Checks validity of the choices, adjust if neccessary and sets the flag for the case where choices
    #  are limited by default from the start.
    set_choices = function(choices) {
      ordered_counts <- .table(private$x)
      possible_choices <- names(ordered_counts)
      if (is.null(choices)) {
        choices <- possible_choices
      } else {
        choices <- as.character(choices)
        choices_adjusted <- choices[choices %in% possible_choices]
        if (length(setdiff(choices, choices_adjusted)) > 0L) {
          warning(
            sprintf(
              "Some choices not found in data. Adjusting. Filter id: %s.",
              private$get_id()
            )
          )
          choices <- choices_adjusted
        }
        if (length(choices) == 0) {
          warning(
            sprintf(
              "None of the choices were found in data. Setting defaults. Filter id: %s.",
              private$get_id()
            )
          )
          choices <- possible_choices
        }
      }
      private$set_choices_counts(unname(ordered_counts[choices]))
      private$set_is_choice_limited(possible_choices, choices)
      private$teal_slice$choices <- choices
      invisible(NULL)
    },
    # @description
    # Check whether the initial choices filter out some values of x and set the flag in case.
    set_is_choice_limited = function(x, choices) {
      xl <- x[!is.na(x)]
      private$is_choice_limited <- length(setdiff(xl, choices)) > 0L
      invisible(NULL)
    },
    # @description
    # Sets choices_counts private field.
    set_choices_counts = function(choices_counts) {
      private$choices_counts <- choices_counts
      invisible(NULL)
    },
    # @description
    # Checks whether the input should be rendered as a checkboxgroup/radiobutton or a drop-down.
    is_checkboxgroup = function() {
      length(private$get_choices()) <= getOption("teal.threshold_slider_vs_checkboxgroup")
    },
    cast_and_validate = function(values) {
      tryCatch(
        expr = {
          values <- as.character(values)
          if (anyNA(values)) stop()
        },
        error = function(e) stop("The vector of set values must contain values coercible to character.")
      )
      values
    },
    # 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
    },
    remove_out_of_bounds_values = function(values) {
      in_choices_mask <- values %in% private$get_choices()
      if (length(values[!in_choices_mask]) > 0) {
        warning(paste(
          "Values:", toString(values[!in_choices_mask], width = 360),
          "are not in choices of column", private$get_varname(), "in dataset", private$get_dataname(), "."
        ))
      }
      values[in_choices_mask]
    },

    # shiny modules ----

    # @description
    # UI Module for `ChoicesFilterState`.
    # 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)

      # we need to isolate UI to not rettrigger renderUI
      isolate({
        countsmax <- private$choices_counts
        countsnow <- if (!is.null(private$x_reactive())) {
          unname(
            .table(private$x_reactive())[private$get_choices()]
          )
        }

        ui_input <- if (private$is_checkboxgroup()) {
          labels <- countBars(
            inputId = ns("labels"),
            choices = private$get_choices(),
            countsnow = countsnow,
            countsmax = countsmax
          )
          tags$div(
            class = "choices_state",
            if (private$is_multiple()) {
              checkboxGroupInput(
                inputId = ns("selection"),
                label = NULL,
                selected = private$get_selected(),
                choiceNames = labels,
                choiceValues = private$get_choices(),
                width = "100%"
              )
            } else {
              radioButtons(
                inputId = ns("selection"),
                label = NULL,
                selected = private$get_selected(),
                choiceNames = labels,
                choiceValues = private$get_choices(),
                width = "100%"
              )
            }
          )
        } else {
          labels <- mapply(
            FUN = make_count_text,
            label = private$get_choices(),
            countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,
            countmax = countsmax
          )

          teal.widgets::optionalSelectInput(
            inputId = ns("selection"),
            choices = stats::setNames(private$get_choices(), labels),
            selected = private$get_selected(),
            multiple = private$is_multiple(),
            options = shinyWidgets::pickerOptions(
              actionsBox = TRUE,
              liveSearch = (length(private$get_choices()) > 10),
              noneSelectedText = "Select a value"
            )
          )
        }
        tags$div(
          uiOutput(ns("trigger_visible")),
          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) {
          logger::log_trace("ChoicesFilterState$server_inputs initializing, id: { private$get_id() }")

          # 1. renderUI is used here as an observer which triggers only if output is visible
          #  and if the reactive changes - reactive triggers only if the output is visible.
          # 2. We want to trigger change of the labels only if reactive count changes (not underlying data)
          non_missing_values <- reactive(Filter(Negate(is.na), private$x_reactive()))
          output$trigger_visible <- renderUI({
            logger::log_trace("ChoicesFilterState$server_inputs@1 updating count labels, id: { private$get_id() }")

            countsnow <- if (!is.null(private$x_reactive())) {
              unname(
                .table(non_missing_values())[private$get_choices()]
              )
            }

            # update should be based on a change of counts only
            isolate({
              if (private$is_checkboxgroup()) {
                updateCountBars(
                  inputId = "labels",
                  choices = private$get_choices(),
                  countsmax = private$choices_counts,
                  countsnow = countsnow
                )
              } else {
                labels <- mapply(
                  FUN = make_count_text,
                  label = private$get_choices(),
                  countnow = if (is.null(countsnow)) rep(list(NULL), length(private$get_choices())) else countsnow,
                  countmax = private$choices_counts
                )
                teal.widgets::updateOptionalSelectInput(
                  session = session,
                  inputId = "selection",
                  choices = stats::setNames(private$get_choices(), labels),
                  selected = private$get_selected()
                )
              }
              NULL
            })
          })

          if (private$is_checkboxgroup()) {
            private$observers$selection <- observeEvent(
              ignoreNULL = FALSE,
              ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
              eventExpr = input$selection,
              handlerExpr = {
                logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")

                selection <- if (is.null(input$selection) && private$is_multiple()) {
                  character(0)
                } else {
                  input$selection
                }

                private$set_selected(selection)
              }
            )
          } else {
            private$observers$selection <- observeEvent(
              ignoreNULL = FALSE,
              ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
              eventExpr = input$selection_open, # observe click on a dropdown
              handlerExpr = {
                if (!isTRUE(input$selection_open)) { # only when the dropdown got closed
                  logger::log_trace("ChoicesFilterState$server_inputs@2 changed selection, id: { private$get_id() }")

                  selection <- if (is.null(input$selection) && private$is_multiple()) {
                    character(0)
                  } else if (isTRUE(length(input$selection) != 1) && !private$is_multiple()) {
                    # In optionalSelectInput user is able to select mutliple options. But if FilterState is not multiple
                    # we should prevent this selection to be processed further.
                    # This is why notification is thrown and dropdown is changed back to latest selected.
                    showNotification(paste(
                      "This filter exclusively supports single selection.",
                      "Any additional choices made will be disregarded."
                    ))
                    teal.widgets::updateOptionalSelectInput(
                      session, "selection",
                      selected = private$get_selected()
                    )
                    return(NULL)
                  } else {
                    input$selection
                  }
                  private$set_selected(selection)
                }
              }
            )
          }


          private$keep_na_srv("keep_na")

          # 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
          private$observers$selection_api <- observeEvent(private$get_selected(), {
            # it's important to not retrigger when the input$selection is the same as reactive values
            # kept in the teal_slice$selected
            if (!setequal(input$selection, private$get_selected())) {
              logger::log_trace("ChoicesFilterState$server@1 state changed, id: { private$get_id() }")
              if (private$is_checkboxgroup()) {
                if (private$is_multiple()) {
                  updateCheckboxGroupInput(
                    inputId = "selection",
                    selected = private$get_selected()
                  )
                } else {
                  updateRadioButtons(
                    inputId = "selection",
                    selected = private$get_selected()
                  )
                }
              } else {
                teal.widgets::updateOptionalSelectInput(
                  session, "selection",
                  selected = private$get_selected()
                )
              }
            }
          })

          logger::log_trace("ChoicesFilterState$server_inputs initialized, id: { private$get_id() }")
          NULL
        }
      )
    },
    server_inputs_fixed = function(id) {
      moduleServer(
        id = id,
        function(input, output, session) {
          logger::log_trace("ChoicesFilterState$server_inputs_fixed initializing, id: { private$get_id() }")

          output$selection <- renderUI({
            countsnow <- if (!is.null(private$x_reactive())) {
              unname(
                .table(private$x_reactive())[private$get_choices()]
              )
            }
            countsmax <- private$choices_counts

            ind <- private$get_choices() %in% isolate(private$get_selected())
            countBars(
              inputId = session$ns("labels"),
              choices = isolate(private$get_selected()),
              countsnow = countsnow[ind],
              countsmax = countsmax[ind]
            )
          })

          logger::log_trace("ChoicesFilterState$server_inputs_fixed initialized, id: { private$get_id() }")
          NULL
        }
      )
    },

    # @description
    # UI module to display filter summary
    #  renders text describing number of selected levels
    #  and if NA are included also
    content_summary = function(id) {
      selected <- private$get_selected()
      selected_text <-
        if (length(selected) == 0L) {
          "no selection"
        } else {
          if (sum(nchar(selected)) <= 40L) {
            paste(selected, collapse = ", ")
          } else {
            paste(length(selected), "levels selected")
          }
        }
      tagList(
        tags$span(
          class = "filter-card-summary-value",
          selected_text
        ),
        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"))
          }
        )
      )
    }
  )
)

#' `table` handling `POSIXlt`
#'
#' @param x (`vector`) variable to get counts from.
#' @return vector of counts named by unique values of `x`.
#'
#' @keywords internal
.table <- function(x) {
  table(
    if (is.factor(x)) {
      x
    } else {
      as.character(x)
    }
  )
}