1

我正在尝试将其他信息插入到reactableR 中 - 一个大约有 3600 行。我尝试在每一行下嵌套一个图（类似于this，但使用嵌套图而不是子表）。我可以完成这项工作的唯一方法是使用plotlywithin reactable，如下所示：


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

但可悲的是，对于这么多数据，输出表格需要很长时间，而且我试图让它更快的任何东西（例如toWebGL()）都没有改变。我真正关心的是速度，以及与每一行相关的某种可视化 - 我并不特别关心它是否plotly是其他东西。

第二种选择是为每一行使用一个内嵌的 HTML 小部件（如图所示）。在我的示例中，如果添加：

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

这并不像选项那么慢plotly，但在更大的方案中仍然非常慢。关于如何加快这两个例子的任何想法，有人吗？

4

1 回答 1

1

PaulM和我一起研究了一个解决方案，并设法加快了其中一个选项的速度：涉及在线迷你图的选项。事实证明，基于一些分析工作，使该过程特别缓慢的不是绘制迷你图本身，而是从 R 中翻译它们以便将它们合并到 HTMLreactable表中的后续工作。

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

之后的最后一个障碍是确保即使用户对列进行排序或导航到不同的结果页面，迷你图（每行一个）仍然显示 - 通常迷你图会在以这种方式与表格交互时消失。为此，我们确保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)
  
}
于 2021-02-19T19:56:46.960 回答