baptiste/tableGrob_theme.r

## tableGrob_theme.r
library(gtable)
library(plyr)

library(methods)

theme <- setRefClass("theme", fields = list( bg = "vector",
                                             fg = "vector",
                                             colours = "vector",
                                             font = "list",
                                             row_font = "list",
                                             col_font = "list",
                                             core_font = "list",
                                             cell_function = "function"),
                     methods = list(set_fonts = function(...){
                       temp <- modifyList(font, list(col=colours[1]))
                       font <<- modifyList(temp, list(...))
                       row_font <<- modifyList(font, row_font)
                       col_font <<- modifyList(font, col_font)
                       core_font <<- modifyList(font, core_font)
                     },
                                    set_colours = function(...){
                                      colours <<- unlist(list(...))
                                    }, set_fg = function(...){
                                      fg <<- unlist(list(...))
                                    }, set_bg = function(...){
                                      bg <<- unlist(list(...))
                                    } ))

theme_default <- new( "theme", bg = c("grey90","grey98"),
                      fg = "grey50",
                      colours = c(low = "black", high = "red"),
                      font = list(fontfamily="Helvetica", fontsize=11),
                      row_font = list(fontface="italic", fontsize=10),
                      col_font = list(fontface="bold", fontsize=12),
                      core_font = list(fontfamily="mono", fontsize=12,col="black"),
                      cell_function = grid::textGrob )

## 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, theme=theme_default,
                          type = c("row","col"), font=theme$font,
                          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, theme$cell_function, gp=do.call(gpar, font), ...)
  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") <- if(type==1) widths[[which(sapply(widths, length) == n)]] else
    do.call(unit.c, lapply(widths, max))
  attr(d, "heights") <- if(type==2) heights[[which(sapply(heights, length) == n)]] 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])

  ## 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, col=theme$colours[1])) else
                                     segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
                                                  x1 = unit(1, "npc"), y1 = unit(0, "npc"),
                                                  gp=gpar(lwd=0.5, col=theme$colours[1]))
  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("", "a", 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, rows=rownames(d), cols=colnames(d),
                      theme=theme_default,
                      parse=TRUE, widths=NULL, heights=NULL,
                      fill=c("grey95",NA), padding = unit(c(2,2),"mm"),
                      just=c("centre", "centre"), ...){
  theme$set_bg(fill)
  theme$set_fonts(list())

  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$bg, 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=do.call(gpar, theme$core_font)), 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_header(cols, type="row", theme=theme, font=theme$col_font)
  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", theme=theme, font=theme$row_font)

  gl <- gtable_add_grob(gl, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$colours[1])),
                        l=1, r=ncol(gl), t=1, b=nrow(gl), z=Inf, name="boxfg")

  gt <- gtable_add_grob(gt, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$colours[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=0.5, col=theme$fg))
  hg <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
                     x1 = unit(1, "npc"), y1 = unit(0, "npc"),gp=gpar(lwd=0.5, col=theme$fg))

  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=NA, col=theme$fg)),
                         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, col="white",lwd=2)),
                         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"))

all$vp <- vp
  all
}


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,fill=c("grey","red",rep("grey90",4)))
#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(gp)

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

	library(methods)

	theme <- setRefClass("theme", fields = list( bg = "vector",
	fg = "vector",
	colours = "vector",
	font = "list",
	row_font = "list",
	col_font = "list",
	core_font = "list",
	cell_function = "function"),
	methods = list(set_fonts = function(...){
	temp <- modifyList(font, list(col=colours[1]))
	font <<- modifyList(temp, list(...))
	row_font <<- modifyList(font, row_font)
	col_font <<- modifyList(font, col_font)
	core_font <<- modifyList(font, core_font)
	},
	set_colours = function(...){
	colours <<- unlist(list(...))
	}, set_fg = function(...){
	fg <<- unlist(list(...))
	}, set_bg = function(...){
	bg <<- unlist(list(...))
	} ))

	theme_default <- new( "theme", bg = c("grey90","grey98"),
	fg = "grey50",
	colours = c(low = "black", high = "red"),
	font = list(fontfamily="Helvetica", fontsize=11),
	row_font = list(fontface="italic", fontsize=10),
	col_font = list(fontface="bold", fontsize=12),
	core_font = list(fontfamily="mono", fontsize=12,col="black"),
	cell_function = grid::textGrob )

	## 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, theme=theme_default,
	type = c("row","col"), font=theme$font,
	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, theme$cell_function, gp=do.call(gpar, font), ...)
	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") <- if(type==1) widths[[which(sapply(widths, length) == n)]] else
	do.call(unit.c, lapply(widths, max))
	attr(d, "heights") <- if(type==2) heights[[which(sapply(heights, length) == n)]] 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])

	## 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, col=theme$colours[1])) else
	segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
	x1 = unit(1, "npc"), y1 = unit(0, "npc"),
	gp=gpar(lwd=0.5, col=theme$colours[1]))
	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("", "a", 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, rows=rownames(d), cols=colnames(d),
	theme=theme_default,
	parse=TRUE, widths=NULL, heights=NULL,
	fill=c("grey95",NA), padding = unit(c(2,2),"mm"),
	just=c("centre", "centre"), ...){
	theme$set_bg(fill)
	theme$set_fonts(list())

	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$bg, 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=do.call(gpar, theme$core_font)), 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_header(cols, type="row", theme=theme, font=theme$col_font)
	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", theme=theme, font=theme$row_font)

	gl <- gtable_add_grob(gl, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$colours[1])),
	l=1, r=ncol(gl), t=1, b=nrow(gl), z=Inf, name="boxfg")

	gt <- gtable_add_grob(gt, rectGrob(gp=gpar(lwd=0.8,fill=NA, col=theme$colours[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=0.5, col=theme$fg))
	hg <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
	x1 = unit(1, "npc"), y1 = unit(0, "npc"),gp=gpar(lwd=0.5, col=theme$fg))

	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=NA, col=theme$fg)),
	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, col="white",lwd=2)),
	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"))

	all$vp <- vp
	all
	}


	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,fill=c("grey","red",rep("grey90",4)))
	#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(gp)

	# library(tables)