tablegrob

tablegrob

library(gtable)
library(plyr)
library(grid)


table_theme <- function(bg = c("grey95", "grey98"),
                        fg = c("black", "black"),
                        just=c("center","center"),
                        separator = list(h=FALSE, v=TRUE), box = FALSE,
                        core = list(bg=bg, fg=fg, separator=separator, box=box, just=just),
                        row_header = core,
                        col_header = modifyList(core, list(just=c("right", "center")))){
  
  list(bg=bg, fg=fg, separator=separator, box=box,
       core=core, row_header=row_header, col_header=col_header)
}

# table_theme()

## build a rectGrob with parameters
cellRect <- function(fill=NA) 
  rectGrob(gp=gpar(fill=fill, col=NA))

cellText <- function(label, colour="black", hjust=c("left", "center", "right"), ...) {
  hjust <- match.arg(hjust)
  x <- switch(hjust,
              "left" = 0,
              "center"=0.5,
              "right"=1)
  textGrob(label, x=x, hjust=x, gp=gpar(col=colour, ...))
}
# 
# g <- cellText("test", hjust="left")
# grid.draw(g)

## fail-safe plotmath parsing
tryparse <- function(lab)
  tryCatch(parse(text=lab), error = function(e) lab)

## stack two isomorphic gtables along z
combine <- function(g1, g2){
  g1$grobs <- c(g1$grobs, g2$grobs)
  g2$layout <- transform(g2$layout, z= g1$layout$z - 1, name="rect")
  g1$layout <- rbind(g1$layout, g2$layout)
  g1
}

rowMax_units <- function(m){
  do.call(unit.c, apply(m, 1, function(l)
    max(do.call(unit.c, lapply(l, grobHeight)))))
}

colMax_units <- function(m){
  do.call(unit.c, apply(m, 2, function(l)
    max(do.call(unit.c, lapply(l, grobWidth)))))
}


cbind_gtable <- function(x, y, size = "max") {
  stopifnot(nrow(x) == nrow(y))
  if (ncol(x) == 0) return(y)
  if (ncol(y) == 0) return(x)
  
  y$layout$l <- y$layout$l + ncol(x)
  y$layout$r <- y$layout$r + ncol(x)
  x$layout <- rbind(x$layout, y$layout)
  
  x$widths <- gtable:::insert.unit(x$widths, y$widths)
  x$colnames <- c(x$colnames, y$colnames)
  
  size <- match.arg(size, c("first", "last", "max", "min"))
  x$heights <- switch(size,
                      first = x$heights,
                      last = y$heights,
                      min = unit.pmin(x$heights, y$heights),
                      max = unit.pmax(x$heights, y$heights)
  )
  
  x$grobs <- append(x$grobs, y$grobs)
  
  x
}

rbind_gtable <- function (x, y, size = "max") 
{
  stopifnot(ncol(x) == ncol(y))
  if (nrow(x) == 0) 
    return(y)
  if (nrow(y) == 0) 
    return(x)
  y$layout$t <- y$layout$t + nrow(x)
  y$layout$b <- y$layout$b + nrow(x)
  x$layout <- rbind(x$layout, y$layout)
  x$heights <- gtable:::insert.unit(x$heights, y$heights)
  x$rownames <- c(x$rownames, y$rownames)
  size <- match.arg(size, c("first", "last", "max", "min"))
  x$widths <- switch(size, first = x$widths, last = y$widths, 
                     min = unit.pmin(x$widths, y$widths), max = unit.pmax(x$widths, 
                                                                          y$widths))
  x$grobs <- append(x$grobs, y$grobs)
  x
}


findHeights <- function(l)
  do.call(unit.c, lapply(l,grobHeight))
findWidths <- function(l)
  do.call(unit.c, lapply(l,grobWidth))

