Question

我正在尝试构建一个动态表单，用户可以在其中添加一些条件（通过actionButton）并为这些条件选择值。当他完成选择时，他可能会启动一些计算。可以通过“删除”按钮删除每个条件。

除了最后插入的组件没有对相关的删除按钮做出反应之外，它对所有人都很好。仅当单击“添加条件”按钮时，才会删除最后一个组件。

这是一个错误还是你指出我的错误？

我正在使用一个带有renderUI的observeEvent来构建组件：

在server.R

中

observeEvent(input$go, {

output$ui <- renderUI({

    rows <- lapply(names(components),buildComponent)

    res = do.call(fluidRow, rows)

})

makeObservers()

})

makeObservers为每个组件创建一个observeEvent闭包：

makeObservers <- eventReactive(input$go, {

IDs <- names(components) 

new_ind <- !(IDs %in% vals$y)    

res <- lapply(IDs[new_ind], function (x) {

  observeEvent(input[[paste0("rmv", x)]], {

    if(components[[x]] == "Main1") removeComponent(x)
  })
})
} , 
 ignoreNULL = F, ignoreInit = F)

请找一个有效的例子。

library(shiny)
library(shinythemes)

criterias <- c("Criteria 1", "Criteria 2", "Criteria 3", "Criteria 4")
components <<- list()
counter <<- 0

buildComponent <- function(val) {
  idselect = paste0("select", val)
  idremove <- paste0("rmv", val)
  div(
    selectInput(idselect, "criteria :", criterias, criterias[0]),
    actionButton(idremove, paste0("X", val),icon = icon("remove"), size = "small")
  )
}

removeComponent <- function(x) {
  print(paste0("Removing" ,x))
  xpath1 = paste0("div:has(> #select", x ,")" )
  xpath2 = paste0("div:has(> #rmv", x ,")" )
  removeUI(
    selector = xpath1, multiple = T#, immediate=T
  )
  removeUI(
    selector = xpath2, multiple = T#, immediate=T
  )
  components[[as.character(x)]] <<- NULL
}

ui <- shinyUI(fluidPage(
                    sidebarPanel(
                      actionButton("go", "Criteria", icon = icon("plus-circle"), 
                                   size = "small"),
                      uiOutput("ui")
                    ),
                    mainPanel(
                      actionButton("activate", "show cpts"),
                      textOutput('show_components')
                    )
) )

server <- shinyServer(function(input, output, session) {
  # Keep track of which observer has been already created
  vals <- reactiveValues(y = NULL)

  makeObservers <- eventReactive(input$go, {
    IDs <- names(components) 
    new_ind <- !(IDs %in% vals$y)
    print("new_ind")
    print(IDs[new_ind])
    # update reactive values
    vals$y <- names(components) 
    res <- lapply(IDs[new_ind], function (x) {
      observeEvent(input[[paste0("rmv", x)]], {
    print(paste0("rmv", x))
    print(components[[x]])
    if(components[[x]] == "Main1") removeComponent(x)
      })
    })
  } , ignoreNULL = F, ignoreInit = F)

  observeEvent(input$go, {
    output$ui <- renderUI({
      print(counter)
      counter <<- counter + 1
    components[[as.character(counter)]] <<- "Main1"
    print("adding component : ")
    print(paste0(names(components),collapse = ";"))
    rows <- lapply(names(components),buildComponent)
    res = do.call(fluidRow, rows)
    })
    makeObservers()
  })

  observeEvent(input$activate, {
    output$show_components <- renderPrint({
      components
    })
  })
})

shinyApp(ui, server)

感谢Mike Wise的精彩言论，我已经能够发现确切的问题:(请参阅Mike回答中的评论）。这是一些代码：

library(shiny)
library(shinythemes)

criterias <- c("Criteria 1", "Criteria 2", "Criteria 3", "Criteria 4")
components <<- list()
counter <<- 0

buildComponent <- function(val) {
  idselect = paste0("select", val)
  idremove <- paste0("rmv", val)
  div(
    selectInput(idselect, "criteria :", criterias, criterias[0]),
    actionButton(idremove, paste0("X", val),icon = icon("remove"), size = "small")
  )
}

removeComponent <- function(x) {
  print(paste0("Removing" ,x))
  xpath1 = paste0("div:has(> #select", x ,")" )
  xpath2 = paste0("div:has(> #rmv", x ,")" )
  removeUI(
    selector = xpath1, multiple = T#, immediate=T
  )
  removeUI(
    selector = xpath2, multiple = T#, immediate=T
  )
  components[[as.character(x)]] <<- NULL
}

ui <- shinyUI(fluidPage(
  sidebarPanel(
    actionButton("go", "Criteria", icon = icon("plus-circle"), 
             size = "small"),
    uiOutput("ui")
  ),
  mainPanel(
    actionButton("activate", "show cpts"),
    textOutput('show_components')
  )
) )

server <- shinyServer(function(input, output, session) {
  # Keep track of which observer has been already created
  vals <- reactiveValues(y = NULL)

  makeObservers <- eventReactive(input$go, {
    IDs <- names(components) 
    new_ind <- !(IDs %in% vals$y)
    print("new_ind")
    print(IDs[new_ind])
    # update reactive values
    vals$y <- names(components) 
    res <- lapply(IDs[new_ind], function (x) {
      observeEvent(input[[paste0("rmv", x)]], {
    print(paste0("rmv", x))
    print(components[[x]])
    if(components[[x]] == "Main1") removeComponent(x)
      })
    })
  } , ignoreNULL = F, ignoreInit = F)

  observeEvent(input$go, {
    counter <<- counter + 1
    components[[as.character(counter)]] <<- "Main1"
    output$ui <- renderUI({
      print(counter)
      print("adding component : ")
      print(paste0(names(components),collapse = ";"))
      rows <- lapply(names(components),buildComponent)
      res = do.call(fluidRow, rows)
    })
    makeObservers()
  })

  observeEvent(input$activate, {
    output$show_components <- renderPrint({
      components
    })
  })
})

shinyApp(ui, server)

Answer 1

好的，代码中存在一些问题，我不得不做一些小而重要的修改来理解它，然后让它按预期工作。但它基本上是相同的代码。

的变化：

将rv$y更改为rv$prev_components。
将components和counter变量放入reactiveValues以摆脱<<-，因为您已经使用reactiveValues已经消除了需要<<-
添加setdiff以查找您的姓名的新增内容（这是关键）。
将makeObervables更改为一个简单的函数（无论如何都没有用作eventReactive）。
可能还有其他一些被遗忘的小事。

这是代码：

library(shiny)
library(shinythemes)

criterias <- c("Criteria 1", "Criteria 2", "Criteria 3", "Criteria 4")

vals <- reactiveValues(prev_components=list(),components=list(),counter=0)

buildComponent <- function(val) {
  idselect = paste0("select", val)
  idremove <- paste0("rmv", val)
  div(
    selectInput(idselect, "criteria :", criterias, criterias[0]),
    actionButton(idremove, paste0("X", val),icon = icon("remove"), size = "small")
  )
}

removeComponent <- function(x) {
  print(paste0("Removing" ,x))
  xpath1 = paste0("div:has(> #select", x ,")" )
  xpath2 = paste0("div:has(> #rmv", x ,")" )
  removeUI(
    selector = xpath1, multiple = T#, immediate=T
  )
  removeUI(
    selector = xpath2, multiple = T#, immediate=T
  )
  vals$components[[as.character(x)]] <<- NULL
}

ui <- shinyUI(fluidPage(
  sidebarPanel(
    actionButton("go", "Criteria", icon = icon("plus-circle"),
                 size = "small"),
    uiOutput("uii")
  ),
  mainPanel(
    actionButton("activate", "show cpts"),
    textOutput('show_components')
  )
) )


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

  makeObservers <- function() {
    IDs <- names(vals$components)
    new_ind <- setdiff(IDs,vals$prev_components)

    vals$prev_components <- names(vals$components)
    res <- lapply(new_ind, function (x) {
      observeEvent(input[[paste0("rmv", x)]], {
        print(paste0("rmv", x))
        print(vals$components[[x]])
        if(vals$components[[x]] == "Main1") removeComponent(x)
      })
    })
  }

  observeEvent(input$go, {
    print(vals$counter)
    vals$counter <- vals$counter + 1
    vals$components[[as.character(vals$counter)]] <- "Main1"

    output$uii <- renderUI({
      print("adding component : ")
      print(paste0(names(vals$components),collapse = ";"))
      rows <- lapply(names(vals$components),buildComponent)
      res = do.call(fluidRow, rows)
    })
    makeObservers()
  })

  observeEvent(input$activate, {
    output$show_components <- renderPrint({
      vals$components
    })
  })
})

shinyApp(ui, server)

屏幕截图：

闪亮：动态形式/ ui：列表中的最后一个观察者不会触发removeUI

1 个答案: