gtable tests

Source code for this page is at: https://gist.github.com/3145503

library(devtools)
dev_mode()

## Dev mode: ON

load_all("~/Dropbox/Projects/gtable")

## Loading gtable

Craete an empty frame for use later:

gtf <- gtable_matrix("gtf", matrix(rep(list(rectGrob(gp = gpar(fill = "grey95"))), 
    4), nrow = 2), widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), 
    "cm"))

Default

# List of 4 grobs
gs <- lapply(1:4, function(x) rectGrob(width = unit(x/2, "cm"), height = unit(x/2, "cm"),
                                       gp = gpar(fill = rainbow(4)[x])))

# Put them in a gtable matrix
gt <- gtable_matrix("gt", matrix(gs, nrow = 2), 
                    widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"))

grid.newpage()
grid.draw(gtf)
grid.draw(gt)

Justification by setting just in grobs

gs <- lapply(1:4, function(x) rectGrob(width = unit(x/2, "cm"), height = unit(x/2, "cm"),
                                       y = 0, just = "bottom",
                                       gp = gpar(fill = rainbow(4)[x])))
gt <- gtable_matrix("gt", matrix(gs, nrow = 2), 
                    widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"))

grid.newpage()
grid.draw(gtf)
grid.draw(gt)

Justifcation by setting vp in grobs

gs <- lapply(1:4, function(x) 
  rectGrob(width = unit(x/2, "cm"), height = unit(x/2, "cm"),
           gp = gpar(fill = rainbow(4)[x]),
           vp = viewport(y = 0, just = "bottom", height = unit(x/2, "cm"))))

gt <- gtable_matrix("gt", matrix(gs, nrow = 2), 
                    widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"))

grid.newpage()
grid.draw(gtf)
grid.draw(gt)

Justification by wrapping each grob in a gTree

gs <- lapply(1:4, function(x) 
  gTree(children = gList(rectGrob(width = unit(x/2, "cm"), height = unit(x/2, "cm"),
                                  gp = gpar(fill = rainbow(4)[x]),
                                  vp = viewport(height = unit(x/2, "cm"), y = 0, just = "bottom")))))

gt <- gtable_matrix("gt", matrix(gs, nrow = 2), 
                    widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"))

grid.newpage()
grid.draw(gtf)
grid.draw(gt)

gtable inside a gtable

# Make the smaller gtable
gsc <- lapply(1:4, function(x) rectGrob(width = unit(1, "cm"), height = unit(1, "cm"),
                                        gp = gpar(fill = rainbow(4)[x])))
gtc <- gtable_matrix("gtc", matrix(gsc, nrow = 2),
                     widths = unit(rep(1, 2), "cm"), heights = unit(rep(1, 2), "cm"))

# Make the larger gtable and put the smaller one in it
gs <- lapply(1:3, function(x) rectGrob(width = unit(x/2, "cm"), height = unit(x/2, "cm"),
                                       gp = gpar(fill = rainbow(4)[x])))
gs[[4]] <- gtc
gt <- gtable_matrix("gt", matrix(gs, nrow = 2), 
                    widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"))

grid.newpage()
grid.draw(gtf)
grid.draw(gt)

gtable in gtable, with justification defined by viewport

gsc <- lapply(1:4, function(x) rectGrob(width = unit(1, "cm"), height = unit(1, "cm"),
                                        gp = gpar(fill = rainbow(4)[x])))
gtc <- gtable_matrix("gtc", matrix(gsc, nrow = 2),
                     widths = unit(rep(1, 2), "cm"), heights = unit(rep(1, 2), "cm"))
gtc <- editGrob(gtc, vp =  viewport(y = 0, just = "bottom", height = gtable_height(gtc)))


gs <- lapply(1:3, function(x) rectGrob(width = unit(x/2, "cm"), height = unit(x/2, "cm"),
                                       gp = gpar(fill = rainbow(4)[x])))

gs[[4]] <- gtc
gt <- gtable_matrix("gt", matrix(gs, nrow = 2), 
                    widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"))
grid.newpage()
grid.draw(gtf)
grid.draw(gt)

# boxes alone
grid.newpage()
grid.draw(gtc)

gtable on top of gtable

Both gtables are the same size, 4x4cm. One is centered; the other is bottom-justified.

grid.newpage()
gtf <- gtable_matrix("gtf", matrix(rep(list(rectGrob(gp = gpar(fill = "grey95"))), 4), nrow = 2), 
                     widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"))
grid.draw(gtf)

gs <- lapply(1:4, function(x) rectGrob(width = unit(x/2, "cm"), height = unit(x/2, "cm"),
                                       gp = gpar(fill = rainbow(4)[x])))
gt <- gtable_matrix("gt", matrix(gs, nrow = 2), 
                    widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"),
                    vp = viewport(y = 0, height = gtable_height(gt), just = "bottom"))

grid.draw(gt)

gtable in gtable, with some text, and justification defined by viewport

gsc <- list(textGrob("First cell", rot = 90),
            rectGrob(width = unit(1, "cm"), height = unit(1, "cm"),
              gp = gpar(fill = rainbow(4)[3])),
            textGrob("Third cell", rot = 90),
            rectGrob(width = unit(1, "cm"), height = unit(1, "cm"),
              gp = gpar(fill = rainbow(4)[4])))

gtc <- gtable_matrix("gtc", matrix(gsc, nrow = 2),
                     widths = unit(rep(1, 2), "cm"),
                     heights = unit.c(grobHeight(gsc[[1]]), grobHeight(gsc[[2]])))

gtc <- editGrob(gtc, vp =  viewport(y = 0, just = "bottom", height = gtable_height(gtc)))


gs <- lapply(1:3, function(x) rectGrob(width = unit(x/2, "cm"), height = unit(x/2, "cm"),
                                       gp = gpar(fill = rainbow(4)[x])))

gs[[4]] <- gtc
gt <- gtable_matrix("gt", matrix(gs, nrow = 2), 
                    widths = unit(rep(4, 2), "cm"), heights = unit(rep(4, 2), "cm"))
grid.newpage()
grid.draw(gtf)
grid.draw(gt)