Синхронизация горизонтальных полос прокрутки для таблиц данных в приложении R Shiny - PullRequest
Новая
       35

Синхронизация горизонтальных полос прокрутки для таблиц данных в приложении R Shiny

1 голос
/ 11 июля 2020

Есть ли способ синхронизировать горизонтальные полосы прокрутки из DataTable или даже иметь одну горизонтальную полосу прокрутки для нескольких таблиц? Я пытаюсь сделать так, чтобы несколько таблиц с одинаковым количеством столбцов и шириной столбцов выстраивались вместе, когда пользователь использует горизонтальную полосу прокрутки.

Так, например, в приведенном ниже примере кода я ' m пытается выровнять каждый из столбцов с пометкой «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)

1 Ответ

0 голосов
/ 14 июля 2020

Вот способ использования библиотеки 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)
...