基于动态列名选择的数据框子集不正确

Question

我有下面的闪亮应用程序，用户可以在其中从数据框中选择一个或多个列名。

name<-c("John","Jack","Bill")
value1<-c(2,4,6)
add<-c("SDF","GHK","FGH")
value2<-c(3,4,5)
dt<-data.frame(name,value1,add,value2)

那么对于他所做的每一个选择，相对的pickerInput() 可能会显示在下面。然后根据选择的列或列及其值，我想对初始数据框进行子集化并将其显示在表格中。但是对于我将在我的 orifinal 应用程序中使用的每个不同的数据框，列的名称可能会有所不同，所以我需要一种更通用的方法来做到这一点。我的方法如下，但有些东西不起作用。例如，如果我选择name（没有选择任何名称）和选择了所有值的value1，我会得到一个空表，而我应该拥有所有值。当我开始选择名称时，表格开始填满。

library(DT)
# ui object
ui <- fluidPage(
    titlePanel(p("Spatial app", style = "color:#3474A7")),
    sidebarLayout(
        sidebarPanel(
            pickerInput(
                inputId = "p1",
                label = "Select Column headers",
                choices = colnames( dt),
                multiple = TRUE,
                options = list(`actions-box` = TRUE)
            ),
            #Add the output for new pickers
            uiOutput("pickers")
        ),
        
        mainPanel(
            DTOutput("table")
        )
    )
)

# server()
server <- function(input, output) {
    
    observeEvent(input$p1, {
        #Create the new pickers 
        output$pickers<-renderUI({
            div(lapply(input$p1, function(x){
                if (is.numeric(dt[[x]])) {
                    sliderInput(inputId=x, label=x, min=min(dt[x]), max=max(dt[[x]]), value=c(min(dt[[x]]),max(dt[[x]])))
                }
                else if (is.factor(dt[[x]])) {
                    selectInput(
                        inputId = x#The colname of selected column
                        ,
                        label = x #The colname of selected column
                        ,
                        choices = dt[,x]#all rows of selected column
                        ,
                        multiple = TRUE
                        
                    )
                }
                
            }))
        })
    })
    output$table<-renderDT({
        req(input$p1, sapply(input$p1, function(x) input[[x]]))
        dt_part <- dt
        for (colname in input$p1) {
            if (is.factor(dt_part[[colname]])) {
                dt_part <- subset(dt_part, dt_part[[colname]] %in% input[[colname]])
            } else {
                dt_part <- subset(dt_part, (dt_part[[colname]] >= input[[colname]][[1]]) & dt_part[[colname]] <= input[[colname]][[2]])
            }
        }
        dt_part
    })
}

# shinyApp()
shinyApp(ui = ui, server = server)

Answer 1

默认情况下，未选择任何值的输入为NULL。所以你必须检查输入是否为NULL，然后不要过滤。如果你使用dplyr，我最近写了一个function 来让这个过滤在闪亮时更容易。

这是您的代码的工作示例：

library(shiny)
library(DT)
library(shinyWidgets)
# ui object
ui <- fluidPage(
  titlePanel(p("Spatial app", style = "color:#3474A7")),
  sidebarLayout(
    sidebarPanel(
      pickerInput(
        inputId = "p1",
        label = "Select Column headers",
        choices = colnames( dt),
        multiple = TRUE,
        options = list(`actions-box` = TRUE)
      ),
      #Add the output for new pickers
      uiOutput("pickers")
    ),
    
    mainPanel(
      DTOutput("table")
    )
  )
)

# server()
server <- function(input, output) {
  
  observeEvent(input$p1, {
    #Create the new pickers 
    output$pickers<-renderUI({
      div(lapply(input$p1, function(x){
        if (is.numeric(dt[[x]])) {
          sliderInput(inputId=x, label=x, min=min(dt[x]), max=max(dt[[x]]), value=c(min(dt[[x]]),max(dt[[x]])))
        }
        else if (is.factor(dt[[x]])) {
          selectInput(
            inputId = x#The colname of selected column
            ,
            label = x #The colname of selected column
            ,
            choices = dt[,x]#all rows of selected column
            ,
            multiple = TRUE
            
          )
        }
        
      }))
    })
  })
  
  output_table <- reactive({
    req(input$p1, sapply(input$p1, function(x) input[[x]]))
    dt_part <- dt
    for (colname in input$p1) {
      if (is.factor(dt_part[[colname]]) && !is.null(input[[colname]])) {
        dt_part <- subset(dt_part, dt_part[[colname]] %in% input[[colname]])
      } else {
        if (!is.null(input[[colname]][[1]])) {
          dt_part <- subset(dt_part, (dt_part[[colname]] >= input[[colname]][[1]]) & dt_part[[colname]] <= input[[colname]][[2]])
        }
      }
    }
    dt_part
  })
  output$table<-renderDT({
    output_table()
  })
}

# shinyApp()
shinyApp(ui = ui, server = server)