issue with filtering dataframe using multiple dropdowns in Shiny

[SKC]

I am currently working with a data set that is not too large (about 30,000 rows and 81 columns). I am trying to build a shiny app that subsets the dataframe based on 4 total choices (conditionally, so first filter subsets the dataframe based on the choice, only showing choices in the second dropdown that match that filter condition, and so on for the rest of the filters ) and then outputs a few tables.

(I apologize before hand for the long question and error outputs)

As of now I have built an app that works on occasion but fails in most cases. Either the R session is terminated or the after a couple of choices the app stops responding or takes extremely long to populate the subsequent menu items to choose from, eventually freezing. I am not able to figure out what the error is. Below is my app

I can share the data if needed.

ui_4 = pageWithSidebar(
    headerPanel("Data overview with 4 filters "),
    sidebarPanel(
      uiOutput("status"),   ###### these are the four filters
      uiOutput("region"),
      uiOutput("country"),
      uiOutput("serial")
      
    ),
    
    mainPanel(
      tableOutput("table")
    )
  )

server_4 = function(input, output) {

  
  ####### Choosing first variable (status)
  output$status <- renderUI({ selectizeInput('var1', 'Select Status', choices = c("Choose" = "", wo_rev_21_small$status))}) #####wo_rev_21_small is my dataframe
  

  ###### second choice (region)
  output$region <- renderUI({ 
    choice_region <- reactive({
      wo_rev_21_small %>% 
        filter(status == input$var1) %>% 
        pull(region)})
    
    selectizeInput('var2', 'Select region', choices = c("Choose" = "", choice_region()))})
   

  ###### Third choice (country)
  output$country <- renderUI({ 
    choice_country <- reactive({
      wo_rev_21_small %>% 
        filter(status == input$var1) %>% 
        filter(region == input$var2) %>%
        pull(country)})
    
    selectizeInput('var3', 'Select Country', choices = c("Choose" = "", choice_country()))})
  
  
  ##### Select variable 3 (serial)
  output$serial <- renderUI({
    choice_sl <- reactive({
      wo_rev_21_small %>% 
        filter(status == input$var1) %>% 
        filter(region == input$var2) %>% 
        filter(country == input$var3) %>%
        pull(serial)}) 
    selectizeInput('var4', 'Select  serial ', choices = c("select" = "", choice_sl()))
    
  })
  
  
  tab <- reactive({    ###### This is where I subset the dataframe based on choices
    
    wo_rev_21_small %>% 
      filter(status == input$var1) %>% 
      filter(region == input$var2) %>% 
      filter(country == input$var3) %>% 
      filter(serial == input$var4) 
  })
  
  
  output$table <- renderTable({ tab() })
  
  
}


shinyApp(ui_4, server_4)

The filter does not work (or does not load quickly and correctly)most cases or if one or two levels of filters load, the rest dont, or takes extremely long time by the time I get through the choice from the drop down.

A snapshot of the command window in R studio is below

Warning: The select input "var1" contains a large number of options; consider using server-side selectize for massively improved performance. See the Details section of the ?selectizeInput help topic.
Warning: Error in filter: Problem while computing `..1 = status == input$var1`.
x Input `..1` must be of size 25545 or 1, not size 0.
  141: <Anonymous>
Warning: Error in filter: Problem while computing `..1 = status == input$var1`.
x Input `..1` must be of size 25545 or 1, not size 0.
  142: <Anonymous>
Warning: Error in filter: Problem while computing `..1 = status == input$var1`.
x Input `..1` must be of size 25545 or 1, not size 0.
  143: <Anonymous>
Warning: Error in filter: Problem while computing `..1 = status == input$var1`.
x Input `..1` must be of size 25545 or 1, not size 0.
  135: <Anonymous>
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
Warning: The select input "var2" contains a large number of options; consider using server-side selectize for massively improved performance. See the Details section of the ?selectizeInput help topic.
Warning: Error in filter: Problem while computing `..1 = region == input$var2`.
x Input `..1` must be of size 17208 or 1, not size 0.
  141: <Anonymous>
Warning: Error in filter: Problem while computing `..1 = region == input$var2`.
x Input `..1` must be of size 17208 or 1, not size 0.
  142: <Anonymous>
Warning: Error in filter: Problem while computing `..1 = region == input$var2`.
x Input `..1` must be of size 17208 or 1, not size 0.
  134: <Anonymous>
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
Warning: The select input "var3" contains a large number of options; consider using server-side selectize for massively improved performance. See the Details section of the ?selectizeInput help topic.
Warning: Error in filter: Problem while computing `..1 = country == input$var3`.
x Input `..1` must be of size 17178 or 1, not size 0.
  141: <Anonymous>
Warning: Error in filter: Problem while computing `..1 = country == input$var3`.
x Input `..1` must be of size 17178 or 1, not size 0.
  133: <Anonymous>
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.
Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON.

