在嵌套模块中使用 Shiny 的 updateSelectInput [英] Using Shiny's updateSelectInput within nested modules
本文介绍了在嵌套模块中使用 Shiny 的 updateSelectInput的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
背景
应用程序的结构如下:
<预><代码>.├── R│ ├── mod_observationSelector.R│ ├── mod_previewTable.R│ └── mod_summaryTable.R└── app.R随着文件完成各自的功能:
mod_observationSelector.R- 提供了一种updateSelectInput机制，便于在mtcars数据中选择整数或实数列mod_previewTable.R- 为所选列生成headmod_summaryTable.R- 为所选列生成summary
设计假设
mod_observationSelector.R此模块中可用的链接界面元素应可用于提供选择机制的其余模块
问题
嵌套后，下拉选择不再更新.
工作版本
在嵌套之前.
mod_observationSelector.R
observationSelectorUI <- function(id) {ns <- NS(id)流体页面(选择输入(inputId = ns(varTypes"),label = h3(变量类型"),选择 = 列表(整数"= TRUE，真实"= 错误)，选择 = FALSE，多个 = FALSE),选择输入(inputId = ns(selectColumn"),label = h4(选定的列"),选择 = 字符(0)))}观察选择服务器<-函数(id，数据){模块服务器(ID，功能(输入，输出，会话){observeEvent(eventExpr = input$varTypes,handlerExpr = {all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))selected_cols <-名称(all_cols[all_cols == input$varTypes])更新选择输入(会话 = 会话，inputId = "selectColumn",标签 = 粘贴(选定"，ifelse(input$varTypes, "integer", "real"),列"),选择 = selected_cols)})})}app.R
图书馆(闪亮")图书馆(tidyverse")ui <-流体页面(titlePanel(嵌套模块")，观察选择器UI(colChooser"))# 定义绘制直方图所需的服务器逻辑服务器 <- 功能(输入，输出){观察选择器服务器(colChooser")}# 运行应用程序闪亮应用(用户界面 = 用户界面，服务器 = 服务器)破解版
问题
- 以前工作的
updateSelect现在坏了
app.R
图书馆(闪亮")图书馆(tidyverse")ui <-fluidPage(titlePanel(嵌套模块"),tabsetPanel(summaryUI(modSummary"),previewUI("modPreview")))# 定义绘制直方图所需的服务器逻辑服务器 <- 功能(输入，输出){摘要服务器(modSummary")预览服务器(modPreview")}# 运行应用程序闪亮应用(用户界面 = 用户界面，服务器 = 服务器)mod_observationSelector.R
实际上，没有变化.
observationSelectorUI <- function(id) {ns <- NS(id)流体页面(选择输入(inputId = ns(varTypes"),label = h3(变量类型"),选择 = 列表(整数"= TRUE，真实"= 错误)，选择 = FALSE，多个 = FALSE),选择输入(inputId = ns(selectColumn"),label = h4(选定的列"),选择 = 字符(0)))}观察选择服务器<-函数(id，数据){模块服务器(ID，功能(输入，输出，会话){observeEvent(eventExpr = input$varTypes,handlerExpr = {all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))selected_cols <-名称(all_cols[all_cols == input$varTypes])更新选择输入(会话 = 会话，inputId = "selectColumn",标签 = 粘贴(选定"，ifelse(input$varTypes, "integer", "real"),列"),选择 = selected_cols)})})}mod_summaryTable.R
summaryUI <- function(id) {ns <- NS(id)tabPanel(汇总表",列(4，观察选择器UI(ns(colChooser")))，column(8, tableOutput(ns('summaryTable'))))}summaryServer <- function(id) {模块服务器(ID，功能(输入，输出，会话){输出$summaryTable <-渲染表(摘要(mtcars [，输入 $selectColumn]))})}mod_previewTable
previewUI <- function(id) {ns <- NS(id)tabPanel(汇总表",列(4，观察选择器UI(ns(colChooser")))，column(8, tableOutput(ns('headTable'))))}预览服务器 <- 函数(id){模块服务器(ID，功能(输入，输出，会话){输出$headTable <-renderTable(head(mtcars[, input$selectColumn]))})}预期结果
- 跨模块的下拉选择更新
- 模块内下拉选择的结果可用于外部"生成摘要等的模块
为方便起见，代码也可在 GitHub 上找到:konradzdeb/nestedModule.
解决方案
为了后人，解决方案如下
mod_observationSelector.R
返回反应元素.
observationSelectorUI <- function(id) {ns <- NS(id)标签列表(选择输入(inputId = ns(varTypes"),label = h3(变量类型"),选择 = 列表(整数"= TRUE，真实"= 错误)，选择 = FALSE，多个 = FALSE),选择输入(inputId = ns(selectColumn"),label = h4(选定的列"),选择 = c(cyl"、hp"、vs"、am"、gear"、carb")))}观察选择服务器<-函数(id，数据){模块服务器(ID，功能(输入，输出，会话){observeEvent(eventExpr = input$varTypes,handlerExpr = {all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))selected_cols <-名称(all_cols[all_cols == input$varTypes])更新选择输入(会话 = 会话，inputId = "selectColumn",标签 = 粘贴(选定"，ifelse(input$varTypes, "integer", "real"),列"),选择 = selected_cols)})# 返回选择结果返回(反应({验证(需要(输入 $selectColumn，FALSE))输入$选择列}))})}使用模块输入
与任何其他响应式一样，我从嵌套模块中获取结果，然后调用它们innerResult().
previewUI <- function(id) {ns <- NS(id)tabPanel(汇总表",列(4，观察选择器UI(ns(colChooser")))，column(8, tableOutput(ns('headTable'))))}预览服务器 <- 函数(id){模块服务器(ID，功能(输入，输出，会话){innerResult <-observationSelectorServer("colChooser")output$headTable <- renderTable(head(mtcars[,innerResult()]))})}完整应用
可在 GitHub 上获取:b25758b.
Background
The application is of the following structure:
.
├── R
│ ├── mod_observationSelector.R
│ ├── mod_previewTable.R
│ └── mod_summaryTable.R
└── app.R
With the files fulling the respective functions:
mod_observationSelector.R- provides anupdateSelectInputmechanism facilitating selction of integere or real columns inmtcarsdatamod_previewTable.R- generatesheadfor selected columnmod_summaryTable.R- generatessummaryfor selected column
Design assumptions
mod_observationSelector.Rlinked interface elements available in this module should be usable across remaining modules providing a selection mechanism
Problem
After nesting, the drop-down selection does no longer update.
Working version
Prior to nesting.
mod_observationSelector.R
observationSelectorUI <- function(id) {
ns <- NS(id)
fluidPage(
selectInput(
inputId = ns("varTypes"),
label = h3("Variable types"),
choices = list("Integer" = TRUE,
"Real" = FALSE),
selectize = FALSE,
multiple = FALSE
),
selectInput(
inputId = ns("selectColumn"),
label = h4("Selected Column"),
choices = character(0)
)
)
}
observationSelectorServer <- function(id, data) {
moduleServer(id,
function(input, output, session) {
observeEvent(eventExpr = input$varTypes,
handlerExpr = {
all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
selected_cols <-
names(all_cols[all_cols == input$varTypes])
updateSelectInput(
session = session,
inputId = "selectColumn",
label = paste(
"Selected",
ifelse(input$varTypes, "integer", "real"),
"columns"
),
choices = selected_cols
)
})
})
}
app.R
library("shiny")
library("tidyverse")
ui <- fluidPage(
titlePanel("Nested Modules"),
observationSelectorUI("colChooser")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
observationSelectorServer("colChooser")
}
# Run the application
shinyApp(ui = ui, server = server)
Broken version
Problems
- Previously working
updateSelectis now broken
app.R
library("shiny")
library("tidyverse")
ui <- fluidPage(titlePanel("Nested Modules"),
tabsetPanel(summaryUI("modSummary"),
previewUI("modPreview")
))
# Define server logic required to draw a histogram
server <- function(input, output) {
summaryServer("modSummary")
previewServer("modPreview")
}
# Run the application
shinyApp(ui = ui, server = server)
mod_observationSelector.R
In effect, no change.
observationSelectorUI <- function(id) {
ns <- NS(id)
fluidPage(
selectInput(
inputId = ns("varTypes"),
label = h3("Variable types"),
choices = list("Integer" = TRUE,
"Real" = FALSE),
selectize = FALSE,
multiple = FALSE
),
selectInput(
inputId = ns("selectColumn"),
label = h4("Selected Column"),
choices = character(0)
)
)
}
observationSelectorServer <- function(id, data) {
moduleServer(id,
function(input, output, session) {
observeEvent(eventExpr = input$varTypes,
handlerExpr = {
all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
selected_cols <-
names(all_cols[all_cols == input$varTypes])
updateSelectInput(
session = session,
inputId = "selectColumn",
label = paste(
"Selected",
ifelse(input$varTypes, "integer", "real"),
"columns"
),
choices = selected_cols
)
})
})
}
mod_summaryTable.R
summaryUI <- function(id) {
ns <- NS(id)
tabPanel("Summary table",
column(4, observationSelectorUI(ns("colChooser"))),
column(8, tableOutput(ns('summaryTable'))))
}
summaryServer <- function(id) {
moduleServer(id,
function(input, output, session) {
output$summaryTable <-
renderTable(summary(mtcars[, input$selectColumn]))
})
}
mod_previewTable
previewUI <- function(id) {
ns <- NS(id)
tabPanel("Summary table",
column(4, observationSelectorUI(ns("colChooser"))),
column(8, tableOutput(ns('headTable'))))
}
previewServer <- function(id) {
moduleServer(id,
function(input, output, session) {
output$headTable <-
renderTable(head(mtcars[, input$selectColumn]))
})
}
Desired outcomes
- Drop-down selection updates across the modules
- Results from the in-module drop-down selection can be used in "outer" module to produce summaries, etc.
For convenience, the code is also available on GitHub: konradzdeb/nestedModule.
解决方案
For posterity, the solution is as follows
mod_observationSelector.R
Reactive element is returned.
observationSelectorUI <- function(id) {
ns <- NS(id)
tagList(
selectInput(
inputId = ns("varTypes"),
label = h3("Variable types"),
choices = list("Integer" = TRUE,
"Real" = FALSE),
selectize = FALSE,
multiple = FALSE
),
selectInput(
inputId = ns("selectColumn"),
label = h4("Selected Column"),
choices = c("cyl", "hp", "vs", "am", "gear", "carb")
)
)
}
observationSelectorServer <- function(id, data) {
moduleServer(id,
function(input, output, session) {
observeEvent(eventExpr = input$varTypes,
handlerExpr = {
all_cols <- map_lgl(.x = mtcars, ~ all(. %% 1 == 0))
selected_cols <-
names(all_cols[all_cols == input$varTypes])
updateSelectInput(
session = session,
inputId = "selectColumn",
label = paste(
"Selected",
ifelse(input$varTypes, "integer", "real"),
"columns"
),
choices = selected_cols
)
})
# Return the selection result
return(reactive({
validate(need(input$selectColumn, FALSE))
input$selectColumn
}))
})
}
Using module inputs
As with any other reactive, I'm bringing the results from the nested module and then call them innerResult().
previewUI <- function(id) {
ns <- NS(id)
tabPanel("Summary table",
column(4, observationSelectorUI(ns("colChooser"))),
column(8, tableOutput(ns('headTable'))))
}
previewServer <- function(id) {
moduleServer(id,
function(input, output, session) {
innerResult <- observationSelectorServer("colChooser")
output$headTable <- renderTable(head(mtcars[, innerResult()]))
})
}
Full app
Available on GitHub: b25758b.
这篇关于在嵌套模块中使用 Shiny 的 updateSelectInput的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