gtable_rowheader <- function(header, n = NULL, theme=table_theme()$row_header,
                             padding=unit(rep(2,2),"mm"), ...){
  
  type <- 1L
  if(is.null(n)) n <- max(apply(header, type, length))
  
  require(plyr)
  start <- alply(header, type, function(s) which(!is.na(s), TRUE))
  end <- llply(start, function(s) c(s[-1], n+1) - 1 )
  
  fixed <- rep(seq_along(start), sapply(start, length)) # t,b for rows, l,r for cols
  ## dirty trick to follow the labels order
  header <- t(header)
  label <- header[!is.na(header)]
  
  d <- data.frame(label =  label,
                  start=unlist(start), end=unlist(end), fixed, fixed,
                  stringsAsFactors=FALSE)
  
  names(d) <- c("label","l","r","t","b") 
  ## make grobs
  d$grobs <- lapply(d$label, cellText, hjust=theme$just[1])
  d$widths <- lapply(d$grobs, grobWidth)
  d$heights <- lapply(d$grobs, grobHeight)
  
  widths <- dlply(d, names(d)[4], # t if type==1, l if type==2
                  function(d) width=do.call(unit.c, d$widths))
  heights <- dlply(d, names(d)[4],
                   function(d) heights=do.call(unit.c, d$heights))
  
  ## extract widths and heights relevant to the layout
  attr(d, "widths") <- widths[[which(sapply(widths, length) == n)]] 
  attr(d, "heights") <- do.call(unit.c, lapply(heights, max))
  
  ## create gtable
  g <- gtable()
  g <- gtable_add_cols(g, attr(d,"widths") + padding[1])
  g <- gtable_add_rows(g, attr(d,"heights")+ padding[2])
  
  ## vertical/horizontal separators
  sg <- segmentsGrob(x0 = unit(1, "npc"), y0 = unit(0, "npc"),
                     x1 = unit(1, "npc"), y1 = unit(1, "npc"),
                     gp=gpar(lwd=1, col=theme$fg[1])) 
  d2 <- subset(d, r < n) 
  if(theme$separator$v)
    g <- with(d2, gtable_add_grob(g, replicate(length(d2$grobs), sg, simplify=FALSE),
                                  t, l, b, r, z=1, name="sep"))
  
  g <- with(d, gtable_add_grob(g, grobs, t, l, b, r, z=0, name="text"))
  g
}

## NAs are used to indicate grobs that span multiple cells
gtable_colheader <- function(header, n = NULL, theme=table_theme()$col_header,
                             padding=unit(rep(2,2),"mm"), ...){
  
  type <- 2L
  if(is.null(n)) n <- max(apply(header, type, length))
  
  require(plyr)
  start <- alply(header, type, function(s) which(!is.na(s), TRUE))
  end <- llply(start, function(s) c(s[-1], n+1) - 1 )
  
  fixed <- rep(seq_along(start), sapply(start, length)) # t,b for rows, l,r for cols
  
  label <- header[!is.na(header)]
  
  d <- data.frame(label =  label,
                  start=unlist(start), end=unlist(end), fixed, fixed,
                  stringsAsFactors=FALSE)
  
  names(d) <- c("label","t","b","l","r")
  
  ## make grobs
  d$grobs <- lapply(d$label, cellText, hjust=theme$just[1])
  d$widths <- lapply(d$grobs, grobWidth)
  d$heights <- lapply(d$grobs, grobHeight)
  
  widths <- dlply(d, names(d)[4], # t if type==1, l if type==2
                  function(d) width=do.call(unit.c, d$widths))
  heights <- dlply(d, names(d)[4],
                   function(d) heights=do.call(unit.c, d$heights))
  
  ## extract widths and heights relevant to the layout
  attr(d, "widths") <- do.call(unit.c, lapply(widths, max))
  attr(d, "heights") <- heights[[which(sapply(heights, length) == n)]]
  
  ## create gtable
  g <- gtable()
  g <- gtable_add_cols(g, attr(d,"widths") + padding[1])
  g <- gtable_add_rows(g, attr(d,"heights")+ padding[2])
  
  ## vertical/horizontal separators
  sg <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
                     x1 = unit(1, "npc"), y1 = unit(0, "npc"),
                     gp=gpar(lwd=1, col=theme$fg[1]))
  d2 <- subset(d, b < n)
  if(theme$separator$h)
    g <- with(d2, gtable_add_grob(g, replicate(length(d2$grobs), sg, simplify=FALSE),
                                  t, l, b, r, z=1, name="sep"))
  
  g <- with(d, gtable_add_grob(g, grobs, t, l, b, r, z=0, name="text"))
  g
}

# h <- matrix(c("", "a", NA, "b", NA, paste("cell", 1:5)), nrow=2, byrow=TRUE)
# g <- gtable_rowheader(h)
# g2 <- gtable_colheader(t(h))
# g <- gtable_rowheader(h, theme=table_theme(bg = "black", sep=T)$row_header)
# g2 <- gtable_colheader(t(h),theme=table_theme(bg = "black", sep=T)$col_header)
# grid.newpage()
# grid.draw(g)



