r - 在 R Shiny 应用程序中同步 DataTables 的水平滚动条
问题描述
有没有办法让 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)
解决方案
这是一种使用 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)
推荐阅读
- python - 如何创建通道敏感损失函数?
- javascript - 鼠标移动/滚动到下一个哈希
- android - 更新 xamrain 15.7.1 后无法调用项目菜单
- python - 摆脱 Pandas 多索引 DataFrame 的 HTML 样式的额外标题行
- c# - VSTS 托管代理无法加载 DLL MSB3246
- python - 如何在pygame的精灵表中从精灵中删除黑色背景
- r - 如何在不更改原始表的情况下使用 data.table := 运算符?
- powershell - 函数的多个 ParameterSet 在从脚本声明时起作用,但在从模块导入时不起作用
- jquery - tinymce 编辑器中图像位置的变化在预览中没有准确定位
- mysql - 基于 Mysql json 的趋势标签实现