我怎样才能加速嵌套图的反应？

Question

我正在尝试将附加信息插入 R 中的 reactable - 一个大约有 3600 行的信息。我试过在每一行下嵌套一个图（类似于 this，但使用嵌套图而不是 sub-tables）。我能完成这项工作的唯一方法是在 reactable 中使用 plotly，像这样：


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

但遗憾的是，对于如此多的数据，输出 table 需要很长时间，而我尝试使其更快的任何操作（例如 toWebGL()）都没有任何改变。我真正关心的是速度，以及与每一行相关联的某种可视化 - 我并不特别关心它是 plotly 还是其他东西。

第二个选项是为每一行使用内联 HTML 小部件（显示 here）。在我的例子中，如果添加：

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

这不像选项那样慢，但在更大的方案中仍然非常慢。任何关于如何加速这两个例子的想法？

Answer 1

PaulM 和我一起研究了一个解决方案，并设法加快了其中一个选项：涉及内嵌迷你图的选项。结果表明，基于一些分析工作，使过程特别缓慢的不是绘制迷你图本身，而是随后将它们从 R 翻译出来以便将它们合并到 HTML reactable table.

因此，为了完全绕过缓慢的翻译过程，我们编写了一个代码模板，该模板将环绕要绘制的数据点。这就是我们随后直接提供给 reactable 的内容，连同 html = TRUE 参数，以便将代码解释为这样，而不是作为常规文本。

之后的最后一个障碍是确保迷你图（每行一个）仍然显示，即使用户对列进行排序或导航到不同的结果页面 - 通常迷你图会在与table这样。为此，我们确保 reactable 会在任何点击后 10 毫秒重新绘制。

这是一个包含在 shiny 中的示例，显示了所有这些操作以及旧（慢）版本。对我来说，加速版本大约在 0.5 秒内呈现，而旧版本 - 大约 13 秒。

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

我怎样才能加速嵌套图的反应？

How can I speed up a reactable with nested graphs?

r

plotly

reactable