Synchronize horizontal scrollbars for DataTables in R Shiny application

Question

Is there a way to get the horizontal scrollbars from a DataTable to be synchronized or even just have one horizontal scrollbar for multiple tables? I'm trying to have it where multiple tables with the same number of columns and column widths would be lined up together when the user uses the horizontal scrollbar.

So for example, in the sample code below, I'm trying to get each of the columns labeled "V#" to line up between the two tables as a user uses one of the horizontal scrollbars.

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)

Stéphane Laurent · Accepted Answer · 2020-07-14T22:10:48.427

Here is a way using a JavaScript library. You have to set the same column widths in order to get a perfect match.

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)

EDIT

The following map automatically sets each column width to the maximum of the two widths of this column in the two initial tables. Therefore the column widths are equal in an optimal way.

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)

Synchronize horizontal scrollbars for DataTables in R Shiny application

1 Answers1

EDIT

Linked