【发布时间】：2020-09-11 03:14:18
【问题描述】：
我的可重现闪亮应用程序创建了一些数据，这些数据应通过使用lapply 调用绘图模块来绘制。因此，它包含主应用程序、模块化的Page_ui/Page_server 和Module_ui/Module_server。
当它没有在tabPanel/navbarPage 中实现时，它可以作为一个独立的应用程序运行。然而，在后一种设置中，数据被创建（可以通过代码的message 输出观察到）但不通过绘图模块。为什么？
详细部分：
主应用，一个从
ui和server调用的navbarPage。navbarPage（Page_ui和Page_server）的模块化页面 (tabPanel) 通过单击“加载”按钮创建一些数据（DataPack，一个包含三个元素的列表）并通过lapply调用绘图模块（灵感来自Thomas Roh 的示例）。绘图模块（
Module_ui和Module_server）用于绘制DataPack的每个列表元素，并在绘图模块 (AnalysedPack) 内创建一些统计信息。
包裹在navbarPage中时代码不起作用：
library(shiny)
library(TTR)
# Single Plot Module to be repeated using lapply in Page_server
Module_ui <- function(id) {
ns <- NS(id)
uiOutput(ns("Plot"))
}
Module_Server <- function(
input, output, session,
DataPack, DataSetName, InputButton_GetData) {
AnalysedPack <- eventReactive(
InputButtton_GetData(), {
message(paste("Analysed Pack", DataSetName))
AnalysedPack <- runMean(DataPack()[[DataSetName]])
return(AnalysedPack)
})
output[['Plot']] <- renderUI({
fluidRow( renderPlot({
message(paste("Base_Plot", DataSetName))
plot(DataPack()[[DataSetName]])
lines(AnalysedPack(), col = "tomato", lwd = 2)}) )
})
}
# navbarPage Module as tabPanel
Page_ui <- function(id) {
ns <- NS(id)
tabPanel("Charts", fluidPage(
style = "padding-top: 140px;",
div(id = ns("placehere")),
absolutePanel(
top = 0, width = "97%", fixed = TRUE,
div(fluidRow(column(
6, fluidRow(h4("Data Generation")),
fluidRow(actionButton(ns("InputButton_GetData"),
"Load", width = "100%"))) )) ) ))
}
Page_server <- function(input, output, session) {
DataPack <- eventReactive(
input$InputButton_GetData, {
message("----- Creating new DataPack -----")
n <- round(runif(1, min = 100, max = 500))
message("Data length:", n)
DataPack <- NULL
DataPack$one <- rnorm(n)
DataPack$two <- rnorm(n)^2
DataPack$three <- sin(rnorm(n)^6)
return(DataPack)
})
InputButton_GetData_rx <-
reactive(input$InputButton_GetData)
observeEvent(
input$InputButton_GetData, {
lapply(names(DataPack()), function(DataSetName) {
id <- sprintf('Plot%s', DataSetName)
message("DataSetName: ", DataSetName)
message("id: ", id)
insertUI(
selector = "#placehere",
where = "beforeBegin",
ui = Module_ui(id))
message("callModule: ", id)
callModule(
Module_Server, id,
DataPack = DataPack,
DataSetName = DataSetName,
InputButton_GetData = InputButton_GetData_rx) })
})
}
# Main App with navbarPage
ui <- navbarPage(
"Navbar!",
Page_ui("someid"),
position = "fixed-bottom")
server <- function(input, output, session) {
callModule(Page_server, "someid")
}
shinyApp(ui, server)
代码在未包含在 navbarPage 中时有效（设置段落以便逐行与上面有问题的代码进行比较）：
library(shiny)
library(TTR)
# Single Plot Module to be repeated using lapply in Page_server
Module_ui <- function(id) {
ns <- NS(id)
uiOutput(ns("Plot"))
}
Module_Server <- function(
input, output, session,
DataPack, DataSetName, InputButton_GetData, xlim) {
AnalysedPack <- eventReactive(c(
InputButton_GetData()), {
message(paste("Analysed Pack", DataSetName))
AnalysedPack <- runMean(DataPack()[[DataSetName]])
return(AnalysedPack)
})
output[['Plot']] <- renderUI({
# `fluidRow`, `div$tag`, or `taglist` necessary as wrapper for some html object
fluidRow( renderPlot({
message(paste("Base_Plot", DataSetName))
plot(DataPack()[[DataSetName]])
lines(AnalysedPack(), col = "tomato", lwd = 2) }) )
})
}
# navbarPage Module
Page_ui <- fluidPage(
style="padding-top: 140px;",
div(id = "placehere"),
absolutePanel(
top = 0, width = "97%", fixed = TRUE,
div(fluidRow(column(
6, fluidRow(h4("Data Generation")),
fluidRow(actionButton("InputButton_GetData",
"Load", width = "100%"))) )) )
)
Page_server <- function(input, output, session) {
DataPack <- eventReactive(
input$InputButton_GetData, {
message("----- Creating new DataPack -----")
n <- round(runif(1, min = 100, max = 500))
message("Data length:", n)
DataPack <- NULL
DataPack$one <- rnorm(n)
DataPack$two <- rnorm(n)^2
DataPack$three <- sin(rnorm(n)^6)
return(DataPack)
})
InputButton_GetData_rx <-
reactive(input$InputButton_GetData)
observeEvent(
input$InputButton_GetData, {
lapply(names(DataPack()), function(DataSetName) {
id <- sprintf('Plot%s', DataSetName)
message("DataSetName: ", DataSetName)
message("id: ", id)
insertUI(
selector = "#placehere",
where = "beforeBegin",
ui = Module_ui(id))
message("callModule: ", id)
callModule(
Module_Server, id,
DataPack = DataPack,
DataSetName = DataSetName,
InputButton_GetData = InputButton_GetData_rx) })
})
}
shinyApp(Page_ui, Page_server)
为了完整起见，代码在顺序调用模块时也能正常工作（不带lapply）：
library(shiny)
library(TTR)
# Single Plot Module to be repeated sequentially
Module_ui <- function(id) {
ns <- NS(id)
plotOutput(ns("Plot"))
}
Module_Server <- function(
input, output, session,
DataPack, DataSetName, InputButton_GetData, xlim) {
AnalysedPack <- eventReactive(c(
InputButton_GetData()), {
message(paste("Analysed Pack", DataSetName))
AnalysedPack <- runMean(DataPack()[[DataSetName]])
return(AnalysedPack)
})
output$Plot <- renderPlot({
message(paste("Base_Plot", DataSetName))
plot(DataPack()[[DataSetName]])
lines(AnalysedPack(), col = "tomato", lwd = 2)
})
}
# navbarPage Module as tabPanel
Page_ui <- function(id) {
ns <- NS(id)
tabPanel("Charts", fluidPage(
style = "padding-top: 140px;",
absolutePanel(
top = 0, width = "97%", fixed = TRUE,
div(fluidRow(column(
6, fluidRow(h4("Data Generation")),
fluidRow(actionButton(ns("InputButton_GetData"),
"Load", width = "100%"))) )) ),
Module_ui(ns("Plot_1")), Module_ui(ns("Plot_2")), Module_ui(ns("Plot_3")) ))
}
Page_server <- function(input, output, session) {
DataPack <- eventReactive(
input$InputButton_GetData, {
message("----- Creating new DataPack -----")
n <- round(runif(1, min = 100, max = 500))
message("Data length:", n)
DataPack <- NULL
DataPack$one <- rnorm(n)
DataPack$two <- rnorm(n)^2
DataPack$three <- sin(rnorm(n)^6)
return(DataPack)
})
InputButton_GetData_rx <-
reactive(input$InputButton_GetData)
callModule(Module_Server, "Plot_1",
DataPack = DataPack,
DataSetName = "one",
InputButton_GetData = InputButton_GetData_rx)
callModule(Module_Server, "Plot_2",
DataPack = DataPack,
DataSetName = "two",
InputButton_GetData = InputButton_GetData_rx)
callModule(Module_Server, "Plot_3",
DataPack = DataPack,
DataSetName = "three",
InputButton_GetData = InputButton_GetData_rx)
}
# Main App
ui <- navbarPage(
"Navbar!",
Page_ui("some_ns"),
position = "fixed-bottom")
server <- function(input, output, session) {
callModule(Page_server, "some_ns")
}
shiny::shinyApp(ui, server)
【问题讨论】：
-
我在您的代码中发现了几个缺陷：1)
insertUI中的selector是#placehere但您将它包装在ns()中Page_ui因此它不能放置新的用户界面。要么你必须输入#someid-placehere（因为你的电话Page_ui("someid")）或者删除ns()。 2）你在renderUI里面放了一个renderPlot，我认为这行不通。将uiOutput替换为plotOutput并删除renderUI。但是，它仍然没有显示绘图，我猜这是由于在insertUI中创建的 ID。事实上，如果你把p("test")放在module_ui中（在tagList和plotOutput中），... -
那么“test”会显示3次。我还尝试将
textOutput放入module_ui和renderText放入module_server，但它没有显示任何内容。因此，我认为问题出在模块中lapply中调用模块的方式，我不知道如何解决。希望这会有所帮助 -
使用的示例是一些原始代码的缩短版本，因此，
renderUI和renderPlot的双重输入。这似乎不是问题，但是，您对fluidRow、div$tag或taglist形式的缺失html 包装器是正确的（我更改了上面的代码）。为了完整起见，我将发布未包含在navbarPage中的代码，这表明lapply调用很好。调用模块本身或者将变量传递给Module_ui/Module_server一定有问题。
标签： r shiny shiny-reactivity shinymodules