vcontext("Justification")
library(grid)
# Utility functions
# =====================================================================
# Make an empty frame for use later, with 2x2 grid of 2x2cm squares
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"))
# Make a list of four colored rectGrobs, increasing in size
inc_grobs <- function(...) {
# List of 4 colored grobs, increasing in size
grobs <- list()
for (i in 1:4) {
grobs[[i]] <- rectGrob(
width = unit(i/2, "cm"),
height = unit(i/2, "cm"),
gp = gpar(fill = rainbow(4)[i]),
...)
}
grobs
}
# Make a list of four colored rectGrobs, small and same size
small_grobs <- function() {
grobs <- list()
for (i in 1:4) {
grobs[[i]] <- rectGrob(
width = unit(1, "cm"),
height = unit(1, "cm"),
gp = gpar(fill = rainbow(4)[i]))
}
grobs
}
# Turn a list of grobs into a 2-row gtable
# 'size' is the height/width of each cell, in cm
make_gtable <- function(name, grobs, size = 4) {
gtable_matrix(name, matrix(grobs, nrow = 2),
widths = unit(rep(size, length(grobs)/2), "cm"),
heights = unit(rep(size, 2), "cm"))
}
# No justification
# =====================================================================
# Make the colored grobs and put them in a gtable
gt <- make_gtable("gt", inc_grobs())
save_vtest2("grobs, no justification", {
grid.newpage()
grid.draw(gtf)
grid.draw(gt)
})
# Justification by specifying 'just' in grobs
# =====================================================================
# Make the colored grobs with justification
# and put them in a gtable
gt_just <- make_gtable("gt_just", inc_grobs(y = 0, just = "bottom"))
save_vtest2("justification by specifying 'just' in grobs", {
grid.newpage()
grid.draw(gtf)
grid.draw(gt_just)
})
# Justification by specifying 'vp' in grobs
# =====================================================================
# List of 4 colored grobs, increasing in size
grobs_vp <- list()
for (i in 1:4) {
grobs_vp[[i]] <- rectGrob(
width = unit(i/2, "cm"),
height = unit(i/2, "cm"),
gp = gpar(fill = rainbow(4)[i]),
vp = viewport(y = 0, just = "bottom", height = unit(i/2, "cm")))
}
gt_vp <- make_gtable("gt_vp", grobs_vp)
save_vtest2("justification by specifying 'vp' in grobs", {
grid.newpage()
grid.draw(gtf)
grid.draw(gt_vp)
})
# Justification by wrapping grobs in gTree and setting 'vp' in gTree
# =====================================================================
grobs_gtvp <- list()
for (i in 1:4) {
grobs_gtvp[[i]] <- gTree(children = gList(rectGrob(
width = unit(i/2, "cm"),
height = unit(i/2, "cm"),
gp = gpar(fill = rainbow(4)[i]))),
vp = viewport(y = 0, just = "bottom", height = unit(i/2, "cm")))
}
gt_gtvp <- make_gtable("gt_gtvp", grobs_gtvp)
save_vtest2("Justification by wrapping grobs in gTree and setting 'vp' in gTree", {
grid.newpage()
grid.draw(gtf)
grid.draw(gt_gtvp)
})
# gtable in gtable, no justification
# =====================================================================
# Make the smaller gtable
gt_inner <- make_gtable("gt_inner", small_grobs(), size = 1)
# Make the outer wrapper gtable
grobs_outer <- inc_grobs()
# Set fourth grob to inner gtable
grobs_outer[[4]] <- gt_inner
gt_outer <- make_gtable("gt_outer", grobs_outer)
save_vtest2("gtable in gtable, no justification", {
grid.newpage()
grid.draw(gtf)
grid.draw(gt_outer)
})
# gtable in gtable, justification by specifying 'vp' in inner gtable
# =====================================================================
# Make the smaller gtable
gt_inner_vp <- make_gtable("gt_inner_vp", small_grobs(), size = 1)
gt_inner_vp <- editGrob(gt_inner_vp,
vp = viewport(y = 0, just = "bottom", height = gtable_height(gt_inner_vp)))
# Make the outer wrapper gtable
grobs_outer_vp <- inc_grobs()
# Set fourth grob to inner gtable
grobs_outer_vp[[4]] <- gt_inner_vp
gt_outer_vp <- make_gtable("grobs_outer_vp", grobs_outer_vp)
save_vtest2("gtable in gtable, justification by specifying 'vp' in inner gtable", {
grid.newpage()
grid.draw(gtf)
grid.draw(gt_outer_vp)
})
save_vtest2("inner gtable not nested, justification by specifying 'vp'", {
grid.newpage()
grid.draw(gtf)
grid.draw(gt_inner_vp)
})
# gtable in gtable with text, justification by specifying 'vp' in inner gtable
# =====================================================================
grobs_inner_vptext <- list(
textGrob("First cell", rot = 90),
rectGrob(width = unit(1, "cm"), height = unit(1, "cm"),
gp = gpar(fill = rainbow(4)[3])),
textGrob("The third cell", rot = 90),
rectGrob(width = unit(1, "cm"), height = unit(1, "cm"),
gp = gpar(fill = rainbow(4)[4])))
gt_inner_vptext <- gtable_matrix("gt_inner_vptext", matrix(grobs_inner_vptext, nrow = 2),
widths = unit(rep(1, 2), "cm"),
heights = unit.c(max(grobHeight(grobs_inner_vptext[[1]]),
grobHeight(grobs_inner_vptext[[3]])),
grobHeight(grobs_inner_vptext[[2]])))
gt_inner_vptext <- editGrob(gt_inner_vptext, vp = viewport(y = 0,
just = "bottom", height = gtable_height(gt_inner_vptext)))
# Make the outer wrapper gtable
grobs_outer_vptext <- inc_grobs()
# Set fourth grob to inner gtable
grobs_outer_vptext[[4]] <- gt_inner_vptext
gt_outer_vptext <- make_gtable("gt_outer_vptext", grobs_outer_vptext)
save_vtest2("gtable in gtable with text, justification by specifying 'vp' in inner gtable", {
grid.newpage()
grid.draw(gtf)
grid.draw(gt_outer_vptext)
})
end_vcontext()
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.