Tooltips for the headers of a datatable in Shiny
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
In this post, I show how to use the
qTip2 JavaScript library to create some
tooltips on the headers of a DT datatable in Shiny,
displaying some information about the columns, such as summary
statistics.
Firstly, we write a function returning some JavaScript code that creates
some hidden div elements which will contain the contents of
the tooltips. This function takes two arguments: n, the
number of div elements to create (this will be the number
of columns of the table), and prefixID; the i-th
div will have the identifier {prefixID}-{i}.
We also set a class to each div, namely
qtip-big.
createDiv <- function(n, prefixID){
sprintf(paste(
"for(var i = 1; i <= %d; i++){",
" var div;",
sprintf(" var id = '%s-' + i.toString();", prefixID),
" if(document.getElementById(id) === null){",
" div = document.createElement('div');",
" div.setAttribute('id', id);",
" div.setAttribute('class', 'qtip-big');",
" div.style.display = 'none';",
" document.body.appendChild(div);",
" }",
"}",
sep = "\n"
), n)
}
cat(createDiv(3, "TOOLTIP"))
## for(var i = 1; i <= 3; i++){
## var div;
## var id = 'TOOLTIP-' + i.toString();
## if(document.getElementById(id) === null){
## div = document.createElement('div');
## div.setAttribute('id', id);
## div.setAttribute('class', 'qtip-big');
## div.style.display = 'none';
## document.body.appendChild(div);
## }
## }
Now we write a function returning some JavaScript code that writes the
contents of the div elements. It takes as arguments
dat, the dataframe for the table, i, the index
of a column of dat, and prefixID as in the
function createDiv. If the i-th column is
numeric, we fill the div element with some summary
statistics of this column, otherwise the information we provide in the
div element is the number of levels of the contents of the
column, an enumeration of the levels (at most three), and the number of
missing values.
fillDiv <- function(dat, i, prefixID){
x <- dat[[i]]
if(is.numeric(x)){
sprintf(paste(
"var div = document.getElementById('%s-%d');",
"var html = '<b> Min: </b> %s</br>';",
"html = html + '<b> Max: </b> %s</br>';",
"html = html + '<b> Mean: </b> %s</br>';",
"html = html + '<b> Std. dev.: </b> %s</br>';",
"html = html + '<b> Missing values: </b> %d';",
"div.innerHTML = html;",
sep = "\n"
),
prefixID,
i,
formatC(min(x, na.rm=TRUE)),
formatC(max(x, na.rm=TRUE)),
formatC(mean(x, na.rm=TRUE)),
formatC(sd(x, na.rm=TRUE)),
sum(is.na(x)))
}else{
if(is.factor(x)) x <- as.character(x)
levels0 <- sort(unique(na.omit(x)))
nlevels <- length(levels0)
levels <-
if(nlevels>3) c(levels0[1:2], levels0[nlevels]) else levels0
ncharMax <- 25
nchars <- nchar(levels)
if(7+sum(nchars) > ncharMax){
levels[1] <- paste0("<br/>", levels[1])
if(nlevels >= 2 && sum(nchars) > ncharMax){
levels[2] <- paste0("<br/>", levels[2])
if(nlevels >= 3 && sum(nchars[2:3]) > ncharMax){
levels[3] <- paste0("<br/>", levels[3])
}
}
}
levelsSummary <- ifelse(nlevels > 3,
paste0(c(levels[1],
paste0(levels[2], ", ..."),
levels[3]),
collapse = ", "),
paste0(levels, collapse = ", "))
sprintf(paste(
"var div = document.getElementById('%s-%d');",
"var html = '<b> Number of levels: </b> %d</br>';",
sprintf("html = html + '<b> Level%s: </b> %%s</br>'",
ifelse(nlevels==1, "", "s")),
"html = html + '<b> Missing values: </b> %d'",
"div.innerHTML = html;",
sep = "\n"
),
prefixID,
i,
nlevels,
levelsSummary,
sum(is.na(x)))
}
}
cat(fillDiv(iris, 1, "TOOLTIP"))
## var div = document.getElementById('TOOLTIP-1');
## var html = '<b> Min: </b> 4.3</br>';
## html = html + '<b> Max: </b> 7.9</br>';
## html = html + '<b> Mean: </b> 5.843</br>';
## html = html + '<b> Std. dev.: </b> 0.8281</br>';
## html = html + '<b> Missing values: </b> 0';
## div.innerHTML = html;
cat(fillDiv(iris, 5, "TOOLTIP"))
## var div = document.getElementById('TOOLTIP-5');
## var html = '<b> Number of levels: </b> 3</br>';
## html = html + '<b> Levels: </b> <br/>setosa, versicolor, virginica</br>'
## html = html + '<b> Missing values: </b> 0'
## div.innerHTML = html;
Finally we write a function returning the JavaScript code of the
qTip tooltips. Its arguments are n, the number
of columns of the table, and prefixID as before.
tooltips <- function(n, prefixID){
settings <- sprintf(paste(
"{",
" overwrite: true,",
" content: {",
sprintf(" text: $('#%s-%%s').clone()", prefixID),
" },",
" show: {",
" ready: false",
" },",
" position: {",
" my: 'bottom %%s',",
" at: 'top center'",
" },",
" style: {",
" classes: 'qtip-youtube'",
" }",
"}",
sep = "\n"
), 1:n)
settings <- sprintf(settings, ifelse(1:n > n/2, "right", "left"))
sprintf("var tooltips = [%s];", paste0(settings, collapse=","))
}
cat(tooltips(2, "TOOLTIP"))
## var tooltips = [{
## overwrite: true,
## content: {
## text: $('#TOOLTIP-1').clone()
## },
## show: {
## ready: false
## },
## position: {
## my: 'bottom left',
## at: 'top center'
## },
## style: {
## classes: 'qtip-youtube'
## }
## },{
## overwrite: true,
## content: {
## text: $('#TOOLTIP-2').clone()
## },
## show: {
## ready: false
## },
## position: {
## my: 'bottom right',
## at: 'top center'
## },
## style: {
## classes: 'qtip-youtube'
## }
## }];
Now we are ready to write the Shiny app. Put the files
jquery.qtip.min.css and
jquery.qtip.min.js in the
www subfolder. We use the shinyjs package
to run the JavaScript code with the function runjs.
library(shiny)
library(shinyjs)
library(DT)
CSS <- "
.qtip-big {
font-size: 15px;
line-height: 18px;
white-space: nowrap;
word-spacing: 1px;
}
"
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
tags$script(src = "jquery.qtip.min.js"),
tags$style(CSS)
),
useShinyjs(),
br(), br(), br(), br(), br(),
DTOutput("dtable")
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
dat <- iris
for(i in 1:ncol(dat)){
runjs(createDiv(i, "TOOLTIP"))
runjs(fillDiv(dat, i, "TOOLTIP"))
}
headerCallback <- c(
"function(thead, data, start, end, display){",
" var ncols = data[0].length;",
tooltips(ncol(dat), "TOOLTIP"),
" for(var i = 1; i < ncols; i++){",
" $('th:eq(' + i + ')', thead).qtip(tooltips[i-1]);",
" }",
"}"
)
datatable(
dat,
options = list(
headerCallback = JS(headerCallback),
columnDefs = list(
list(className = "dt-center", targets = "_all")
)
)
)
})
}
shinyApp(ui, server)
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.