闪亮的 selectInput 'Select All' 层次结构

Posted 2023-03-24

【中文标题】闪亮的 selectInput \'Select All\' 层次结构

【英文标题】：Shiny selectInput 'Select All' hierarchy闪亮的 selectInput 'Select All' 层次结构

【发布时间】：2021-02-15 10:14:29

【问题描述】：

编辑：添加示例数据。

我想为多个 SelectInputs 添加一个“全选”选项。因此，如果我选择“所有”国家/地区，第二个 selectInput 下拉菜单将显示所有地区，如果我选择特定国家/地区，我可以选择该国家或特定国家的“所有”地区。

选择所有适用于***的作品，但我不知道如何将其应用于第二个地区级。

如果可能的话，我想在没有 pickerInPut 的情况下这样做。

数据：

   Country <-  c('England', 'Scotland', 'Wales', 'Ireland', 'Spain', 'England', 'Scotland', 'Wales', 'Ireland', 'Spain', 'England', 'Scotland', 'Wales', 'Ireland', 'Spain' , 'England', 'Scotland', 'Wales', 'Ireland', 'Spain')
    
    Region  <- c('North' , 'East', 'South', 'South', 'North' , 'South', 'East', 'North' , 'South', 'West', 'North' , 'South' , 'North' , 'West', 'North' , 'West', 'West', 'East', 'East', 'South')
    
    Value   <- c(100, 150, 400, 300, 100, 150, 300, 200, 500, 600, 300, 200, 250, 300, 100, 150, 300, 200, 500, 600)
    
    Outcomes <- c('Green', 'Red','' , 'Amber', 'Green', 'Green', 'Red','' , 'Red', 'Amber', 'Red', 'Green', 'Green', 'Green','' ,'' , 'Amber', 'Amber', 'Red', 'Red')
    
    Outputs <- c('Red', 'Green', 'Green', 'Green', '','' , 'Amber', 'Green', 'Red','' , 'Red', 'Amber', 'Red', 'Green', 'Green', '','' , 'Amber', 'Amber', 'Red')
    
    Risk <- c('Green', 'Green', 'Red', 'Red','' , 'Amber', 'Green', 'Green', 'Amber','' , 'Green', 'Red', 'Amber', 'Green', 'Green', 'Red', '', 'Red', 'Amber', '')
    
    
    Joined_data <- data.frame(Country, Region, Value, Outcomes, Outputs, Risk)

list<- unique(Joined_data$Country)
list2 <- unique(Joined_data$`Region`)

用户界面：

ui<- dashboardPage(
  dashboardHeader(title = "Performance"),
  

  dashboardSidebar(selectizeInput(inputId = "Country", label = "Country", choices = c('All', list)),
                  (selectizeInput(inputId = "Region", label = "Region", choices = c('All', list2)))),
  
 
  dashboardBody( 
    fluidRow(
      box(valueBoxOutput(outputId = "Total", width = 12), title = "Total"),
      box(valueBoxOutput(outputId = "Value", width = 12), title = "Value"),     

      
    )
  ),

)

服务器：

server <- function(input, output, session)  
  
Test <- reactive(
  if(input$Country == 'All') 
    Joined_data  %>% 
      filter(`Contract Locality` == input$Locality)
   else 
  Joined_data %>%
    filter(`Country` == input$Country, `Region` == input$Region)
  
)
  


  output$Total <- renderValueBox(
  
   valueBox(Test() %>%
      tally(), 
    
    req(input$Country)
    
  )
  

  output$Value <- renderValueBox(

    valueBox(Test() %>%
               summarise("Annualised_Value" = sum(`Value (Annualised)`)) %>%
               prettyNum(big.mark = ","), 
             
             req(input$Country)
    
  )


  Country.choice <- reactive(
    Joined_data %>% 
      filter(Country == input$Country %>%
      pull(Region)
  )
  
  observe(
    
    updateSelectizeInput(session, "Region", choices = Country.choice())
    
  )
  

shiny::shinyApp(ui=ui,server=server)

【参考方案1】：

也许pickerInput 会满足您的需求，如下面的示例所示。

ui = fluidPage(
  titlePanel(title=div(img(src="YBS.png", height = 140, width = 140), "This is a Test")),
  sidebarLayout(
    sidebarPanel(
      uiOutput("organt"),
      uiOutput("cellt")
    ),
    mainPanel(
      tableOutput("MegaData")
    )
  )
)


server = function(input, output, session) 
  
  df1 <- veteran
  MegaP <- df1 %>% mutate(Organ=ifelse(trt==1,"Lung","Skin"))
  
  output$organt <- renderUI(
    selectInput("OrganT",
                label = "Organ",
                choices = unique(MegaP$Organ),
                multiple = T,
                selected = "All")
  )
  
  MegaP1 <- reactive(
    data <- subset(MegaP, Organ %in% req(input$OrganT))
  )
  
  output$cellt <- renderUI(
    req(MegaP1())
    mychoices <- as.character(unique(MegaP1()$celltype))
    pickerInput(inputId = "Cell",
                label = "Cell Line",
                choices = mychoices,
                multiple = TRUE, 
                options = list(`actions-box` = TRUE)
                )
  )
  
  selectedData <- reactive(
    req(MegaP1(),input$Cell)
    data <- subset(MegaP1(), celltype %in% input$Cell)
  )
  
  output$MegaData = renderTable(
    selectedData()
  )
  


shinyApp(ui = ui, server = server)

编辑：

要在不使用 pickerInput 的情况下执行此操作，您可以尝试以下操作：

dat <- data.frame(Country, Region, Value, Outcomes, Outputs, Risk)

list<- unique(dat$Country)
list2 <- unique(dat$`Region`)

app <- shinyApp(
  ui = shinyUI(
    pageWithSidebar(
      headerPanel("Simple Test"),
      sidebarPanel(
        selectInput("cy", "Country", choices = c("All", list )),
        selectInput("rg", "Region", choices = c("All", list2 ))
      ),
      mainPanel(
        DTOutput("out")
      )
    )
  ),
  server = function(input, output, session) 
    filtered <- reactive(
      rows <- (input$cy == "All" | dat$Country == input$cy) &
        (input$rg == "All" | dat$Region == input$rg)
      dat[rows,,drop = FALSE]
    )
    output$out <- renderDT(filtered())
  
)

【讨论】：

我试过了，但在第二个下拉菜单中仍然没有给我一个“全部”选项

请尝试更新后的代码。您可以将 selectInput 移动到服务器端。