R Shiny bi-directional reactive progressive filtering

[Garrick McComas]

I'm pulling a large dataset down into a Shiny app that I only want to pull once with a reactive function and one mandatory filter. Using the reactiveUI framework, I then want to be able to do progressive filtering on the dataset with a combination of several independent selectizeInput(s) such that the available choices are dictated by the selectizeInput(s) already selected. The kicker is that I'm trying to do this without stipulating any order of operations to the filtering, such that any combination of applied inputs would in turn inform available choices in the other available inputs. I'd also like for the user to get back to the original unfiltered dataset by simply clearing inputs.

In the script below, I've simulated this process with one "mandatory" filter that has to be applied before the full dataset is pulled into Shiny nested in a reactive function. The resultant dataset is then nested in another reactive function where the optional and progressive filtering takes place.

Currently the script momentarily applies a filter before reverting to the full dataset, implying that either some sort of recursion is taking place or the initial reactive function that generates the large dataset is being triggered. I've come across a lot of notes about the use of "isolate" that might be of help here, but I haven't been able to figure out how it might be applied in this case. I'm sure the answer to my issue is buried in some post, but I'm having a very difficult time determining how to fix this issue. I would be most grateful for any help!

library(shiny)

library(dplyr)

library(ggplot2)

ui <- fluidPage(

    

    fluidRow(

        # control panel

        column(

            # initial input required to query large dataset

            numericInput(

                inputId = "min_year",

                label = "Select Min Model Year",

                min = 1999,

                max = 2008,

                value = 2000

            ),

            # progressive manufacturer filter

            uiOutput("manufacturer_control"),

            # progressive transmission filter

            uiOutput("trans_control"),

            # progressive compact filter

            uiOutput("cyl_control"),

            width = 2

        ),

        # display table

        column(

            tableOutput("table"),

            width = 10

        )

    )

)

server <- function(input, output) {

    

    # reactive function to pull down large dataset once

    mpg_all <- reactive({

        

        ggplot2::mpg %>% filter(year >= input$min_year)

    })

    

    # reactive filtering on large dataset that progressively narrows input choices

    mpg_fltr <- reactive({

        mpg_fltr <- mpg_all()

        

        if (!is.null(input$manufacturer)) {

            mpg_fltr <- filter(mpg_fltr, manufacturer %in% input$maufacturer)

        }

        

        if (!is.null(input$trans)) {

            mpg_fltr <- filter(mpg_fltr, trans %in% input$trans)

        }

        if (!is.null(input$cyl)) {

            mpg_fltr <- filter(mpg_fltr, cyl %in% input$cyl)

        }

        mpg_fltr

    })

    

    # create manufacturer input

    output$manufacturer_control <- renderUI({

        selectizeInput(

            inputId = "manufacturer",

            label = "Select Manufacturers",

            choices = mpg_fltr()$manufacturer,

            multiple = TRUE

        )

    })

    

    # create transmission input

    output$trans_control <- renderUI({

        selectizeInput(

            inputId = "trans",

            label = "Select Transmissions",

            choices = mpg_fltr()$trans,

            multiple = TRUE

        )

    })

    

    # create cylinder count input

    output$cyl_control <- renderUI({

        selectizeInput(

            inputId = "cyl",

            label = "Select Cylinder Count",

            choices = mpg_fltr()$cyl,

            multiple = TRUE

        )

    })

    

    # display results in table

    output$table <- renderTable({

        head(mpg_fltr(), 20)

    })

}

shinyApp(ui = ui, server = server)

[Joe Cheng]

Try taking a look at my example. https://gist.github.com/jcheng5/76cffbbdd9db0b0e971fd34f575fa45b This is an inherently tricky problem, whether you're using reactive or imperative primitives; as exemplified by this comment in my gist:

  # 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.)

--
You received this message because you are subscribed to the Google Groups "Shiny - Web Framework for R" group.
To unsubscribe from this group and stop receiving emails from it, send an email to shiny-discus...@googlegroups.com.
To view this discussion on the web visit https://groups.google.com/d/msgid/shiny-discuss/0a2868ba-bee1-459f-9b83-58d8336374e7%40googlegroups.com.
For more options, visit https://groups.google.com/d/optout.

[Garrick McComas]

Thanks a bunch Joe! There is a bunch of functionality in here I haven't used yet so it will take me a while to parse apart what you've done here, but this looks like it does exactly what I'm looking for. I really appreciate your help.

[Garrick McComas]

