How can I speed up a reactable with nested graphs? - r

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?

Answer 1

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)
}