R/data_extract_filter_module.R

In teal.transform: Functions for Extracting and Merging Data in the 'teal' Framework

#' Returns a `shiny.tag` object with the UI for a `filter_spec` object
#'
#' @details Creates two `optionSelectInput` elements (one for column and one for values) based
#' on a definition of a [filter_spec()] object.
#'
#' @param filter (`filter_spec`) the object generated with [filter_spec()].
#' @param id (`character(1)`) the shiny `inputId` for the generated `shiny.tag`.
#'
#' @return `shiny.tag` defining the `filter_spec`'s UI element.
#'
#' @keywords internal
#'
data_extract_filter_ui <- function(filter, id = "filter") {
  checkmate::assert_class(filter, "filter_spec")
  checkmate::assert_string(id)

  ns <- NS(id)

  html_col <- teal.widgets::optionalSelectInput(
    inputId = ns("col"),
    label = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_label),
    choices = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_choices),
    selected = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$vars_selected),
    multiple = filter$vars_multiple,
    fixed = filter$vars_fixed
  )

  html_vals <- teal.widgets::optionalSelectInput(
    inputId = ns("vals"),
    label = filter$label,
    choices = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$choices),
    selected = `if`(inherits(filter, "delayed_filter_spec"), NULL, filter$selected),
    multiple = filter$multiple,
    fixed = filter$fixed
  )

  div(
    class = "filter_spec",
    if (filter$vars_fixed) shinyjs::hidden(html_col) else html_col,
    html_vals
  )
}

#' Handles events emitted from the UI generated by `data_extract_filter_ui`
#'
#' @note This shiny module server updates the values of the `vals`
#' [teal.widgets::optionalSelectInput()] widget.
#' It's responsible for setting the initial values and the subsequent updates to
#' the `vals` widget based on the input of the `col` widget.
#'
#' @param id (`character`) id string.
#' @param datasets (`named list`) a list of reactive `data.frame` type objects.
#' @param filter (`filter_spec`) the filter generated by a call to [filter_spec()].
#'
#' @return `NULL`, invisibly.
#'
#' @keywords internal
#'
data_extract_filter_srv <- function(id, datasets, filter) {
  checkmate::assert_list(datasets, types = "reactive", names = "named")
  moduleServer(
    id,
    function(input, output, session) {
      # We force the evaluation of filter, otherwise the observers are set up with the last element
      # of the list in data_extract_single_srv and not all of them (due to R lazy evaluation)
      force(filter)
      logger::log_trace("data_extract_filter_srv initialized with: { filter$dataname } dataset.")

      isolate({
        # when the filter is initialized with a delayed spec, the choices and selected are NULL
        # here delayed are resolved and the values are set up
        teal.widgets::updateOptionalSelectInput(
          session = session,
          inputId = "col",
          choices = filter$vars_choices,
          selected = filter$vars_selected
        )
        teal.widgets::updateOptionalSelectInput(
          session = session,
          inputId = "vals",
          choices = filter$choices,
          selected = filter$selected
        )
      })

      observeEvent(
        input$col,
        ignoreInit = TRUE, # When observeEvent is initialized input$col is still NULL as it is set few lines above
        ignoreNULL = FALSE, # columns could be NULL, then vals should be set to NULL also
        handlerExpr = {
          if (!rlang::is_empty(input$col)) {
            choices <- value_choices(
              datasets[[filter$dataname]](),
              input$col,
              `if`(isTRUE(input$col == attr(filter$choices, "var_choices")), attr(filter$choices, "var_label"), NULL)
            )

            selected <- if (!is.null(filter$selected)) {
              filter$selected
            } else if (filter$multiple) {
              choices
            } else {
              choices[1]
            }
          } else {
            choices <- character(0)
            selected <- character(0)
          }
          dn <- filter$dataname
          fc <- paste(input$col, collapse = ", ")
          logger::log_trace("data_extract_filter_srv@1 filter dataset: { dn }; filter var: { fc }.")
          # In order to force reactivity we run two updates: (i) set up dummy values (ii) set up appropriate values
          # It's due to a missing reactivity triggers if new selected value is identical with previously selected one.
          teal.widgets::updateOptionalSelectInput(
            session = session,
            inputId = "vals",
            choices = paste0(input$val, "$_<-_random_text_to_ensure_val_will_be_different_from_previous"),
            selected = paste0(input$val, "$_<-_random_text_to_ensure_val_will_be_different_from_previous")
          )

          teal.widgets::updateOptionalSelectInput(
            session = session,
            inputId = "vals",
            choices = choices,
            selected = selected
          )
        }
      )
    }
  )
}

#' Returns the initial values for the `vals` widget of a `filter_spec` object
#'
#' @inheritParams data_extract_filter_srv
#'
#' @return named `list` with two slots `choices` and `selected`.
#'
#' @keywords internal
#'
get_initial_filter_values <- function(filter, datasets) {
  initial_values <- list()
  if (is.null(filter$vars_selected)) {
    initial_values$choices <- character(0)
    initial_values$selected <- character(0)
  } else if (is.null(filter$choices)) {
    initial_values$choices <- value_choices(
      datasets[[filter$dataname]](),
      as.character(filter$vars_selected)
    )
    initial_values$selected <- if (inherits(filter$selected, "all_choices")) {
      initial_values$choices
    } else {
      filter$selected
    }
  } else {
    initial_values$choices <- filter$choices
    initial_values$selected <- filter$selected
  }

  initial_values
}