library(DT)library(shiny)shinyCheckbox <- function(id, values) { inputs <- character(length(values)) for(i in seq_along(inputs)) { inputs[i] <- as.character( checkboxInput(paste0(id, i), label = NULL, value = values[i], width = "20px") ) } inputs}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 <- data.frame( Sr = c(1.5, 2.3), Description = c("A - B", "X - Y"))## details of row 1subdat1 <- data.frame( Chromosome = c("chr18","chr4"), SNP = c("rs2","rs3"), YN = c(TRUE, FALSE), stringsAsFactors = FALSE)subdat1$check <- shinyCheckbox("check", subdat1$YN)## details of row 2subdat2 <- data.frame( Chromosome = c("chr19","chr20"), SNP = c("rs3","rs4"), YN = c(TRUE, FALSE), stringsAsFactors = FALSE)subdat2$check <- shinyCheckbox("check", subdat2$YN)Dat <- NestedData(dat, list(subdat1, subdat2))## whether to show row namesrowNames = FALSEcolIdx <- as.integer(rowNames)## the callbackparentRows <- 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 subtable;"," if(colNames.indexOf('_details') === -1){"," subtable = $(id).DataTable({"," 'data': data,"," 'columns': columns,"," 'autoWidth': true,"," 'deferRender': true,"," 'info': false,"," 'lengthChange': false,"," 'ordering': data.length > 1,"," 'order': [],"," 'paging': false,"," 'scrollX': false,"," 'scrollY': false,"," 'searching': false,"," 'sortClasses': false,"," 'rowCallback': rowCallback,"," 'headerCallback': headerCallback,"," 'columnDefs': [{targets: '_all', className: 'dt-center'}]"," });"," } else {"," subtable = $(id).DataTable({"," 'data': data,"," 'columns': columns,"," 'autoWidth': true,"," 'deferRender': true,"," 'info': false,"," 'lengthChange': false,"," 'ordering': data.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'});"," }", # THIS IS THE CODE I ADDED TO DEAL WITH THE CHECKBOXES:" $(id).on('click', '[id^=check]', function(){"," var id = this.getAttribute('id');"," var i = parseInt(/check(\\d+)/.exec(id)[1]);"," var value = $(this).prop('checked');"," subtable.cell(i-1, 2).data(value).draw();"," });","};","","// --- 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 = -colIdx-1, 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" ) ) ))
If you have a Shiny app and you want to update subdat1/2
when the checkboxes are clicked, you can do as follows (I changed the callback):
library(DT)library(shiny)shinyCheckbox <- function(id, values) { inputs <- character(length(values)) for(i in seq_along(inputs)) { inputs[i] <- as.character( checkboxInput(paste0(id, i), label = NULL, value = values[i], width = "20px") ) } inputs}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 <- data.frame( Sr = c(1.5, 2.3), Description = c("A - B", "X - Y"))## details of row 1subdat1 <- data.frame( Chromosome = c("chr18","chr4"), SNP = c("rs2","rs3"), YN = c(TRUE, FALSE), stringsAsFactors = FALSE)subdat1$check <- shinyCheckbox("check", subdat1$YN)## details of row 2subdat2 <- data.frame( Chromosome = c("chr19","chr20"), SNP = c("rs3","rs4"), YN = c(TRUE, FALSE), stringsAsFactors = FALSE)subdat2$check <- shinyCheckbox("check", subdat2$YN)Dat <- NestedData(dat, list(subdat1, subdat2))## whether to show row namesrowNames = FALSEcolIdx <- as.integer(rowNames)## the callbackparentRows <- 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 subtable;"," if(colNames.indexOf('_details') === -1){"," subtable = $(id).DataTable({"," 'data': data,"," 'columns': columns,"," 'autoWidth': true,"," 'deferRender': true,"," 'info': false,"," 'lengthChange': false,"," 'ordering': data.length > 1,"," 'order': [],"," 'paging': false,"," 'scrollX': false,"," 'scrollY': false,"," 'searching': false,"," 'sortClasses': false,"," 'rowCallback': rowCallback,"," 'headerCallback': headerCallback,"," 'columnDefs': [{targets: '_all', className: 'dt-center'}]"," });"," } else {"," subtable = $(id).DataTable({"," 'data': data,"," 'columns': columns,"," 'autoWidth': true,"," 'deferRender': true,"," 'info': false,"," 'lengthChange': false,"," 'ordering': data.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'});"," }", # THIS IS THE CODE I ADDED TO DEAL WITH THE CHECKBOXES:" $(id).on('click', '[id^=check]', function(){"," var id = this.getAttribute('id');"," var i = parseInt(/check(\\d+)/.exec(id)[1]);"," var value = $(this).prop('checked');"," subtable.cell(i-1, 2).data(value).draw();"," Shiny.setInputValue('update', {child: childId, row: i, value: value});"," });","};","","// --- 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('⊖');"," }"," }","});")ui <- fluidPage( br(), actionButton("print", "Print child rows"), br(), DTOutput("dtable"))server <- function(input, output, session) { output[["dtable"]] <- renderDT({ datatable( Dat, callback = callback, rownames = rowNames, escape = -colIdx-1, selection = "none", 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" ) ) ) ) }) observeEvent(input[["update"]], { child <- stringr::str_extract(input[["update"]][["child"]], "\\d+$") row <- as.integer(input[["update"]][["row"]]) value <- input[["update"]][["value"]] if(child == "0") { subdat1[row, "YN"] <<- value } else if(child == "1") { subdat2[row, "YN"] <<- value } }) observeEvent(input[["print"]], { print(subdat1$YN) print(subdat2$YN) })}shinyApp(ui, server)