在 Shiny 中动态创建 Reactive UI 输入和按钮

Question

我希望能够动态添加 UI 输入，使用输入值，并使操作与动态添加的 UI 按钮相关联。

我能找到的最接近的解决方案是，它确实处理了我需要的前两件事。但是，我不知道如何将响应式操作与动态添加按钮的点击操作相关联。

最简单的用例是在许多现代网站上经常看到的东西（并且很容易在 Shiny 之外使用 HTML/CSS/JS 实现）：

有一行输入，下面有一个按钮，上面写着 "add." 当您单击添加按钮时，会添加另一行，并在该行末尾有一个按钮，可让您删除那一行。这样，您可以通过单击添加按钮在列表底部添加另一行，或通过单击该行中的删除按钮删除显示的任何行。

如上面的 Whosebug link 所示，可以使用动态呈现 UI 之外的按钮添加行。您可以通过在动态呈现的 UI 之外添加一个类似的按钮来轻松删除行，但这只允许您删除最后一行（或一些硬编码的行号）。我想要的是在每一行上动态呈现按钮，单击时删除该行。

我一直遇到的主要问题是，假设每一行都有一个 ID 号 1、2、3 等，那么每个按钮可能都有一个 ID "remove1"、"remove2"， "remove3"，等等。但是，据我所知，我无法为可能具有变量值的 ID 创建通用的 observeEvent：

observeEvent(input$removei,{
    # remove row i
})

当然，我希望更通用 - 按钮不一定要删除行，我可能还希望它打开一个显示与该行相关的数据的 modal/another 面板。

任何人都可以提供有关如何执行此操作的任何见解吗？提前致谢！

编辑：演示我想要的代码片段（从上面的 Whosebug link 修改而来）。理想情况下，我希望能够单击 "x" 按钮并删除与其关联的行。

library(shiny)

ui <- shinyUI(pageWithSidebar(
  headerPanel("Add Features"),
  sidebarPanel(width=4,
               fluidRow(column(12,
                               h3('Features'),
                               uiOutput('uiOutpt')
               )), # END fluidRow
               fluidRow(
                 column(4,div()),
                 column(4,actionButton("add", "Add!")),
                 column(4,actionButton('goButton',"Analyze"))
               ) # END fluidRow
  ), # END sidebarPanel
  mainPanel(
    verbatimTextOutput("nText"),
    textOutput("text2"),
    tableOutput('tbl')
  )
))

server <- shinyServer(function(input, output) {
  features <- reactiveValues(renderd=c(1))

  ntext <- eventReactive(input$goButton, {
    out <- lapply(features$renderd,function(i){
      vn <- paste0('Feature',i)
      # Get input values by namw
      sprintf( 'Variable: %s',input[[vn]] )
    })
    do.call(paste,c(out,sep="\n"))
  })

  df <- eventReactive(input$goButton, {
    out <- lapply(features$renderd,function(i){
      vn <- paste0('Feature',i)
      data.frame(Variable=input[[vn]] )
    })
    do.call(rbind,out)
  })

  output$nText <- renderText({
    ntext()
  })
  output$text2 <- renderText({ 
    sprintf("You have selected feature: %s", 
paste(features$renderd,collapse=", "))
  })

  output$tbl <- renderTable({
    df()
  })

  # Increment reactive values used to store how may rows we have rendered
  observeEvent(input$add,{
    if (max(features$renderd) > 2) return(NULL)
    features$renderd <- c(features$renderd, max(features$renderd)+1)
  })

  # If reactive vector updated we render the UI again
  observe({
    output$uiOutpt <- renderUI({
      # Create rows
      rows <- lapply(features$renderd,function(i){
        fluidRow(
          selectInput(paste0('Feature',i), 
                                 label = "", 
                                 choices = 
list("Feature1","Feature2","Feature3"), 
                                 selected = paste0('Feature',i)),   
          actionButton(paste0('remove',i), label="x")
        )
      })
      do.call(shiny::tagList,rows)

    })
  })
})

shinyApp(ui=ui,server=server)

Answer 1

没有可重现的例子很难给你一个好的答案。我认为这应该可以解决您的问题：

## loop over the ids ( we have an event by id)
for(ii in id_list){
  local({
    ## just wrap the observeEvent part under local
    i <- ii
    observeEvent(input[[paste0("remove",i)]],{
    # remove row i
   })
 )}
}

Answer 2

看来您正在寻找闪亮的模块，它可以让您创建一组 ui 一起工作。您可以查看 https://shiny.rstudio.com/articles/modules.html 中的示例。稍后，我会尝试根据您的问题进行调整。

更新：问题适配闪亮模块

library(shiny)

cellUI <- function(id) {
    ns <- NS(id)

    fluidRow(
        selectInput(ns("Feature"),
                    label = "",
                    choices =
                        list("Feature1","Feature2","Feature3"),
                    selected = paste0("Feature", id)),
        actionButton(ns("remove"), label="x")
    )
}

cellSever <- function(input, output, features, feature, session) {
    observeEvent(input$remove, {
        features$renderd[features$renderd == feature] <- NULL
    })
}

ui <- shinyUI(pageWithSidebar(
    headerPanel("Add Features"),
    sidebarPanel(width=4,
                 fluidRow(column(12,
                                 h3('Features'),
                                 uiOutput('uiOutpt')
                 )), # END fluidRow
                 fluidRow(
                     column(4,div()),
                     column(4,actionButton("add", "Add!")),
                     column(4,actionButton('goButton',"Analyze"))
                 ) # END fluidRow
    ), # END sidebarPanel
    mainPanel(
        verbatimTextOutput("nText"),
        textOutput("text2"),
        tableOutput('tbl')
    )
))

server <- shinyServer(function(input, output) {
    features <- reactiveValues(renderd=list(1))

    ntext <- eventReactive(input$goButton, {
        out <- lapply(features$renderd,function(i){
            vn <- paste0('Feature')
            # Get input values by namw
            sprintf( 'Variable: %s',input[[NS(i)(vn)]] )
        })
        do.call(paste,c(out,sep="\n"))
    })

    df <- eventReactive(input$goButton, {
        out <- lapply(features$renderd,function(i){
            vn <- paste0('Feature')
            data.frame(Variable=input[[NS(i)(vn)]] )
        })
        do.call(rbind,out)
    })

    output$nText <- renderText({
        ntext()
    })
    output$text2 <- renderText({
        sprintf("You have selected feature: %s",
                paste(features$renderd,collapse=", "))
    })

    output$tbl <- renderTable({
        df()
    })

    # Increment reactive values used to store how may rows we have rendered
    observeEvent(input$add,{
        if (features$renderd[[length(features$renderd)]] > 2) return(NULL)
        features$renderd <- c(features$renderd, features$renderd[[length(features$renderd)]]+1)
    })

    # If reactive vector updated we render the UI again
    observe({
        output$uiOutpt <- renderUI({
            # Create rows
            rows <- lapply(features$renderd,function(i){
                fluidRow(
                    cellUI(i)
                )
            })
            lapply(features$renderd, function(i) callModule(cellSever, i, features = features, feature = i))
            do.call(shiny::tagList,rows)

        })
    })
})

shinyApp(ui=ui,server=server)

Answer 3

我想出了一个使用 Shiny Modules 来解决这个问题的不错的解决方案。它允许您按一下按钮添加行，并根据您的选择删除任意行。一个问题是现在给定的 "id" 行只是不断递增，以确保每个 "id" 都是唯一的。如果有人有更好的方法来做到这一点，请告诉我。谢谢！

library(shiny)

rowInput <- function(id){
  ns <- NS(id)
  fluidRow(
    selectInput(ns(id), 
                label = "", 
                choices = list("Feature1","Feature2","Feature3")),
    conditionalPanel('!output.bool', actionButton(ns('remove'), label="x"))
  )
} 

row <- function(input, output, session, features, id){
  observeEvent(input$remove, {
    if(length(features$renderd) < 2){
      print(features$renderd)
      return()
    }
    features$renderd <- features$renderd[features$renderd != id]
  })
}

ui <- shinyUI(pageWithSidebar(
  headerPanel("Add Features"),
  sidebarPanel(width=4,
               fluidRow(column(12,
                               h3('Features'),
                               uiOutput('uiOutpt')
               )), # END fluidRow
               fluidRow(
                 column(4,div()),
                 column(4,actionButton("add", "Add!")),
                 column(4,actionButton('goButton',"Analyze"))
               ) # END fluidRow
  ), # END sidebarPanel
  mainPanel(
    verbatimTextOutput("nText"),
    textOutput("text2"),
    tableOutput('tbl'),
    textOutput("bool")
  )
))

server <- shinyServer(function(input, output) {
  features <- reactiveValues(renderd=c(1))

  nextId <- 2
  minModuleCalled <- 0

  output$bool <- reactive({
    length(features$renderd) == 1
  })

  ntext <- eventReactive(input$goButton, {
    out <- lapply(features$renderd,function(i){
      vn <- paste0('Feature',i)
      # Get input values by namw
      sprintf( 'Variable: %s',input[[vn]] )
    })
    do.call(paste,c(out,sep="\n"))
  })

  df <- eventReactive(input$goButton, {
    out <- lapply(features$renderd,function(i){
      vn <- paste0('Feature',i)
      data.frame(Variable=input[[vn]] )
    })
    do.call(rbind,out)
  })

  output$nText <- renderText({
    ntext()
  })
  output$text2 <- renderText({ 
    sprintf("You have selected feature: %s", 
paste(features$renderd,collapse=", "))
  })

  output$tbl <- renderTable({
    df()
  })

  # Increment reactive values used to store how may rows we have rendered
  observeEvent(input$add,{
    features$renderd <- c(features$renderd, nextId)
    nextId <<- nextId + 1
  })

  # If reactive vector updated we render the UI again
  observe({
    output$uiOutpt <- renderUI({
      # Create rows
      rows <- lapply(features$renderd, function(i){
        rowInput(paste0("Feature",i))
      })
      lapply(features$renderd, function(i){
        if(i > minModuleCalled){
          print(paste("new module",i))
          callModule(row, paste0("Feature",i), features, i)
          minModuleCalled <<- i
        }
      })
      do.call(shiny::tagList,rows)
    })
  })
})

shinyApp(ui=ui,server=server)

在 Shiny 中动态创建 Reactive UI 输入和按钮

Dynamic Creation of Reactive UI Inputs and Buttons in Shiny

r

shiny

reactive