Question

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

用户界面通过单击“加载”按钮来创建一些数据（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的文章（Link 1，Link 2）和this post，它的工作方式如下：

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)

使用insertUI重复闪亮模块

1 个答案: