闪亮：模块 UI 的 updateSelectInput（在 insertUI 之后）

Question

以下闪亮的应用程序使用模块，它可以工作：

library(shiny)


LHSchoices <- c("X1", "X2", "X3", "X4")

LHSchoices2 <- c("S1", "S2", "S3", "S4")

#------------------------------------------------------------------------------#

# MODULE UI ----
variablesUI <- function(id, number) {

  ns <- NS(id)

  tagList(
    fluidRow(
      column(6,
             selectInput(ns("variable"),
                         paste0("Select Variable ", number),
                         choices = c("Choose" = "", LHSchoices)
             )
      ),

      column(6,
             numericInput(ns("value.variable"),
                          label = paste0("Value ", number),
                          value = 0, min = 0
             )
      )
    )
  )

}

#------------------------------------------------------------------------------#

# MODULE SERVER ----

variables <- function(input, output, session, variable.number){
  reactive({

    req(input$variable, input$value.variable)

    # Create Pair: variable and its value
    df <- data.frame(
      "variable.number" = variable.number,
      "variable" = input$variable,
      "value" = input$value.variable,
      stringsAsFactors = FALSE
    )

    return(df)

  })
}

#------------------------------------------------------------------------------#

# Shiny UI ----

ui <- fixedPage(
  tabsetPanel(type = "tabs",id="tabs",
              tabPanel("t1",value="t1"),
              tabPanel("t2",value="t2")),

  variablesUI("var1", 1),
  h5(""),
  actionButton("insertBtn", "Add another line"),

  verbatimTextOutput("test1"),
  tableOutput("test2")
)

# Shiny Server ----

server <- function(input, output) {

  add.variable <- reactiveValues()

  add.variable$df <- data.frame("variable.number" = numeric(0),
                                "variable" = character(0),
                                "value" = numeric(0),
                                stringsAsFactors = FALSE)

  var1 <- callModule(variables, paste0("var", 1), 1)

  observe(add.variable$df[1, ] <- var1())

  observeEvent(input$insertBtn, {

    btn <- sum(input$insertBtn, 1)

    insertUI(
      selector = "h5",
      where = "beforeEnd",
      ui = tagList(
        variablesUI(paste0("var", btn), btn)
      )
    )

    newline <- callModule(variables, paste0("var", btn), btn)

    observeEvent(newline(), {
      add.variable$df[btn, ] <- newline()
    })

  })

  output$test1 <- renderPrint({
    print(add.variable$df)
  })

  output$test2 <- renderTable({
    add.variable$df
  })

}

#------------------------------------------------------------------------------#

shinyApp(ui, server)

现在，我想用动态选择更新 selectInput。为此，我找到了this answer，可以使用updateSelectInput这个函数。

但在这个应用程序中，selectInput 是在一个模块中。以下不起作用

  observe({
    updateSelectInput(session, "variable",
                      choices = choices_var()
    )})

choices_var() 是一些反应值（例如，它可能取决于所选的选项卡）。

这是完整的代码。

library(shiny)


LHSchoices <- c("X1", "X2", "X3", "X4")

LHSchoices2 <- c("S1", "S2", "S3", "S4")

#------------------------------------------------------------------------------#

# MODULE UI ----
variablesUI <- function(id, number) {

  ns <- NS(id)

  tagList(
    fluidRow(
      column(6,
             selectInput(ns("variable"),
                         paste0("Select Variable ", number),
                         choices = c("Choose" = "", LHSchoices)
             )
      ),

      column(6,
             numericInput(ns("value.variable"),
                          label = paste0("Value ", number),
                          value = 0, min = 0
             )
      )
    )
  )

}

#------------------------------------------------------------------------------#

# MODULE SERVER ----

variables <- function(input, output, session, variable.number){
  reactive({

    req(input$variable, input$value.variable)

    # Create Pair: variable and its value
    df <- data.frame(
      "variable.number" = variable.number,
      "variable" = input$variable,
      "value" = input$value.variable,
      stringsAsFactors = FALSE
    )

    return(df)

  })
}

#------------------------------------------------------------------------------#

# Shiny UI ----

ui <- fixedPage(
  tabsetPanel(type = "tabs",id="tabs",
              tabPanel("tab1",value="t1"),
              tabPanel("tab2",value="t2")),

  variablesUI("var1", 1),
  h5(""),
  actionButton("insertBtn", "Add another line"),

  verbatimTextOutput("test1"),
  tableOutput("test2")
)

# Shiny Server ----

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


  choices_var <- reactive({
    if (input$tabs=="t1"){

      choices_var <- LHSchoices
    }
    if (input$tabs=="t2") {
      choices_var <- LHSchoices2
    }
    return(choices_var)
  })

  observe({
    updateSelectInput(session, "variable",
                      choices = choices_var()
    )})


  add.variable <- reactiveValues()

  add.variable$df <- data.frame("variable.number" = numeric(0),
                                "variable" = character(0),
                                "value" = numeric(0),
                                stringsAsFactors = FALSE)

  var1 <- callModule(variables, paste0("var", 1), 1)

  observe(add.variable$df[1, ] <- var1())

  observeEvent(input$insertBtn, {

    btn <- sum(input$insertBtn, 1)

    insertUI(
      selector = "h5",
      where = "beforeEnd",
      ui = tagList(
        variablesUI(paste0("var", btn), btn)
      )
    )

    newline <- callModule(variables, paste0("var", btn), btn)

    observeEvent(newline(), {
      add.variable$df[btn, ] <- newline()
    })

  })

  output$test1 <- renderPrint({
    print(add.variable$df)
  })

  output$test2 <- renderTable({
    add.variable$df
  })

}

