I would like to set check-box values to the corresponding values in column 'YN' when a child rows loads and after the user clicks/unclicks a checkbox I would like 'YN' column to update. I don't need check-boxes on parent rows. I've tried to modify an example I've found, but it's not working on child rows. Please suggest how to implement this correctly. Here is an example of code that works but doesn't update the 'YN' column. Thank you very much. Here is the code:
library(DT)
dat <- data.frame(
Sr = c(1.5, 2.3),
Description = c("A - B", "X - Y")
)
## details of row 1
subdat1 <- data.frame(
Chromosome = c("chr18","chr4"),
SNP = c("rs2","rs3"),
YN = c(TRUE, FALSE),
stringsAsFactors = FALSE
)
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
}
subdat1$check <- shinyCheckbox("check", subdat1$YN)
## details of row 2
subdat2 <- data.frame(
Chromosome = c("chr19","chr20"),
SNP = c("rs3","rs4"),
YN = c(TRUE, FALSE),
stringsAsFactors = FALSE
)
subdat2$check <- shinyCheckbox("check", subdat2$YN)
## merge the row details
subdats <- lapply(list(subdat1, subdat2), purrr::transpose)
## dataframe for the datatable
Dat <- cbind(" " = "⊕", dat, details = I(subdats))
###spliting subdata into dataframes###
subdat <- data.frame(
Gene_SUB=c("MUTYH","AR"),
Location_SUB=c("chr1:45797228","chr2:45797228"),
Exon_SUB=c(NA,23),
HGVS_p_SUB=c("NP_001121897.1:p.(Gly396Asp)","NP_001121897.1:p.(Gly396Asp)"),
stopA=c(45797278,114925456),
YN = c(FALSE, FALSE),
stringsAsFactors = FALSE
)
maindat <- data.frame(
Gene=c("MUTYH","AR"),
Location=c("chr1:45797228","chr2:45797228"),
Exon=c(NA,23),
HGVS_p=c("NP_001121897.1:p.(Gly396Asp)","NP_001121897.1:p.(Gly396Asp)"),
stopA=c(45797278,114925456),
stringsAsFactors = FALSE
)
subdat$check <- shinyCheckbox("check", subdat$YN)
fs<-split(subdat, factor(subdat$stopA, levels = unique(subdat$stopA)))
subdats <- lapply(fs, purrr::transpose)
oplus <- sapply(subdats, function(x) if(length(x)) "⊕" else "")
Dat <- cbind(" " = oplus, maindat, details = I(subdats))
## the callback
callback = JS(
"$('[id^=check]').on('click', function(){",
" var id = this.getAttribute('id');",
" var i = parseInt(/check(\\d+)/.exec(id)[1]);",
" var value = $(this).prop('checked');",
" var cell = table.cell(i-1, 2).data(value).draw();",
"})",
"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);",
" 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'}]",
" });",
"};",
"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());",
" }",
"});")
## datatable
datatable(Dat, callback = callback, escape = FALSE,
options = list(
columnDefs = list(
list(visible = FALSE, targets = ncol(Dat)),
list(orderable = FALSE, className = 'details-control', targets = 1),
list(className = "dt-center", targets = "_all")
)
#preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
#drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
),
)
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 1
subdat1 <- 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 2
subdat2 <- 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 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 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 1
subdat1 <- 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 2
subdat2 <- 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 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 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)