2

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

tabPanel当它没有在/中实现时，它作为一个独立的应用程序工作navbarPage。然而，在后一种设置中，数据是创建的（可以通过message代码的输出观察到），但不会通过绘图模块传递。为什么？

详细零件：

  1. 主应用程序，navbarPage从ui和调用server。

  2. (和)的模块化页面 ( tabPanel)通过单击“加载”按钮创建一些数据 ( ，一个包含三个元素的列表)，并通过(受Thomas Roh示例的启发) 调用绘图模块。navbarPagePage_uiPage_serverDataPacklapply

  3. 绘图模块 (Module_ui和Module_server) 用于绘制每个列表元素，DataPack并在绘图模块 ( ) 中创建一些统计信息AnalysedPack。

包装在 a 中时代码不起作用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)

该代码在未包含在 a 中时有效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)
4

1 回答 1

2

您的代码使用lapply并且navbarPage不会在正确的命名空间中生成 UI，因为使用navbarPage构造时，您的模块“更深一层”。我在下面添加了更新的代码片段。

相关更改是使用 . 设置添加的 UI 组件的名称session$ns(id)。

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 包（v0.3.0）于 2020-06-04 创建

于 2020-06-04T06:55:04.863 回答