Hierarchical input select

Question

Could you please help me solving an issue related to Hierarchical input select.

I build a simply app for hierarchical input selecting, where the choices of each selectInput are updating based on the previous user selection. The app works, but I have found some strange behavior, which I want to avoid if possible.

My first input is the sliderInput, where the user can select which rows of the mtcars table should be used for the further sub-selection.

Then the selected cars are shown in the first selectInput and after the user choose which cars he want to see, the second selectInput mpg is filtered respectively.

Then after pressing an Action button, the sub-selection is displayed as table output.

When the user start the procedure from the beginning by changing the sliderInput, only the cars choices are updated. If we press on mpg selectInput we can still see the old selection.

Off course when we select again some cars the mpg are getting updated.

Do you know some way to avoid this behavior. My goal is, that mpg is always empty after the sliderInput is getting updated and not showing the old selections.

Thank you.

John

#  Hierarchical inputSelect Example with mtcars
library(shiny)
library(dplyr)

ui <- fluidPage(
    mainPanel(
        fluidRow(
            column(width=2,
                   sliderInput(inputId = "RowsINP",label = "Rows",min=1, max = dim(mtcars)[1], value=16,step=1),
                   selectInput("carsINP", "cars", choices = NULL,multiple=TRUE),
                   selectInput("mpgINP", "mpg", choices = NULL,multiple=TRUE),
                   actionButton("actionINP", "action")
            ),
            column(width=10,
                   tableOutput('table')
            )
        )
    )
)
server <- function(input, output,session) {
    mtcars_tab <-  reactive({
        req(input$RowsINP)
        data.frame(cars=rownames(mtcars[1:input$RowsINP,]),mtcars[1:input$RowsINP,])
    })
    observeEvent(mtcars_tab(), {
        updateSelectInput(session,"carsINP", choices = unique(mtcars_tab()$cars))
    })
    cars <- reactive({
        req(input$carsINP)
        filter(mtcars_tab(), cars %in% input$carsINP)
    })
    observeEvent(cars(), {
        # Also tried this option and many others
            #  if (!isTruthy(input$carsINP[1])){choices <- NULL}
            #  else{ choices <- unique(arrange(cars(),mpg)$mpg)}
        choices <- unique(arrange(cars(),mpg)$mpg)
        updateSelectInput(session, "mpgINP", choices = choices)
    })
    mpg <-eventReactive(input$actionINP,{
        filter(cars(), mpg %in% input$mpgINP)
    })
    output$table <- renderTable(mpg())
}
# Run the application 
shinyApp(ui = ui, server = server)

heds1 heds1 · Accepted Answer · 2020-09-11T09:30:09

In my opinion, uiOutput/renderUI is perfect for these situations. We can avoid using a bunch of observeEvent and updateSelectInput calls, and the dropdown choices are updated (effectively) instantaneously, so you won't see the issue you've shown in your example. I think it's also a little bit easier to follow.

library(dplyr)
library(shiny)

ui <- {
    fluidPage(
        fluidRow(
            sliderInput(inputId = "rows",label = "Rows",
                min=1, max = dim(mtcars)[1],
                value=16, step=1),
            uiOutput('car_selector'),
            uiOutput('mpg_selector'),
            actionButton('action', 'Action'),
            dataTableOutput('table_data')
        )
    )
}

server <- function(input, output, session) {
    
    # render the car selection input
    output$car_selector <- renderUI({
        selectInput('car_input', 'Cars',
            choices = rownames(mtcars)[1:input$rows],
            multiple = TRUE)
    })
    
    # render the mpg selection input
    output$mpg_selector <- renderUI({
        selectInput('mpg_input', 'mpg',
            choices = mtcars[rownames(mtcars) %in% input$car_input, 'mpg'],
            multiple = TRUE)
    })
    
    # update the table data when the action button is clicked
    table_data <- eventReactive(input$action, {
        mtcars[rownames(mtcars) %in% input$car_input & mtcars$mpg %in% input$mpg_input, ]
    })
    
    # render the table data
    output$table_data <- renderDataTable(table_data())
    
}

shinyApp(ui, server)

Hierarchical input select

1 Answers