---
title: "Tooltips for the headers of a datatable in Shiny"
author: "Stéphane Laurent"
date: '2020-02-16'
tags: R, datatables, javascript, shiny
rbloggers: yes
output:
  md_document:
    variant: markdown
    preserve_yaml: true
  html_document:
    highlight: kate
    keep_md: no
highlighter: pandoc-solarized
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE, collapse = TRUE)
```

In this post, I show how to use the 
[qTip2](http://qtip2.com/) 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`. 

```{r, attr.source='.numberLines'}
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)
}
```

```{r}
cat(createDiv(3, "TOOLTIP"))
```

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.

```{r, attr.source='.numberLines'}
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)))
  }
}
```

```{r}
cat(fillDiv(iris, 1, "TOOLTIP"))
cat(fillDiv(iris, 5, "TOOLTIP"))
```

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.

```{r, attr.source='.numberLines'}
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=","))
}
```

```{r}
cat(tooltips(2, "TOOLTIP"))
```

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`. 

```{r, attr.source='.numberLines', eval=FALSE}
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)
```

![](./figures/DTqTip.gif)