r-使用insertUI重复闪亮的模块

Question

我使用一个闪亮的模块来分别绘制列表中的每个元素(一些数据(。

ui通过单击"加载"按钮创建一些数据(DataPack((到目前为止有两个元素的列表(。然后通过模块绘制数据，而每个模块的x轴范围由ui的sliderInput控制。此外，每个模块通过单击模块的"处理"按钮绘制一些"分析"(运行平均值(。

对于ui和服务器功能，是否有一种方法可以使用insertUI，根据列表DataPack的长度重复模块，但保留ui的滑块输入与每个模块之间的连接(从而避免在ui中复制和粘贴Module_ui以及在服务器功能中复制和粘贴callModule数次(？谢谢

library(shiny)
library(TTR)
Module_ui <- function(id) {
ns <- NS(id)
tagList(
fluidRow(
column(2, column(12, fluidRow(
numericInput(
inputId = ns("NumericInput_BW"),
label   = NULL,
min     = 1,
max     = 100,
value   = 10,
step    = 1))),
fluidRow(
column(12, actionButton(
ns("InputButton_ProcessData"), "Process", width = "100%")))),
column(10, plotOutput(ns("Plot"))))
)
}

Module_Server <- function(input, output, session,
DataPack, AnalysedPack, 
DataSetName, 
InputButton_GetData,
xlim) {
AnalysedPack <- eventReactive(c(
InputButton_GetData(),
input$InputButton_ProcessData), {
message(paste("Analysed Pack", DataSetName))
AnalysedPack <-
runMean(DataPack()[[DataSetName]],
min(input$NumericInput_BW,
length(DataPack()[[DataSetName]])))
return(AnalysedPack)
})
output$Plot <- renderPlot({
message(paste("Base_Plot", DataSetName))
plot(DataPack()[[DataSetName]],
xlim = c(xlim()[1],
xlim()[2]))
lines(AnalysedPack(), 
col = "tomato", lwd = 2)
})
}

ui <- fluidPage(
fluidRow(
column(
6,
column(
12,
fluidRow(h4("Data Generation")),
fluidRow(actionButton("InputButton_GetData", "Load", width = "100%")))),
column(
6,
column(
12,
fluidRow(h4("Update Plot")),
sliderInput(
"SliderInput_xAxis",
label = NULL,
min = 0,
max = 150,
value = c(0, 150),
animate = TRUE))
)
),
Module_ui("Plot_1"),
Module_ui("Plot_2")
)

server <- function(input, output, session) {
DataPack <- eventReactive(
input$InputButton_GetData, {
message("DataPack")
n <- round(runif(1, min = 100, max = 500))
message(n)
DataPack <- NULL
DataPack$one <- rnorm(n)
DataPack$two <- rnorm(n)^2
updateSliderInput(
session = session,
inputId = "SliderInput_xAxis",
value   = c(1, n),
min     = 1,
max     = n)
return(DataPack)
})
SliderInput_xAxis_rx       <- reactive(input$SliderInput_xAxis)
InputButton_GetData_rx     <- reactive(input$InputButton_GetData)
callModule(Module_Server, "Plot_1",
DataPack                = DataPack,
DataSetName             = "one",
InputButton_GetData     = InputButton_GetData_rx,
xlim                    = SliderInput_xAxis_rx)
callModule(Module_Server, "Plot_2",
DataPack                = DataPack,
DataSetName             = "two",
InputButton_GetData     = InputButton_GetData_rx,
xlim                    = SliderInput_xAxis_rx)
}

shinyApp(ui, server)

Answer 1

受Thomas Roh的文章(链接1，链接2(以及这篇文章的启发，它的工作原理如下：

library(shiny)
library(TTR)
Module_ui <- function(id) {
ns <- shiny::NS(id)
shiny::uiOutput(ns("Plot"))
}
Module_Server <- function(
input, output, session,
DataPack, DataSetName, InputButton_GetData, xlim) {
AnalysedPack <- eventReactive(c(
InputButton_GetData(),
input$InputButton_ProcessData), {
message(paste("Analysed Pack", DataSetName))
AnalysedPack <-
runMean(DataPack()[[DataSetName]],
min(input$NumericInput_BW,
length(DataPack()[[DataSetName]])))
return(AnalysedPack)
})
output[['Plot']] <- renderUI({
ns <- session$ns
tags$div(
id = environment(ns)[['namespace']],
tagList(
fluidRow(
column(2, column(12, fluidRow(
numericInput(
inputId = ns("NumericInput_BW"),
label   = NULL,
min     = 1,
max     = 100,
value   = 10,
step    = 1))),
fluidRow(
column(12, actionButton(
ns("InputButton_ProcessData"),
"Process", width = "100%")))),
column(10, 
renderPlot({
message(paste("Base_Plot", DataSetName))
plot(DataPack()[[DataSetName]],
xlim = c(xlim()[1],
xlim()[2]))
lines(AnalysedPack(),
col = "tomato", lwd = 2)
}) ) )
)
)
})
}

ui <- fluidPage(
fluidRow(
column(
6,
column(
12,
fluidRow(h4("Data Generation")),
fluidRow(actionButton(
"InputButton_GetData", "Load", width = "100%")))),
column(
6,
column(
12,
fluidRow(h4("Update Plot")),
sliderInput(
"SliderInput_xAxis",
label = NULL,
min = 0,
max = 150,
value = c(0, 150),
animate = TRUE)
)
),
column(12, actionButton('addButton', '', icon = icon('plus')))
)
)

server <- function(input, output, session) {
DataPack <- eventReactive(
input$InputButton_GetData, {
message("DataPack")
n <- round(runif(1, min = 100, max = 500))
message(n)
DataPack <- NULL
DataPack$one <- rnorm(n)
DataPack$two <- rnorm(n)^2
updateSliderInput(
session = session,
inputId = "SliderInput_xAxis",
value   = c(1, n),
min     = 1,
max     = n)
return(DataPack)
})
SliderInput_xAxis_rx   <-
reactive(input$SliderInput_xAxis)
InputButton_GetData_rx <-
reactive(input$InputButton_GetData)
observeEvent(input$InputButton_GetData, {
lapply(names(DataPack()), function(DataSetName) {
id <- sprintf('Plot%s', DataSetName)
insertUI(
selector = "#addButton",
where = "afterEnd",
ui = Module_ui(id)
)
callModule(
Module_Server, id,
DataPack            = DataPack,
DataSetName         = DataSetName,
InputButton_GetData = InputButton_GetData_rx,
xlim                = SliderInput_xAxis_rx)
})
})
}

shinyApp(ui, server)