[英]shiny: updateSelectInput for a module UI (after insertUI)
以下 shiny 应用程序使用模块,它可以工作:
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。 为此,我找到了这个答案,并且可以使用 function 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())
})
编辑 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
的选择?
您的variable
输入位于模块中。 您正在尝试从主server
function 更新它。 所以你有一个命名空间不匹配。 它也违反了模块应该是自包含的原则。
理想情况下,您应该更新定义它的模块中的variable
输入。 如果更新依赖于模块外部存在的值,您可以将它们作为响应传递给模块服务器 function。
* 编辑 *这是一个简单的、独立的示例,以响应 OP 的请求,以演示如何使用主server
function 提供的数据更新位于模块内的selectInput
。 我已经删除了与演示目的不直接相关的所有内容。
该应用程序包括模块的两个实例(由moduleUI
和moduleController
定义)。 每个实例都有自己的id
,因此服务器可以区分它们。 主 UI 还包括一对selectInput
,每个都告诉一个模块实例要显示什么。
完成这项工作的关键是将控制seelctinput
的值传递给相应模块实例的 controller,例如:
mod1 <- callModule(moduleController, "Module1", reactive({input$module1Mode}))
模块 controller function 看起来像这样
moduleController <- function(input, output, session, selector) { ... }
请注意名为selector
的附加参数,它对应于控制selectInput
的当前值。 该模块对其 controller 的更改做出反应
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)
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.