R Shiny - 使用 selectInput 刷新动态生成的输入函数

Question

我有一个闪亮的应用程序，一旦我更改了 selectInput 值，我的动态生成的 UI 将无法正确显示。

在这里，您可以在两个数据框之间进行选择。当您单击该按钮时，它会生成一个 selectInput（其值是数据框的列名）和 checkboxInput UI（您选择的列的唯一值）。这很好，但是一旦我更改了我想要查看的数据框，selectInput 值就会“相应地”填充新数据框的列名。但是，checkboxInput 不再显示。

ui <- fluidPage(
  fluidRow(
    column(4, 
           uiOutput("projectSelection"),
           uiOutput("addCol")
    )
  ),
  fluidRow(
    tags$div(id="rowLabel")
  )
)

server <- function(input, output, session) {
  Project.ID <- c("Test Project 1", "Test Project 1", "Test Project 1", "Test Project 1")
  Project.ID2 <- c("Test Project 2", "Test Project 2", "Test Project 2", "Test Project 2")
  Author.ID <- c("1234", "5234", "3253", "5325")
  Fav.Color <- c("Blue", "Red", "Blue", "Green")
  Author.Name <- c("Bob", "Jenny", "Bob", "Alice")

  output$projectSelection <- renderUI(
    selectInput("projectSelection",
                "Project Name:",
                c("Project1", "Project2"),
                selectize=TRUE)
  )

  # update datatable
  project <- reactive({
    if(input$projectSelection == "Project1"){
      projectDT <- data.frame(Project.ID, Author.ID, Author.Name)
    }
    if(input$projectSelection == "Project2"){
      projectDT <- data.frame(Project.ID2, Author.Name, Fav.Color)
    }
    return(projectDT)
  })


  #Button to add comparison column
  output$addCol <- renderUI({
    input$projectSelection #re-render once projectSelection changes?
    if(is.null(input$projectSelection)) return() 
    actionButton('addCol', strong("Add UI"), icon=icon("plus", class=NULL, lib="font-awesome"))
  })

  observeEvent({input$addCol},{
    insertUI(
      selector = "#rowLabel", 
      where = "beforeEnd", 
      ui = div(              
        fluidRow( 
             column(4, 
                    uiOutput(paste0("showMeta",input$addCol)),
                    uiOutput(paste0("showVal",input$addCol)),
                    br()
          )
        )
      )
    )
  })

  #Output creations
  lapply(1:10, function(idx){
    #comparison dropdowns
    output[[paste0("showMeta",idx)]] <- renderUI({
      input$projectSelection
      selectInput(inputId =  paste0("metalab",idx),
                  label =  "Column Label:",
                  choices =  c(unique(as.vector(colnames(project())))),
                  selectize = TRUE,
                  selected = input[[paste0("metalab",idx)]]
      )
    })
    output[[paste0("showVal",idx)]] <- renderUI({
      req(input$addCol >= idx)
      input$projectSelection
      if(!is.null(input[[paste0("metalab", idx)]])){
        checkboxGroupInput(paste0("metaval",idx),
                           "Column Value:",
                           choices = unique(as.vector(unlist(project()[[input[[paste0("metalab",idx)]]]]))),
                           selected = input[[paste0("metaval",idx)]]
        )

      }
    })
  })

  # observe({input$projectSelection},
  #         {
  #           lapply(1:10, function(idx){
  #             updateSelectInput(session, paste0("metalab",idx),
  #                               label =  "Column Label:",
  #                               choices =  c(unique(as.vector(colnames(project()))))
  #             )
  #           })
  #         })
}

shinyApp(ui=ui, server = server)

我不确定沿线某处是否存在引用问题，但我希望 checkboxInput UI 显示适当的值（对于选定的列）。我曾考虑过在input$projectSelection 更改后尝试让它重新渲染，但这似乎无济于事。我还尝试为其添加observe，以便在input$projectSelection 更改时动态生成的UI 更新，但我也没有成功。

我将不胜感激任何和所有的帮助！谢谢！

Answer 1

您的复选框仅在您单击“添加”按钮时更新。

我已经根据列名的selectinput更改了它的代码来制作动态复选框，我相信功能保持不变

ui <- fluidPage(
  fluidRow(
    column(4, 
           uiOutput("projectSelection"),
           uiOutput("addSelect"),
           uiOutput("checkbox")
    )
  ),
  fluidRow(
    tags$div(id="rowLabel")
  )
)

server <- function(input, output, session) {
  Project.ID <- c("Test Project 1", "Test Project 1", "Test Project 1", 
                  "Test Project 1")
  Project.ID2 <- c("Test Project 2", "Test Project 2", "Test Project 
                 2", "Test Project 2")
  Author.ID <- c("1234", "5234", "3253", "5325")
  Fav.Color <- c("Blue", "Red", "Blue", "Green")
  Author.Name <- c("Bob", "Jenny", "Bob", "Alice")

  output$projectSelection <- renderUI(
    tagList( 
     selectInput("projectSelection",
                  "Project Name:",
                  c("Project1", "Project2"),
                  selectize=TRUE),
      actionButton('addCol', strong("Add UI"), icon=icon("plus", 
             class=NULL, lib="font-awesome"))
   )

 )

  # update datatable
  project <- reactive({
    if(input$projectSelection == "Project1"){
      projectDT <- data.frame(Project.ID, Author.ID, Author.Name)
    }
    if(input$projectSelection == "Project2"){
      projectDT <- data.frame(Project.ID2, Author.Name, Fav.Color)
    }
    return(projectDT)
  })


  observeEvent(input$addCol,{ 
    output$addSelect <- renderUI({
      selectInput("abc","Column Names", choices = 
      c(unique(as.vector(colnames(project())))))

    })

    output$checkbox <- renderUI({
      checkboxGroupInput("cde", "Column Value", choices = project()
       [,input$abc] ) 
    })  
  })   

}

shinyApp(ui=ui, server = server)