header data.frame

header.r

library(gtable)
library(plyr)
library(tables)

## 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,
                          type = c("row","col"),
                          fun = textGrob, 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, fun, ...)
  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))

  ## first implementation: only care about complete row/col
  ## table_widths <- widths[[ which(sapply(widths, length) == n)[1] ]]
  ## table_heights <- heights[[ which(sapply(heights, length) == n)[1] ]]

  if(type == 1){
  rrepeats <- dlply(d, "t", function(.d) .d$r - .d$l + 1)
  
  table_widths <- do.call(unit.pmax, lapply(seq_along(widths), function(ii){
    n <- rrepeats[[ii]]
    rep(1/n * widths[[ii]], n)
  }))
  }

  if(type == 2){
  crepeats <- dlply(d, "l", function(.d) .d$b - .d$t + 1)
  table_heights <- do.call(unit.pmax, lapply(seq_along(heights), function(ii){
    n <- crepeats[[ii]]
    rep(1/n * heights[[ii]], n)
  }))
  }
  
  
  ## extract widths and heights relevant to the layout
  attr(d, "widths") <- if(type==1) table_widths else
                                   do.call(unit.c, lapply(widths, max))
  attr(d, "heights") <- if(type==2) table_heights 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])
  ## browser()

  ## 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)) else
  segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
               x1 = unit(1, "npc"), y1 = unit(0, "npc"),gp=gpar(lwd=0.5))
  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("", "aaaaaaaaaaaaa\nbbbbbbbbbbbb\ncc", 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, ...) {
   UseMethod("tableGrob", d)
}


tableGrob.data.frame <- tableGrob.matrix <- tableGrob_fun <-
  function(d, rows=rownames(d), cols=colnames(d),
           parse=TRUE, widths=NULL, heights=NULL,
           fill=c("grey95",NA), 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(fill, 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=gpar(col="black")), SIMPLIFY=FALSE)

  ## make the rect grobs
  cgrobsr <- mapply(cellRect, fill=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")
  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")
  ## 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)) 
  hg <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
                     x1 = unit(1, "npc"), y1 = unit(0, "npc"),gp=gpar(lwd=0.5))

  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="grey90")),
                         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)),
                         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"))
  
  gtable_gTree(all, vp=vp, ...)
  
}

tableGrob.tabular <- function(d, rows=attr(d, "rowLabels"), cols=attr(d, "colLabels"),
                              ...){
  m <- as.matrix(d, rowLabels = FALSE, colLabels = FALSE)
  tableGrob_fun(m, rows, cols, ...)
}

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,gp=gpar(cex=1))
## 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,gp=gpar(cex=0.8), 
##                 widths=unit(1,"null"), heights=unit(1/nrow(d),"npc"))
## grid.draw(g2)
## grid.rect(gp=gpar(lty=3))


library(tables)


tabular( (Species + 1) ~ (n=1) + Format(digits=2)*
          (Sepal.Length + Sepal.Width)*(mean + sd), data=iris ) -> a


## g <- gtable_header(attr(a, "rowLabels"), type="col")
## g2 <- gtable_header(attr(a, "colLabels"), type="row")

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


 g3 <- tableGrob(a, attr(a, "rowLabels"), attr(a, "colLabels"))

# This example shows some of the less common options         
Sex <- factor(sample(c("Male", "Female"), 100, rep=TRUE))
Status <- factor(sample(c("low", "medium", "high"), 100, rep=TRUE))
z <- rnorm(100)+5
fmt <- function(x) {
  s <- format(x, digits=2)
  even <- ((1:length(s)) %% 2) == 0
  s[even] <- sprintf("(%s)", s[even])
  s
}
b <- tabular( Justify(c)*Heading()*z*Sex*Heading(Statistic)*Format(fmt())*(mean+sd) ~ Status )

 g4 <- tableGrob(b)

 gridExtra::grid.arrange(g3,g4)