combine header and table matrix version

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
}


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


row_header_cells <- function(m){
  t_m <- t(m)
  n_cols <- ncol(m)
  ind_non_na <- which(!is.na(t_m), TRUE)
  start_points <- split(ind_non_na[, 1], ind_non_na[, 2])
  
  lapply(seq_along(start_points), 
    function(ii)
    {
      x <- start_points[[ii]]
      len <- c(diff(x), n_cols - x[length(x)] + 1L)
      mapply(seq, x, length.out = len, SIMPLIFY = FALSE)
    }
  )

}

col_header_cells <- function(m){
  n_rows <- nrow(m)
  ind_non_na <- which(!is.na(m), TRUE)
  start_points <- split(ind_non_na[, 1], ind_non_na[, 2])
  
  lapply(seq_along(start_points), 
    function(ii)
    {
      x <- start_points[[ii]]
      len <- c(diff(x), n_rows - x[length(x)] + 1L)
      print(x)
      mapply(seq, x, length.out = len, SIMPLIFY = FALSE)
    }
  )

}

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

  if(is.null(header)) return(nullGrob())
  
  grobs <- apply(header, 1, function(row)
                 lapply(row[!is.na(row)], textGrob,
                        gp=gpar(fontface= "bold")))
  
  cells <- row_header_cells(header)
  
  lengths <- sapply(grobs, length)
  n <- max(lengths)
  
  all.widths <- lapply(grobs, findWidths)
  ## header with all cells defines the widths
  widths <- do.call(unit.pmax, all.widths[lengths == n]) + padding[1]
  heights <- do.call(unit.c, lapply(grobs, function(lg) max(findHeights(lg))))+ padding[2]
  
  gt <-  gtable(widths = widths, heights = heights, name = "header")
  
  for(ii in seq_along(cells)){
    row <- cells[[ii]]
  for(jj in seq_along(row)){
    gt <-  gtable_add_grob(gt, rectGrob(gp=gpar(lwd=0.1)), t=ii,
                           l=min(row[[jj]]), b = ii, r = max(row[[jj]]),
                           z = 1,name="rect")
    gt <-  gtable_add_grob(gt, grobs[[ii]][[jj]], t=ii,
                           l=min(row[[jj]]), b = ii, r = max(row[[jj]]),
                           z = -1,name="text")

  }
}
  gt
}

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

  if(is.null(header)) return(nullGrob())
  
  grobs <- apply(header, 2, function(col)
                 lapply(col[!is.na(col)], textGrob,
                        gp=gpar(fontface= "bold")))
  
  cells <- col_header_cells(header)
  
  lengths <- sapply(grobs, length)
  n <- max(lengths)
  
  all.heights <- lapply(grobs, findHeights)
  ## header with all cells defines the widths
  heights <- do.call(unit.pmax, all.heights[lengths == n]) + padding[2]
  widths <- do.call(unit.c, lapply(grobs, function(lg) max(findWidths(lg)))) + padding[1]
  ## print(widths)
  ## widths <- unit(rep(1, ncol(header)),"null")
  ## heights <- unit(rep(1, nrow(header)),"null")
  
  gt <-  gtable(widths = widths, heights = heights, name = "header")
  
  for(ii in seq_along(cells)){
    col <- cells[[ii]]
  for(jj in seq_along(col)){
    gt <-  gtable_add_grob(gt, rectGrob(gp=gpar(lwd=0.1)), l=ii,
                           t=min(col[[jj]]), r = ii, b = max(col[[jj]]),
                           z = 1, name="rect")
    gt <-  gtable_add_grob(gt, grobs[[ii]][[jj]], l=ii,
                           t=min(col[[jj]]), r = ii, b = max(col[[jj]]),
                           z = -1,name="text")

  }
}
  gt
}







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)
  gt <- makeRowHeader(t(cols))
  gl <- makeColHeader(matrix(rows))
  ## browser()
  ## 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"))
  ## print("ok")
  all <- rbind_gtable(
               cbind_gtable(empty, gt, "last"),
               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)"
rownames(d) <- c(1,2,3,4,5,"very\nhigh\nindeed")
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)))

table2table <- function(table){
  grid.newpage()
  
  grid.table(table, attr(table, "rowLabels"), t(attr(table, "colLabels")))
  

}

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

table2table(a)