Created
May 11, 2013 22:54
-
-
Save baptiste/5561717 to your computer and use it in GitHub Desktop.
tablegrob
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
library(gtable) | |
library(plyr) | |
library(grid) | |
table_theme <- function(bg = c("grey95", "grey98"), | |
fg = c("black", "black"), | |
just=c("center","center"), | |
separator = list(h=FALSE, v=TRUE), box = FALSE, | |
core = list(bg=bg, fg=fg, separator=separator, box=box, just=just), | |
row_header = core, | |
col_header = modifyList(core, list(just=c("right", "center")))){ | |
list(bg=bg, fg=fg, separator=separator, box=box, | |
core=core, row_header=row_header, col_header=col_header) | |
} | |
# table_theme() | |
## build a rectGrob with parameters | |
cellRect <- function(fill=NA) | |
rectGrob(gp=gpar(fill=fill, col=NA)) | |
cellText <- function(label, colour="black", hjust=c("left", "center", "right"), ...) { | |
hjust <- match.arg(hjust) | |
x <- switch(hjust, | |
"left" = 0, | |
"center"=0.5, | |
"right"=1) | |
textGrob(label, x=x, hjust=x, gp=gpar(col=colour, ...)) | |
} | |
# | |
# g <- cellText("test", hjust="left") | |
# grid.draw(g) | |
## 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)) | |
gtable_rowheader <- function(header, n = NULL, theme=table_theme()$row_header, | |
padding=unit(rep(2,2),"mm"), ...){ | |
type <- 1L | |
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 | |
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) <- c("label","l","r","t","b") | |
## make grobs | |
d$grobs <- lapply(d$label, cellText, hjust=theme$just[1]) | |
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)) | |
## extract widths and heights relevant to the layout | |
attr(d, "widths") <- widths[[which(sapply(widths, length) == n)]] | |
attr(d, "heights") <- 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]) | |
## vertical/horizontal separators | |
sg <- segmentsGrob(x0 = unit(1, "npc"), y0 = unit(0, "npc"), | |
x1 = unit(1, "npc"), y1 = unit(1, "npc"), | |
gp=gpar(lwd=1, col=theme$fg[1])) | |
d2 <- subset(d, r < n) | |
if(theme$separator$v) | |
g <- with(d2, gtable_add_grob(g, replicate(length(d2$grobs), sg, simplify=FALSE), | |
t, l, b, r, z=1, name="sep")) | |
g <- with(d, gtable_add_grob(g, grobs, t, l, b, r, z=0, name="text")) | |
g | |
} | |
## NAs are used to indicate grobs that span multiple cells | |
gtable_colheader <- function(header, n = NULL, theme=table_theme()$col_header, | |
padding=unit(rep(2,2),"mm"), ...){ | |
type <- 2L | |
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 | |
label <- header[!is.na(header)] | |
d <- data.frame(label = label, | |
start=unlist(start), end=unlist(end), fixed, fixed, | |
stringsAsFactors=FALSE) | |
names(d) <- c("label","t","b","l","r") | |
## make grobs | |
d$grobs <- lapply(d$label, cellText, hjust=theme$just[1]) | |
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)) | |
## extract widths and heights relevant to the layout | |
attr(d, "widths") <- do.call(unit.c, lapply(widths, max)) | |
attr(d, "heights") <- heights[[which(sapply(heights, length) == n)]] | |
## create gtable | |
g <- gtable() | |
g <- gtable_add_cols(g, attr(d,"widths") + padding[1]) | |
g <- gtable_add_rows(g, attr(d,"heights")+ padding[2]) | |
## vertical/horizontal separators | |
sg <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"), | |
x1 = unit(1, "npc"), y1 = unit(0, "npc"), | |
gp=gpar(lwd=1, col=theme$fg[1])) | |
d2 <- subset(d, b < n) | |
if(theme$separator$h) | |
g <- with(d2, gtable_add_grob(g, replicate(length(d2$grobs), sg, simplify=FALSE), | |
t, l, b, r, z=1, name="sep")) | |
g <- with(d, gtable_add_grob(g, grobs, t, l, b, r, z=0, name="text")) | |
g | |
} | |
# h <- matrix(c("", "a", NA, "b", NA, paste("cell", 1:5)), nrow=2, byrow=TRUE) | |
# g <- gtable_rowheader(h) | |
# g2 <- gtable_colheader(t(h)) | |
# g <- gtable_rowheader(h, theme=table_theme(bg = "black", sep=T)$row_header) | |
# g2 <- gtable_colheader(t(h),theme=table_theme(bg = "black", sep=T)$col_header) | |
# grid.newpage() | |
# grid.draw(g) | |
tableGrob <- function(d, rows=rownames(d), cols=colnames(d), | |
theme=table_theme(), | |
parse=TRUE, widths=NULL, heights=NULL, | |
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(theme$core$bg, length=n) | |
ccolour <- rep(theme$core$fg, length=n) | |
## try parsing the labels (plotmath) | |
if(parse){ | |
content <- lapply(content, tryparse) | |
} | |
## make the text grobs | |
cgrobst <- mapply(cellText, label=content, colour=ccolour, | |
MoreArgs=list(hjust=theme$core$just[1]), | |
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 <- if(is.null(cols)) gtable_matrix("cols", matrix(list(nullGrob()), ncol=nc, nr=1), | |
cwidths, unit(0,"mm")) else | |
gtable_rowheader(cols, theme=theme$row_header) | |
gl <- if(is.null(rows)) gtable_matrix("rows", matrix(list(nullGrob()), nrow=nr, nc=1), | |
unit(0,"mm"), cheights) else | |
gtable_colheader(rows, theme=theme$col_header) | |
if(theme$row_header$box) | |
gl <- gtable_add_grob(gl, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$row_header$fg[1])), | |
l=1, r=ncol(gl), t=1, b=nrow(gl), z=Inf, name="boxfg") | |
if(theme$col_header$box) | |
gt <- gtable_add_grob(gt, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$col_header$fg[1])), | |
l=1, r=ncol(gt), t=1, b=nrow(gt), z=Inf, name="boxfg") | |
## 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=1, col=theme$core$fg[1])) | |
hg <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"), | |
x1 = unit(1, "npc"), y1 = unit(0, "npc"), | |
gp=gpar(lwd=1, col=theme$core$fg[1])) | |
vp <- seq.int(nc-1) ; hp <- seq.int(nr-1) | |
gvr <- replicate(nc-1, vg, simplify=FALSE) | |
ghr <- replicate(nr-1, hg, simplify=FALSE) | |
if(theme$core$separator$v) | |
ngc <- gtable_add_grob(gc, gvr, l=vp, r=vp, t=1, b=nr, z=Inf, name="vsep") | |
if(theme$core$separator$h) | |
ngc <- gtable_add_grob(ngc, ghr, l=1, r=nc, t=hp, b=hp, z=Inf, name="hsep") | |
if(theme$core$box) | |
ngc <- gtable_add_grob(ngc, rectGrob(gp=gpar(col=NA,fill=NA, col=theme$core$fg[1])), | |
l=1, r=nc, t=1, b=nr, z=-Inf, name="boxbg") | |
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")) | |
all$vp <- vp | |
all | |
} | |
grid.table <- function(...) | |
grid.draw(tableGrob(...)) | |
## tests | |
d <- head(iris,20) | |
# 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,fill=c("grey","red",rep("grey90",4))) | |
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)) | |
g2 <- tableGrob(d, widths=unit(1,"null"), heights=unit(1/nrow(d),"npc")) | |
grid.draw(g2) | |
grid.rect() |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment