动态创建反应性UI输入和按钮的闪亮

Question

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

我能找到的最接近的解决方案是this stackoverflow question，它确实处理了我需要的前两件事。但是，我无法弄清楚如何将被动操作与动态添加按钮的点击操作相关联。

最简单的用例可能会出现在很多现代网站上（并且很容易在Shiny之外使用HTML / CSS / JS实现）：

有一排输入，下面有一个按钮，表示＆＃34;添加。＆＃34;单击“添加”按钮时，将添加另一行，以及该行末尾的一个按钮，允许您删除该行。通过这种方式，您可以通过单击添加按钮在列表底部添加另一行，或者通过单击该行中的删除按钮来删除显示的任何行。

如上面的stackoverflow链接所示，可以使用动态呈现的UI之外的按钮添加行。您可以通过在动态呈现的UI之外添加类似按钮来轻松删除行，但这只允许您删除最后一行（或一些硬​​编码的行号）。我想要的是在每一行上都有动态渲染的按钮，当点击它们时，删除该行。

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

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

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

任何人都可以就如何做到这一点给出任何见解吗？提前谢谢！

编辑：一个代码片段（从上面的stackoverflow链接修改），演示了我想要的内容。理想情况下，我希望能够点击＆＃34; x＆＃34;按钮并删除与其关联的行。

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来解决这个问题的合适解决方案。它允许您通过按下按钮添加行，并根据您的选择删除任意行。一个问题是给定的＆＃34; id＆＃34;现在的行只是简单地增加，以确保每个＆＃34; id＆＃34;是独特的。如果有人有更好的方法，请告诉我。谢谢！

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)