如何将 lapply 与 moduleServer 一起使用，返回我想要观察的反应

Question

我正在尝试简化我的代码。我不想复制/粘贴类似的元素，而是想定义一个描述它们的列表，然后应用 lapply 来获取它们。我需要与全球环境进行双向通信。

这就是我的开始。我有一个全局

numericInput

，并且我有多个包含

numericInput

的模块。更改全局会传播到模块。通过单击按钮可以将更改模块传播到全局。一旦全局更新，这就会传播到所有模块：

library(shiny)

testUI <- function(id) {
  tagList(
    numericInput(NS(id, "module"), "module", value = NULL),
    actionButton(NS(id,"button"), label = "send")
  )
}

testServer <- function(id,reactinput) {
  stopifnot(is.reactive(reactinput))
  
  moduleServer(id, function(input,output,session) {
    rval <- reactiveValues(num = NULL)
    observe({rval$num <- reactinput()})
    observeEvent(rval$num,{updateNumericInput(inputId = "module", value = rval$num)})
    
    observeEvent(input$button, {
      rval$num <- input$module
    })
    return(reactive({rval$num}))
  }) 
}

testApp <- function() {
  ui <- fluidPage(
    numericInput("global", "global", value = 5),

    testUI("test1"),
    testUI("test2"),
    testUI("test3") 
  )

  server <- function(input, output, session) {
    val1 <- testServer("test1",reactive(input$global))
    observeEvent(val1(), {updateNumericInput(inputId = "global", value = val1())})

    val2 <-testServer("test2",reactive(input$global))
    observeEvent(val2(), {updateNumericInput(inputId = "global", value = val2())})

    val3 <-testServer("test3",reactive(input$global))
    observeEvent(val3(), {updateNumericInput(inputId = "global", value = val3())})
  }
  shinyApp(ui, server)  
}

testApp()

这有效。但是，对于实际的应用程序，并且有大量被调用的模块，这很快就不那么有趣了。 我发现我们可以使用 lapply 来生成 UI：

library(shiny)

itemlist <- list("test1", "test2", "test3")

testUI <- function(id) {
  tagList(
    numericInput(NS(id, "module"), "module", value = NULL),
    actionButton(NS(id,"button"), label = "send")
  )
}

testServer <- function(id,reactinput) {
  stopifnot(is.reactive(reactinput))
  
  moduleServer(id, function(input,output,session) {
    rval <- reactiveValues(num = NULL)
    observe({rval$num <- reactinput()})
    observeEvent(rval$num,{updateNumericInput(inputId = "module", value = rval$num)})
    
    observeEvent(input$button, {
      rval$num <- input$module
    })
    return(reactive({rval$num}))
  }) 
}

testApp <- function() {
  ui <- fluidPage(
    numericInput("global", "global", value = 5), 
    lapply(itemlist,testUI)
  )
  
  server <- function(input, output, session) {
    val1 <- testServer("test1",reactive(input$global))
    observeEvent(val1(), {updateNumericInput(inputId = "global", value = val1())})

    val2 <-testServer("test2",reactive(input$global))
    observeEvent(val2(), {updateNumericInput(inputId = "global", value = val2())})

    val3 <-testServer("test3",reactive(input$global))
    observeEvent(val3(), {updateNumericInput(inputId = "global", value = val3())})
  }
  shinyApp(ui, server)  
}

testApp()

这仍然有效。 但当然，我也不想复制/粘贴服务器功能。我不知道该怎么做。我上网查了一下，也看了几个帖子。我认为这个线程非常接近我想做的事情，但我无法弄清楚如何将它应用到我的情况中。 此主题没有答案。我找不到任何其他关于 lapply 和返回响应的服务器函数的帖子。也许我没有使用正确的搜索词。 大多数尝试根本不起作用。当我这样做时，它至少不再崩溃了：

server <- function(input, output, session) {
    vallist <- reactive(lapply(itemlist,function(item) {testServer(item,
reactinput=reactive(input$global))}))
    observeEvent(vallist(), {updateNumericInput(inputId = "global", value = vallist())}
  }

但它不起作用。我一直在踢自己，事情一定没有我做的那么难。任何有关如何调用服务器函数和观察返回的反应的帮助将不胜感激。

Answer 1

您可以使用

lapply

创建模块服务器和

observe

rs，如下所示：

library(shiny)

itemlist <- list("test1", "test2", "test3")

testUI <- function(id) {
  tagList(
    numericInput(NS(id, "module"), "module", value = NULL),
    actionButton(NS(id, "button"), label = "send")
  )
}

testServer <- function(id, reactinput) {
  stopifnot(is.reactive(reactinput))

  moduleServer(id, function(input, output, session) {
    rval <- reactiveValues(num = NULL)
    observe({
      rval$num <- reactinput()
    })
    observeEvent(rval$num, {
      updateNumericInput(inputId = "module", value = rval$num)
    })

    observeEvent(input$button, {
      rval$num <- input$module
    })
    return(reactive({
      rval$num
    }))
  })
}

testApp <- function() {
  ui <- fluidPage(
    numericInput("global", "global", value = 5),
    lapply(itemlist, testUI)
  )

  server <- function(input, output, session) {
    names(itemlist) <- itemlist
    
    vals <- lapply(itemlist, testServer, reactinput = reactive(input$global))
    
    lapply(itemlist, \(item) {
      observe({
        updateNumericInput(inputId = "global", value = vals[[item]]())
      })
    })
  }
  shinyApp(ui, server)
}

testApp()