Параметр selectInput не отображает варианты выбора и сбрасывает значения до «Все» в блестящем приложении - PullRequest
Новая
       40

Параметр selectInput не отображает варианты выбора и сбрасывает значения до «Все» в блестящем приложении

0 голосов
/ 20 января 2019

Я строю блестящее приложение на данных mtcars. Я сталкиваюсь с проблемой в кнопках selectInput . Когда я нажимаю кнопку disp слева, я не получаю выбора. Я получаю только Все . Точно так же, когда я помещаю некоторые значения в фильтр карбюратора , а затем выбираю другое значение из против фильтра , сразу карбюратор и disp сбрасывается в «Все», что не должно быть происходящим Предыдущие выбранные значения в carb и disp должны оставаться, если они присутствуют в против выбранного значения. Может кто-нибудь, пожалуйста, посмотрите на мои коды. Буду очень признателен. 

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)

1 Ответ

0 голосов
/ 24 января 2019

Я сделал несколько изменений в вашем коде.В частности, я добавил 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)

К вашему сведению, для более чистого решения вас может заинтересовать selectizeGroupUI в пакете shinyWidgets: 

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