数据未传递到模块化闪亮内部的模块 tabPanel/navbarPage

Question

我的可重现闪亮应用程序创建了一些数据，这些数据应通过使用 lapply 调用绘图模块来绘制。因此，它包含主应用程序、模块化的 Page_ui/Page_server 和 Module_ui/Module_server。

如果未在 tabPanel/navbarPage 中实现，它会作为独立应用程序运行。然而，在后一种设置中，数据被创建（可以通过代码的 message 输出观察到）但没有通过 plot 模块传递。为什么？

详细部分：

主应用程序，从 ui 和 server 调用的 navbarPage。
navbarPage（Page_ui 和 Page_server）的模块化页面 (tabPanel) 创建一些数据 (DataPack ，一个包含三个元素的列表）通过单击 "Load" 按钮并通过 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)

Answer 1

您使用 lapply 和 navbarPage 的代码不会在正确的命名空间中生成 UI，因为使用 navbarPage 时，您的模块是 "one level deeper"。我在下面添加了更新的代码片段。

相关更改是使用 session$ns(id) 设置您添加的 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;", 
      div(id = "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(session$ns(id))
      )

      message("callModule: ", id)
      callModule(
        Module_Server,
        id,
        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)
#> PhantomJS not found. You can install it with webshot::install_phantomjs(). If it is installed, please make sure the phantomjs executable can be found via the PATH variable.

^{由 reprex package (v0.3.0)}

于 2020-06-04 创建

数据未传递到模块化闪亮内部的模块 tabPanel/navbarPage

Data not passed through to module inside modularized shiny tabPanel/navbarPage

r

shiny

shiny-reactivity

shinymodules