如何在observeEvent 中运行两个for 循环？

Question

我有一个动态创建绘图并更新输入值的应用程序。该应用程序正在运行，但我必须加载绘图，然后加载需要两个操作按钮和观察事件的值。

我尝试放置两个用于创建绘图并使用Load All actionButton 更新值的for 循环，但它们似乎无法在observeEvent 中协同工作。我还尝试将 for 循环转换为 lapply，但它不起作用。

library(shiny)

histogramUI <- function(id,var,bins) {
  tagList(
    fluidRow(column(4, selectInput(NS(id, "var"), "Variable", choices = names(mtcars),selected=var),
                    numericInput(NS(id, "bins"), "bins", value = bins, min = 1)),
             column(8, plotOutput(NS(id, "hist"))))
  )
}

histogramServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    data <- reactive(mtcars[[input$var]])
    output$hist <- renderPlot({
      hist(data(), breaks = 10, main = input$var)
    }, res = 96)
  })
}


ui <- 
  fluidPage(
    actionButton("load_plots", "Load Plots"),
    actionButton("load_values", "Load Values"),
    actionButton("load_all", "Load All"),
    div(id = "add_here")
  )

server <- function(input, output, session) {
  
  a <- list("hist_1-var" = "hp", 
            "hist_2-var" = "cyl", 
            "hist_3-var" = "am", 
            "hist_4-var" = "disp", 
            "hist_5-var" = "wt")
  
  modules <- c("add", "hist_1", "hist_2", "hist_3", "hist_4", "hist_5")
  
  
  
  observeEvent(input$load_plots, {
    
    bins <- 10
    if (length(modules)>1) {
      for (i in 1:(length(modules))) {
        if (substr(modules[i],1,4)=='hist') {
          histogramServer(modules[i])
          insertUI(selector = "#add_here", ui = histogramUI(modules[i],paste0(modules[i],"-var"),paste0(modules[i],"-bin")))
        }
      }
    }
  })
  
  observeEvent(input$load_values, {
    
    for (i in 1:length(a)) {
      updateSelectInput(session, inputId = names(a[i]), choices = names(mtcars), selected = a[[i]])
    }
  })
  
  observeEvent(input$load_all, {
    bins <- 10
    if (length(modules)>1) {
      lapply(seq_along(modules),
             function(i) {
               if (substr(modules[i],1,4)=='hist') {
                 histogramServer(modules[i])
                 insertUI(selector = "#add_here", ui = histogramUI(modules[i],paste0(modules[i],"-var"),paste0(modules[i],"-bin")))
               }
               }
      )
      }
    
    lapply(seq_along(a),
           function(k) {
             for (i in 1:length(a)) {
               updateSelectInput(session, inputId = names(a[i]), choices = names(mtcars), selected = a[[i]])
             }
           }
    )
    
 #   if (length(modules)>1) {
 #     for (i in 1:(length(modules))) {
 #       
 #       if (substr(modules[i],1,4)=='hist') {
 #         histogramServer(modules[i])
 #         insertUI(selector = "#add_here", ui = histogramUI(modules[i],paste0(modules[i],"-var"),paste0(modules[i],"-bin")))
 #       }
 #     }
 #   }
 #   
 #   for (i in 1:length(a)) {
 #     updateSelectInput(session, inputId = names(a[i]), choices = names(mtcars), selected = a[[i]])
 #   }    
  })
}

shinyApp(ui, server, enableBookmarking = "server")

Answer 1

对于初始插入，您需要使预先选择的变量对服务器可用。否则服务器将尝试访问尚不存在的input$var (NULL)。这同样适用于bins。

请检查以下内容：

library(shiny)

histogramUI <- function(id, selected_var, selected_bins, module_choices) {
  tagList(fluidRow(
    column(
      4,
      selectInput(
        NS(id, "var"),
        "Variable",
        choices = module_choices,
        selected = selected_var
      ),
      numericInput(NS(id, "bins"), "bins", value = selected_bins, min = 1)
    ),
    column(8, plotOutput(NS(id, "hist")))
  ))
}

histogramServer <- function(id, selected_var, selected_bins, module_choices) {
  moduleServer(id, function(input, output, session) {
    var <- reactive({
      if(is.null(input$var)){
        selected_var
      } else {
        var <- input$var
      }
    })
    
    bins <- reactive({
      if(is.null(input$bins)){
        selected_bins
      } else {
        bins <- input$bins
      }
    })
    
    data <- reactive({
      mtcars[[which(module_choices == var())]]
    })
    
    output$hist <- renderPlot({
      hist(data(), breaks = bins(), main = var())
    }, res = 96)
  })
}

ui <- fluidPage(
  actionButton("load_all", "Load All"),
  div(id = "add_here")
)

server <- function(input, output, session) {
  observeEvent(input$load_all, {
    
    modules <- c("hist_1", "hist_2", "hist_3", "hist_4", "hist_5")
    module_choices <- paste0(modules, "-var")
    names(module_choices) <- colnames(mtcars)[seq_along(module_choices)]
    bins <- 11
    
    if (length(modules) > 1) {
      lapply(seq_along(modules), function(i) {
        histogramServer(modules[i], module_choices[i], bins, module_choices)
        insertUI(
          selector = "#add_here",
          ui = histogramUI(modules[i], module_choices[i], bins, module_choices)
        )
      })
    }
  })
}

shinyApp(ui, server, enableBookmarking = "server")

Answer 2

我会准确回答你的问题。默认insertUI 以延迟方式进行评估。您需要使用 immediate 之类的 insertUI(..., immediate = TRUE) 参数来强制立即评估。

正是你的情况。

insertUI(selector = "#add_here", 
                     ui = histogramUI(modules[i], paste0(modules[i], "-var"), paste0(modules[i], "-bin")), 
                     immediate = TRUE)