如何在 renderUI 中重新启动 lapply 循环

Question

我正在尝试创建一个能够过滤非预定次数的表的闪亮代码。当用户上传不同的（新）表时，不幸的是代码中断了，因为我需要以某种方式重新启动 lapply 循环，丢弃以前存储的列名。

我想为 Shiny 中的表格创建一个非预定义的过滤选项。用户可以选择一列并过滤表，在该列中选择不同的分类变量。可以通过按“添加”按钮添加其他选择字段。

用户界面：

library(shiny)
library(shinydashboard)
library(dplyr)

ui <- shinyUI(
  pageWithSidebar(
  headerPanel("testing of dynamic number of selection"),
  sidebarPanel(
    uiOutput("buttons")),
  mainPanel(
    uiOutput("drops")
    ,tableOutput("table")
  )
))

服务器：

一个表 (test.csv) 会自动存储在反应值中，并且第一个搜索字段会出现 3 个按钮（添加 = 通过读取 colnames 和存储唯一变量的多选来添加新的搜索字段）列。过滤功能由计算按钮激活）

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

###### read in test file
values<-reactiveValues(number = 1,
                    upload = NULL,
                    input = NULL)

values$upload<-read.csv("test.csv")

#just the "add" button, in this instance it shouldn't be a uiOutput
output$buttons <- renderUI({
  div(
    actionButton(inputId = "add", label = "Add"), actionButton(inputId = "calc", label = "Calculate"),
    actionButton(inputId = "new", label = "new table")
  )
})

#pressing the add button
observeEvent(input$add, {
  cat("i adding a new record\n")
  values$number  <- values$number + 1L })

daStuff <- function(i){  
  inputName<-paste0("drop", i)
  inputName2<-paste0("select", i)
  inputText<-if(values$number>0){input[[paste0("drop",i)]]}else{F} # previously selected value for dropdown
  inputSelect <- if(values$number>1){input[[paste0("select",i)]]}else{F} # previously selected value for dropdown
  fluidRow(
    column(6,selectInput(inputName, inputName, c(colnames(values$upload)), selected = inputText)),   
    column(6,selectInput(inputName2, inputName2,                     
    na.omit(unique(as.vector(values$upload[,input[[paste0("drop",i)]]]))),
                         multiple=TRUE, selectize=TRUE, selected=inputSelect)) )}

output$drops<- renderUI({
  lapply(seq_len(values$number), daStuff)})

通过按下“计算”按钮，上传的表格将根据所选的唯一值进行过滤并显示在 output$table 中

observeEvent(input$calc, {
   values$input<-NULL
    for (i in 1:values$number){
      if(!is.null(input[[paste0("select",i)]])){
        if(is.null(values$input)){
          values$input<- filter(values$upload,values$upload[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
        else{
          values$input<- filter(values$input,values$input[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
      } }
   if (is.null(values$input)){values$input<-values$upload}

   output$table <- renderTable({values$input}) 
   })

我的问题是当我上传一个新表 (test2.csv) 时，我不知道如何删除以前存储的选择（drop* 和 select* 值）并返回一条错误消息。

 observeEvent(input$new,{
   values$upload<-read.csv("test2.csv")
})
}

shinyApp(ui=ui, server = server)

我想我应该以某种方式停止 lapply 循环并重新启动它，因此之前存储的值会根据新的选择被替换，但我有点不知道如何实现这一点。

Answer 1

以防万一您可能仍在寻找解决方案，我想分享一些类似的东西，并且可能会根据您的需求进行调整。

这将observeEvent 用于所有选择输入。如果它检测到任何更改，它将更新所有输入，包括基于drop 的select 的可能性。

此外，当读取新文件时，drop 和 select 的 selectInput 将重置为第一个值。

编辑：我忘记为下拉菜单保留selected = input[[paste0("drop",i)]]（请参阅修改后的代码）。现在似乎在添加新过滤器时保留了这些值 - 如果这是您的想法，请告诉我。

library(shiny)
library(shinydashboard)
library(dplyr)

myDataFrame <- read.csv("test.csv")

ui <- shinyUI(
  pageWithSidebar(
    headerPanel("Testing of dynamic number of selection"),
    sidebarPanel(
      fileInput("file1", "Choose file to upload", accept = ".csv"),
      uiOutput("buttons")
    ),
    mainPanel(
      uiOutput("inputs"),
      tableOutput("table")
    )
  )
)

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

  myInputs <- reactiveValues(rendered = c(1))

  myData <- reactive({
    inFile <- input$file1
    if (is.null(inFile)) {
      d <- myDataFrame
    } else {
      d <- read.csv(inFile$datapath)
    }
    d
  })

  observeEvent(lapply(paste0("drop", myInputs$rendered), function(x) input[[x]]), {
    for (i in myInputs$rendered) {
      updateSelectInput(session, 
                       paste0('select', i), 
                       choices = myData()[input[[paste0('drop', i)]]],
                       selected = input[[paste0("select",i)]])
    }
  })

  output$buttons <- renderUI({
    div(
      actionButton(inputId = "add", label = "Add"), 
      actionButton(inputId = "calc", label = "Calculate")
    )
  })

  observeEvent(input$add, {
    myInputs$rendered <- c(myInputs$rendered, max(myInputs$rendered)+1)
  })

  observeEvent(input$calc, {
    showData <- NULL
    for (i in 1:length(myInputs$rendered)) {
      if(!is.null(input[[paste0("select",i)]])) {
        if(is.null(showData)) {
          showData <- filter(myData(), myData()[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
        }
        else {
          showData <- filter(showData, showData[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
        }
      }
    }
    if (is.null(showData)) { showData <- myData() }
    output$table <- renderTable({showData}) 
  })

  observe({
    output$inputs <- renderUI({
      rows <- lapply(myInputs$rendered, function(i){
        fluidRow(
          column(6,  selectInput(paste0('drop',i), 
                               label = "", 
                               choices = colnames(myData()), 
                               selected = input[[paste0("drop",i)]])),
          column(6,  selectInput(paste0('select',i),
                               label = "",
                               choices = myData()[1],
                               multiple = TRUE,
                               selectize = TRUE))
        )
      })
      do.call(shiny::tagList, rows)
    })
  })
}

shinyApp(ui, server)