Dynamically render output via shiny modules based on input selections

shiny
,
1

Hello, I'm trying to dynamically render output based on the input selected by the user. I can dynamically render the module UI and output but the module output is not being placed inside the module UI.

A simplified example using nyc flights is, for each origin selected, I want to generate a shiny box that contains a data table with all of the flights for that origin. My module UI creates the box UI and the output renders the datatable. When it renders the data table is rendered outside the box, as thought the UI is not connected to the output. I must be having some sort of namespace issue or naming issue.

image
image1906×884 27.5 KB

library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)
library(shinycssloaders)
library(nycflights13)
library(tidyverse)

nyc_flight_data <- nycflights13::flights

summaryTableUI  <- function(id, title, width = 6, height="300px") {
  ns <- NS(id)

  box(title = title,
      collapsible = TRUE, width = width,
      DT::dataTableOutput(ns("summaryTable"), height = height) %>% withSpinner()
  )

}

summaryTable <- function(input, output, session, data, run_click, origin_str) {

  ns <- session$ns

  output$dataTable <- DT::renderDataTable({

    req(run_click())

    data
    
  }, options = list(scrollX = TRUE,
                    autoWidth = TRUE#,  #Add a way to submit column defs
                    #columnDefs=column_defs_cfr
  ),
  escape = FALSE)


}

ui <- dashboardPage(skin = "black",
                    dashboardHeader(
                      title="Test App"
                    ),
                    dashboardSidebar(
                      sidebarMenu(id = "sidebar",
                                  pickerInput(
                                    inputId = "selectOrigin",
                                    label = "Origin :",
                                    choices = unique(nyc_flight_data$origin),
                                    options = list(
                                      `actions-box` = TRUE,
                                      `live-search` = TRUE,
                                      `virtual-scroll` = 10,
                                      `multiple-separator` = "\n",
                                      size = 10
                                    ),
                                    multiple = TRUE
                                  ),
                                  actionButton("runButton", "Run")
                      )
                    ),
                    dashboardBody(
                      uiOutput("origin_flight_detail")
                    )
)


server <- function(input, output, session) {
  
  click <- reactive(input$runButton)
  
  output$origin_flight_detail <- renderUI({
    
    req(input$runButton)
    
    origin_list <- input$selectOrigin
    unique_outputs <- length(origin_list)
    
    lapply(1:unique_outputs, function(i) {
      input_name <- paste0("input", i)
      input_title <- origin_list[i]
      print(paste0("input name: ",input_name))
      #output_list[[i]]<- list(salesSummaryTableUI(ns(input_name),input_title))
      list(summaryTableUI(input_name,input_title),
           output[[input_name]] <- callModule(summaryTable,input_name,nyc_flight_data,click,origin_list[i]))
      
    })
    
  })
  
}

shinyApp(ui = ui, server = server)

If I skip the module UI call and just put the box around the callModule it works but that doesn't follow the standard module setup. Maybe that's OK? Hoping I'm just overlooking something simple. Thanks in advance for thoughts!

 output$sales_detail <- renderUI({
    
    req(run_click())
    
    key_account_list <- inputs$key_account_list
    unique_outputs <- length(key_account_list)
    lapply(1:unique_outputs, function(i) {
      input_name <- paste0("input", i)
      # box(title = input_name,
      #     collapsible = TRUE, width = 6,
          callModule(salesSummaryTable,input_name,sales_data,run_click,key_account_list[i])#)
    })

})
2

Had some issues due to wishSpinners seeming to break my solution when applied on the datatable elements, this might be less of an issue than otherwise given datatable by default have their own 'processing' busy message that they display. anyway, hope this helps and gets you closer:

library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)
library(shinycssloaders)
library(nycflights13)
library(tidyverse)

nyc_flight_data <- nycflights13::flights

summaryTableUI  <- function(id, title, width = 6, height="300px") {
  ns <- NS(id)
  
  box(title = title,
      collapsible = TRUE, width = width,
      DT::dataTableOutput( ns("dataTable"), height = height)  
  ) %>% withSpinner()
  
}

summaryTable <- function(input, output, session, data, run_click, origin_str) {
  
  ns <- session$ns
  
  output$dataTable <- DT::renderDataTable({
    
    req(run_click())
    
    data
    
  }, options = list(scrollX = TRUE,
                    autoWidth = TRUE#,  #Add a way to submit column defs
                    #columnDefs=column_defs_cfr
  ),
  escape = FALSE)
  
  
}

