R闪亮包中的父/子行

Question

我在 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[, ' ' := '&#9658;']
# 
# 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[, ' ' := '&#9658;']
# 
# 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('&#9658;')
                } else {
                row.child(format(row.data())).show()
                format_datatable(row.data())
                td.html('&#9660;')
                }
                })




                ")
  )
},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

任何帮助将不胜感激！

谢谢 呸呸呸

Answer 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(" " = "&oplus;", 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(" " = "&oplus;", 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('&oplus;');",
  "  } else {",
  "    row.child(format(row.data())).show();",
  "    td.html('&CircleMinus;');",
  "    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(" " = "&oplus;", 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(" " = "&oplus;", 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('&oplus;');",
  "  } else {",
  "    var childId = tblId + '-child-' + rowIdx;",
  "    row.child(format(row.data(), childId)).show();",
  "    td.html('&CircleMinus;');",
  "    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")
            )
          ))