有没有办法在R / DT中默认隐藏组条目并显示聚合行

Question

我是DT的真正粉丝 - R的数据表包装器。 目前，我面临着以下挑战：

我们有带有两个键的数据，例如大陆和国家，然后是一些测量值，我最初只想显示大陆的汇总数据(聚合可能类似于这里 https://datatables.net/extensions/rowgroup/examples/initialisation/customRow.html(，如果单击大陆，每个国家的隐藏行变得可见(类似于这个 https://rstudio.github.io/DT/002-rowdetails.html(

对于这些虚拟数据

dat <- rbind(
data.frame(Continent = rep("Europe", 3),
Country = c("England", "France", "Italy"),
x = 1 : 3,
y = 7 : 5),
data.frame(Continent = rep("Africa", 3),
Country = c("Niger", "Benin", "Uganda"),
x = 5 : 7,
y = 2 : 4))

我想展示

Continent TotalX MeanY
1:    Europe      6     6
2:    Africa     18     3

默认情况下，如果单击欧洲或非洲，则应显示相应的条目。

目前我实现了这个： 现状

虚拟应用程序具有以下代码(取自折叠行组闪亮(

library(shiny)
library(DT)
ui <- fluidPage(# Application title
titlePanel("Collapse/Expand table"),
mainPanel(DTOutput("my_table")))
callback_js <- JS(
"table.on('click', 'tr.group', function () {",
"  var rowsCollapse = $(this).nextUntil('.group');",
"  $(rowsCollapse).toggleClass('hidden');",
"});"
)
dat <- rbind(
data.frame(Continent = rep("Europe", 3),
Country = c("England", "France", "Italy"),
x = 1 : 3,
y = 7 : 5),
data.frame(Continent = rep("Africa", 3),
Country = c("Niger", "Benin", "Uganda"),
x = 5 : 7,
y = 2 : 4))

server <- function(input, output) {
output$my_table <- DT::renderDT({
datatable(
dat,
extensions = 'RowGroup',
options = list(rowGroup = list(dataSrc = 1), pageLength = 20),
callback = callback_js,
selection = 'none'
)
})
}
# Run the application
shinyApp(ui = ui, server = server)

但到目前为止，它不包括聚合。

我进行了广泛的搜索，但我对如何包含javascript的知识非常有限。

我被一个事实触发了，我收到了一张 excel 表，这是可能的......并感谢任何建议。

Answer 1

感谢Stéphane Laurent 以及他在这篇文章中的回答 R中的父/子行 我终于能够回答这个问题。请参阅下面的代码，了解玩具问题的独立解决方案。

对于我们还需要复杂标头的真正问题 - 为此，以下帖子非常有用 如何在 R Shiny 中创建具有复杂标头的数据表？

library(shiny)
library(data.table)
library(DT)
library(purrr)

# ---
# Data Preparation
# ---
dat <- rbind(
data.table(Continent = rep("Europe", 3),
Country = c("England", "France", "Italy"),
x = 1 : 3,
y = 7 : 5),
data.table(Continent = rep("Africa", 3),
Country = c("Niger", "Benin", "Uganda"),
x = 5 : 7,
y = 2 : 4))
# Outer data table - country values aggregated by continent
parents  <- dat[, .(TotalX = sum(x), MeanY = mean(y)), by = Continent]
# List of inner data tables - list should have length of parents rows
children <- split(dat, by = "Continent") %>% 
purrr::map(function(x) {x[, .(Country, x, y)]})
# ---
# Helping functions
# from https://stackoverflow.com/questions/60662749/parent-child-rows-in-r
# ---
NestedData <- function(dat, children){
stopifnot(length(children) == nrow(dat))
g <- function(d){
if(is.data.frame(d)){
purrr::transpose(d)
}else{
purrr::transpose(NestedData(d[[1]], children = d$children))
}
}
subdats <- lapply(children, g)
oplus <- sapply(subdats, function(x) if(length(x)) "&oplus;" else "")
cbind(" " = oplus, dat, "_details" = I(subdats), stringsAsFactors = FALSE)
}
rowNames <- FALSE
colIdx <- as.integer(rowNames)

Dat <- NestedData(
dat = parents, 
children = children
)
parentRows <- which(Dat[, 1] != "")
# make the callback - is dependent on input data (should vanish in future)
callback = JS(
sprintf("var parentRows = [%s];", toString(parentRows-1)),
sprintf("var j0 = %d;", colIdx),
"var nrows = table.rows().count();",
"for(var i=0; i < nrows; ++i){",
"  if(parentRows.indexOf(i) > -1){",
"    table.cell(i,j0).nodes().to$().css({cursor: 'pointer'});",
"  }else{",
"    table.cell(i,j0).nodes().to$().removeClass('details-control');",
"  }",
"}",
"",
"// make the table header of the nested table",
"var format = function(d, childId){",
"  if(d != null){",
"    var html = ",
"      '<table class="display compact hover" ' + ",
"      'style="padding-left: 30px;" 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')){",
"  } else {",
"  }",
"};",
"",
"// 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',",
"  });",
"};",
"",
"// 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('&oplus;');",
"  } else {",
"    var childId = tblId + '-child-' + rowIdx;",
"    row.child(format(row.data(), childId)).show();",
"    td.html('&CircleMinus;');",
"    format_datatable(row.data(), childId);",
"  }",
"});")

# ---
# App definition
# ---
ui <- fluidPage(# Application title
titlePanel("Collapse/Expand table"),
mainPanel(DTOutput("my_table")))
server <- function(input, output) {
output$my_table <- DT::renderDT({
datatable(
Dat, callback = callback, rownames = rowNames,
escape = - colIdx - 1,
options = list(
dom = "t",
columnDefs = list(
list(visible = FALSE, targets = ncol(Dat)-1+colIdx),
list(orderable = FALSE, className = 'details-control',
targets = colIdx),
list(className = "dt-center", targets = "_all")
)
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)