4

my background in Javascript is non - existent and therefore resorted to using some code posted by davlee1972 on GitHub. This code has been trained on the mtcars file, and was then changed to my own data.

The issue here is that whilst the code works for the first two child/parent relationships, it seems to only publish the column headings for the last child.

The code : 

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)

the resulting webpage looks like the below and as displayed, only shows the AccounReffullname and Fullamount headings instead of the multiple rows that should be there below each financial category.

enter image description here

moreover, in the case of the COGS component, it only seems to show the AccountReffullname Column and is missing the Fullamount column.

My question is, where in the javascript does it control the number of layers child/parent relationships and does anyone have any idea as to why this works on the mtcars file however fails on the same format for my own data.

The code i used was posted on the following links :

https://github.com/rstudio/DT/issues/525 https://github.com/rstudio/shiny-examples/issues/9#issuecomment-362000334

Any help would be much appreciated!

thanks piyuw

Victor Stoddard
  • 3,582
  • 2
  • 27
  • 27
piyuw
  • 61
  • 1
  • 6
  • That's because of the white spaces. Are you still looking for a solution ? – Stéphane Laurent Jun 13 '19 at 12:57
  • Hi Stephane, yes Im still looking for a solution, didn't understand what you exactly mean by white spaces. In the mean time, let me try to get you some code so you can reproduce my dilemma. Thanks – piyuw Jun 14 '19 at 13:44
  • See my answer. If you don't manage to use it with your data, please edit your post to include your data (and the way you use to build it). – Stéphane Laurent Jun 14 '19 at 14:09

1 Answers1

9

The problem with this code is that it uses the contents of the rows to build the identifiers of the child tables, and it is forbidden to use dots and white spaces in an identifier. As you can see, the child tables do not appear for rows containing a white space.

The code replaces the dots by doing replace('.','_'). This is not enough in general, because this replaces only the first occurence of a dot (with an underscore). In the code below, I replace dots and white spaces with underscores by doing replace(/[\\s|\\.]/g, '_'). The g means "global": this replaces all occurences.

To use my code, the child tables must be included in a column named "details" and this must be the last column. This code allows multiple levels of nesting: you can also define a child table for a row of a child table. In this example, the first row has a two-levels nesting.

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

enter image description here

Edit

Here is a better solution. This one does not use the rows contents to build the identifier. The code is simpler and this allows to have identical rows. I have changed details to _details, in case the user has a column named details in his dataset.

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

Here is an example of hierarchical data:

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[, ' ' := '&oplus;']

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[, ' ' := '&oplus;']

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

enter image description here

Stéphane Laurent
  • 75,186
  • 15
  • 119
  • 225
  • Thank you so much stephane for the detailed outlining of all the different components. please allow me sometime to go through your example and do some trial and error on my end and let you know how it goes :). Once again, thanks so much for taking the time out of your day :) – piyuw Jun 16 '19 at 15:40
  • @Stéphane Laurent does your JS block work for an arbitrary data frame? I am trying to utilize your block since I have no clue how to write JS and I can't seem to populate the child data table. Getting the same results as the original poster. – Timothy Mcwilliams Mar 12 '20 at 19:32
  • @TimothyMcwilliams The code in the Edit should work, yes. – Stéphane Laurent Mar 12 '20 at 20:15
  • @StéphaneLaurent How would his look if I only need one level nesting? Can't seem to get this to work. – Timothy Mcwilliams Mar 12 '20 at 20:58
  • @TimothyMcwilliams It's hard to reply in a comment. Could you open a new question? – Stéphane Laurent Mar 12 '20 at 21:04
  • @StéphaneLaurent Sure can. Will do that now. – Timothy Mcwilliams Mar 12 '20 at 21:08
  • @StéphaneLaurent, see this when you have the time. https://stackoverflow.com/questions/60662749/parent-child-rows-in-r – Timothy Mcwilliams Mar 12 '20 at 22:44