Bugs with large dataframe filters & view in R shiny

[Mos_Taf]

I'm trying do make a shiny application with interdependant selectInput() , it seems to work fine with a "little" dataframe but crash with a "large" dataframe. Here is my example, with two dataframes : First, you can launch the application with the two dataframe, just comment the one you dont want to show in output. Is it a problem with performance, I have to use data.table ? or it's updateSelectInput() functions problem ?

library(shiny)
library(dplyr)
library(DT)

# df <- tibble(LETTERS = rep(LETTERS, 2), Numbers = as.character(1:52),
#              letters = paste(LETTERS, Numbers, sep = ""))

df <- tibble(LETTERS = rep(LETTERS, 1000), Numbers = as.character(1:(26*1000)),
             letters = paste(LETTERS, Numbers, sep = ""))

ui <- fluidPage(

  titlePanel("Title"),

  sidebarLayout(
    sidebarPanel(width=3,
                 selectInput("filter1", "Filter 1", multiple = TRUE, choices = c(unique(df$LETTERS))),
                 selectInput("filter2", "Filter 2", multiple = TRUE, choices = c(unique(df$Numbers))),
                 selectInput("filter3", "Filter 3", multiple = TRUE, choices = c(unique(df$letters)))),

    mainPanel(
      DT::dataTableOutput("tableprint")
    )
  )
)

server <- function(input, output, session) {


  goButton <- reactive({
    # Data

    df1 <- df

    if (length(input$filter1)){
      df1 <- df1[which(df1$LETTERS %in% input$filter1),]
    }

    # Update selectInput choices based on the filtered data. Update 'selected' to reflect the user input.
    updateSelectInput(session, "filter1", choices = c("All", df$LETTERS), selected = input$filter1)
    updateSelectInput(session, "filter2", choices = c("All", df1$Numbers), selected = input$filter2)



    if (length(input$filter2)){
      df1 <- df1[which(df1$Numbers %in% input$filter2),]
    }
    updateSelectInput(session, "filter3", choices = c("All", df1$letters), selected = input$filter3)
    updateSelectInput(session, "filter1", choices = c("All", df1$LETTERS), selected = input$filter1)

    if (length(input$filter3)){
      df1 <- df1[which(df1$letters %in% input$filter3),]
    }
    updateSelectInput(session, "filter1", choices = c("All", df1$LETTERS), selected = input$filter1)
    updateSelectInput(session, "filter2", choices = c("All", df1$Numbers), selected = input$filter2)


    datatable(df1)
  })

  output$tableprint <- DT::renderDataTable({
    goButton()

  })
}

shinyApp(ui, server)

I tried the same example with a textOutput() function to show dimension of the output dataframe and get some issues, I think it's a bug with the updateSelectInput function

[lxy009]

26K rows is not large enough to cause a slow down in tibble.
its that there's too many choices in the select inputs.
you're asking the web browser to render 26K options in the dropdown menu.
maybe shiny is adding to that overhead but i would bet that's the root of the problem.

