theming tableGrob

tableGrob_theme.r

library(gtable)
library(plyr)

library(methods)

theme <- setRefClass("theme", fields = list( bg = "vector",
                                             fg = "vector",
                                             colours = "vector", 
                                             font = "list",
                                             row_font = "list",
                                             col_font = "list",
                                             core_font = "list",
                                             cell_function = "function"),
                     methods = list(set_fonts = function(...){
                       temp <- modifyList(font, list(col=colours[1]))
                       font <<- modifyList(temp, list(...))
                       row_font <<- modifyList(font, row_font)
                       col_font <<- modifyList(font, col_font)
                       core_font <<- modifyList(font, core_font)
                     },
                                    set_colours = function(...){
                                      colours <<- unlist(list(...))
                                    }, set_fg = function(...){
                                      fg <<- unlist(list(...))
                                    }, set_bg = function(...){
                                      bg <<- unlist(list(...))
                                    } ))

theme_default <- new( "theme", bg = c("grey90","grey98"),
                      fg = "grey50",
                      colours = c(low = "black", high = "red"), 
                      font = list(fontfamily="Helvetica", fontsize=11),
                      row_font = list(fontface="italic", fontsize=10),
                      col_font = list(fontface="bold", fontsize=12),
                      core_font = list(fontfamily="mono", fontsize=12,col="black"),
                      cell_function = grid::textGrob )

## creates a gtable
## given a header (character matrix, possibly with attributes)
## NAs are used to indicate grobs that span multiple cells
gtable_header <- function(header, n = NULL, theme=theme_default,
                          type = c("row","col"), font=theme$font,
                          padding=unit(rep(2,2),"mm"), ...){
  
  type <- match.arg(type)
  type <- switch(type, "row" = 1, "col" = 2)
  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
  if(type == 1) 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) <- if(type==1) c("label","l","r","t","b") else
    c("label","t","b","l","r")
  
  ## make grobs
  d$grobs <- lapply(d$label, theme$cell_function, gp=do.call(gpar, font), ...)
  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") <- if(type==1) widths[[which(sapply(widths, length) == n)]] else
    do.call(unit.c, lapply(widths, max))
  attr(d, "heights") <- if(type==2) heights[[which(sapply(heights, length) == n)]] else
    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 <- if(type == 1) segmentsGrob(x0 = unit(1, "npc"), y0 = unit(0, "npc"),
                                   x1 = unit(1, "npc"), y1 = unit(1, "npc"),
                                   gp=gpar(lwd=0.5, col=theme$colours[1])) else
                                     segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
                                                  x1 = unit(1, "npc"), y1 = unit(0, "npc"),
                                                  gp=gpar(lwd=0.5, col=theme$colours[1]))
  d2 <- if(type == 1) subset(d, r < n) else subset(d, b < n)
  g <- with(d2, gtable_add_grob(g, replicate(length(d2$grobs), sg, simplify=FALSE),
                                t, l, b, r, z=1, name="rect"))
  
  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_header(h, type="row")
## g2 <- gtable_header(t(h), type="col")

## grid.newpage()
## grid.draw(g)
## grid.newpage()
## grid.draw(g2)



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

## 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))


tableGrob <- function(d, rows=rownames(d), cols=colnames(d),
                      theme=theme_default,
                      parse=TRUE, widths=NULL, heights=NULL,
                      fill=c("grey95",NA), padding = unit(c(2,2),"mm"),
                      just=c("centre", "centre"), ...){
  theme$set_bg(fill)
  theme$set_fonts(list())
  
  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$bg, length=n)
  
  ## try parsing the labels (plotmath)
  if(parse){
    content <- lapply(content, tryparse)
  }
  
  ## make the text grobs
  cgrobst <- mapply(textGrob, label=content,
                    MoreArgs=list(gp=do.call(gpar, theme$core_font)), 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_header(cols, type="row", theme=theme, font=theme$col_font)
  gl <- if(is.null(rows)) gtable_matrix("rows", matrix(list(nullGrob()), nrow=nr, nc=1),
                                        unit(0,"mm"), cheights) else
                                          gtable_header(rows, type="col", theme=theme, font=theme$row_font)
  
  gl <- gtable_add_grob(gl, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$colours[1])),
                        l=1, r=ncol(gl), t=1, b=nrow(gl), z=Inf, name="boxfg")
  
  gt <- gtable_add_grob(gt, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$colours[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=0.5, col=theme$fg)) 
  hg <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
                     x1 = unit(1, "npc"), y1 = unit(0, "npc"),gp=gpar(lwd=0.5, col=theme$fg))
  
  vp <- seq.int(nc-1) ; hp <- seq.int(nr-1)
  gvr <- replicate(nc-1, vg, simplify=FALSE)
  ghr <- replicate(nr-1, hg, simplify=FALSE)
  
  ngc <- gtable_add_grob(gc, gvr, l=vp, r=vp, t=1, b=nr, z=1, name="vsep")
  ngc <- gtable_add_grob(ngc, ghr, l=1, r=nc, t=hp, b=hp, z=1, name="hsep")
  ngc <- gtable_add_grob(ngc, rectGrob(gp=gpar(col=NA,fill=NA, col=theme$fg)),
                         l=1, r=nc, t=1, b=nr, z=-Inf, name="boxbg")
  ngc <- gtable_add_grob(ngc, rectGrob(gp=gpar(lwd=0.8,fill=NA, col="white",lwd=2)),
                         l=1, r=nc, t=1, b=nr, z=Inf, name="boxfg")
  
  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)
#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)))
#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(gp)

# library(tables)