Improve Shiny page population performance (#314)

* perf: reduce Shiny page load latency

* fix: stabilize loading feedback across panels

* fix: unify page loading feedback

* fix: restore loader across menu panels

* perf: remove remaining page-load overhead

* fix: render panels after inputs initialise

* fix: stabilize dynamic panel rendering

* fix: initialise enrichment overview controls

* test: serialize enrichment overview browser coverage

* test: limit enrichment browser regression to current R

* ci: serialize browser tests on R 4.1

* test: restore eager browser fixture setup

Author: pinin4fjords

R/assaydatatable.R

@@ -70,7 +70,10 @@ assaydatatableOutput <- function(id) {
 
   moduleMain(
     NULL,
-    htmlOutput(ns("assaydatatable")),
+    simpletableOutput(
+      ns("assaydatatable"),
+      tabletitle = textOutput(ns("assaydatatable_title"), inline = TRUE)
+    ),
     help = modalInput(ns(assaydatatable_modal$id), "help", "help")
   )
 }
@@ -111,17 +114,16 @@ assaydatatable <- function(id, eselist) {
 
     # Render the output area - and provide an input-dependent title
 
-    output$assaydatatable <- renderUI({
-      ns <- session$ns
-
-      simpletableOutput(ns("assaydatatable"), tabletitle = paste("Assay data", selectmatrix_reactives$getAssay(), sep = ": "), spinner = TRUE)
+    output$assaydatatable_title <- renderText({
+      paste("Assay data", selectmatrix_reactives$getAssay(), sep = ": ")
     })
 
     # Pass the matrix to the simpletable module for display
 
     simpletable("assaydatatable",
       downloadMatrix = selectmatrix_reactives$selectLabelledMatrix, displayMatrix = selectmatrix_reactives$selectLabelledLinkedMatrix,
-      filename = selectmatrix_reactives$getAssay(), rownames = FALSE
+      filename = selectmatrix_reactives$getAssay(), rownames = FALSE,
+      ready = selectmatrix_reactives$inputsReady
     )
   })
 }

R/barplot.R

@@ -41,11 +41,13 @@ barplotOutput <- function(id, height = 400) {
 #' @param getPlotmatrix Reactive supplying a matrix to plot
 #' @param getYLabel Reactive supplying the Y axis label
 #' @param barmode Bar mode: 'stack', 'group' or 'overlay'
+#' @param ready Reactive that returns TRUE when the plot data and controls are
+#'   fully initialised.
 
-barplot <- function(id, getPlotmatrix, getYLabel, barmode = "stack") {
+barplot <- function(id, getPlotmatrix, getYLabel, barmode = "stack", ready = reactive(TRUE)) {
   moduleServer(id, function(input, output, session) {
     output$barPlot <- renderPlotly({
-      validate(need(input$barMode, "Waiting for bar mode"))
+      req(ready(), inputsInitialised(input$barMode))
 
       interactive_barchart(getPlotmatrix(), barmode = input$barMode, ylab = getYLabel()) %>%
         shinyngsPlotlyConfig("barplot", format = session$userData$plotFormat())

R/boxplot.R

@@ -140,9 +140,19 @@ boxplot <- function(id, eselist) {
     selectmatrix_reactives <- selectmatrix("sampleBoxplot", eselist, select_genes = FALSE)
     groupby_reactives <- groupby("boxplot", eselist = eselist, group_label = "Color by", selectColData = selectmatrix_reactives$selectColData)
 
+    inputsReady <- reactive({
+      req(
+        selectmatrix_reactives$inputsReady(),
+        groupby_reactives$inputsReady(),
+        inputsInitialised(input$plotType, input$whiskerDistance)
+      )
+      TRUE
+    })
+
     # Render the plot
 
     output$quartilesPlot <- renderUI({
+      req(inputsReady())
       ns <- session$ns
       plotOutputId <- if (input$plotType == "boxes") {
         "sampleBoxplot"
@@ -151,17 +161,19 @@ boxplot <- function(id, eselist) {
       } else {
         "quartilesPlotly"
       }
-      shinycssloaders::withSpinner(plotlyOutput(ns(plotOutputId), height = "600px"), color = shinyngsSpinnerColor())
+      plotlyOutput(ns(plotOutputId), height = "600px")
     })
 
     output$quartilesPlotly <- renderPlotly({
+      req(inputsReady())
       selected_matrix <- selectmatrix_reactives$selectMatrix()
       ese <- selectmatrix_reactives$getExperiment()
       interactive_quartiles(selected_matrix, id_to_label(rownames(selected_matrix), ese), selectmatrix_reactives$getAssayMeasure(), whisker_distance = input$whiskerDistance) %>%
         shinyngsPlotlyConfig("quartiles", format = session$userData$plotFormat())
     })
 
     output$densityPlotly <- renderPlotly({
+      req(inputsReady())
       interactive_densityplot(selectmatrix_reactives$selectMatrix(), selectmatrix_reactives$selectColData(), groupby_reactives$getGroupby(), expressiontype = selectmatrix_reactives$getAssayMeasure(), palette = groupby_reactives$getPalette()) %>%
         shinyngsPlotlyConfig("density", format = session$userData$plotFormat())
     })
@@ -198,6 +210,7 @@ boxplot <- function(id, eselist) {
     })
 
     output$sampleBoxplot <- renderPlotly({
+      req(inputsReady())
       withProgress(message = "Making sample boxplot", value = 0, {
         interactive_boxplot_from_statistics(list(" " = getBoxplotStatistics()), selectmatrix_reactives$selectColData(), groupby_reactives$getGroupby(),
           expressiontype = selectmatrix_reactives$getAssayMeasure(),
@@ -221,7 +234,7 @@ boxplot <- function(id, eselist) {
       downloadMatrix = getDistributionSummary,
       displayMatrix = getDistributionSummary,
       filename = "distribution_summary", rownames = FALSE,
-      server = FALSE, initial_order = list()
+      server = FALSE, initial_order = list(), ready = inputsReady
     )
   })
 }

R/categorycountplot.R

@@ -34,8 +34,8 @@ categorycountplotOutput <- function(id) {
   ns <- NS(id)
 
   list(
-    shinycssloaders::withSpinner(plotlyOutput(ns("plot"), height = "500px"), color = shinyngsSpinnerColor()),
-    simpletableOutput(ns("table"), tabletitle = "Counts", spinner = TRUE)
+    plotlyOutput(ns("plot"), height = "500px"),
+    simpletableOutput(ns("table"), tabletitle = "Counts")
   )
 }
 
@@ -110,6 +110,13 @@ categorycountplot <- function(id, getAnnotation, filename = "categorycounts") {
       if (is.null(input$barmode)) "group" else input$barmode
     })
 
+    inputsReady <- reactive({
+      if (!inputsInitialised(input$category, input$fill)) {
+        return(FALSE)
+      }
+      identical(input$fill, "none") || inputsInitialised(input$barmode)
+    })
+
     # The tally itself only depends on category/fill, not on barmode - shared so the table and plot (and a barmode-only change) don't each
     # re-tally the annotation data frame independently
 
@@ -135,12 +142,13 @@ categorycountplot <- function(id, getAnnotation, filename = "categorycounts") {
     })
 
     output$plot <- renderPlotly({
+      req(inputsReady())
       title <- paste("Counts by", prettify_variable_name(input$category))
 
       interactive_barchart(getCountMatrix(), barmode = getBarmode(), ylab = "Count", title = title) %>%
         shinyngsPlotlyConfig(filename, format = session$userData$plotFormat())
     })
 
-    simpletable("table", displayMatrix = countTable, filename = filename, rownames = FALSE)
+    simpletable("table", displayMatrix = countTable, filename = filename, rownames = FALSE, ready = inputsReady)
   })
 }

R/clustering.R

@@ -79,9 +79,9 @@ clusteringOutput <- function(id) {
   moduleMain(
     NULL,
     uiOutput(ns("geneClusteringTitle")),
-    shinycssloaders::withSpinner(plotlyOutput(ns("geneClusteringPlot"), height = "600px"), color = shinyngsSpinnerColor()),
+    plotlyOutput(ns("geneClusteringPlot"), height = "600px"),
     h4("Table of values by cluster"),
-    simpletableOutput(ns("geneClusteringTable"), spinner = TRUE),
+    simpletableOutput(ns("geneClusteringTable")),
     help = modalInput(ns(clustering_modal$id), "help", "help")
   )
 }
@@ -118,6 +118,18 @@ clustering <- function(id, eselist) {
 
     getPalette <- colormaker("clustering", getNumberCategories = getClusterNumber)
 
+    inputsReady <- reactive({
+      req(
+        selectmatrix_reactives$inputsReady(),
+        inputsInitialised(
+          input$cluster_number, input$cluster_display,
+          input$average_type, input$limits,
+          input[["clustering-palette_name"]]
+        )
+      )
+      TRUE
+    })
+
     ############################################################################# Form accessors
 
     # The number of clusters
@@ -234,6 +246,7 @@ clustering <- function(id, eselist) {
     )
 
     output$geneClusteringPlot <- renderPlotly({
+      req(inputsReady())
       getClusterPlot() %>% shinyngsPlotlyConfig("clustering", format = session$userData$plotFormat())
     })
 
@@ -261,7 +274,7 @@ clustering <- function(id, eselist) {
 
     # Render the table and provide for download, using the simpletable module.
 
-    simpletable("geneClusteringTable", downloadMatrix = makeMatrixWithClusters, displayMatrix = makeLinkedMatrixWithClusters, filter = "top", filename = "clustered_matrix", rownames = FALSE)
+    simpletable("geneClusteringTable", downloadMatrix = makeMatrixWithClusters, displayMatrix = makeLinkedMatrixWithClusters, filter = "top", filename = "clustered_matrix", rownames = FALSE, ready = inputsReady)
   })
 }