Is there a way to hide group entries and show aggregate row by default in R / DT

Question

I am a real fan of DT - the datatables wrapper for R. Currently, I am facing the following challenge:

We have data with two keys, e.g. continent and country and then some measurements and I would like to show initially only the aggregated data for the continent (aggregation maybe similar to here https://datatables.net/extensions/rowgroup/examples/initialisation/customRow.html) and if one clicks on the continent the hidden row for each country become visible (similar to this https://rstudio.github.io/DT/002-rowdetails.html)

For these dummy data

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

I would like to show

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

by default and if one clicks on Europe or Africa the corresponding entries should show up.

Currently I achieve this: current status

The dummy app has the following code (taken from Collapse rowGroup Shiny)

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)

But so far it does not include the aggregation.

I searched extensively, but my knowledge on how to include javascript is very limited.

I am triggered by the fact that I received an excel sheet where this is possible... and grateful for any suggestion.

Answer 1

Thanks to Stéphane Laurent and his answer at this post Parent/Child Rows in R I was able to finally answer the question. See the code below for a self contained solution of the toy problem.

For the real problem where we needed also complex headers - for this the following post was very useful How to create datatable with complex header in 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)