r - selectInput 小部件的条件更新

Question

使用starwars数据集，下面是我面临的问题的一个最小示例。

我的应用程序有三个selectInput用于过滤数据表。它们selectInput根据前一个的选定值相互更新。

该应用程序还包含用于选择类型字符的单选按钮。单击单选按钮“默认”时，默认情况下selectInput应选择选项中的第一个值。但是，当单选按钮是一个字符（即不是“默认”）时，selectInput应该更新并选择定义该字符的值（通过反应对象info()）。由于 的选择发生了变化selectInput，因此应该对表进行相应的过滤。

（我必须遵循的唯一限制是我不能在应用程序的 UI 中使用数据集。）

这是示例应用程序。

library(shiny)
library(dplyr)

ui <- fluidPage(
    selectInput(inputId="sex",
                label="SEX",
                choices=c(""),
                selected=NULL
    ),
    selectInput(inputId="homeworld",
                label="HOMEWORLD",
                choices=c(""),
                selected=NULL
    ),
    selectInput(inputId="species",
                label="SPECIES",
                choices=c(""),
                selected=NULL
    ),
    hr(),
    radioButtons(inputId="radio",
                 label=NULL,
                 choices=c("default", "C-3PO", "Leia Organa")
    ),
    hr(),
    verbatimTextOutput("info_object"),
    hr(),
    DT::dataTableOutput("table")
)

server <- function(session, input, output){
    
    # Get Sex / Homeworld / Species about character selected
    info <- reactive({
        if(input$radio == "default"){
            return(NULL)
        }
        else{
            list(Sex = starwars %>% subset(name == input$radio) %>% pull(sex),
                 Homeworld = starwars %>% subset(name == input$radio) %>% pull(homeworld),
                 Species = starwars %>% subset(name == input$radio) %>% pull(species))
        }
    })
    
    # To control the content of the 'info()' object
    output$info_object <- renderPrint({
        cat("info() object values:\n")
        print(info())
    })
    
    # Update selectInput widgets
    observe({
        if(is.null(info())){
            updateSelectInput(session=session,
                              inputId="sex",
                              choices=starwars$sex %>% 
                                         unique()
            )
            
            observeEvent(input$sex, {
                updateSelectInput(session=session,
                                  inputId="homeworld",
                                  choices=starwars %>% 
                                          subset(sex == input$sex) %>% 
                                          pull(homeworld) %>% 
                                          unique()
                )
            })
            
            observeEvent(input$homeworld, {
                updateSelectInput(session=session,
                                  inputId="species",
                                  choices=starwars %>% 
                                          subset(sex == input$sex & homeworld == input$homeworld) %>% 
                                          pull(species) %>% 
                                          unique()
                )
            })
        }
        else{
            updateSelectInput(session=session,
                              inputId="sex",
                              choices=starwars$sex %>% 
                                      unique(),
                              selected = info()$Sex
            )
            
            observeEvent(input$sex, {
                updateSelectInput(session=session,
                                  inputId="homeworld",
                                  choices=starwars %>% 
                                          subset(sex == input$sex) %>% 
                                          pull(homeworld) %>% 
                                          unique(),
                                  selected = info()$Homeworld
                )
            })
            
            observeEvent(input$homeworld, {
                updateSelectInput(session=session,
                                  inputId="species",
                                  choices=starwars %>% 
                                          subset(sex == input$sex & homeworld == input$homeworld) %>% 
                                          pull(species) %>% 
                                          unique(),
                                  selected = info()$Species
                )
            })
        }
        
        # Data table
        output$table <- DT::renderDataTable({
            DT::datatable(starwars %>% subset(sex == input$sex & homeworld == input$homeworld & species == input$species))
        })
    })                             
}

shinyApp(ui, server)

如您所见，selectInput选择单选按钮时不会正确更新。

标签： rshiny

Answer 1

这可能是由于您的选择和选择之间的冲突。

对于这种类型的事情，我喜欢构建一个反应链，但同时观察两个选择也可以。将您observeEvent的物种更改为：

  observeEvent(c(input$homeworld, input$species), {
    updateSelectInput(session=session,
                      inputId="species",
                      choices=starwars %>% 
                        subset(sex == input$sex & homeworld == input$homeworld) %>% 
                        pull(species) %>% 
                        unique(),
                      selected = info()$Species
    )
  })