As the output screen shows these warning and errors are the same for each variable as I select from the dropdown menu.
How can this be fixed? I dont think 30,000 rows is large enough to slow down the output by that much.
I have a feeling it is something to do with the way I am filtering/subsetting the data frame.
Is there a solution for this/a better way to do this?

If you have got this far, thanks for patiently going through my problem!!!!!

Thanks for any help in advance.

[nirgrahamuk]

I only glanced at your code, but to me having reactive() definitions nested within renderUI's is a major mistake, the code should be written to eliminate such nesting.

[SKC]

Thanks for your reply @nirgrahamuk . I have tried multiple ways to do this. this is the only way so far that has given me an output that is sort of close to what I am looking for.

I will try your solution and let you know in any case

[SKC]

Can I pick your brain once more @nirgrahamuk ? I am stuck at what I think is the final step

I have now figured out the filtering process and I can now conditionally filter the dataset based on choice 1 -> choice2-> choice3 and so on.

The code is below

ui_temp = shinyUI({
  sidebarPanel(size = 2,
    
    htmlOutput("region_selector"),
    htmlOutput("country_selector"),
    htmlOutput("serial_selection"))

})


server_temp =shinyServer(function(input, output) {
 
  output$region_selector <- renderUI({
    
    selectInput(
      inputId = "region", 
      label = "Select Region",
      choices = ((wo_rev_21$region)))
    
  })
  
  output$country_selector <- renderUI({
    
    available <- wo_rev_21[wo_rev_21$region == input$region, "country"]
    
    selectInput(
      inputId = "country", 
      label = "Select Country:",
      choices = (available),
      selected = (available)[1])
    
  })
  
  output$serial_selection <- renderUI({
    
    available <-  wo_rev_21[wo_rev_21$country == input$country, "serial"]
    
    selectInput(
      inputId = "serial", 
      label = "Select IP:",
      choices = (available),
      selected = (available)[1])
    
  })
 })

shinyApp(ui_temp, server_temp)

