1. 技术文章
  2. Problems writing code for an R DT summarizing result across multiple studies with collapsable child rows

Problems writing code for an R DT summarizing result across multiple studies with collapsable child rows

由 核能气质少年 提交于 2020-05-11 12:11:11

问题


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('&oplus;',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('&oplus;');
                   } else {
                   row.child(format(row.data())).show();
                   td.html('&CircleMinus;');
                   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"],["&oplus;","&oplus;"],["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('&oplus;');\n                   } else {\n                   row.child(format(row.data())).show();\n                   td.html('&CircleMinus;');\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('&oplus;',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('&oplus;');
                   } else {
                   row.child(format(row.data())).show();
                   td.html('&CircleMinus;');
                   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)
)

回答1:


There are two issues.

d[",nested_columns,"]['cohort'].length

There's no cohort column. Replace with

d[",nested_columns,"]['studyName'].length

The other issue is the replacement of the dots with underscores:

var result = ('<table id=\"child_' + ",not_nested_columns_str," + '\">').replace('.','_') + '<thead><tr>'

This replaces only the first dot. Change to 

var result = ('<table id=\"child_' + ",not_nested_columns_str," + '\">').replace('/\\./g','_') + '<thead><tr>'

Also here:

var subtable = $(('table#child_' + ",not_nested_columns_str,").replace('.','_')).DataTable({

Full code: 

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('&oplus;',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 (var 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('&oplus;');
                   } else {
                   row.child(format(row.data())).show();
                   td.html('&CircleMinus;');
                   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)
)



回答2:


Future proofing

Building on the superb answer by @StéphaneLaurent, here are some changes to make it 2020-proof:

  1. All input must be named for nest() these days, so replace nest(-nest_fields) with nest(data=(-nest_fields))
  2. data.frame() gives an error and should be replaced with tibble() in this line: data <- dt %>% { bind_cols(data.frame(' ' = rep('&oplus;', nrow(.))), .) }
  3. The line nested_columns <- which(sapply(data,class)=="list") %>% setNames(NULL) doesn't work any longer because, for some reason, the class of the nested tibble is no longer list, but instead two classes: "vctrs_list_of" and "vctrs_vctr". We need to add an extra sapply() to deal with double classes, like so: nested_columns <- which(sapply(sapply(data,class), function(x) "vctrs_list_of" %in% x)) %>% setNames(NULL)


Edge case (FWIW)

On a separate note – as I just spent 3 hours figuring this out – the above solution dynamically creates unique table ids in the JavaScript callback by concatenating all values in the row, separated by _, like so: 

"var result = ('<table id=\"child_' + ",not_nested_columns_str," + '\">').replace(/\\./g,'_') + '<thead><tr>'"

If, like in my case, any of the cells in the row contain a string, which contain blank spaces, the id doesn't work, and it fails silently (it will simply not display values in the child row, only the headers).

My workaround is to have a unique ID column (id) in your original data.frame and to use that for table id instead. This requires adding the line id_column <- which(names(data)=="id"), and to change the bit in the JS callback like so:

"var result = ('<table id=\"child_' + d[",id_column,"] + '\">') + '<thead><tr>'"

Make sure to also adjust the JS callback bit where it creates subtable, since it does that using the table id:

"var subtable = $(('table#child_' + d[",id_column,"])).DataTable({"

NB. We can omit the .replace() bit in JS if we assure the id column only contains numbers.

Finally, if you want to hide the ID column in the final output, you can always add it to the options list, like so: 

list(visible = FALSE, targets = c(0,id_column,nested_columns) ), # Hide row numbers and nested columns`

Hopefully this saves someone else a bunch of time figuring it out!



来源：https://stackoverflow.com/questions/55800155/problems-writing-code-for-an-r-dt-summarizing-result-across-multiple-studies-wit

标签
javascript
r
r-markdown
dt
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!