tableGrob <- function(d, rows=rownames(d), cols=colnames(d),
                      theme=table_theme(),
                      parse=TRUE, widths=NULL, heights=NULL,
                      padding = unit(c(2,2),"mm"),
                      just=c("centre", "centre"), ...){
  
  m <- as.matrix(d)
  content <- c(m)
  n <- length(content)
  nc <- NCOL(d)
  nr <- NROW(d)
  if(!is.null(rows))
    rows <- as.matrix(rows)
  if(!is.null(cols)){
    cols <- as.matrix(cols)
    if(ncol(cols) == 1) cols <- t(cols)
  }
  
  ## basic aesthetic params
  cfill <- rep(theme$core$bg, length=n)
  ccolour <- rep(theme$core$fg, length=n)
  
  ## try parsing the labels (plotmath)
  if(parse){
    content <- lapply(content, tryparse)
  }
  
  ## make the text grobs
  cgrobst <- mapply(cellText, label=content, colour=ccolour, 
                    MoreArgs=list(hjust=theme$core$just[1]),
                    SIMPLIFY=FALSE)
  ## make the rect grobs
  cgrobsr <- mapply(cellRect, cfill, SIMPLIFY=FALSE)
  
  ## wrap grobs into matrices
  mcgrobst <- matrix(cgrobst, ncol=nc)
  mcgrobsr <- matrix(cgrobsr, ncol=nc)
  
  ## figure out layout dimensions
  cwidths <- colMax_units(mcgrobst) + padding[1]
  cheights <- rowMax_units(mcgrobst) + padding[2]
  
  ## headers (may span multiple rows/columns)
  gt <- if(is.null(cols)) gtable_matrix("cols", matrix(list(nullGrob()), ncol=nc, nr=1),
                                        cwidths, unit(0,"mm")) else
                                          gtable_rowheader(cols, theme=theme$row_header)
  gl <- if(is.null(rows)) gtable_matrix("rows", matrix(list(nullGrob()), nrow=nr, nc=1),
                                        unit(0,"mm"), cheights) else
                                          gtable_colheader(rows, theme=theme$col_header)
  
  if(theme$row_header$box)
  gl <- gtable_add_grob(gl, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$row_header$fg[1])),
                        l=1, r=ncol(gl), t=1, b=nrow(gl), z=Inf, name="boxfg")
  
  if(theme$col_header$box)
  gt <- gtable_add_grob(gt, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$col_header$fg[1])),
                        l=1, r=ncol(gt), t=1, b=nrow(gt), z=Inf, name="boxfg")
  
  ## widths and heights, if not supplied, accommodate all labels
  if(is.null(widths))
    widths <- unit.pmax(gt$widths, cwidths) else
      widths <- rep(widths, length.out=nc)
  if(is.null(heights))
    heights <- unit.pmax(gl$heights, cheights) else
      heights <- rep(heights, length.out=nr)
  
  ## create gtable
  coretext <- gtable_matrix("core", mcgrobst, widths, heights)
  corerect <- gtable_matrix("core", mcgrobsr, widths, heights)
  
  ## combine gtables along z
  gc <- combine(coretext, corerect)
  
  ## add vert and horiz separators
  vg <- segmentsGrob(x0 = unit(1, "npc"), y0 = unit(0, "npc"),
                     x1 = unit(1, "npc"), y1 = unit(1, "npc"),
                     gp=gpar(lwd=1, col=theme$core$fg[1])) 
  hg <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
                     x1 = unit(1, "npc"), y1 = unit(0, "npc"),
                     gp=gpar(lwd=1, col=theme$core$fg[1]))
  
  vp <- seq.int(nc-1) ; hp <- seq.int(nr-1)
  gvr <- replicate(nc-1, vg, simplify=FALSE)
  ghr <- replicate(nr-1, hg, simplify=FALSE)
  if(theme$core$separator$v)
  ngc <- gtable_add_grob(gc, gvr, l=vp, r=vp, t=1, b=nr, z=Inf, name="vsep")
  if(theme$core$separator$h)
  ngc <- gtable_add_grob(ngc, ghr, l=1, r=nc, t=hp, b=hp, z=Inf, name="hsep")
  
  if(theme$core$box)
  ngc <- gtable_add_grob(ngc, rectGrob(gp=gpar(col=NA,fill=NA, col=theme$core$fg[1])),
                         l=1, r=nc, t=1, b=nr, z=-Inf, name="boxbg")
  
  empty <- gtable( unit(rep(0, length(unique(gl$layout$l))), "cm"),
                   unit(rep(0, length(unique(gt$layout$t))), "cm"))
  
  all <- rbind_gtable(
    cbind_gtable(empty, gt, "last"),
    cbind_gtable(gl, ngc, size="last"), size="last")
  ## justify bottom-right corner
  vp <- viewport(x=unit(1,"npc"),
                 y=0.5*sum(gt$heights), just=c("right","bottom"))
  
  all$vp <- vp
  all
}


grid.table <- function(...)
  grid.draw(tableGrob(...))


## tests

d <- head(iris,20)
# d[2,2] <- "this is\nhigh"
# d[3,4] <- "integral(alpha)"
# rownames(d) <- c(1,2,3,4,5,"very\nhigh\nindeed")
# d <- matrix(letters[1:10],2)
grid.newpage()
# g <- tableGrob(d,fill=c("grey","red",rep("grey90",4)))
g <- tableGrob(d)
grid.draw(g)

## ## ## layout on the page, with fixed row heights. 
# ## ## Note how 'npc' are more useful than 'null' units here.
grid.newpage()
pushViewport(viewport(height=0.8,width=0.9))
g2 <- tableGrob(d, widths=unit(1,"null"), heights=unit(1/nrow(d),"npc"))
grid.draw(g2)
grid.rect()