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

2
votes

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)
1
rshinyshiny-reactivityshinymodules
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
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
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. - Fabian

1 Answers

2
votes

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)