Now is there anyway to extract the object (data frame) being passed to output$serial_selection (the final filter? maybe by wrapping the final filter in a reactive object or some other way?
I would like to perform some operations on this final dataframe that has been subset based on this filtering process.

Or is my entire approach wrong and do I need to find another way to go about filtering and extracting the final dataframe I need?

[ismirsehregal]

Can you please share the output of dput(wo_rev_21_small)?

[nirgrahamuk]

here is one way. I used mpg as example data, and I did 3 levels rather than 4. but its just a case of adding more

library(shiny)
library(tidyverse)


ui <- pageWithSidebar(
  headerPanel("Data overview with 3 filters "),
  sidebarPanel(
    uiOutput("manufacturer"), ###### these are the four filters
    uiOutput("model"),
    uiOutput("trans")
  ),
  mainPanel(
    tableOutput("table")
  )
)

server <- function(input, output) {


  ####### Choosing first variable (status)
  output$manufacturer <- renderUI({
    selectizeInput("var1", "Select Manu",
      choices = c("Choose" = "", unique(mpg$manufacturer))
    )
  })

  f1 <- reactive({

    iv1 <- input$var1
    if(isTruthy(iv1))
    return(mpg %>%
      filter(manufacturer == iv1))
    NULL
  })

  ###### second choice (model)
  output$model <- renderUI({

    lf1 <- req(f1())

    selectizeInput("var2",
      "Select model",
      choices = c(
        "Choose" = "",
        unique(pull(lf1, model))
      )
    )
  })

  f2 <- reactive({
    iv2 <- input$var2
    if (isTruthy(iv2) & isTruthy(f1())) {
      return(f1() %>%
               filter(model == iv2))
    }
    NULL
  })



  ###### third choice (trans)
  output$trans <- renderUI({
    lf2 <- req(f2())
    selectizeInput("var3",
      "Select trans",
      choices = c(
        "Choose" = "",
        req(unique(pull(lf2, trans)))
      )
    )
  })

  tab <- reactive({
    iv3 <- input$var3
    if (isTruthy(iv3) & isTruthy(f2())) {
      return(f2() %>%
        filter(trans == iv3))
    }
    NULL
  })




  output$table <- renderTable({

    if (isTruthy(tab())) {
      return(tab())
    }
    if (isTruthy(f2())) {
      return(f2())
    }
    if (isTruthy(f1())) {
      return(f1())
    }
    mpg
  })
}


shinyApp(ui, server)

[ismirsehregal]

Due to the lack of example data: building up on @nirgrahamuk's mpg example.

There are two points I'd like to bring up:

1. As mentioned in the first warning you pasted above, for a large number of options consider using server-side selectize for massively improved performance.
   Please see this related article:

https://shiny.rstudio.com/articles/selectize.html

2. For a fast and responsive app try to avoid renderUI and use update* functions in the server part instead (avoids re-rendering and goes hand in hand with point 1)

Please check the following:

library(shiny)
library(ggplot2) # mpg {ggplot2} # Fuel economy data from 1999 to 2008 for 38 popular models of cars

ui <- pageWithSidebar(
  headerPanel("Data overview with 3 filters "),
  sidebarPanel(
    selectizeInput(inputId = "manufacturer", label = "Select manufacturer", choices = NULL),
    conditionalPanel(
      condition = "input.manufacturer!= null && input.manufacturer!= ''",
      style = "display: none;",
      selectizeInput(inputId = "model", label = "Select model", choices = NULL)
    ),
    conditionalPanel(
      condition = "input.model!= null && input.model!= ''",
      style = "display: none;",
      selectizeInput(inputId = "trans", label = "Select type of transmission", choices = NULL)
    )
  ),
  mainPanel(tableOutput("table"))
)

server <- function(input, output, session) {
  filterVars <- c("manufacturer", "model", "trans")
  freezeReactiveValue(input, "manufacturer")
  updateSelectizeInput(session, 'manufacturer', choices = c("", unique(mpg$manufacturer)), selected = "", server = TRUE)
  
  filteredData <- reactive({
    tmpDF <- mpg
    for(var in filterVars){
      if(isTruthy(input[[var]])){
        filteredTmpDF <- with(tmpDF, tmpDF[get(var) %in% input[[var]],])
        if(nrow(filteredTmpDF) > 0){
          tmpDF <- filteredTmpDF
        }
      }
    }
    tmpDF
  })
  
  observeEvent(input$manufacturer, {
    updateSelectizeInput(session, 'model', choices = c("", unique(filteredData()$model)), selected = "", server = TRUE)
  })
  
  observeEvent(input$model, {
    updateSelectizeInput(session, 'trans', choices = c("", unique(filteredData()$trans)), selected = "", server = TRUE)
  })
  
  output$table <- renderTable({
    filteredData()
  })
}

shinyApp(ui, server)

[SKC]

Thanks for your responses and all your help @nirgrahamuk and @ismirsehregal .

The solution I have worked out is as follows.

I am using selectInput on the server side now. The filtering is fast and output so far is as expected.

below is the snapshot of the solution. If you think this is a valid solution do let me know I will mark it as a solution.

ui = pageWithSidebar(
  headerPanel("Test"),
  sidebarPanel(
    htmlOutput("status_Selector"),
    htmlOutput("region_selector"),
    htmlOutput("country_selector"),
    htmlOutput("who_selector"),
    htmlOutput("serial_selection")    
  ),  
  mainPanel(
    tableOutput("table"),
    tableOutput("table2"),
    tableOutput("table3"),
    tableOutput("table4")
  )
)

server =function(input, output) {  
  output$status_Selector <- renderUI({    
    selectInput(
      inputId = "status", 
      label = "Select status",
      choices = ((wo_rev_21$status)))    
  })
  
  output$region_selector <- renderUI({    
    available <- wo_rev_21[wo_rev_21$tatus == input$status, "region"]    
    selectInput(
      inputId = "region", 
      label = "Select region:",
      choices = (available),
      selected = (available)[1])    
  })
    
  output$country_selector <- renderUI({    
    available <- wo_rev_21[wo_rev_21$region == input$region, "country"]    
    selectInput(
      inputId = "country", 
      label = "Select Country:",
      choices = (available),
      selected = (available)[1])    
  })
  
  output$client_selector <- renderUI({    
    available <-  wo_rev_21[wo_rev_21$country == input$country, "who"]    
    selectInput(
      inputId = "who", 
      label = "Select who:",
      choices = (available),
      selected = (available)[1])    
  })
  output$IP_selection <- renderUI({    
    available <-  wo_rev_21[wo_rev_21$who == input$who, "ip_serial_number"]    
    selectInput(
      inputId = "serial", 
      label = "Select serial:",
      choices = (available),
      selected = (available)[1])    
  })
  
#####getting the final  dataframe that has been subset based on the 5 filters
  tab = reactive({
    wo_rev_21[][wo_rev_21$ip_serial_number %in% input$serial,]  
  })
  
#### I then create  5 more dataframes, and perform operations using tab() as the reactive object containing the final dataframe that has been subset. 

#####I am only sharing one table as a instance to keep this relatively small.  I can share all if requested

  dataframe1 = reactive({ data.frame("client" = tab()$who[1],
                                     "status" = tab()$status[1],
                                     "location" = tab()$country[1],
                                     "region" = tab()$region[1],
                                     "ip" = tab()who[1],
                                     "slno" = tab()$serial[1],
                                     "date" = tab()$date[1],
                                     "start" = tab()$start[1])
    
  })
  
  output$table = renderTable({dataframe1()},
                             striped = TRUE, bordered = TRUE,  
                             hover = TRUE, spacing = 'm',  
                             rownames = TRUE,  
                             na = 'missing')
}

shinyApp(ui, server)

Thanks for all your help again!!