also, look at your updateSelectInput( .... choices=c("All", df$LETTERS ... and similar lines.
make sure that's what you really want and not unique(df$LETTERS).

[Mos_Taf]

Thanks @lexy009, 26k option is too large for a browser ? But a select input doesnt show all the modalities only some of them isnt it ?
I compared this solution with below solution and I noticed that the updateselectinput() function is not adapted in my case

[Mos_Taf]

I tried this with a different exemple seems to work but not really beautiful .. do you think I can improve this ?

df <- structure(list(Continent = c("Africa", "Africa", "Asia", "Asia",
"Asia", "Asia", "Asia", "Asia", "Asia", "Asia", "Asia", "Asia",
"Asia", "Asia", "Asia", "Asia", "Asia", "Asia", "Europe", "Europe",
"Europe", "Europe", "Europe", "Europe", "Europe", "Europe", "Europe",
"Europe", "Europe", "Europe", "Europe", "Europe", "Europe", "Europe",
"Europe", "Europe", "Europe", "Europe", "Europe", "Europe", "Europe",
"Europe", "Europe", "North America", "North America", "North America",
"North America", "North America", "North America", "North America",
"North America", "North America", "North America", "North America",
"North America", "North America", "North America", "North America",
"North America", "North America", "North America", "North America",
"Oceania", "Oceania", "Oceania", "Oceania", "Oceania", "Oceania",
"Oceania", "Oceania", "Oceania", "Oceania", "Oceania", "Oceania",
"Oceania", "Oceania", "South America", "South America", "South America",
"South America", "South America", "South America", "South America",
"South America", "South America", "South America", "South America",
"South America"), Country = c("Algeria", "Angola", "India", "India",
"India", "India", "India", "India", "India", "India", "Cambodia",
"Iraq", "Israel", "Japan", "Jordan", "Pakistan", "Philippines",
"Qatar", "Belgium", "Bosnia and Herzegovina", "Bulgaria", "Croatia",
"Cyprus", "Czech Republic", "Denmark", "Estonia", "Finland",
"France", "Georgia", "Monaco", "Montenegro", "Netherlands", "Norway",
"Poland", "Portugal", "Romania", "San Marino", "Serbia", "Slovakia",
"Slovenia", "Spain", "Sweden", "Switzerland", "United States",
"United States", "United States", "United States", "United States",
"United States", "United States", "United States", "United States",
"United States", "United States", "United States", "United States",
"United States", "Panama", "Saint Kitts and Nevis", "Saint Lucia",
"Saint Vincent and the Grenadines", "Trinidad and Tobago", "Australia",
"Fiji", "Kiribati", "Marshall Islands", "Micronesia", "Nauru",
"New Zealand", "Palau", "Papua New Guinea", "Samoa", "Solomon Islands",
"Tonga", "Tuvalu", "Vanuatu", "Argentina", "Bolivia", "Brazil",
"Chile", "Colombia", "Ecuador", "Guyana", "Paraguay", "Peru",
"Suriname", "Uruguay", "Venezuela"), State = c("State_Algeria",
"State_Angola", "Andhra Pradesh", "Arunachal Pradesh", "Assam",
"Bihar", "Chhattisgarh", "Goa", "Gujarat", "Haryana", "State_Cambodia",
"State_Iraq", "State_Israel", "State_Japan", "State_Jordan",
"State_Pakistan", "State_Philippines", "State_Qatar", "State_Belgium",
"State_Bosnia and Herzegovina", "State_Bulgaria", "State_Croatia",
"State_Cyprus", "State_Czech Republic", "State_Denmark", "State_Estonia",
"State_Finland", "State_France", "State_Georgia", "State_Monaco",
"State_Montenegro", "State_Netherlands", "State_Norway", "State_Poland",
"State_Portugal", "State_Romania", "State_San Marino", "State_Serbia",
"State_Slovakia", "State_Slovenia", "State_Spain", "State_Sweden",
"State_Switzerland", "Alabama", "Alaska", "Arizona", "Arkansas",
"California", "Colorado", "Connecticut", "Delaware", "District of Columbia",
"Florida", "Georgia", "Hawaii", "Idaho", "Iowa", "State_Panama",
"State_Saint Kitts and Nevis", "State_Saint Lucia", "State_Saint Vincent and the Grenadines",
"State_Trinidad and Tobago", "State_Australia", "State_Fiji",
"State_Kiribati", "State_Marshall Islands", "State_Micronesia",
"State_Nauru", "State_New Zealand", "State_Palau", "State_Papua New Guinea",
"State_Samoa", "State_Solomon Islands", "State_Tonga", "State_Tuvalu",
"State_Vanuatu", "State_Argentina", "State_Bolivia", "State_Brazil",
"State_Chile", "State_Colombia", "State_Ecuador", "State_Guyana",
"State_Paraguay", "State_Peru", "State_Suriname", "State_Uruguay",
"State_Venezuela"), Population = c(436315, 322788, 84665533,
1382611, 31169272, 103804637, 25540196, 1457723, 60383628, 25353081,
943256, 91267, 536097, 420799, 287888, 980889, 792094, 702230,
334450, 118410, 515967, 398281, 659918, 216675, 133583, 176648,
131878, 941740, 860759, 783373, 188232, 835066, 59606, 992782,
377751, 720217, 982980, 56697, 644305, 391579, 352490, 143215,
90170, 817644, 743157, 572583, 595467, 749073, 527312, 914680,
843229, 978792, 589096, 705171, 750524, 579311, 566931, 800722,
427156, 753354, 153684, 557458, 987445, 675226, 115191, 664896,
619308, 274021, 363655, 85848, 66679, 513121, 427450, 985883,
250922, 406122, 379940, 790470, 300293, 106926, 383729, 851993,
860519, 607444, 776975, 961911, 769912, 979218)), row.names = c(NA, -88L), class = c("tbl_df", "tbl", "data.frame"))

library(shiny)
library(readxl)
library(shinydashboard)
library(dplyr)
library(DT)

is.not.null <- function(x) !is.null(x)

header <- dashboardHeader(
title = "Test",
dropdownMenu(type = "notifications",
notificationItem(
text = "RAS",
icon("cog", lib = "glyphicon")
)
)
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Data", tabName = "ShowData", icon = icon("dashboard")),
menuItem("Summary", tabName = "ShowSummary", icon = icon("bar-chart-o"))
)
)

body <- dashboardBody(
tabItems(
tabItem(tabName = "ShowData",
DT::dataTableOutput("table")
),
tabItem(tabName = "ShowSummary",
box(width =3,
h3("Test"),
helpText("Please Continent, Country and State Combition"),
uiOutput("continent"),
uiOutput("country"),
uiOutput("state")
),

        box(width =9,
            DT::dataTableOutput("table_subset")
        )
)

)
)

ui = dashboardPage(
header,
sidebar,
body
)

################################################
################################################

server = shinyServer(function(input,output){

data <- bind_rows(replicate(5500, df, simplify = FALSE))

output$table <- DT::renderDataTable({
if(is.null(data)){return()}
DT::datatable(data, options = list(scrollX = T))
})

output$continent <- renderUI({
selectInput(inputId = "Continent", "Select Continent",choices = c("all", var_continent()), multiple = T)
})
output$country <- renderUI({
selectInput(inputId = "Country", "Select Country",choices = c("all", var_country()), multiple = T)
})
output$state <- renderUI({
selectInput(inputId = "State", "Select State",choices = c("all", var_state()), multiple = T)
})

var_continent <- reactive({
file1 <- data
if(is.null(data)){return()}
as.list(c("all", unique(file1$Continent)))
})

continent_function <- reactive({
file1 <- data
continent <- input$Continent
continent <<- input$Continent
if (is.null(continent)){
return(file1)
} else {
file2 <- file1 %>%
filter(Continent %in% continent)
return (file2)
}

})

var_country <- reactive({
file1 <- continent_function()
continent <- input$Continent
file2 <- data

if(is.null(continent)){
  as.list(unique(file2$Country))
} else {
  as.list(unique(file1$Country))
}

})

country_function <- reactive({
file1 <- data
country <- input$Country
country <<- input$Country
if (is.null(country)){
return(file1)
} else {
file2 <- file1 %>%
filter(Country %in% country)
return (file2)
}

})

var_state <- reactive({
file1 <- country_function()
country <- input$Country
file2 <- data

if(is.null(country)){
  as.list(unique(file2$State))
} else {
  as.list(unique(file1$State))
}

})

state_function <- reactive({
file1 <- data
state <- input$State
state <<- input$State
if (is.null(state)){
return(file1)
} else {
file2 <- file1 %>%
filter(State %in% state)
return (file2)
}

})

df <- reactive({

file1 <- data
continent <- input$Continent
country <- input$Country
state <- input$State

if (is.null(continent) & is.not.null(country) & is.not.null(state)){
  file2 <- file1 %>%
    filter(Country %in% country, State %in% state)
} else if (is.null(country) & is.not.null(continent) & is.not.null(state)){
  file2 <- file1 %>%
    filter(State %in% state, Continent %in% continent)
} else if (is.null(state) & is.not.null(country) & is.not.null(continent)){
  file2 <- file1 %>%
    filter(Country %in% country, Continent %in% continent)
} else if (is.null(continent) & is.null(country) & is.not.null(state)){
  file2 <- file1 %>%
    filter(State %in% state)
} else if (is.null(continent) & is.null(state) & is.not.null(country)){
  file2 <- file1 %>%
    filter(Country %in% country)
} else if (is.null(country) & is.null(state) & is.not.null(continent)){
  file2 <- file1 %>%
    filter(Continent %in% continent)
} else {
  file2 <- file1 %>%
    filter(Country %in% country, State %in% state, Continent %in% continent)
}
file2

})

output$table_subset <- DT::renderDataTable({
# validate(
# need(input$Continent, 'Check that'),
# need(input$Country, 'Please choose :)')
# need(input$State, 'Please choose :D')
# )
DT::datatable(df(), options = list(scrollX = T))

})

})

shinyApp(ui, server)

[hadley]

I found the logic in your app rather hard to follow because you're doing everything in one giant reactive — this initially made me wonder if you'd accidentally created an infinite loop, but a bit of experimentation with the reactlog verified that this wasn't the case.

To make it easier to understand what's going on, I reduce the number of inputs to two, and used multiple reactives and observers to isolate the key idea:

library(shiny)

grid <- expand.grid(x = LETTERS, y = seq_len(1e5))
n <- 1e4
df <- grid[sort(sample(nrow(grid), n)), , drop = FALSE]

selected <- function(col, input) {
  if (length(input) == 0) {
    rep(TRUE, length(col))
  } else {
    col %in% input
  }
}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectInput("x", "x", multiple = TRUE, choices = unique(df$x)),
      selectInput("y", "y", multiple = TRUE, choices = unique(df$y)),
    ),
    mainPanel(
      tableOutput("table")
    )
  )
)

