R/columnFilterUI.R

In stephLH/shiny.filter: Easily set bidirectionnal (cascading) filters to a table

#' columnFilterUI
#'
#' @param id \dots
#' @param inline \dots
#'
#' @export
columnFilterUI <- function(id, inline) {
  ns <- shiny::NS(id)
  if (inline == TRUE) {
    div(style="display: inline-block;", shiny::uiOutput(ns("filter_container")))
  } else {
    shiny::uiOutput(ns("filter_container"))
  }

}

#' columnFilter
#'
#' @param input \dots
#' @param output \dots
#' @param session \dots
#' @param df \dots
#' @param col_num \dots
#' @param col_name \dots
#' @param choice_filter \dots
#' @param reset \dots
#'
#' @export
columnFilter <- function(input, output, session, df, col_num, col_name, choice_filter, reset=F) {

  if (reset) {

    shiny::updateSelectInput(session, "filter_value",
                      choices = sort(unique(df()[,col_num,drop=TRUE])),
                      selected = NULL)

  } else {

    # This renders a selectInput and only re-renders when the selected data
    # frame changes. (i.e. it doesn't re-render when filters change state.)
    output$filter_container <- renderUI({
      # Don't render if col_num is > actual number of cols
      shiny::req(col_num <= ncol(df()))

      shiny::freezeReactiveValue(input, "filter_value")

      choices <- sort(unique(df()[,col_num,drop=TRUE]))

      shinyWidgets::pickerInput(session$ns("filter_value"), col_name, multiple = T,
                                choices = choices,
                                options = list(`actions-box` = T, `select-all-text` = "Tout sélectionner",
                                               `deselect-all-text` = "Tout désélectionner",
                                               `none-selected-text` = "Aucune sélection",
                                               `live-search` = TRUE))

    })

    # When the other filters change, update this filter to remove rows that
    # are filtered out by the other filters' criteria. (We also add in the
    # currently selected values for this filter, so that changing other
    # filters does not cause this filter's selected values to be unselected;
    # while that behavior might make sense logically, it's a poor user
    # experience.)
    observeEvent(choice_filter(), {

      current_values <- input$filter_value

      shinyWidgets::updatePickerInput(session, "filter_value",
                                      choices = sort(unique(c(current_values, df()[choice_filter(),col_num,drop=TRUE]))),
                                      selected = current_values
      )

    })

  }

  # Return a reactive that is a row index of selected rows, according to
  # just this filter. If this filter shouldn't be taken into account
  # because its col_num is too high, or if there are no values selected,
  # just return TRUE to accept all rows.
  reactive({
    if (col_num > ncol(df())) {
      TRUE
    } else if (!isTruthy(input$filter_value)) {
      TRUE
    } else {
      df()[,col_num,drop=TRUE] %in% input$filter_value
    }
  })
}