#------------------------------------------------------------------------------#

shinyApp(ui, server)

我想知道如何修改代码以便可以修改选项。

编辑：我通过添加以下代码成功更新了第一个 UI。所以现在我的问题是：我们如何才能动态到达variablesUI？

  choices_var <<- reactive({
    if (input$tabs=="t1"){

      choices_var <- LHSchoices
    }
    if (input$tabs=="t2") {
      choices_var <- LHSchoices2
    }
    return(choices_var)
  })

  observeEvent({
    choices_var()
  }, {
    updateSelectInput(session, "var1-variable",
                      choices = choices_var())
  })

EDIT 2：我可以像下面这样手动完成，但是那样真的很难看，而且添加的 UI 数量应该是有限的。

  observeEvent({
    choices_var()
  }, {
    updateSelectInput(session, "var1-variable",
                      choices = choices_var())
  })

  observeEvent({
    choices_var()
  }, {
    updateSelectInput(session, "var2-variable",
                      choices = choices_var())
  })

编辑 3

现在我的问题变得更加具体：当使用insertUI 插入selectInput 时，如何使用updateSelectInput 更新新插入的selectInput 的选择？

Answer 1

您的variable 输入在一个模块中。您正在尝试从主要的 server 函数更新它。所以你有一个命名空间不匹配。这也违反了模块应该是自包含的原则。

理想情况下，您应该更新定义它的模块中的variable 输入。如果更新依赖于模块外部存在的值，您可以将它们作为响应传递给模块服务器函数。

*** 编辑 *** 这是一个简单的、自包含的示例，以响应 OP 的请求，以演示如何使用主 server 函数提供的数据更新位于模块内的 selectInput。我已经删除了与演示目的不直接相关的所有内容。

该应用程序包含模块的两个实例（由moduleUI 和moduleController 定义）。每个实例都有自己的id，因此服务器可以区分它们。主 UI 还包括一对selectInputs，每个@s 告诉一个模块实例要显示什么。

完成这项工作的关键是将控制seelctinput 的值传递给相应模块实例的控制器，例如：

mod1 <- callModule(moduleController, "Module1", reactive({input$module1Mode}))

模块控制器函数如下所示

moduleController <- function(input, output, session, selector) { ... }

注意名为selector 的附加参数，它对应于控制selectInput 的当前值。该模块通过

对其控制器的更改做出反应

  observeEvent(selector(), {
    updateSelectInput(session, "select", choices=choiceLists[[selector()]])
  })

并用

向主服务器返回一个值

  returnValue <- reactive({
    input$select
  })
  
  return(returnValue)

如果您使用该应用程序，您会发现每个模块实例显示的选择列表可以独立控制，服务器可以区分（并响应）每个模块实例返回的值。

这是完整的代码：

library(shiny)

moduleUI <- function(id) {
  ns <- NS(id)
  
  wellPanel(
    h4(paste0("This is module id"), id),
    selectInput(ns("select"), label="Make a choice: ", choices=c())
  )
}

moduleController <- function(input, output, session, selector) {
  ns <- session$ns
  
  choiceLists <- list(
    "Animals"=c("Cat", "Dog", "Rabbit", "Fish"),
    "Fruit"=c("Apple", "Orange", "Pear", "Rambutan"),
    "Sports"=c("Football", "Cricket", "Rugby", "Volleyball"),
    "Countries"=c("Great Britain", "China", "USA", "France")
  )
  
  observeEvent(selector(), {
    updateSelectInput(session, "select", choices=choiceLists[[selector()]])
  })
  
  returnValue <- reactive({
    input$select
  })
  
  return(returnValue)
}

ui <- fixedPage(
  selectInput("module1Mode", label="Select module 1 mode", choices=c("Animals", "Fruit")),
  moduleUI("Module1"),
  selectInput("module2Mode", label="Select module 2 mode", choices=c("Sports", "Countries")),
  moduleUI("Module2"),
  textOutput("mod1Text"),
  textOutput("mod2Text")
)

server <- function(input, output, session) {
  mod1 <- callModule(moduleController, "Module1", reactive({input$module1Mode}))
  mod2 <- callModule(moduleController, "Module2", reactive({input$module2Mode}))
  
  observe({
    if (is(mod1(), "character")) print("Ah-ha!")
  })
  
  output$mod1Text <- renderText({
    paste("Module 1 selection is", mod1())
  })

  output$mod2Text <- renderText({
    paste("Module 2 selection is", mod2())
  })
}

shinyApp(ui, server)