How can I speed up a reactable with nested graphs?

Question

I am trying to insert additional information into a reactable in R - one which has about 3600 rows. I've tried nesting a plot under each row (similar to this, but with nested plots instead of sub-tables). The only way I could make this work was to use plotly within reactable, like so:


library(reactable)
library(magrittr)
library(plotly)

my_diamonds <- diamonds
my_diamonds$cats <- cut(my_diamonds$price, 850)
my_diamonds <- my_diamonds[ order(my_diamonds$cut, my_diamonds$cats), ]
data <- unique(my_diamonds[, c("cut", "cats")])



reactable(data,
          details = function(index) {
            diam_data <- my_diamonds[my_diamonds$cut == data$cut[index] & my_diamonds$cats == data$cats[index], ]
            plot_ly(diam_data,
                    x = ~1:nrow(diam_data),
                    y = ~y, 
                    type = 'scatter',
                    mode = 'lines') # %>% toWebGL()
          }
)

But sadly, for this amount of data, this takes forever to output the table, and anything I've tried to make it faster (such as toWebGL()) changes nothing. All I really care about is the speed, and having some sort of visualisation associated with each row - I don't particularly care if it's plotly or something else.

A second option would be to use an in-line HTML widget for each row (shown here). In my example, this could be done if adding:

data_parcels <- split(my_diamonds, list(my_diamonds$cats, my_diamonds$cut), drop = T)
data$nested_points <- sapply(data_parcels, '[[', 'y')
data$sparkline <- NA


library(sparkline)
reactable(data, 
          columns = list(
            sparkline = colDef(cell = function(value, index) {
              sparkline(data$nested_points[[index]])
            })
          ))

This isn't quite as slow as the plotly option, but still very slow in the larger scheme of things. Any ideas on how to speed up either example, anyone?

score 2 · Accepted Answer · answered Feb 19 '21 at 19:56

PaulM and I have worked on a solution together, and managed to speed up one of the options: the one involving in-line sparklines. As it turned out based on some profiling work, what was making the process particularly slow wasn't drawing the sparklines in itself, rather the subsequent work of translating them from R so that they could be incorporated into the HTML reactable table.

So to bypass that slow translation process entirely, we wrote a code template that would get wrapped around the data points to be plotted. This is what we then served directly to reactable, alongside an html = TRUE argument, for the code to be interpreted as such, rather than as regular text.

The final hurdle after that was to ensure that the sparklines (one per row) were still on display even if a user sorted a column or navigated to a different page of results - normally the sparklines would disappear on interacting with the table in this way. For this, we ensured that that the reactable would be redrawn 10ms after any click.

Here is an example wrapped in shiny that shows all this in action, alongside the old (slow) version. For me, the sped up version renders in about 0.5s roughly, whereas the old one - about 13s.

library(reactable)
library(magrittr)
library(plotly)
library(sparkline)
library(shiny)
library(shinycssloaders)
library(shinyWidgets)