server <- function(input, output, session) {
  x_sel <- reactive(selected(df$x, input$x))
  y_sel <- reactive(selected(df$y, input$y))
  df_sel <- reactive(df[x_sel() & y_sel(), , drop = FALSE])
  
  observeEvent(x_sel(), {
    updateSelectInput(session, "y", choices = unique(df_sel()$y), selected = input$y)
  })
  observeEvent(y_sel(), {
    updateSelectInput(session, "x", choices = unique(df_sel()$x), selected = input$x)
  })
  
  output$table <- renderTable({
    head(df_sel(), 20)
  })
}

shinyApp(ui, server)

Playing around with this suggests that @lxy009's diagnosis is correct: as you select more letters in x, it takes longer and longer to update. This is because you're sending more and more data to the browser. It would probably be possible to optimise this, but it would require an understanding of javascript so that you could do the filtering in the browser instead of round-tripping back and forth to R each time.

[Mos_Taf]

Hi hadley, it's such an honor to exchange with you !

My example was not very readable. After some reserch and help in Stackoverflow, I did something functional and more faster.

df <- structure(list(Continent = c("Asia", "Oceania", "Europe", 
                                   "North America", "Europe", "Oceania", "Europe", "South America",
                                   "North America","Europe"), Country = c("India", "Tonga", "Georgia",
                                                                          "United States", "Spain", "New Zealand", "Sweden", "Suriname", 
                                                                          "United States","Finland"), State = c("Haryana", "State_Tonga", 
                                                                                                                "State_Georgia", "Florida", "State_Spain", "State_New Zealand", 
                                                                                                                "State_Sweden", "State_Suriname", "Idaho", "State_Finland"), 
                     Population = c(25353081, 985883, 860759, 589096, 352490, 363655,
                                    143215, 961911, 579311, 131878)), row.names = c(NA, -10L), 
                class = c("tbl_df", "tbl", "data.frame"))

