3

My reproducible shiny app creates some data which shall be plotted by calling a plot module using lapply. It, therefore, contains the main app, the modularized Page_ui/Page_server, and the Module_ui/Module_server.

It works as a stand-alone app when it is not implemented in the tabPanel/navbarPage. In the latter setting, however, the data is created (which can be observed by the message output of the code) but not passed through the plot module. Why?

The parts in detail:

  1. The main app, a navbarPage called from ui and server.

  2. The modularized page (tabPanel) for the navbarPage (Page_ui and Page_server) which creates some Data (DataPack, a list with three elements) by clicking the "Load" button and calls the plot module via lapply (inspired by the example from Thomas Roh).

  3. The plot module (Module_ui and Module_server) for plotting each list element of DataPack with some statistics created inside the plot module (AnalysedPack).

The code does not work when wrapped in 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)

The code works when not wrapped in a navbarPage (paragraphs set in order to compare with problematic code above line by line):

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)

For completeness the code works as well when calling the module sequentially (without 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)
Cevior
  • 97
  • 8
  • I found several flaws in your code: 1) the `selector` in `insertUI` is `#placehere` but you wrapped it in `ns()` in `Page_ui` therefore it can't place the new UI. Either you have to put `#someid-placehere` (since your call `Page_ui("someid")`) or remove the `ns()`. 2) You put a `renderPlot` inside `renderUI` and I don't think this works. Replace `uiOutput` with `plotOutput` and remove `renderUI`. However, it still doesn't show the plots and I guess this is due to the ids created in `insertUI`. Indeed, if you put `p("test")` in `module_ui` (in a `tagList` with `plotOutput`), ... – bretauv May 24 '20 at 16:27
  • then "test" will be displayed three times. I also tried to put a `textOutput` in `module_ui` and `renderText` in `module_server` but it doesn't show anything. Therefore, I think the problem comes from the way modules are called in `lapply` in a module, and I don't know how to fix it. Hope this helps – bretauv May 24 '20 at 16:29
  • The example used is a shortened version of some original code, therefore, the double entry with `renderUI` and `renderPlot`. This seems not to be the problem, however, you are right about the missing html wrapper in the form of `fluidRow`, `div$tag`, or `taglist` (I changed the code above). For completeness I will post the code which works when not wrapped in a `navbarPage` which demonstrates that the `lapply` call is fine. There must be a problem with calling the module itself or rather passing the variables to `Module_ui`/`Module_server`. – Cevior May 25 '20 at 07:24

1 Answers1

3

Your code using lapply and the navbarPage doesn't generate the UI in the proper namespace, since when using the navbarPage construct your modules are "one level deeper". I added the updated code snippet below.

Relevant change is setting the name of your added UI component using 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.

Created on 2020-06-04 by the reprex package (v0.3.0)

Søren Schaffstein
  • 737
  • 6
  • 7