visual_test/justification.r

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()
r-lib/gtable documentation built on Aug. 23, 2023, 12:15 a.m.