Повторение блестящих модулей с использованием insertUI

Question

Я использую блестящий модуль для построения каждого элемента (некоторых данных) списка соответственно.

Пользовательский интерфейс создает некоторые данные (DataPack) (список с двумя элементами), нажимая " Load "-кнопка. Затем данные наносятся на график через модуль, тогда как диапазон оси x графика каждого модуля контролируется sliderInput пользовательского интерфейса. Кроме того, каждый модуль строит некоторый «анализ» (среднее значение), нажимая кнопку модуля «Процесс».

Есть ли способ, как для пользовательского интерфейса, так и для функции сервера, использовать insertUI таким образом, что модуль повторяется в зависимости от длины списка DataPack, но при этом сохраняется связь между входом ползунка пользовательского интерфейса с каждым модулем (что позволяет избежать копирования и вставки 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

Вдохновленный статьей Томаса Ро ( Ссылка 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)