问题
The following shiny app uses modules, it works:
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)
Now, I would like to update the selectInput, with dynamic choices. For this, I found this answer, and it is possible to use the function updateSelectInput.
But in this app, the selectInput is in a module. The following doesn't work
observe({
updateSelectInput(session, "variable",
choices = choices_var()
)})
choices_var() is some reactive values (it can depend on the selected tab for example).
Here is the full code.
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)
I would like to how to modify the code so that the choices can be modified.
EDIT: I succeded to update the first UI by adding the code below. So now my question is: how can we dynamically reach the 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: I can do it manually as below, but that would be really ugly, and the number of added UI should be limited.
observeEvent({
choices_var()
}, {
updateSelectInput(session, "var1-variable",
choices = choices_var())
})
observeEvent({
choices_var()
}, {
updateSelectInput(session, "var2-variable",
choices = choices_var())
})
EDIT 3
Now my question becomes more specific: when inserting a selectInput using insertUI, how to update the choices of newly inserted selectInput with updateSelectInput ?
回答1:
Your variable input is in a module. You're trying to update it from the main server function. So you have a namespace mismatch. It also violates the principle that modules should be self-contained.
Ideally, you should update the variable input in the module which defines it. If the update depends on values which exist outside the module, you can pass them as reactives to the module server function.
* Edit *
Here is a simple, self-conatined example in response to OP's request for demonstration of how to update a selectInput that lives inside a module with data provided by the main server function. I've removed everything that isn't directly relevant to the purpose of the demonstration.
The app includes two instances of the module (defined by moduleUI and moduleController). Each instance has its own id, so the server can distinguidh between them. The main UI also includes pair of selectInputs, each of which tells one of the module instances what to display.
The key to making this work is passing the value of the controlling seelctinput to the controller of the appropriate instance of the module, for example:
mod1 <- callModule(moduleController, "Module1", reactive({input$module1Mode}))
The module controller function looks like this
moduleController <- function(input, output, session, selector) { ... }
Note the additional argument named selector, which corresponds to the current value of the controlling selectInput. The module reacts to changes to its controller with
observeEvent(selector(), {
updateSelectInput(session, "select", choices=choiceLists[[selector()]])
})
And returns a value to the main server with
returnValue <- reactive({
input$select
})
return(returnValue)
If you play with the app, you'll see that the selection list displayed by each instance of the module can be controlled independently and the server can distinguish between (and react to) the values returned by each instance of the module.
Here's the full code:
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)
来源：https://stackoverflow.com/questions/62225295/shiny-updateselectinput-for-a-module-ui-after-insertui