我的可复制闪亮应用程序创建了一些数据,这些数据应通过使用lapply
调用绘图模块进行绘图。因此,它包含主应用程序,模块化的Page_ui
/ Page_server
和Module_ui
/ Module_server
。
未在tabPanel
/ navbarPage
中实现时,它可作为独立应用程序使用。但是,在后一种设置中,将创建数据(可以通过代码的message
输出观察到),但不会通过绘图模块。为什么?
详细部分:
主应用程序,从navbarPage
和ui
调用的server
。
tabPanel
(navbarPage
和Page_ui
)的模块化页面(Page_server
),通过单击“加载”按钮创建一些数据(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)
您使用lapply
和navbarPage
的代码根本不会为您的绘图生成UI。我在下面的更新代码段中添加了它们。
但是我建议您不要像这样简单地静态地包含它们,而是编写一个小函数以能够包含动态数量的UI元素。
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(
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("Plotone")),
Module_ui(ns("Plottwo")),
Module_ui(ns("Plotthree"))
)
)
}
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,
session = session,
DataPack = DataPack,
DataSetName = DataSetName,
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)