selectInput 不显示选项并将值重置为 shinyApp 中的“全部”

Question

我正在 mtcars 数据上构建一个 shinyApp。我在 selectInput 按钮 中遇到问题。当我单击左侧的 disp 按钮 时，我没有选择。我只得到全部。 同样，当我将一些值放入 carb 过滤器，然后从 vs filter 中选择另一个值时，carb 和 disp 立即重置为“All”不应该发生。 carb 和 disp 中先前选择的值如果存在于 vs 选择值中，则应保留。 有人可以看看我的代码。我将不胜感激。

library(readr)  
library(shiny)   
library(DT)     
library(dplyr) 
library(shinythemes) 
library(htmlwidgets) 
library(shinyWidgets) 
library(shinydashboard)


data_table<-mtcars


#ui
ui = fluidPage( 
  sidebarLayout(
    sidebarPanel (



      uiOutput("vs_selector"),
      uiOutput("carb_selector"),
      uiOutput("disp_selector")),


    mainPanel(


      DT::dataTableOutput('mytable') )))




#server
server = function(input, output, session) {

  output$vs_selector <- renderUI({


    selectInput(inputId = "vs",
                label = "vs:", multiple = TRUE,
                choices = c( unique(data_table$vs)),
                selected = c(0,1))

  })



  output$carb_selector <- renderUI({

    available0 <- data_table[c(data_table$vs %in% input$vs ), "carb"]  


    selectInput(
      inputId = "carb", 
      label = "carb:",
      multiple = TRUE,
      choices = c('All',as.character(unique(available0))),
      selected = 'All')

  })



  output$disp_selector <- renderUI({

    available <- data_table[c(data_table$carb %in% input$carb    &    
data_table$vs %in% input$vs), "disp"]

    selectInput(
      inputId = "disp", 
      label = "disp:",
      multiple = TRUE,
      choices = c('All',as.character(unique(available))),
      selected = 'All')

  })



  thedata <- reactive({


    data_table<-data_table[data_table$vs %in% input$vs,]


    if(input$carb != 'All'){
      data_table<-data_table[data_table$carb %in% input$carb,]
    }


    if(input$disp != 'All'){
      data_table<-data_table[data_table$disp %in% input$disp,]
    }


    data_table

  })


  output$mytable = DT::renderDataTable({

    DT::datatable( {     

                     thedata()   # Call reactive thedata()


                   })

  })}  

shinyApp(ui = ui, server = server)

Answer 1

我对您的代码做了几处修改。特别是，我添加了一些req 的（参见?req），并在output$disp_selector 中修改了available：

available <- data_table[["disp"]][data_table$vs %in% input$vs]
if(! "All" %in% input$carb){
  available <- available[data_table$carb %in% input$carb]
}

---

data_table<-mtcars    

#ui
ui = fluidPage( 
  sidebarLayout(
    sidebarPanel (

      uiOutput("vs_selector"),
      uiOutput("carb_selector"),
      uiOutput("disp_selector")),


    mainPanel(

      DT::dataTableOutput('mytable') 

    )

))




#server
server = function(input, output, session) {

  output$vs_selector <- renderUI({

    selectInput(inputId = "vs",
                label = "vs:", multiple = TRUE,
                choices = c( unique(data_table$vs)),
                selected = c(0,1))

  })

  output$carb_selector <- renderUI({

    req(input$vs)

    available0 <- data_table[c(data_table$vs %in% input$vs ), "carb"]  

    selectInput(
      inputId = "carb", 
      label = "carb:",
      multiple = TRUE,
      choices = c('All',as.character(unique(available0))),
      selected = 'All')

  })


  output$disp_selector <- renderUI({
    req(input$vs, input$carb)

    available <- data_table[["disp"]][data_table$vs %in% input$vs]
    if(! "All" %in% input$carb){
      available <- available[data_table$carb %in% input$carb]
    }

    selectInput(
      inputId = "disp", 
      label = "disp:",
      multiple = TRUE,
      choices = c('All',as.character(unique(available))),
      selected = 'All')

  })



  thedata <- reactive({

    req(input$disp, input$vs, input$carb)

    data_table<-data_table[data_table$vs %in% input$vs,]

    if(! "All" %in% input$carb){
      data_table<-data_table[data_table$carb %in% input$carb,]
    }

    if(! "All" %in% input$disp){
      data_table<-data_table[data_table$disp %in% input$disp,]
    }

    data_table

  })


  output$mytable = DT::renderDataTable({

    DT::datatable( {     

      thedata()   # Call reactive thedata()

    })

  })

}  

shinyApp(ui = ui, server = server)

---

仅供参考，对于更清洁的解决方案，您可能对 shinyWidgets 包中的 selectizeGroupUI 感兴趣：

library(shiny)
library(shinyWidgets)

ui <- fluidPage(
  fluidRow(
    column(
      width = 10, offset = 1,
      tags$h3("Filter data with selectize group"),
      panel(
        selectizeGroupUI(
          id = "my-filters",
          params = list(
            disp = list(inputId = "disp", title = "disp:"),
            carb = list(inputId = "carb", title = "carb:"),
            vs = list(inputId = "vs", title = "vs:")
          )
        ), status = "primary"
      ),
      dataTableOutput(outputId = "table")
    )
  )
)

server <- function(input, output, session) {
  res_mod <- callModule(
    module = selectizeGroupServer,
    id = "my-filters",
    data = mtcars,
    vars = c("disp", "carb", "vs")
  )
  output$table <- renderDataTable(res_mod())
}

shinyApp(ui, server)