new prototype of tableGrob with cells editing and adjustable cell sizes

tableGrob.r

library(gtable)

## layout the core cells with top and left headers
align_table <- function(core, top, left, just=c("center", "center")){

  gl <- grid.layout(nrow=2,ncol=2,
                    widths=unit.c(sum(left$widths), sum(core$widths)),
                    heights=unit.c(sum(top$heights), sum(core$heights)),
                    just=just)
  
  g1 <- gtable_gTree(core, vp=viewport(layout.pos.row=2, layout.pos.col=2))
  g2 <- gtable_gTree(top, vp=viewport(layout.pos.row=1, layout.pos.col=2))
  g3 <- gtable_gTree(left, vp=viewport(layout.pos.row=2, layout.pos.col=1))
  
  gTree(children=gList(g1,g2,g3), vp=viewport(layout=gl))
}

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

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

tableGrob <- function(d, rows=rownames(d), cols=colnames(d),
                      parse=TRUE, widths=NULL, heights=NULL,
                      fill=c("grey98","grey90"), 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)

  ## basic aesthetic params
  cfill <- rep(fill, length=n)
  tfill <- rep("white", length=nc)
  lfill <- rep("white", length=nr)

  ## try parsing the labels (plotmath)
  if(parse){
    content <- lapply(content, tryparse)
    ## cols <- lapply(cols, tryparse)
    ## rows <- lapply(rows, tryparse)
  }

  ## make the text grobs
  cgrobst <- mapply(textGrob, label=content,
                   MoreArgs=list(gp=gpar(col="black")), SIMPLIFY=FALSE)
  tgrobst <- mapply(textGrob, label=cols,
                   MoreArgs=list(gp=gpar(col="grey20", fontface="bold")), SIMPLIFY=FALSE)
  lgrobst <- mapply(textGrob, label=rows,
                   MoreArgs=list(gp=gpar(col="grey20", fontface="italic")), SIMPLIFY=FALSE)
  
  ## make the rect grobs
  cgrobsr <- mapply(cellRect, cfill, SIMPLIFY=FALSE)
  tgrobsr <- mapply(cellRect, tfill, SIMPLIFY=FALSE)
  lgrobsr <- mapply(cellRect, lfill, SIMPLIFY=FALSE)

  ## wrap grobs into matrices
  mcgrobst <- matrix(cgrobst, ncol=nc)
  mcgrobsr <- matrix(cgrobsr, ncol=nc)
  
  mtgrobst <- matrix(tgrobst, ncol=nc)
  mtgrobsr <- matrix(tgrobsr, ncol=nc)
  
  mlgrobst <- matrix(lgrobst, nrow=nr)
  mlgrobsr <- matrix(lgrobsr, nrow=nr)
  
  ## figure out layout dimensions
  cwidths <- colMax_units(mcgrobst) + padding[1]
  cheights <- rowMax_units(mcgrobst) + padding[2]
  twidths <- colMax_units(mtgrobst) + padding[1]
  theights <- rowMax_units(mtgrobst) + padding[2]
  lwidths <- colMax_units(mlgrobst) + padding[1]
  lheights <- rowMax_units(mlgrobst) + padding[2]

  ## widths and heights, if not supplied, accommodate all labels
  if(is.null(widths))
    widths <- unit.pmax(twidths, cwidths) else
  widths <- rep(widths, length.out=nc)
  if(is.null(heights))
    heights <- unit.pmax(lheights, cheights) else
  heights <- rep(heights, length.out=nr)
  
  ## create gtables
  coretext <- gtable_matrix("core", mcgrobst, widths, heights)
  corerect <- gtable_matrix("core", mcgrobsr, widths, heights)

  toptext <- gtable_matrix("top", mtgrobst, widths, theights)
  toprect <- gtable_matrix("top", mtgrobsr, widths, theights)
  
  lefttext <- gtable_matrix("left", mlgrobst, lwidths, heights)
  leftrect <- gtable_matrix("left", mlgrobsr, lwidths, heights)
  
  ## combine gtables along z
  g1 <- combine(coretext, corerect)
  g2 <- combine(toptext, toprect)
  g3 <- combine(lefttext, leftrect)
  
  ## align the tables
  align_table(g1,g2,g3, just=just)
  
}

## tests
d <- head(iris)
d[2,2] <- "this is\nhigh"
d[3,4] <- "integral(alpha)"

g <- tableGrob(d)
grid.newpage()
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.9,width=0.9))
grid.rect(gp=gpar(lty=3))
g2 <- tableGrob(d, widths=unit(1,"null"), heights=unit(1/nrow(d),"npc"),
                just=c("right","bottom"))
grid.draw(g2)