r - 如何在 r 中动态更新选择输入的选择

Question

我正在开发一个闪亮的应用程序，其中选择输入的选择应该根据早期输入动态更新。

例如，如果在第一个输入小部件中同时选择了类别和细分，并且在第二个输入小部件中只选择了 skin_care，那么在第三个输入小部件中，药物和非药物应该作为选项而不是所有唯一的细分名称。如果在第二个输入小部件中选择了 hair_care 而不是 skin_care，则应该在第三个输入小部件下拉列表中选择 Gents and Ladies。所以基本上从下拉列表中选择的选择取决于用户在早期输入小部件上选择的内容。品牌也一样。在这里，我假设维度的选择总是从左到右。

实际的应用程序会要求用户加载数据，它可以有 10 个维度，或者可能更多。为了简单起见，我保留了三个。

library(shiny)
library(DT)

ui <- shinyUI(fluidPage(
tabsetPanel(
tabPanel("Data", fluid = TRUE,
         sidebarLayout(
           sidebarPanel(p("Please remove None first"),
                        uiOutput("dim"),
                        uiOutput("levels1")),
           mainPanel(
             DT::dataTableOutput("data_display")
           ))))))

server <- shinyServer(function(input,output){

# creating Data 
data <- reactive({
data <-  data.frame(Date = as.Date(c("2018-05-25","2018-05-26")),
            category = c(rep("skin_care",6),rep("hair_care",6)),
            Segment =  c(rep("Medicated",4),rep("Non_Medicated",2),
                       rep("Ladies",4),rep("Gents",2)),
            Brand = c("X","X","Y","Y","Z","Z","A","A","B","B","C","C"),
            sales = round(rnorm(12,100,3)))
})


# Displaying Data  

output$data_display <- DT::renderDataTable(                    
datatable(data(),options = list(pageLength = 12),rownames = FALSE)
)

# selects dimension (Only character variable to be selected)

output$dim<-renderUI({
b<-colnames(data()[sapply(data(),class)=="character"])
selectInput("x","Select only character variable",choices = 
              c("NONE",b[1:length(b)]),selected="NONE",multiple = TRUE)
 })

 #  user selects levels of dimension 

output$levels1<-renderUI({
if(is.null(input$x)){
  return(NULL)
}
else if(sum(input$x=="NONE")==1){
  return(NULL)
}
else{
  lapply(seq(input$x),function(i){
    selectInput(inputId = paste0("range",i),
                paste0("Select level of ",input$x[i]),
                choices = c(unique(data()[,input$x[i]]),"ALL"),multiple = TRUE)

   })
  }
 })
 })
shinyApp(ui,server)

编辑：在动态出现的 selectinput 小部件的下拉菜单中提供选项

标签： rshiny

Answer 1

我玩弄了您提供的代码。这个答案可能看起来不完整，但我相信这是解决您问题的最佳方法。让我们来看看：

1. 在 ui-part 我添加了另一个uiOutput-wrapper 调用level3（如果在第一个下拉列表中选择了多个输入，则仅返回一个下拉列表）
2. 随后我renderUI在服务器部分添加了另一个
3. 我将DT-table 移动到服务器部分的末尾
4. 我在server-part的-object中添加了一套完整的if-else条件levels1（解释的太复杂了，自己试一下）
5. 我还添加了一套完整的 if-else-conditions 来检查 ui 是否有效

但是，我看不到如何在我的答案中保持我的代码通用。我的意思是，如果您有多个列，则为每列创建一个下拉列表可能会更容易。对我来说似乎更容易。

主要问题是您无法猜测用户将在第一个下拉列表中首先选择哪个元素。因此，您需要检查所有可能的组合。如果您有两个以上的变量，那就太疯狂了。无论如何，因为你比我更了解数据，如果额外的编程工作值得花时间的话。如果您不相信我，请使用我的代码，尝试概括代码，使用五个字符列，然后在您学到的内容下方评论。

最后但并非最不重要的一点是，我经常grep对数据进行子集化。如果你将它与 a 结合起来paste，collapse='|'它会匹配你的字符向量的每个场合。

这是应用程序：

library(shiny)
library(DT)

ui <- shinyUI(fluidPage(
  tabsetPanel(
    tabPanel("Data", fluid = TRUE,
             sidebarLayout(
               sidebarPanel(uiOutput("dim"),
                            uiOutput("levels1"),
                            uiOutput("level3")),
               mainPanel(
                 DT::dataTableOutput("data_display")
               ))))))

server <- shinyServer(function(input,output){

  # creating Data 
  data <- reactive({
    data <-  data.frame(Date = as.Date(c("2018-05-25","2018-05-26")),
                        category = c(rep("skin_care",6),rep("hair_care",6)),
                        Brand = c("X","X","Y","Y","Z","Z","A","A","B","B","C","C"),
                        sales = round(rnorm(12,100,3)),stringsAsFactors = FALSE)
  })




  # selects dimension (Only character variable to be selected)

  output$dim<-renderUI({
    b<-colnames(data()[sapply(data(),class)=="character"])
    selectInput("x","Select only character variable",
                choices = b[1:length(b)],multiple = TRUE)
  })


  #  user selects levels of dimension 
  output$levels1<-renderUI({
    if(is.null(input$x)){
      return(NULL)
    }
    else if(sum(input$x=="NONE")==1){
      return(NULL)
    }
    else{
      mydata<-data()
      if(length(input$x)==2){
        selectInput(inputId = 'range1',
                    paste0("Select level of ",'category'),
                    choices = unique(as.character(mydata$category)),
                    selected = "",multiple = TRUE)
      } else {
        lapply(seq(input$x),function(i){
          mychoice<-unique(as.character(mydata[,input$x[i]]))
          selectInput(inputId = paste0("range",i),
                      paste0("Select level of ",input$x[i]),
                      choices = mychoice,selected = "",multiple = TRUE)
          })
      }
    }
  })

  output$level3<-renderUI({
    if(is.null(input$range1) | length(input$x)<2){
      return(NULL)
    } else {
      mydata<-data()
      myrows<-grepl(paste0(input$range1,collapse = '|'),mydata$category)
      mychoices<-unique(as.character(mydata$Brand[myrows]))
      selectInput(inputId = 'range2',
                  paste0("Select level of ",'category'),
                  choices = mychoices,
                  selected = mychoices,multiple = TRUE)
    }

  })

  # Displaying Data  

  output$data_display <- DT::renderDataTable({
    if(is.null(input$x)){ #show full data when nothing is selected in first dropdown
      mydata<-data()
    }
    if(is.null(input$range1)){ # show full data when nothing is selected in second drop down
      mydata<-data()
    } else { # something is selected in second dropdown
      if(length(input$x)>1){ # First dropdown contains two elements
        mydata<-data()
        if(!is.null(input$range2)){
          mydata=mydata[grep(paste0(input$range2,collapse='|'),as.character(mydata$Brand)),]
        }
      } else { # First dropdown contains one element
        mydata<-data()
        if(input$x=='Brand'){
          mydata=mydata[grep(paste0(input$range1,collapse='|'),as.character(mydata$Brand)),]
        } else{
          mydata=mydata[grep(paste0(input$range1,collapse='|'),as.character(mydata$category)),]
        }
      } # close: First dropdown has one element
    } # close: something is selected in second dropdown


    datatable(mydata,options = list(pageLength = 12),rownames = FALSE)
  })


  # observeEvent(input$x,
  #              updateSelectInput(inputId = paste0("range",i),
  #                                paste0("Select level of ",input$x[i]),
  #                                choices = unique(data()[,input$x])))

})

shinyApp(ui,server)