The problem: Including an emoticon to a parent/child table mutes the child table. How to overcome this difficulty?
The added issue is that the inclusion of virtually any special character leads to the same result. I suspect that the answer is in the call back but it beats my JS skills.
The code:
library(shiny)
library(DT)
library(tidyverse)
### == script knicked from https://github.com/rstudio/shiny-examples/issues/9
shinyApp(
ui = fluidPage(DT::DTOutput("tbl")),
server = function(input, output, session) {
df <- tibble(names=c("Joan", "Michael", "Vincent"), hex =c("🦁","🦁","🦁"), DOB=c("2020-04-05", "2020-04-05","2020-04-05"))
df <- df %>%
as.data.frame() %>%
nest(-names, -hex)
# add control column
data <- df %>% {bind_cols(data_frame(' ' = rep('►',nrow(.)))
,.)}
# get dynamic info and strings
nested_columns <- which(sapply(data,class)=="list") %>% setNames(NULL)
not_nested_columns <- which(!(seq_along(data) %in% c(1,nested_columns)))
not_nested_columns_str <- not_nested_columns %>% paste(collapse="] + '_' + d[") %>% paste0("d[",.,"]")
# The callback
# turn rows into child rows and remove from parent
callback <- paste0("
table.column(1).nodes().to$().css({cursor: 'pointer'});
// Format data object (the nested table) into another table
var format = function(d) {
if(d != null){
var result = ('<table id=\"child_' + ",not_nested_columns_str," + '\">').replace('.','_') + '<thead><tr>'
for (var col in d[",nested_columns,"]){
result += '<th>' + col + '</th>'
}
result += '</tr></thead></table>'
return result
}else{
return '';
}
}
var format_datatable = function(d) {
var dataset = [];
for (i = 0; i < + d[",nested_columns,"]['DOB'].length; i++) {
var datarow = [];
for (var col in d[",nested_columns,"]){
datarow.push(d[",nested_columns,"][col][i])
}
dataset.push(datarow)
}
var subtable = $(('table#child_' + ",not_nested_columns_str,").replace('.','_')).DataTable({
'data': dataset,
'autoWidth': false,
'deferRender': true,
'info': false,
'lengthChange': false,
'ordering': true,
'paging': false,
'scrollX': false,
'scrollY': false,
'searching': false
});
};
table.on('click', 'td.details-control', function() {
var td = $(this), row = table.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())
}
});
"
)
DDT <- datatable(
data,
escape = -c(2,4), # raw HTML in column 2
options = list( paging=FALSE,info = FALSE,
columnDefs = list(
list(visible = FALSE, targets = c(0,nested_columns) ), # Hide row numbers and nested columns
list(orderable = FALSE, className = 'details-control', targets = 1) # turn first column into control column
)
),
callback = JS(callback)
)
output$tbl <- DT::renderDT({
DDT
}, server = FALSE, width = 6)
session$onSessionEnded(function() {
observe(cat(paste0("Ended: ", values$sessionId)))
})
if(format(Sys.time(), "%M")=='00'){
onStop(function() {
dbDisconnect(con)
})
}
# you need set the server to FALSE
},
options = list(port = 33333)
)
Any thoughts?
In order to make a datatable with children, it's better to use the method I give on my blog. Currently there are some mistakes in the callback code, I need to update this post, so I provide the full code here for your case:
library(DT)
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 <- ifelse(lengths(subdats), "⊕", "")
cbind(" " = oplus, dat, "_details" = I(subdats),
stringsAsFactors = FALSE)
}
Dat <- NestedData(
data.frame(
names = c("Joan", "Michael", "Vincent"),
hex = c("🦁","🦁","🦁"),
stringsAsFactors = FALSE
),
children = list(
data.frame(DOB = "2020-04-05", stringsAsFactors = FALSE),
data.frame(DOB = "2020-04-05", stringsAsFactors = FALSE),
data.frame(DOB = "2020-04-05", stringsAsFactors = FALSE)
)
)
## whether to show row names
rowNames = FALSE
colIdx <- as.integer(rowNames)
## the callback
parentRows <- which(Dat[,1] != "")
callback <- JS(
sprintf("var parentRows = [%s];", toString(parentRows-1)),
sprintf("var j0 = %d;", colIdx),
"var nrows = table.rows().count();",
"for(let i = 0; i < nrows; ++i){",
" var $cell = table.cell(i,j0).nodes().to$();",
" if(parentRows.indexOf(i) > -1){",
" $cell.css({cursor: 'pointer'});",
" }else{",
" $cell.removeClass('details-control');",
" }",
"}",
"",
"// --- make the table header of the nested table --- //",
"var formatHeader = function(d, childId){",
" if(d !== null){",
" var html = ",
" '<table class=\"display compact hover\" ' + ",
" 'style=\"padding-left: 30px;\" id=\"' + childId + ",
" '\"><thead><tr>';",
" var data = d[d.length-1] || d._details;",
" for(let key in data[0]){",
" html += '<th>' + key + '</th>';",
" }",
" html += '</tr></thead></table>'",
" return html;",
" } else {",
" return '';",
" }",
"};",
"",
"// --- row callback to style rows of 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 header of 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 formatDatatable = function(d, childId){",
" var data = d[d.length-1] || d._details;",
" var colNames = Object.keys(data[0]);",
" var columns = colNames.map(function(x){",
" return {data: x.replace(/\\./g, '\\\\\\.'), title: x};",
" });",
" var id = 'table#' + childId;",
" var options = {",
" 'dom': 't',",
" 'data': data,",
" 'columns': columns,",
" 'autoWidth': true,",
" 'deferRender': true,",
" 'info': false,",
" 'lengthChange': false,",
" 'ordering': data.length > 1,",
" 'order': [],",
" 'paging': false,",
" 'scrollX': false,",
" 'scrollY': false,",
" 'searching': true,",
" 'sortClasses': false,",
" 'rowCallback': rowCallback,",
" 'headerCallback': headerCallback",
" };",
" var hasChild = colNames.indexOf('_details') > -1",
" if(!hasChild){",
" var columnDefs = ",
" {'columnDefs': [{targets: '_all', className: 'dt-center'}]};",
" var subtable = $(id).DataTable(",
" $.extend(options, columnDefs)",
" );",
" } else {",
" var columnDefs = {",
" 'columnDefs': [",
" {targets: -1, visible: false},",
" {targets: 0, orderable: false, className: 'details-control'},",
" {targets: '_all', className: 'dt-center'}",
" ]};",
" var subtable = $(id).DataTable(",
" $.extend(options, columnDefs)",
" ).column(0).nodes().to$().css({cursor: 'pointer'});",
" }",
"};",
"",
"// --- display the child table on click --- //",
"// array to store id's of already created child tables",
"var children = [];",
"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;",
" if(children.indexOf(childId) === -1){",
" // this child has not been created yet",
" children.push(childId);",
" row.child(formatHeader(row.data(), childId)).show();",
" td.html('⊖');",
" formatDatatable(row.data(), childId, rowIdx);",
" }else{",
" // this child has already been created",
" row.child(true);",
" td.html('⊖');",
" }",
" }",
"});")
datatable(
Dat,
callback = callback, rownames = rowNames, escape = -c(colIdx+1, 3),
options = list(
paging = FALSE,
searching = FALSE,
columnDefs = list(
list(
visible = FALSE,
targets = ncol(Dat)-1+colIdx
),
list(
orderable = FALSE,
className = "details-control",
targets = colIdx
),
list(
className = "dt-center",
targets = "_all"
)
)
)
)