multiple header lines

header.r

library(gtable)

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[[1]])) x  else  list(x)

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

  
makeHeader <- function(header = NULL, fill=c("grey98","grey90"),
                       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]
  
  makecol <- function(ii){
    g <- gtable(widths = max(widths[[ii]]) + padding[1], heights = all.heights)
    groups <- split(seq.int(n), rep(seq.int(lengths[ii]), each=n/lengths[ii]))
    for(jj in seq_along(grobs[[ii]])){
      thiscol <- groups[[jj]]
      g <- gtable_add_grob(g, rectGrob(gp=gpar(fill=fill[ii])), z=0,
                           t=min(thiscol), l=1, b = max(thiscol),
                           r = 1, name="rect")
      g <- gtable_add_grob(g, grobs[[ii]][jj],z=2,
                           t=min(thiscol), l=1, b = max(thiscol),
                           r = 1, name="text")
    }
    g
  }
  
  makerow <- function(ii){
    g <- gtable(widths = all.widths, heights = max(heights[[ii]]) + padding[1])
    groups <- split(seq.int(n), rep(seq.int(lengths[ii]), each=n/lengths[ii]))
    for(jj in seq_along(grobs[[ii]])){
      thisrow <- groups[[jj]]
      g <- gtable_add_grob(g, rectGrob(gp=gpar(fill=fill[ii])), z=0,
                           t=1, l=min(thisrow), b = 1,
                           r = max(thisrow),name="rect")
      g <- gtable_add_grob(g, grobs[[ii]][jj],z=2,
                           t=1, l=min(thisrow), b = 1,
                           r = max(thisrow),name="text")
    }
    g
  }

  if(type=="col"){
    gt <- lapply(seq_along(grobs), makerow)
    g <- Reduce(`rbind_gtable`, gt)
  } else {
    gt <- lapply(seq_along(grobs), makecol)
    g <- Reduce(`cbind_gtable`, gt)
  }
  g
}




h <- c("hi", "there")
## h <- list(c("hi", "there"), c("then and there", "indeed"))

## h <- list(c("first", "second"),
##           paste("subheader",1:6))

g <- makeHeader(h, t="row")
g <- makeHeader(h, t="col")
grid.newpage()
grid.draw(g)