combined header and table

combined-table.r

library(gtable)

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

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


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
}

wrap_header <- function(x, n)
  if(is.list(x)) x  else  list(x)

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


## TODO: use "" for empty cell, NA for multi-cell spanning.
makecol <- function(grobs, n, widths, heights, fill, padding){
  ng <- length(grobs)
  g <- gtable(widths = max(widths) + padding, heights = heights)
  groups <- split(seq.int(n), rep(seq.int(ng), each=ceiling(n/ng), length.out=n))
    for(jj in seq_along(grobs)){
      thiscol <- groups[[jj]]
      g <- gtable_add_grob(g, rectGrob(gp=gpar(fill="transparent", col="grey50",lwd=0.2)), z=0,
                           t=min(thiscol), l=1, b = max(thiscol),
                           r = 1, name="rect")
      g <- gtable_add_grob(g, segmentsGrob(1,0,1,1,gp=gpar(col="grey50",lwd=2)), z=0,
                            t=min(thiscol), l=1, b = max(thiscol),
                           r = 1, name="segment")
      g <- gtable_add_grob(g, grobs[jj],z=2,
                           t=min(thiscol), l=1, b = max(thiscol),
                           r = 1, name="text")
    }
  g
}

## TODO: use "" for empty cell, NA for multi-cell spanning.
makerow <- function(grobs, n, widths, heights, fill, padding){
  ng <- length(grobs)
  g <- gtable(widths = widths, heights = max(heights) + padding)
  groups <- split(seq.int(n), rep(seq.int(ng), each=ceiling(n/ng),length.out=n))
    for(jj in seq_along(grobs)){
      thisrow <- groups[[jj]]
      g <- gtable_add_grob(g, rectGrob(gp=gpar(fill="transparent",col="grey50",lwd=0.2)), z=0,
                           t=1, l=min(thisrow), b = 1,
                           r = max(thisrow),name="rect")
      g <- gtable_add_grob(g, segmentsGrob(0,0,1,0,gp=gpar(col="grey50",lwd=2)), z=0,
                           t=1, l=min(thisrow), b = 1,
                           r = max(thisrow),name="segment")
      g <- gtable_add_grob(g, grobs[jj],z=2,
                           t=1, l=min(thisrow), b = 1,
                           r = max(thisrow),name="text")
    }
  g
}

makeHeader <- function(header = NULL, fill=c("white","white"),
                       type=c("col","row"), padding = unit(c(2,2),"mm")){

  if(is.null(header)) return(nullGrob())
  type <- match.arg(type)
  header <- wrap_header(header)
  grobs <- lapply(header, lapply, textGrob,
                  gp=gpar(fontface=if(type=="row") "italic" else "bold"))

  lengths <- sapply(grobs, length)
  n <- max(lengths)
  
  heights <- lapply(grobs, findHeights)
  widths <- lapply(grobs, findWidths)
  ## header with all cells defines the widths
  all.widths <- do.call(unit.pmax, widths[lengths == n]) + padding[1]
  all.heights <- do.call(unit.pmax, heights[lengths == n]) + padding[2]
  
  if(type=="col"){
    gt <- mapply(makerow, grobs=grobs, heights=heights,  
                 MoreArgs=list(n=n, widths=all.widths, fill=fill, padding=padding[2]),
                 SIMPLIFY=FALSE)
    g <- Reduce(`rbind_gtable`, gt)
  } else {
    gt <- mapply(makecol, grobs=grobs, widths=widths, 
                 MoreArgs=list(n=n, heights=all.heights, fill=fill, padding=padding[1]),
                 SIMPLIFY=FALSE)
    g <- Reduce(`cbind_gtable`, gt)
  }
  g
}


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)

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

  ## 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)
  gl <- makeHeader(rows, t="row")
  gt <- makeHeader(cols, t="col")
  
  ## 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)
  
  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),
               cbind_gtable(gl, gc, size="last"), size="last")
  ## justify bottom-right corner
  vp <- viewport(x=unit(1,"npc"),
                 y=0.5*sum(gt$heights), just=c("right","bottom"))
  
  gtable_gTree(all, vp=vp)
  
}


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


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

grid.newpage()
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))
my.rows <- list(paste("sub", seq(1,nrow(d)/2)), expression(alpha, beta), rownames(d))
my.cols <- list("big header", colnames(d),expression(alpha, beta))
## gl <- makeHeader(my.rows, t="row")
## grid.draw(gl)

g2 <- tableGrob(d, rows = my.rows, cols=my.cols,
                widths=unit(1,"null"), heights=unit(1/nrow(d),"npc"))
grid.draw(g2)
grid.rect(gp=gpar(lty=3))


## https://github.com/talgalili/R-code-snippets/blob/master/tabular.cast_df.r
## library(tables)
## library(reshape)

## # getting our data ready
## names(airquality) <- tolower(names(airquality))
## airquality2 <- airquality
## airquality2$temp2 <- ifelse(airquality2$temp > median(airquality2$temp), "hot", "cold")
## aqm <- melt(airquality2, id=c("month", "day","temp2"), na.rm=TRUE)
## colnames(aqm)[4] <- "variable2"	# because otherwise the function is having problem when relying on the melt function of the cast object
## head(aqm,4)

## test <- tabular.cast_df(cast(aqm, month ~ variable2*temp2, c(mean,sd)))


## cnames <- apply(attr(test, "colLabels"), 1, function(r) r[!is.na(r)])
## rnames <- seq(1,nrow(test))

## grid.table(matrix(as.character(test), attr(test,"dim")[1]),
##            rows=rnames, cols=cnames, fill=grey(seq(0.3,0.8,length=30)))