The script you suggested I look at is really impressive and incredibly flexible, but I'm having a very hard time breaking it down into it's component parts...the interdependency of each of the modules makes it difficult for me to determine what the order of operations is. I don't suppose you have a more minimal example you could offer, or if there is anyway to adapt the example code I submitted initially to achieve the same functionality. If not, please don't worry about it and again thanks very much for your time.

[Joe Cheng]

The columnFilterUI, columnFilter, and columnFilterSet code should be lifted into your example as-is; the columnFilterSetUI should be rewritten if you want the select inputs to be laid out differently. These pieces are designed to be reusable (as Shiny Modules). I think this is as minimal and modular as such an app is possible to get, without compromising the user experience. I know it still looks pretty complex.

--
You received this message because you are subscribed to the Google Groups "Shiny - Web Framework for R" group.
To unsubscribe from this group and stop receiving emails from it, send an email to shiny-discus...@googlegroups.com.

To view this discussion on the web visit https://groups.google.com/d/msgid/shiny-discuss/854831cd-7c96-46df-b568-d02fd5471606%40googlegroups.com.

[Garrick McComas]

Thanks very much Joe. This is my first foray in using Shiny modules and this has been a really good learning experience to start leveraging them, if a somewhat ambitious place to start. I really appreciate your input and thanks very much for putting this together.

On Friday, June 2, 2017 at 9:15:34 AM UTC-4, Garrick McComas wrote:

[Garrick McComas]

I've been messing around with the filters.R that you posted back in February of this year and I was wondering if you could recommend how to implement a "Clear All" or reset mechanism to the framework. I'd like to be able to introduce an action button that clears all the current_values filters. Any suggestions?

[Bernie Lindner]

Hi Garrick

below is my proposed way of having a "clear all filters" button, it's not pretty but works

library(shiny)


columnFilterUI <- function(id) {
    ns <- NS(id)
    uiOutput(ns("filter_container"))
}


columnFilter <- function(input, output, session, df, col_num, choice_filter, reset=F) {
   
    if(reset){
        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
        req(col_num <= ncol(df()))
       
        freezeReactiveValue(input, "filter_value")
        selectInput(session$ns("filter_value"), names(df())[[col_num]],
                    choices = sort(unique(df()[,col_num,drop=TRUE])),
                    multiple = 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
       
        updateSelectInput(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
        }
    })
}


columnFilterSetUI <- function(id, maxcol, colwidth) {
    ns <- NS(id)
    fluidRow(
        lapply(1:maxcol, function(i) {
            column(colwidth,
                   columnFilterUI(ns(paste0("col", i)))
            )
        })
        ,actionButton(ns("clear_all_filters_button"), "clear")
    )
}


columnFilterSet <- function(input, output, session, df, maxcol) {
   
    # Each column filter needs to only display the choices that are
    # permitted after all the OTHER filters have had their say. But
    # each column filter must not take its own filter into account
    # (hence we do filter[-col], not filter, in the reactive below).
    create_choice_filter <- function(col) {
        reactive({
            filter_values <- lapply(filters[-col], do.call, args = list())
            Reduce(`&`, filter_values, TRUE)
        })
    }
   
    observeEvent(input$clear_all_filters_button, {
        cat("clear", "\n")
        filters <- lapply(1:maxcol, function(i) {
            callModule(columnFilter, paste0("col", i), df= df, col_num =i, create_choice_filter(i), reset=T)
        })
    })
   
    # filters is a list of reactive expressions, each of which is a
    # logical vector of rows to be selected.
    filters <- lapply(1:maxcol, function(i) {
        callModule(columnFilter, paste0("col", i), df, i, create_choice_filter(i))
    })
   
    reactive({
        # Unpack the list of reactive expressions to a list of logical vectors
        filter_values <- lapply(filters, do.call, args = list())
        # Combine all the logical vectors using & operator
        selected_rows <- Reduce(`&`, filter_values, TRUE)
        # Return the data frame, filtered by the selected rows
        df()[selected_rows,]
    })
}


ui <- fluidPage(
    selectInput("dataset", "Dataset", c("mtcars", "pressure", "cars"), selected = "mtcars"),
    columnFilterSetUI("filterset", maxcol = 4, colwidth = 3),
    DT::dataTableOutput("table")
)


server <- function(input, output, session) {
    selected_data <- reactive({
        get(input$dataset, "package:datasets")
    })
   
    filtered_data <- callModule(columnFilterSet, "filterset", df = selected_data, maxcol = 4)
   
    output$table <- DT::renderDataTable({ filtered_data() })
}


shinyApp(ui, server)