I'm trying to make an interactive table summarizing the top result of an outcome tested in multiple studies, and I would also like the user to access more detailed results via child rows. Only the "top" model with the smallest p-value is shown in the main table.
Right now I have the relevant results into two data frames: 1. top result only, and 2. detailed results. I am merging these and nesting based on the top results which I want to display.
library(DT)
library(tidyr)
library(dplyr)
library(tibble)
# == Create dataframe with results to summarize
allresults <- list(c("HeartAttack", 1e-6, 0.05, 0.005, "study1", "heartAttack_v1", "ageSex", 1e-6),
c("HeartAttack", 1e-6, 0.05, 0.005, "study1", "heartAttack_v2", "ageSexBmi", 0.001),
c("HeartAttack", 1e-6, 0.05, 0.005, "study2", "heartAttack_v1", "ageSex", 0.05),
c("HeartAttack", 1e-6, 0.05, 0.005, "study2", "heartAttack_v2", "ageSexBmi", "0.2"),
c("HeartAttack", 1e-6, 0.05, 0.005, "study3", "heartAttack_v1", "ageSex", "0.005"),
c( "Cancer", 0.05, 0.01, 0.002, "study1", "cancer_v1", "ageSex", 0.6),
c( "Cancer", 0.05, 0.01, 0.002, "study1", "cancer_v2", "ageSex", 0.05),
c("Cancer", 0.05, 0.01, 0.002, "study2", "cancer_v1", "ageSexBmi", 0.2),
c("Cancer", 0.05, 0.01, 0.002, "study2", "cancer_v2", "ageSex", 0.01),
c("Cancer", 0.05, 0.01, 0.002, "study3", "cancer_v1", "ageSexBmi", 0.002))
df <- as.data.frame(t(as.data.frame(allresults)))
colnames(df) <- c("outcome.bestOf", "study1.bestOf", "study2.bestOf", "study3.bestOf", "studyName", "outcome", "model", "pvalue")
rownames(df)<-NULL
# == Collapse to display top-result table, one row per outcome
nest_fields <- c("outcome.bestOf", "study1.bestOf", "study2.bestOf", "study3.bestOf")
dt <- df %>%
nest(-nest_fields)
# == Add (+) column
data <- dt %>% {bind_cols(data_frame(' ' = rep('⊕',nrow(.))),.)}
# == Get dynamic info and strings
# == code via: https://github.com/rstudio/shiny-examples/issues/9
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,"]['cohort'].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': true,
'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())
}
});"
)
# == the Display DT
datatable(
data,
escape = FALSE,
options = list(
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)
)
This code creates the summary table that I want as a tibble, but no child row data appears when I expand:
However, if I access the child rows programmatically, they seem to contain the data I want:
> data[data$outcome.bestOf=="Cancer", 'data'][[1]]
[[1]]
# A tibble: 5 x 4
studyName outcome model pvalue
<fct> <fct> <fct> <fct>
1 study1 cancer_v1 ageSex 0.6
2 study1 cancer_v2 ageSex 0.05
3 study2 cancer_v1 ageSexBmi 0.2
4 study2 cancer_v2 ageSex 0.01
5 study3 cancer_v1 ageSexBmi 0.002
*** EDIT **** Below is the html from Chrome's inspect element option:
<html><head>
<meta charset="utf-8">
<script src="lib/htmlwidgets-1.3/htmlwidgets.js"></script>
<script src="lib/jquery-1.12.4/jquery.min.js"></script>
<link href="lib/datatables-css-0.0.0/datatables-crosstalk.css" rel="stylesheet">
<script src="lib/datatables-binding-0.5/datatables.js"></script>
<link href="lib/dt-core-1.10.16/css/jquery.dataTables.min.css" rel="stylesheet">
<link href="lib/dt-core-1.10.16/css/jquery.dataTables.extra.css" rel="stylesheet">
<script src="lib/dt-core-1.10.16/js/jquery.dataTables.min.js"></script>
<link href="lib/crosstalk-1.0.0/css/crosstalk.css" rel="stylesheet">
<script src="lib/crosstalk-1.0.0/js/crosstalk.min.js"></script>
</head>
<body style="background-color: white; margin: 0px; padding: 40px;">
<div id="htmlwidget_container">
<div id="htmlwidget-3a36880ad35572a39f25" style="width:960px;height:500px;" class="datatables html-widget html-widget-static-bound"><div id="DataTables_Table_0_wrapper" class="dataTables_wrapper no-footer"><div class="dataTables_length" id="DataTables_Table_0_length"><label>Show <select name="DataTables_Table_0_length" aria-controls="DataTables_Table_0" class=""><option value="10">10</option><option value="25">25</option><option value="50">50</option><option value="100">100</option></select> entries</label></div><div id="DataTables_Table_0_filter" class="dataTables_filter"><label>Search:<input type="search" class="" placeholder="" aria-controls="DataTables_Table_0"></label></div><table class="display dataTable no-footer" id="DataTables_Table_0" role="grid" aria-describedby="DataTables_Table_0_info">
<thead>
<tr role="row"><th class="details-control sorting_disabled" rowspan="1" colspan="1" aria-label=" "> </th><th class="sorting" tabindex="0" aria-controls="DataTables_Table_0" rowspan="1" colspan="1" aria-label="outcome.bestOf: activate to sort column ascending">outcome.bestOf</th><th class="sorting" tabindex="0" aria-controls="DataTables_Table_0" rowspan="1" colspan="1" aria-label="study1.bestOf: activate to sort column ascending">study1.bestOf</th><th class="sorting" tabindex="0" aria-controls="DataTables_Table_0" rowspan="1" colspan="1" aria-label="study2.bestOf: activate to sort column ascending">study2.bestOf</th><th class="sorting" tabindex="0" aria-controls="DataTables_Table_0" rowspan="1" colspan="1" aria-label="study3.bestOf: activate to sort column ascending">study3.bestOf</th></tr>
</thead>
<tbody><tr role="row" class="odd"><td class=" details-control" style="cursor: pointer;">⊕</td><td>HeartAttack</td><td>1e-06</td><td>0.05</td><td>0.005</td></tr><tr role="row" class="even"><td class=" details-control" style="cursor: pointer;">⊕</td><td>Cancer</td><td>0.05</td><td>0.01</td><td>0.002</td></tr></tbody></table><div class="dataTables_info" id="DataTables_Table_0_info" role="status" aria-live="polite">Showing 1 to 2 of 2 entries</div><div class="dataTables_paginate paging_simple_numbers" id="DataTables_Table_0_paginate"><a class="paginate_button previous disabled" aria-controls="DataTables_Table_0" data-dt-idx="0" tabindex="0" id="DataTables_Table_0_previous">Previous</a><span><a class="paginate_button current" aria-controls="DataTables_Table_0" data-dt-idx="1" tabindex="0">1</a></span><a class="paginate_button next disabled" aria-controls="DataTables_Table_0" data-dt-idx="2" tabindex="0" id="DataTables_Table_0_next">Next</a></div></div></div>
</div>
<script type="application/json" data-for="htmlwidget-3a36880ad35572a39f25">{"x":{"filter":"none","data":[["1","2"],["⊕","⊕"],["HeartAttack","Cancer"],["1e-06","0.05"],["0.05","0.01"],["0.005","0.002"],[{"studyName":["study1","study1","study2","study2","study3"],"outcome":["heartAttack_v1","heartAttack_v2","heartAttack_v1","heartAttack_v2","heartAttack_v1"],"model":["ageSex","ageSexBmi","ageSex","ageSexBmi","ageSex"],"pvalue":["1e-06","0.001","0.05","0.2","0.005"]},{"studyName":["study1","study1","study2","study2","study3"],"outcome":["cancer_v1","cancer_v2","cancer_v1","cancer_v2","cancer_v1"],"model":["ageSex","ageSex","ageSexBmi","ageSex","ageSexBmi"],"pvalue":["0.6","0.05","0.2","0.01","0.002"]}]],"container":"<table class=\"display\">\n <thead>\n <tr>\n <th> <\/th>\n <th> <\/th>\n <th>outcome.bestOf<\/th>\n <th>study1.bestOf<\/th>\n <th>study2.bestOf<\/th>\n <th>study3.bestOf<\/th>\n <th>data<\/th>\n <\/tr>\n <\/thead>\n<\/table>","options":{"columnDefs":[{"visible":false,"targets":[0,6]},{"orderable":false,"className":"details-control","targets":1},{"orderable":false,"targets":0}],"order":[],"autoWidth":false,"orderClasses":false},"callback":"function(table) {\n\n table.column(1).nodes().to$().css({cursor: 'pointer'});\n \n // Format data object (the nested table) into another table\n var format = function(d) {\n if(d != null){ \n var result = ('<table id=\"child_' + d[2] + '_' + d[3] + '_' + d[4] + '_' + d[5] + '\">').replace('.','_') + '<thead><tr>'\n for (var col in d[6]){\n result += '<th>' + col + '<\/th>'\n }\n result += '<\/tr><\/thead><\/table>'\n return result\n }else{\n return '';\n }\n }\n \n var format_datatable = function(d) {\n var dataset = [];\n for (i = 0; i < + d[6]['cohort'].length; i++) {\n var datarow = [];\n for (var col in d[6]){\n datarow.push(d[6][col][i])\n }\n dataset.push(datarow)\n }\n var subtable = $(('table#child_' + d[2] + '_' + d[3] + '_' + d[4] + '_' + d[5]).replace('.','_')).DataTable({\n 'data': dataset,\n 'autoWidth': true, \n 'deferRender': true, \n 'info': false, \n 'lengthChange': false, \n 'ordering': true, \n 'paging': false, \n 'scrollX': false, \n 'scrollY': false, \n 'searching': false \n });\n };\n \n table.on('click', 'td.details-control', function() {\n var td = $(this), row = table.row(td.closest('tr'));\n if (row.child.isShown()) {\n row.child.hide();\n td.html('⊕');\n } else {\n row.child(format(row.data())).show();\n td.html('⊖');\n format_datatable(row.data())\n }\n });\n}"},"evals":["callback"],"jsHooks":[]}</script>
<script type="application/htmlwidget-sizing" data-for="htmlwidget-3a36880ad35572a39f25">{"viewer":{"width":450,"height":350,"padding":15,"fill":true},"browser":{"width":960,"height":500,"padding":40,"fill":false}}</script>
</body></html>
**** EDIT 2 **** With changes suggested by Stéphane Laurent
allresults <- list(c("HeartAttack", 1e-6, 0.05, 0.005, "study1", "heartAttack_v1", "ageSex", 1e-6),
c("HeartAttack", 1e-6, 0.05, 0.005, "study1", "heartAttack_v2", "ageSexBmi", 0.001),
c("HeartAttack", 1e-6, 0.05, 0.005, "study2", "heartAttack_v1", "ageSex", 0.05),
c("HeartAttack", 1e-6, 0.05, 0.005, "study2", "heartAttack_v2", "ageSexBmi", "0.2"),
c("HeartAttack", 1e-6, 0.05, 0.005, "study3", "heartAttack_v1", "ageSex", "0.005"),
c( "Cancer", 0.05, 0.01, 0.002, "study1", "cancer_v1", "ageSex", 0.6),
c( "Cancer", 0.05, 0.01, 0.002, "study1", "cancer_v2", "ageSex", 0.05),
c("Cancer", 0.05, 0.01, 0.002, "study2", "cancer_v1", "ageSexBmi", 0.2),
c("Cancer", 0.05, 0.01, 0.002, "study2", "cancer_v2", "ageSex", 0.01),
c("Cancer", 0.05, 0.01, 0.002, "study3", "cancer_v1", "ageSexBmi", 0.002))
df <- as.data.frame(t(as.data.frame(allresults)))
colnames(df) <- c("outcome.bestOf", "study1.bestOf", "study2.bestOf", "study3.bestOf", "studyName", "outcome", "model", "pvalue")
rownames(df)<-NULL
# == Collapse to display top-result table, one row per outcome
nest_fields <- c("outcome.bestOf", "study1.bestOf", "study2.bestOf", "study3.bestOf")
dt <- df %>%
nest(-nest_fields)
# == Add (+) column
data <- dt %>% {bind_cols(data_frame(' ' = rep('⊕',nrow(.))),.)}
# == Get dynamic info and strings
# == code via: https://github.com/rstudio/shiny-examples/issues/9
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('/\\./g','_') + '<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,"]['studyName'].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('/\\./g','_') ).DataTable({
'data': dataset,
'autoWidth': true,
'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())
}
});"
)
# == the Display DT
datatable(
data,
escape = FALSE,
options = list(
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)
)
{var%20f='http://v.t.sina.com.cn/share/share.php?appkey=1515056452',u=z||d.location,p=['&url=',e(u),'&title=',e(t||d.title),'&source=',e(r),'&sourceUrl=',e(l),'&content=',c||'gb2312','&pic=',e(p||'')].join('');function%20a(){if(!window.open([f,p].join(''),'mb',['toolbar=0,status=0,resizable=1,width=440,height=430,left=',(s.width-440)/2,',top=',(s.height-430)/2].join('')))u.href=[f,p].join('');};if(/Firefox/.test(navigator.userAgent))setTimeout(a,0);else%20a();})(screen,document,encodeURIComponent,'','','https://i.stack.imgur.com/gcyPw.png', '推荐 啃猪蹄的小仙女 的文章《Problems writing code for an R DT summarizing resu》','https://www.manongdao.com/article-2188003.html','页面编码gb2312|utf-8默认gb2312'));){kind=link}