ui <- dashboardPage(skin = "black",
                    dashboardHeader(
                      title="Test App"
                    ),
                    dashboardSidebar(
                      sidebarMenu(id = "sidebar",
                                  pickerInput(
                                    inputId = "selectOrigin",
                                    label = "Origin :",
                                    choices = unique(nyc_flight_data$origin),
                                    options = list(
                                      `actions-box` = TRUE,
                                      `live-search` = TRUE,
                                      `virtual-scroll` = 10,
                                      `multiple-separator` = "\n",
                                      size = 10
                                    ),
                                    multiple = TRUE
                                  ),
                                  actionButton("runButton", "Run")
                      )
                    ),
                    dashboardBody(
                      uiOutput("origin_flight_detail")
                    )
)


server <- function(input, output, session) {
  
  click <- reactive(input$runButton)
  
  ui_content <- eventReactive(input$runButton,{
    # browser()
    origin_list <- unique(input$selectOrigin)
    unique_outputs <- length(origin_list)
    #remove any prior "input_" outputs
    possibles <- unique(nyc_flight_data$origin)
    lapply(1:length(possibles), function(i) {
      output[[possibles[[i]]]] <- NULL
    })
    
    result <- NULL
    if (unique_outputs>=1){
      result <- lapply(1:unique_outputs, function(i) {
        input_name <- paste0("input_", origin_list[[i]])
        input_title <- origin_list[i]
        print(paste0("input name: ",input_name))
        output[[input_name]] <- callModule(module = summaryTable,
                                           id = input_name,
                                           nyc_flight_data,
                                           click,
                                           origin_list[i])
        tagList(summaryTableUI(input_name,input_title) )
        
      })}
    return (result)
  })
  
  output$origin_flight_detail <- renderUI({ui_content()})
  
}

shinyApp(ui = ui, server = server)
1 Like
3

Thank you @nirgrahamuk, that got my sample solution close and helped me find an error in my real code.
In the end there were two issues:

  1. The namespace, I had tried a bunch of combos of putting the namespace around the id for the module and the ui, i.e.callModule(summaryTable,ns(input_name)) summaryTableUI(ns(input_name),input_title) but in the end I needed only the ns around the summaryTableUI id.

  2. I was assigned the outputs of the module calls to output[[input_name]] - which was not needed, I only needed to call the module and the module would handle rendering the output$ tags.

The final solution is like this and it works withSpinner():

library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)
library(shinycssloaders)
library(nycflights13)
library(tidyverse)

nyc_flight_data <- nycflights13::flights

summaryTableUI  <- function(id, title, width = 6, height="300px") {
  ns <- NS(id)
  
  box(title = title,
      collapsible = TRUE, width = width,
      DT::dataTableOutput( ns("dataTable"), height = height) %>% withSpinner()
  )
}

summaryTable <- function(input, output, session, data, run_click, origin_str) {
  
  ns <- session$ns
  
  output$dataTable <- DT::renderDataTable({
    
    req(run_click())
    
    data
    
  }, options = list(scrollX = TRUE,
                    autoWidth = TRUE#,  #Add a way to submit column defs
                    #columnDefs=column_defs_cfr
  ),
  escape = FALSE)
  
  
}

ui <- dashboardPage(skin = "black",
                    dashboardHeader(
                      title="Test App"
                    ),
                    dashboardSidebar(
                      sidebarMenu(id = "sidebar",
                                  pickerInput(
                                    inputId = "selectOrigin",
                                    label = "Origin :",
                                    choices = unique(nyc_flight_data$origin),
                                    options = list(
                                      `actions-box` = TRUE,
                                      `live-search` = TRUE,
                                      `virtual-scroll` = 10,
                                      `multiple-separator` = "\n",
                                      size = 10
                                    ),
                                    multiple = TRUE
                                  ),
                                  actionButton("runButton", "Run")
                      )
                    ),
                    dashboardBody(
                      uiOutput("origin_flight_detail")
                    )
)


server <- function(input, output, session) {
  
  ns <- session$ns
  click <- reactive(input$runButton)

  
  output$origin_flight_detail <- renderUI({
    
    
    req(input$runButton)
    
    origin_list <- unique(input$selectOrigin)
    if(length(origin_list)==0) {
      origin_list <- unique(nyc_flight_data$origin)
    }
    unique_outputs <- length(origin_list)

    lapply(1:unique_outputs, function(i) {
      input_name <- paste0("input_", origin_list[i])
      input_title <- origin_list[i]
      print(paste0("input name: ",input_name))
      callModule(module = summaryTable,
                 id = input_name,
                 nyc_flight_data,
                 click,
                 origin_list[i])
      summaryTableUI(ns(input_name),input_title)
        
      })
  })
  
}

shinyApp(ui = ui, server = server)

Thank you!

2 Likes
4

Congrats, I'll check it out and learn from your improvements

1 Like
5

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.