分层输入选择

Question

您能帮我解决一个与分层输入选择相关的问题吗？

我为分层输入选择构建了一个简单的应用程序，其中每个 selectInput 的选择都根据之前的用户选择进行更新。该应用程序可以运行，但我发现了一些奇怪的行为，我希望尽可能避免。

我的第一个输入是滑块输入，用户可以在其中选择 mtcars 表的哪些行应用于进一步的子选择。

然后选中的cars显示在第一个selectInput中，用户选择了他想看的cars后，第二个selectInputmpg分别被过滤。

然后在按下操作按钮后，子选择显示为表格输出。

当用户通过更改sliderInput 从头开始​​程序时，仅更新cars 选项。如果我们按下 mpg selectInput，我们仍然可以看到旧的选择。

当我们再次选择一些汽车时，mpg正在更新。

您知道避免这种行为的方法吗？我的目标是，mpg 在sliderInput 得到更新并且不显示旧的选择之后始终为空。

谢谢。

约翰

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

Answer 1

在我看来，uiOutput/renderUI 非常适合这些情况。我们可以避免使用一堆 observeEvent 和 updateSelectInput 调用，并且下拉选项会立即（有效地）更新，因此您不会看到示例中显示的问题。我认为它也更容易理解。

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)