---
title: "Displaying tables as grid graphics"
author: "Baptiste Auguie"
date: '`r Sys.Date()`'
vignette: >
  %\VignetteEngine{knitr::rmarkdown}
  %\VignetteIndexEntry{tableGrob: displaying tables as grid graphics}
output:
  knitr:::html_vignette:
    toc: yes
---

```{r setup, echo=FALSE, results='hide'}
library(knitr)
opts_chunk$set(message=FALSE, fig.width=4, fig.height=2)
```

Tabular data is usually formatted outside the graphics device, e.g via LaTeX, or html tables. However, in some cases it may be convenient to display *small* tables alongside graphics. A couple of packages offer this possibility with base graphics (`plotrix` for instance); the `gridExtra` provides the pair of `tableGrob/grid.table` functions for this purpose. 

## Basic usage

```{r basic}
library(gridExtra)
library(grid)
d <- head(iris[,1:3])
grid.table(d)
```

## Spacing

The spacing of each row/column is automatic, and will adjust to bigger cell contents. Plotmath notation may be used, with the `parse=TRUE` argument. Note that this is applied to individual strings of text, and reverts to standard text if parsing fails (this is useful when mixing multiline text with plotmath in different cells).

```{r annotations, fig.height=3}
d[2,3] <- "this is very wwwwwide"
d[1,2] <- "this\nis\ntall"
colnames(d) <- c("alpha*integral(xdx,a,infinity)", 
                 "this text\nis high", 'alpha/beta')

tt <- ttheme_default(colhead=list(fg_params = list(parse=TRUE)))
grid.table(d, theme=tt)

```

## Aesthetic formatting

The formatting is controlled by *themes*, which are nested lists of graphical parameters. See `ttheme_default` and `ttheme_minimal` for two built-in examples. Changing a few parameters at a time amounts to modifying the list with the new values.

```{r theme, fig.width=8}
tt1 <- ttheme_default()
tt2 <- ttheme_minimal()
tt3 <- ttheme_minimal(
  core=list(bg_params = list(fill = blues9, col=NA),
            fg_params=list(fontface=3)), 
  colhead=list(fg_params=list(col="navyblue")),
  rowhead=list(fg_params=list(col="navyblue", fontface=2L)))

grid.arrange(
  tableGrob(iris[1:4, 1:2], theme=tt1),
  tableGrob(iris[1:4, 1:2], theme=tt2),
  tableGrob(iris[1:4, 1:2], theme=tt3),
  nrow=1)
```

## Text justification

The text labels can be justified; the default is "centre" for the core, header, and row names. These settings can be adjusted by passing the relevant parameters of `textGrob` via the theme nested lists,

```{r justify, fig.width=8}
tt1 <- ttheme_default()
tt2 <- ttheme_default(core=list(fg_params=list(hjust=1, x=0.9)),
                      rowhead=list(fg_params=list(hjust=1, x=0.95)))
tt3 <- ttheme_default(core=list(fg_params=list(hjust=0, x=0.1)),
                      rowhead=list(fg_params=list(hjust=0, x=0)))
grid.arrange(
  tableGrob(mtcars[1:4, 1:2], theme=tt1),
  tableGrob(mtcars[1:4, 1:2], theme=tt2),
  tableGrob(mtcars[1:4, 1:2], theme=tt3),
  nrow=1)
```

## Further gtable processing and integration

Being based on `gtable`, the table can be further processed. In particular, we may edit the cell sizes to align with other content on the page.

```{r sizes, fig.width=8}
g <- g2 <- tableGrob(iris[1:4, 1:3], cols = NULL, rows=NULL)
g2$widths <- unit(rep(1/ncol(g2), ncol(g2)), "npc")
grid.arrange(rectGrob(), rectGrob(), nrow=1)
grid.arrange(g, g2, nrow=1, newpage = FALSE)
```

Other grobs such as separating lines may be added.

```{r separators}
g <- tableGrob(iris[1:4, 1:3], theme=ttheme_minimal())
separators <- replicate(ncol(g) - 2, 
                     segmentsGrob(x1 = unit(0,"npc")), 
                     simplify=FALSE)
g <- gtable::gtable_add_grob(g, grobs = separators, 
                     t = 1, b = nrow(g), l = seq_len(ncol(g)-2)+2)
grid.draw(g)
```

We may also access and modify individual cells, e.g. to highlight a value.

```{r highlight}
g <- tableGrob(iris[1:4, 1:3])
find_cell <- function(table, row, col, name="core-fg"){
  l <- table$layout
  which(l$t==row & l$l==col & l$name==name)
}

ind <- find_cell(g, 3, 2, "core-fg")
ind2 <- find_cell(g, 2, 3, "core-bg")
g$grobs[ind][[1]][["gp"]] <- gpar(fontsize=15, fontface="bold")
g$grobs[ind2][[1]][["gp"]] <- gpar(fill="darkolivegreen1", col = "darkolivegreen4", lwd=5)
grid.draw(g)
```

## Faster tables: an alternative grid function

The `tableGrob` function can be very slow; unfortunately this is the price to pay for its versatility and easier implementation. We use individual `textGrob` and `rectGrob` elements for each cell, instead of relying on the vectorised implementation of these functions. The reason is practical: it is much easier to place, measure, and customise individual grobs, than modify the graphical parameters and positions of a single vectorised grob. An alternative function is presented below, using this vectorised approach, but lacking many of the customisations of `tableGrob`.


```{r ftable, fig.width=6}
grid.ftable <- function(d, padding = unit(4, "mm"), ...) {
  
  nc <- ncol(d)
  nr <- nrow(d)
  
  ## character table with added row and column names
  extended_matrix <- cbind(c("", rownames(d)),   
                           rbind(colnames(d),
                                 as.matrix(d)))
  
  ## string width and height
  w <- apply(extended_matrix, 2, strwidth, "inch")
  h <- apply(extended_matrix, 2, strheight, "inch")
  
  widths <- apply(w, 2, max)
  heights <- apply(h, 1, max)
  
  padding <- convertUnit(padding, unitTo = "in", valueOnly = TRUE)
  
  x <- cumsum(widths + padding) - 0.5 * padding
  y <- cumsum(heights + padding) - padding
  
  rg <- rectGrob(x = unit(x - widths/2, "in"), 
                 y = unit(1, "npc") - unit(rep(y, each = nc + 1), "in"), 
                 width = unit(widths + padding, "in"), 
                 height = unit(heights + padding, "in"))
  
  tg <- textGrob(c(t(extended_matrix)), x = unit(x - widths/2, "in"), 
                 y = unit(1, "npc") - unit(rep(y, each = nc + 1), "in"), 
                 just = "center")
  
  g <- gTree(children = gList(rg, tg), ..., 
             x = x, y = y, widths = widths, heights = heights)
  
  grid.draw(g)
  invisible(g)
}

grid.newpage()
grid.ftable(head(iris, 4), gp = gpar(fill = rep(c("grey90", "grey95"), each = 6)))
```


