1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
#' Visualise the layout of a gtable.
#'
#' This function is a simple wrapper around [grid::grid.show.layout()] that
#' allows you to inspect the layout of the gtable.
#'
#' @param x a gtable object
#' @inheritDotParams grid::grid.show.layout
#'
#' @export
#'
#' @examples
#' gt <- gtable(widths = grid::unit(c(1, 0.5, 2), c("null", "cm", "null")),
#' heights = grid::unit(c(0.2, 1, 3), c("inch", "null", "cm")))
#' gtable_show_layout(gt)
#'
gtable_show_layout <- function(x, ...) {
if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE)
grid.show.layout(gtable_layout(x), ...)
}
gtable_layout <- function(x) {
if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE)
grid.layout(
nrow = length(x$heights), heights = x$heights,
ncol = length(x$widths), widths = x$widths,
respect = x$respect
)
}
vpname <- function(row) {
row <- unclass(row)
paste(row$name, ".", row$t, "-", row$r, "-", row$b, "-", row$l, sep = "")
}
#' @export
widthDetails.gtable <- function(x) absolute.size(gtable_width(x))
#' @export
heightDetails.gtable <- function(x) absolute.size(gtable_height(x))
#' @export
makeContext.gtable <- function(x) {
layoutvp <- viewport(layout = gtable_layout(x), name = x$name)
if (is.null(x$vp)) {
x$vp <- layoutvp
} else {
x$vp <- vpStack(x$vp, layoutvp)
}
x
}
#' @export
makeContent.gtable <- function(x) {
children_vps <- mapply(child_vp,
vp_name = vpname(x$layout),
t = .subset2(x$layout, "t"), r = .subset2(x$layout, "r"),
b = .subset2(x$layout, "b"), l = .subset2(x$layout, "l"),
clip = x$layout$clip,
SIMPLIFY = FALSE
)
x$grobs <- mapply(wrap_gtableChild, x$grobs, children_vps,
SIMPLIFY = FALSE
)
setChildren(x, do.call("gList", x$grobs[order(.subset2(x$layout, "z"))]))
}
#' @export
makeContext.gTableChild <- function(x) {
if (is.null(x$vp)) {
x$vp <- x$wrapvp
} else {
x$vp <- vpStack(x$wrapvp, x$vp)
}
# A gTableChild extends an arbitrary grob class
# so allow existing makeContext() behaviour of
# original grob class to still occur
NextMethod()
}
# Return the viewport for a child grob in a gtable
child_vp <- function(vp_name, t, r, b, l, clip) {
viewport(
name = vp_name, layout.pos.row = t:b,
layout.pos.col = l:r, clip = clip
)
}
# Turn a grob into a gtableChild, and store information about the
# viewport used within the gtable
wrap_gtableChild <- function(grob, vp) {
grob$wrapvp <- vp
grob$name <- vp$name
class(grob) <- c("gTableChild", class(grob))
grob
}
|