library(shiny)                                                                                                                                                                                                                 
library(shinydashboard)
library(dplyr)
library(DT)

is.not.null <- function(x) !is.null(x)


header <- dashboardHeader(
  title = "Test",
  dropdownMenu(type = "notifications",
               notificationItem(
                 text = "RAS",
                 icon("cog", lib = "glyphicon")
               )
  )
)
sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Data", tabName = "ShowData", icon = icon("dashboard")),
    menuItem("Summary", tabName = "ShowSummary", icon = icon("bar-chart-o"))
  )
)

body <- dashboardBody(
  tabItems(
    tabItem(tabName = "ShowData",
            DT::dataTableOutput("table")
    ),
    tabItem(tabName = "ShowSummary",
            box(width =3,
                h3("Test"),
                helpText("Please Continent, Country and State Combition"),
                uiOutput("continent"),
                uiOutput("country")
            ),
            
            box(width =9,
                DT::dataTableOutput("table_subset")
            )
    )
    
    
  )
)

# Put them together into a dashboardPage
ui = dashboardPage(
  header,
  sidebar,
  body
)

################################################
################################################

server = shinyServer(function(input,output,session){
  
  data <- bind_rows(replicate(5000, df, simplify = FALSE))
  # Showing the original data
  output$table <- DT::renderDataTable({
    if(is.null(data)){return()}
    DT::datatable(data, options = list(scrollX = T))
  })
  
  
  
  # Creating filters
  output$continent <- renderUI({
    selectInput(inputId = "Continent", "Select Continent",choices = unique(data$Continent), multiple = T)
  })
  output$country <- renderUI({
    isolate(
      selectInput(inputId = "Country", "Select Country",choices = unique(data$Country), multiple = T)
    )
  })
  
  observe(
    updateSelectInput(
      session = session,
      inputId = "Continent",
      choices = var_continent(),
      selected = input$Continent
    )
  ) 
  
  observe(
    updateSelectInput(
      session = session,
      inputId = "Country",
      choices = var_country(),
      selected = input$Country
    )
  ) 
  
  # Cascasing filter for state
  
  var_continent <- reactive({
    file1 <- data
    country <- input$Country
    file2 <- country_function()
    if(is.null(country)){
      as.list(unique(file1$Continent))
    } else {
      as.list(c(unique(file2$Continent)))
    }
    
  })
  
  # Creating reactive function to subset data
  continent_function <- reactive({
    file1 <- data
    continent <- input$Continent
    
    if (is.null(continent)){
      return(file1)
    } else {
      file2 <- file1 %>% 
        filter(Continent %in% continent)
      return (file2)
    }
    
    
  })
  
  var_country <- reactive({
    file1 <- data
    continent <- input$Continent
    file2 <- continent_function()
    
    if(is.null(continent)){
      as.list(unique(file1$Country))
    } else {
      as.list(unique(file2$Country))
    }
    
  })
  
  country_function <- reactive({
    file1 <- data
    country <- input$Country
    country <- input$Country
    
    if (is.null(country)){
      return(file1)
    } else {
      file2 <- file1 %>%
        filter(Country %in% country)
      return (file2)
    }
    
  })
  
  
  
  
  df <- reactive({
    
    file1 <- data
    continent <- input$Continent
    country <- input$Country
    if (is.not.null(country)){
      file1 <- file1 %>%
        filter(Country %in% country)
    }
    
    if (is.not.null(continent)){
      file1 <- file1 %>%
        filter(Continent %in% continent)
    }
    file1
  })
  
  output$table_subset <- DT::renderDataTable({
    # validate(
    #   need(input$Continent, 'Check that'),
    #   need(input$Country, 'Please choose :)')
    #   need(input$State, 'Please choose :D')
    # )
    DT::datatable(df(), options = list(scrollX = T))
    
  })
  
})

shinyApp(ui, server)

Now I am trying to add something like "select all" something similar to shinyWidgets options

Thanks again !