R闪亮包中的父/子行
Posted
技术标签:
【中文标题】R闪亮包中的父/子行【英文标题】：Parent/Child Rows in R shiny Package 【发布时间】：2018-12-27 18:09:22 【问题描述】：我在 javascript 方面的背景不存在，因此求助于使用 davlee1972 在 GitHub 上发布的一些代码。此代码已在 mtcars 文件上进行过训练，然后更改为我自己的数据。
这里的问题是，虽然代码适用于前两个子/父关系，但它似乎只发布最后一个子的列标题。
代码：
library(data.table)
library(DT)
library(shiny)
ui <- fluidPage(fluidRow(DT::dataTableOutput(width = "100%", "table")))
server <- function(input, output)
output$table = DT::renderDataTable(
# mtcars_dt = data.table(mtcars)
# setkey(mtcars_dt,mpg,cyl)
# mpg_dt = unique(mtcars_dt[, list(mpg, cyl)])
# setkey(mpg_dt, mpg, cyl)
# cyl_dt = unique(mtcars_dt[, list(cyl)])
# setkey(cyl_dt, cyl)
#
# mtcars_dt = mtcars_dt[,list(mtcars=list(.SD)), by = list(mpg,cyl)]
# mtcars_dt[, ' ' := '►']
#
# mpg_dt = merge(mpg_dt,mtcars_dt, all.x = TRUE )
# setkey(mpg_dt, cyl)
# setcolorder(mpg_dt, c(length(mpg_dt),c(1:(length(mpg_dt) - 1))))
#
# mpg_dt = mpg_dt[,list(mpg=list(.SD)), by = cyl]
# mpg_dt[, ' ' := '►']
#
# cyl_dt = merge(cyl_dt,mpg_dt, all.x = TRUE )
# setcolorder(cyl_dt, c(length(cyl_dt),c(1:(length(cyl_dt) - 1))))
DT::datatable(
data = child_1lvl,
rownames = FALSE,
escape = -1,
extensions = c( 'Scroller'),
options = list(
dom = 'Bfrti',
autoWidth = TRUE,
stripeClasses = list(),
deferRender = TRUE,
scrollX = TRUE,
scrollY = "51vh",
scroller = TRUE,
scollCollapse = TRUE,
columnDefs = list(
list(orderable = FALSE, className = 'details-control', targets = 0),
list(visible = FALSE, targets = -1 )
)
),
callback = JS("
table.column(1).nodes().to$().css(cursor: 'pointer')
// Format child object into another table
var format = function(d)
if(d != null)
var result = ('<table id=\"' + d[1] + '\"><thead><tr>').replace('.','_')
for (var col in d[d.length - 1][0])
result += '<th>' + col + '</th>'
result += '</tr></thead></table>'
return result
else
return ''
var format_datatable = function(d)
if(d != null)
if ('SOME CHECK' == 'LAST SET OF CHILD TABLES')
var subtable = $(('table#' + d[1]).replace('.','_')).DataTable(
'data': d[d.length - 1].map(Object.values),
'autoWidth': true,
'deferRender': true,
'stripeClasses': [],
'info': false,
'lengthChange': false,
'ordering': false,
'paging': false,
'scrollX': false,
'scrollY': false,
'searching': false
).draw()
else
var subtable = $(('table#' + d[1]).replace('.','_')).DataTable(
'data': d[d.length - 1].map(Object.values),
'autoWidth': true,
'deferRender': true,
'stripeClasses': [],
'info': false,
'lengthChange': false,
'ordering': false,
'paging': false,
'scrollX': false,
'scrollY': false,
'searching': false,
'columnDefs': ['orderable': false, 'className': 'details-control', 'targets': 0,
'visible': false, 'targets': -1]
).draw()
//var sub_tbl_id = 0;
table.on('click', 'td.details-control', function()
var table = $(this).closest('table')
var td = $(this)
var row = $(table).DataTable().row(td.closest('tr'))
if (row.child.isShown())
row.child.hide()
td.html('►')
else
row.child(format(row.data())).show()
format_datatable(row.data())
td.html('▼')
)
")
)
,server = TRUE)
shinyApp (ui = ui, server = server)
生成的网页如下所示，仅显示 AccounReffullname 和 Fullamount 标题，而不是每个财务类别下方应该存在的多行。
此外，在 COGS 组件的情况下，它似乎只显示 AccountReffullname 列并且缺少 Fullamount 列。
我的问题是，它在 javascript 中的哪个位置控制子/父关系的层数，是否有人知道为什么这适用于 mtcars 文件，但是对于我自己的数据以相同的格式失败。
我使用的代码发布在以下链接上：
https://github.com/rstudio/DT/issues/525 https://github.com/rstudio/shiny-examples/issues/9#issuecomment-362000334
任何帮助将不胜感激！
谢谢 呸呸呸
【问题讨论】：
那是因为空格。您还在寻找解决方案吗？ 嗨，Stephane，是的，我仍在寻找解决方案，但不明白您所说的空白到底是什么意思。同时，让我试着给你一些代码，这样你就可以重现我的困境。谢谢 看我的回答。如果您无法将其与您的数据一起使用，请编辑您的帖子以包含您的数据（以及您用于构建数据的方式）。 【参考方案1】：这段代码的问题是它使用行的内容来构建子表的标识符，并且禁止在标识符中使用点和空格。如您所见，包含空格的行不会显示子表。
代码通过执行replace('.','_') 替换了点。这通常是不够的，因为它只替换了第一次出现的点（带有下划线）。在下面的代码中，我通过replace(/[\\s|\\.]/g, '_') 将点和空格替换为下划线。 g 表示“全局”：这会替换所有出现的情况。
要使用我的代码，子表必须包含在名为"details" 的列中，并且这必须是最后一列。此代码允许多层嵌套：您还可以为子表的一行定义子表。在这个例子中，第一行有两层嵌套。
library(DT)
## data
dat <- data.frame(
Sr = c(1.5, 2.3),
Description = c("A - B", "X - Y")
)
## details of row 1
subsubdat1 <- data.frame(
Ref = c("UVW", "PQR"),
Case = c(99, 999),
stringsAsFactors = FALSE
)
subdat1 <- data.frame(
Chromosome = "chr18",
SNP = "rs2",
details = I(list(purrr::transpose(subsubdat1))),
stringsAsFactors = FALSE
)
subdat1 <- cbind(" " = "⊕", subdat1, stringsAsFactors = FALSE)
## details of row 2
subdat2 <- data.frame(
Chromosome = c("chr19","chr20"),
SNP = c("rs3","rs4"),
stringsAsFactors = FALSE
)
## merge the row details
subdats <- lapply(list(subdat1, subdat2), purrr::transpose)
## dataframe for the datatable
Dat <- cbind(" " = "⊕", dat, details = I(subdats))
## the callback
callback = JS(
"table.column(1).nodes().to$().css(cursor: 'pointer');",
"// Format the nested table into another table",
"var childId = function(d)",
" var tail = d.slice(2, d.length - 1);",
" return 'child_' + tail.join('_').replace(/[\\s|\\.]/g, '_');",
";",
"var format = function (d) ",
" if (d != null) ",
" var id = childId(d);",
" var html = ",
" '<table class=\"display compact\" id=\"' + id + '\"><thead><tr>';",
" for (var key in d[d.length-1][0]) ",
" html += '<th>' + key + '</th>';",
" ",
" html += '</tr></thead></table>'",
" return html;",
" else ",
" return '';",
" ",
";",
"var rowCallback = function(row, dat, displayNum, index)",
" if($(row).hasClass('odd'))",
" for(var j=0; j<dat.length; j++)",
" $('td:eq('+j+')', row).css('background-color', 'papayawhip');",
" ",
" else ",
" for(var j=0; j<dat.length; j++)",
" $('td:eq('+j+')', row).css('background-color', 'lemonchiffon');",
" ",
" ",
";",
"var headerCallback = function(thead, data, start, end, display)",
" $('th', thead).css(",
" 'border-top': '3px solid indigo',",
" 'color': 'indigo',",
" 'background-color': '#fadadd'",
" );",
";",
"var format_datatable = function (d) ",
" var dataset = [];",
" var n = d.length - 1;",
" for (var i = 0; i < d[n].length; i++) ",
" var datarow = $.map(d[n][i], function (value, index) ",
" return [value];",
" );",
" dataset.push(datarow);",
" ",
" var id = 'table#' + childId(d);",
" if (Object.keys(d[n][0]).indexOf('details') === -1) ",
" var subtable = $(id).DataTable(",
" 'data': dataset,",
" 'autoWidth': true,",
" 'deferRender': true,",
" 'info': false,",
" 'lengthChange': false,",
" 'ordering': d[n].length > 1,",
" 'paging': false,",
" 'scrollX': false,",
" 'scrollY': false,",
" 'searching': false,",
" 'sortClasses': false,",
" 'rowCallback': rowCallback,",
" 'headerCallback': headerCallback,",
" 'columnDefs': [targets: '_all', className: 'dt-center']",
" );",
" else ",
" var subtable = $(id).DataTable(",
" 'data': dataset,",
" 'autoWidth': true,",
" 'deferRender': true,",
" 'info': false,",
" 'lengthChange': false,",
" 'ordering': d[n].length > 1,",
" 'paging': false,",
" 'scrollX': false,",
" 'scrollY': false,",
" 'searching': false,",
" 'sortClasses': false,",
" 'rowCallback': rowCallback,",
" 'headerCallback': headerCallback,",
" 'columnDefs': [targets: -1, visible: false, targets: 0, orderable: false, className: 'details-control', targets: '_all', className: 'dt-center']",
" ).column(0).nodes().to$().css(cursor: 'pointer');",
" ",
";",
"table.on('click', 'td.details-control', function () ",
" var tbl = $(this).closest('table');",
" var td = $(this),",
" row = $(tbl).DataTable().row(td.closest('tr'));",
" if (row.child.isShown()) ",
" row.child.hide();",
" td.html('⊕');",
" else ",
" row.child(format(row.data())).show();",
" td.html('⊖');",
" format_datatable(row.data());",
" ",
");")
## datatable
datatable(Dat, callback = callback, escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = ncol(Dat)),
list(orderable = FALSE, className = 'details-control', targets = 1),
list(className = "dt-center", targets = "_all")
)
))
编辑
这里有一个更好的解决方案。这个不使用行内容来构建标识符。代码更简单，这允许具有相同的行。我已将details 更改为_details，以防用户在他的数据集中有一个名为details 的列。
library(DT)
##~~ Multiple levels of nesting ~~##
## data
dat <- data.frame(
Sr = c(1.5, 2.3),
Description = c("A - B", "X - Y")
)
## details of row 1
subsubdat1 <- data.frame(
Ref = c("UVW", "PQR"),
Case = c(99, 999),
stringsAsFactors = FALSE
)
subdat1 <- data.frame(
Chromosome = "chr18",
SNP = "rs2",
"_details" = I(list(purrr::transpose(subsubdat1))),
stringsAsFactors = FALSE,
check.names = FALSE
)
subdat1 <- cbind(" " = "⊕", subdat1, stringsAsFactors = FALSE)
## details of row 2
subdat2 <- data.frame(
Chromosome = c("chr19","chr20"),
SNP = c("rs3","rs4"),
stringsAsFactors = FALSE
)
## merge the row details
subdats <- lapply(list(subdat1, subdat2), purrr::transpose)
## dataframe for the datatable
Dat <- cbind(" " = "⊕", dat, "_details" = I(subdats))
## the callback
callback = JS(
"table.column(1).nodes().to$().css(cursor: 'pointer');",
"",
"// make the table header of the nested table",
"var format = function(d, childId)",
" if(d != null)",
" var html = ",
" '<table class=\"display compact hover\" id=\"' + childId + '\"><thead><tr>';",
" for (var key in d[d.length-1][0]) ",
" html += '<th>' + key + '</th>';",
" ",
" html += '</tr></thead></table>'",
" return html;",
" else ",
" return '';",
" ",
";",
"",
"// row callback to style the rows of the child tables",
"var rowCallback = function(row, dat, displayNum, index)",
" if($(row).hasClass('odd'))",
" $(row).css('background-color', 'papayawhip');",
" $(row).hover(function()",
" $(this).css('background-color', '#E6FF99');",
" , function() ",
" $(this).css('background-color', 'papayawhip');",
" );",
" else ",
" $(row).css('background-color', 'lemonchiffon');",
" $(row).hover(function()",
" $(this).css('background-color', '#DDFF75');",
" , function() ",
" $(this).css('background-color', 'lemonchiffon');",
" );",
" ",
";",
"",
"// header callback to style the header of the child tables",
"var headerCallback = function(thead, data, start, end, display)",
" $('th', thead).css(",
" 'border-top': '3px solid indigo',",
" 'color': 'indigo',",
" 'background-color': '#fadadd'",
" );",
";",
"",
"// make the datatable",
"var format_datatable = function(d, childId)",
" var dataset = [];",
" var n = d.length - 1;",
" for(var i = 0; i < d[n].length; i++)",
" var datarow = $.map(d[n][i], function (value, index) ",
" return [value];",
" );",
" dataset.push(datarow);",
" ",
" var id = 'table#' + childId;",
" if (Object.keys(d[n][0]).indexOf('_details') === -1) ",
" var subtable = $(id).DataTable(",
" 'data': dataset,",
" 'autoWidth': true,",
" 'deferRender': true,",
" 'info': false,",
" 'lengthChange': false,",
" 'ordering': d[n].length > 1,",
" 'order': [],",
" 'paging': false,",
" 'scrollX': false,",
" 'scrollY': false,",
" 'searching': false,",
" 'sortClasses': false,",
" 'rowCallback': rowCallback,",
" 'headerCallback': headerCallback,",
" 'columnDefs': [targets: '_all', className: 'dt-center']",
" );",
" else ",
" var subtable = $(id).DataTable(",
" 'data': dataset,",
" 'autoWidth': true,",
" 'deferRender': true,",
" 'info': false,",
" 'lengthChange': false,",
" 'ordering': d[n].length > 1,",
" 'order': [],",
" 'paging': false,",
" 'scrollX': false,",
" 'scrollY': false,",
" 'searching': false,",
" 'sortClasses': false,",
" 'rowCallback': rowCallback,",
" 'headerCallback': headerCallback,",
" 'columnDefs': [",
" targets: -1, visible: false,",
" targets: 0, orderable: false, className: 'details-control',",
" targets: '_all', className: 'dt-center'",
" ]",
" ).column(0).nodes().to$().css(cursor: 'pointer');",
" ",
";",
"",
"// display the child table on click",
"table.on('click', 'td.details-control', function()",
" var tbl = $(this).closest('table'),",
" tblId = tbl.attr('id'),",
" td = $(this),",
" row = $(tbl).DataTable().row(td.closest('tr')),",
" rowIdx = row.index();",
" if(row.child.isShown())",
" row.child.hide();",
" td.html('⊕');",
" else ",
" var childId = tblId + '-child-' + rowIdx;",
" row.child(format(row.data(), childId)).show();",
" td.html('⊖');",
" format_datatable(row.data(), childId);",
" ",
");")
## datatable
datatable(Dat, callback = callback, escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = ncol(Dat)),
list(orderable = FALSE, className = 'details-control', targets = 1),
list(className = "dt-center", targets = "_all")
)
))
这是分层数据的示例：
library(data.table)
mtcars_dt = data.table(mtcars)
setkey(mtcars_dt, mpg, cyl)
mpg_dt = unique(mtcars_dt[, list(mpg, cyl)])
setkey(mpg_dt, mpg, cyl)
cyl_dt = unique(mtcars_dt[, list(cyl)])
setkey(cyl_dt, cyl)
mtcars_dt =
mtcars_dt[, list("_details" = list(purrr::transpose(.SD))), by = list(mpg,cyl)]
mtcars_dt[, ' ' := '⊕']
mpg_dt = merge(mpg_dt, mtcars_dt, all.x = TRUE )
setkey(mpg_dt, cyl)
setcolorder(mpg_dt, c(length(mpg_dt), c(1:(length(mpg_dt) - 1))))
mpg_dt = mpg_dt[,list("_details" = list(purrr::transpose(.SD))), by = cyl]
mpg_dt[, ' ' := '⊕']
cyl_dt = merge(cyl_dt, mpg_dt, all.x = TRUE )
setcolorder(cyl_dt, c(length(cyl_dt),c(1:(length(cyl_dt) - 1))))
datatable(cyl_dt, callback = callback, escape = -2,
options = list(
columnDefs = list(
list(visible = FALSE, targets = ncol(cyl_dt)),
list(orderable = FALSE, className = 'details-control', targets = 1),
list(className = "dt-center", targets = "_all")
)
))
【讨论】：
非常感谢 stephane 对所有不同组件的详细概述。请允许我有时间通过您的示例并在我的最后进行一些试验和错误，并让您知道它是如何进行的:)。再次感谢您抽出宝贵的时间:) @Stéphane Laurent 您的 JS 块是否适用于任意数据框？我正在尝试利用您的块，因为我不知道如何编写 JS，而且我似乎无法填充子数据表。获得与原始海报相同的结果。 @TimothyMcwilliams 编辑中的代码应该可以工作，是的。 @StéphaneLaurent 如果我只需要一层嵌套，他会是什么样子？似乎无法让它工作。 @TimothyMcwilliams 很难在评论中回复。你能打开一个新问题吗？以上是关于R闪亮包中的父/子行的主要内容，如果未能解决你的问题，请参考以下文章
如何使用 StringAgg 或 ArrayAgg 连接多个子行中的一列来注释 django 查询集？
SQLAlchemy：用新的子行更新版本化的父行会孤立旧的子行