if (interactive()) {
  
  # Init objects
  t0 <- NULL
  t1 <- NULL
  
  my_diamonds <- diamonds
  my_diamonds$cats <- cut(my_diamonds$price, 850)
  my_diamonds <- my_diamonds[ order(my_diamonds$cut, my_diamonds$cats), ]
  data <- unique(my_diamonds[, c("cut", "cats")])
  
  data_parcels <- split(my_diamonds, list(my_diamonds$cats, my_diamonds$cut), drop = T)
  data$nested_points <- sapply(data_parcels, '[[', 'y')
  data$sparkline <- NA
  
  
  ui <- shinyUI(
    basicPage(
      br(),
      radioGroupButtons(
        inputId = "speedChoice",
        label = "Speed",
        choices = c("Fast", "Slow"),
        status = "danger"
      ),
      br(),
      verbatimTextOutput("timeElapsed"),
      br(),
      shinycssloaders::withSpinner(
        reactableOutput("diamonds_table")
      ),
      # Small JS script to re-render a reactable table so that the sparklines show 
      # after the user has modified the table (sorted a col or navigated to a given page of results)
      tags$script('document.getElementById("diamonds_table").addEventListener("click", function(event){
                             setTimeout(function(){
                             console.log("rerender")
                                        HTMLWidgets.staticRender()
                             }, 10);
                          })
                           ')
    )
  )
  
  server <- function(input, output, session) {
    
    output$diamonds_table <- renderReactable({
      
      if (input$speedChoice == "Fast") {
        
        t0 <<- Sys.time()
        
        part1 <- '<span id="htmlwidget-spark-' # + ID
        part2 <- '" class="sparkline html-widget"></span><script type="application/json" data-for="htmlwidget-spark-' # + ID
        part3 <- '">{"x":{"values":[' # + values
        part4 <- '],"options":{"height":20,"width":60},"width":60,"height":20},"evals":[],"jsHooks":[]}</script>'
        
        out <- list(length = nrow(data))
        for (i in 1:nrow(data)) {
          vals <- paste0(data$nested_points[[i]], collapse = ',')
          out[[i]] <- paste0(part1, i, part2, i, part3, vals, part4)
        }
        data$sparkline <- out
        
        
        tab <- reactable(data,
                         columns = list(
                           sparkline = colDef(html = TRUE,
                                              cell = function(value, index) {
                                                return(htmltools::HTML(value))
                                              }
                           )
                         )
        ) %>%
          spk_add_deps() %>% 
          htmlwidgets::onRender(jsCode = "
                      function(el, x) {
                      HTMLWidgets.staticRender();
                      console.log('render happening')
                      }")
        
        t1 <<- Sys.time()
        
        return(tab)
        
      } else {
        
        # Classic, but slow version:
        t0 <<- Sys.time()
        tab <- reactable(data,
                         columns = list(
                           sparkline = colDef(cell = function(value, index) {
                             data$nested_points[[index]] %>%
                               sparkline::sparkline()
                           }
                           )
                         )
        )
        t1 <<- Sys.time()
        
        return(tab)
        
      }
    })
    
    
    output$timeElapsed <- renderText({
      input$speedChoice # Connect to reactable update cycle
      return(t1 - t0)
    })
    
  }
  
  shinyApp(ui = ui, server = server)
  
}

Jakub.Novotny · Answer 2 · 2023-03-12T10:52:04.900

Slightly different answer how to speed up sparklines in reactable in an html widget rather then Shiny.

library(tidyverse)
library(reactable)
library(sparklines)
library(htmltools)
library(htmlwidgets)

# some dummy data
df <- mpg %>%
  group_by(manufacturer) %>%
  summarise(
    sparklines = list(hwy)
  ) %>%
  crossing(id = 1:100)

# standard sparklines (easy and simple, but rather slow)
df %>%
  reactable(
    columns = list(
      sparklines = colDef(
        cell = function(values) {
          sparkline(values, chart_type =  "line")
        })
    )
  )

# manual sparklines (should be faster)

tbl <- df %>%
  rowwise() %>%
  mutate(
    # preparing the sparklines html manually
    # sparklines html looks like this <span class="inlinesparkline">1,2,3,4,5</span>
    sparklines = sparklines %>%
      unlist() %>%
      paste(collapse = ",") %>%
      paste0('<span class="inlinesparkline">', ., '</span>')
  ) %>%
  reactable(
    columns = list(
      sparklines = colDef(html = T) # rendering the content as html
    )
  ) %>%
  # adding a custom JavaScript function to render the sparklines from the html tags
  # once the sparkline is created, the class is changed from inlinesparkline to noinlinesparkline
  # changing the class is necessary because otherwise another rendering would remove the created sparkoines
  # this function is run each 20ms so that it is applied even to sparklines on other pages of the reactable
  prependContent(onStaticRenderComplete(
    HTML("setInterval(function(){ 
            $('.inlinesparkline').sparkline();
            $('.inlinesparkline').toggleClass('inlinesparkline noinlinesparkline');
          }, 50);
         ")
  ))


tbl$dependencies <- getDependency("sparklines") 

tbl

How can I speed up a reactable with nested graphs?

2 Answers2