在 R Shiny 应用程序中同步 DataTables 的水平滚动条

Question

有没有办法让 DataTable 中的水平滚动条同步，或者甚至只为多个表提供一个水平滚动条？我试图让它在用户使用水平滚动条时将具有相同列数和列宽的多个表排列在一起。

例如，在下面的示例代码中，当用户使用其中一个水平滚动条时，我试图让标记为“V#”的每一列在两个表之间对齐。

library(shiny)
library(DT)
library(dplyr)


ui <- fluidPage(
 
    fluidRow(
        DT::dataTableOutput("setosa_table")
    ),
    
    fluidRow(
        DT::dataTableOutput("virginica_table")
    )
    
    
)

server <- function(input, output) {
    
    # Data
    data <- iris %>%
        mutate(Species = as.factor(Species))

    setosa_data <- t(data.frame(data %>%
                                    filter(iris$Species == 'setosa'))
    )
    
    virginica_data <- t(data.frame(data %>%
                                    filter(iris$Species == 'virginica'))
    )
    
    # Data Table Outputs
    output$setosa_table <- renderDataTable({
        datatable(setosa_data,
                  extensions = 'FixedColumns',
                  options = list(scrollX = TRUE,
                                 fixedColumns = list(leftColumns = 1, rightColumns = 0))
        )
    })
    
    output$virginica_table <- renderDataTable({
        
        datatable(virginica_data,
                  extensions = 'FixedColumns',
        options = list(scrollX = TRUE,
                       fixedColumns = list(leftColumns = 1, rightColumns = 0))
        )
    })
    
}

# Run the application 
shinyApp(ui = ui, server = server)

Answer 1

这是一种使用 JavaScript 库的方法。您必须设置相同的列宽才能获得完美匹配。

library(shiny)
library(DT)
library(dplyr)    

js <- "
var myInterval = setInterval(function() {
  var containers = $('.dataTables_scroll');
  if (containers.length === 2) {
    clearInterval(myInterval);
    containers.scrollsync();
  }
}, 200);
"

CSS <- "
.dataTables_info {
  margin-top: 20px;
}
.dataTables_scrollBody {
  overflow-x: hidden !important;
  width: fit-content !important;
}
.dataTables_scrollHead {
  width: fit-content !important;
}
.dataTables_scroll {
  overflow-x: scroll;
}
table.dataTable {
  table-layout: fixed;
}
"

ui <- fluidPage(
  
  tags$head(
    tags$script(src = "https://cdn.jsdelivr.net/gh/zjffun/jquery-ScrollSync/dist/jquery.scrollsync.js"),
    tags$script(HTML(js)),
    tags$style(HTML(CSS))
  ),
  
  fluidRow(
    DTOutput("setosa_table")
  ),
  
  br(),
  
  fluidRow(
    DTOutput("virginica_table")
  )
  
)

server <- function(input, output) {
  
  # Data
  data <- iris %>%
    mutate(Species = as.factor(Species))
  
  setosa_data <- t(data.frame(data %>%
                                filter(iris$Species == 'setosa'))
  )
  
  virginica_data <- t(data.frame(data %>%
                                   filter(iris$Species == 'virginica'))
  )
  
  # Data Table Outputs
  output$setosa_table <- renderDT({
    datatable(setosa_data,
              extensions = 'FixedColumns',
#              callback = JS(js),
              options = list(
                scrollX = TRUE, 
                fixedColumns = list(
                  leftColumns = 1, 
                  rightColumns = 0
                ),
                columnDefs = list(
                  list(targets = "_all", width = "100px")
                )
              )
    )
  })
  
  output$virginica_table <- renderDT({
    
    datatable(virginica_data,
              extensions = 'FixedColumns',
              options = list(
                scrollX = TRUE, 
                fixedColumns = list(
                  leftColumns = 1, 
                  rightColumns = 0
                ),
                columnDefs = list(
                  list(targets = "_all", width = "100px")
                )
              )
    )
  })
  
}

# Run the application 
shinyApp(ui = ui, server = server)

---

编辑

下面的映射自动将每个列的宽度设置为两个初始表中该列的两个宽度中的最大值。因此，列宽以最佳方式相等。

library(shiny)
library(DT)
library(dplyr)


js <- "
var iScrollSync = setInterval(function() {
  var containers = $('.dataTables_scroll');
  var tables = containers.find('table');
  if (tables.length === 4) {
    clearInterval(iScrollSync);
    containers.scrollsync();
  }
}, 200);
var widths = [];
$(document).on('preInit.dt', function(e, settings){
  var api = new $.fn.dataTable.Api(settings);
  var iGetWidths = setInterval(function(){
    var w = $(api.table().header()).find('th').map(function(i,x){return $(x).width();}).get();
    if(w[0] > 0){
      clearInterval(iGetWidths);
      widths.push(w);
    }
  }, 5);
  var iSetWidths = setInterval(function(){
    if(widths.length === 2){
      clearInterval(iSetWidths);
      var maxwidths = widths[0].map(function(w,i){return Math.max(w, widths[1][i]);});
      var dtBody = $(api.table().node()).closest('.dataTables_scrollBody');
      var ths_body = dtBody.find('th');
      ths_body.each(function(index,item){$(item).width(maxwidths[index]);});
      var ths_header = dtBody.parent().find('.dataTables_scrollHead').find('th');
      ths_header.each(function(index,item){$(item).width(maxwidths[index]);});
      api.on('order.dt', function(){
        var ths_body = dtBody.find('th');
        ths_body.each(function(index,item){$(item).width(maxwidths[index]);});
        ths_header.each(function(index,item){$(item).width(maxwidths[index]);});
      });
    }
  }, 5);
});
"

CSS <- "
.dataTables_info {
  margin-top: 20px;
}
.dataTables_scrollBody {
  overflow-x: hidden !important;
  width: fit-content !important;
}
.dataTables_scrollHead {
  width: fit-content !important;
}
.dataTables_scroll {
  overflow-x: scroll;
}
table.dataTable {
  table-layout: fixed;
} 
"

ui <- fluidPage(
  
  tags$head(
    tags$script(src = "https://cdn.jsdelivr.net/gh/zjffun/jquery-ScrollSync/dist/jquery.scrollsync.js"),
    tags$script(HTML(js)),
    tags$style(HTML(CSS))
  ),
  
  fluidRow(
    column(12,
      DTOutput("setosa_table")
    )
  ),
  
  br(),
  
  fluidRow(
    column(
      12,
      DTOutput("virginica_table")
    )
  )
  
)

server <- function(input, output) {
  
  # Data
  data <- iris %>%
    mutate(Species = as.factor(Species))
  
  setosa_data <- t(data.frame(data %>%
                                filter(iris$Species == 'setosa'))
  )
  
  virginica_data <- t(data.frame(data %>%
                                   filter(iris$Species == 'virginica'))
  )
  
  # Data Table Outputs
  output$setosa_table <- renderDT({
    datatable(setosa_data,
              extensions = 'FixedColumns',
              options = list(
                autoWidth = TRUE,
                scrollX = TRUE, 
                fixedColumns = list(
                  leftColumns = 1, 
                  rightColumns = 0
                )
              )
    )
  })
  
  output$virginica_table <- renderDT({
    
    datatable(virginica_data,
              extensions = 'FixedColumns',
              options = list(
                autoWidth = TRUE,
                scrollX = TRUE, 
                fixedColumns = list(
                  leftColumns = 1, 
                  rightColumns = 0
                )
              )
    )
  })
  
}

# Run the application 
shinyApp(ui = ui, server = server)