Skip to content

@baptiste /tablegrob
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tablegrob
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
Something went wrong with that request. Please try again.