R閃亮包裝中的父/子行
[英]Parent/Child Rows in R shiny Package
問題描述
我的Java語言背景不存在，因此只能使用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
任何幫助將非常感激！
謝謝piyuw
1 個解決方案
解決方案1
2 2019-06-14 14:06:38
此代碼的問題在於，它使用行的內容來構建子表的標識符，並且禁止在標識符中使用點和空格。 如您所見，子表不會出現在包含空格的行中。
該代碼通過執行replace('.','_')來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")
)
))
Shiny R 中的父/子行與具有可變行數的單個 dataframe
[英]Parent/Child Rows in Shiny R with a single dataframe that has a variable number of rows
聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.