I would like to filter parent rows in nested datatable by radio buttons. If I set paging to true, the last parent record on a page doesn’t show children. In provided data, one parent doesn’t have a child and that also creates issues with NestedData function. The following code can’t handle reactive data which is need for the buttons on parent rows and also for filtering via radio buttons. Thanks for your help.
library(dplyr)
library(DT)
library(stringr)
library(shiny)
#functions
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)
}
shinyCheckbox <- function(id, values) {
inputs <- character(length(values))
for(i in seq_along(inputs)) {
inputs[i] <-
as.character(
checkboxInput(paste0(i, id), label = NULL, value = values[i], width = "10px")
)
}
inputs
}
#buttons on parent rows
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
#data
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","TET1"),
Location=c("chr1:45797228","chr2:45797228","chr10:70405855"),
Exon=c(NA,23,4),
HGVS_p=c("NP_001121897.1:p.(Gly396Asp)","NP_001121897.1:p.(Gly396Asp)","NM_030625.2:p.Ile1123Met"),
stopA=c(45797278,114925456,70405905),
Classification=c('GroupA','GroupB','GroupC'),
stringsAsFactors = FALSE
)
maindat$Action = shinyInput(actionButton, nrow(maindat), 'button_', label = "GL", onclick = 'Shiny.onInputChange("select_button", this.id)' )
DFList<-split(subdat, factor(subdat$stopA, levels = unique(subdat$stopA)))
#want to be able to hide stopA and YN from child rows as the table loads
newlist<-lapply(DFList, transform, check = shinyCheckbox("check", YN))
#one parent doesn't have a child and it causing problems
Dat <- NestedData(maindat, newlist)
## 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', '#FFFFFF');",
" $(row).hover(function(){",
" $(this).css('background-color', '#d8ecf3');",
" }, function(){",
" $(this).css('background-color', '#FFFFFF');",
" });",
" } else {",
" $(row).css('background-color', '#F1F1F1');",
" $(row).hover(function(){",
" $(this).css('background-color', '#d8ecf3');",
" }, function(){",
" $(this).css('background-color', '#F1F1F1');",
" });",
" }",
"};",
"",
"// --- header callback to style header of child tables --- //",
"var headerCallback = function(thead, data, start, end, display){",
" $('th', thead).css({",
" 'border-top': '3px solid black',",
" 'color': 'black',",
" 'background-color': '#E5FFED'",
" });",
"};",
"",
"// --- 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, 5).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"),
mainPanel(
radioButtons("tb_filters",
label = h4("Options:"),
choices = list(
"GroupA" = "groupa",
"GroupB" = "groupb",
"GroupC" = "groupc"
),
inline=TRUE),
br(),
actionButton("print", "Update db"),
br(),
DTOutput("dtable")
)
)
#setting paging to true breaks the last record on a page
server <- function(input, output, session) {
dataset <- shiny::reactive({
#user can filter parent rows by Classification
if ("groupa" %in% input$tb_filters) Dat <- Dat[with(Dat, grepl("GroupA", paste(Classification))),]
if ("groupb" %in% input$tb_filters) Dat <- Dat[with(Dat, grepl("GroupB", paste(Classification))),]
if ("groupc" %in% input$tb_filters) Dat <- Dat[with(Dat, grepl("GroupC", paste(Classification))),]
Dat
})
output[["dtable"]] <- renderDT({
datatable(
isolate(dataset()),
callback = callback, rownames = rowNames, escape = FALSE,
#-colIdx-1,
selection = "none",
options = list(
paging = TRUE,
searching = TRUE,
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"]]
i=as.numeric(child)+1
DFList[[i]][row, "YN"] <<- value
print(DFList[[i]])
})
shiny::observeEvent(input$select_button, {
selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
test <- main_data[selectedRow,2]
print(test)
})
observeEvent(input[["print"]], {
#update db
})
}
shinyApp(ui, server)