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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
# Code does not currently work - need to thinking about how indexing a gtable
# should work in more detail. How do the grobs move around?
# Join two gtables together based on row/column names.
#
# @inheritParams gtable_align
# @param along dimension to align along, \code{1} = rows, \code{2} = cols.
# Join will occur perpendicular to this direction.
# @examples
# rect <- rectGrob(gp = gpar(fill = "black"))
# circ <- circleGrob(gp = gpar(fill = "red"))
# a <- gtable_col("a", list(rect, circ), width = unit(5, "cm"))
# rownames(a) <- c("top", "mid")
# b <- gtable_col("b", list(circ, rect), width = unit(5, "cm"))
# rownames(b) <- c("mid", "bot")
#
# # Commented out example below because it causes R CMD check to fail
# # when this function is not exported. Uncomment when this function
# # is fixed and exported again.
# # gtable_join(a, b)
gtable_join <- function(x, y, along = 1L, join = "left") {
aligned <- gtable_align(x, y, along = along, join = join)
switch(along,
cbind(aligned$x, aligned$y),
rbind(aligned$x, aligned$y),
cli::cli_abort("{.arg along} > 2 no implemented")
)
}
# Align two gtables based on their row/col names.
#
# @param x \code{\link{gtable}}
# @param y \code{\link{gtable}}
# @param along dimension to align along, \code{1} = rows, \code{2} = cols.
# @param join when x and y have different names, how should the difference
# be resolved? \code{inner} keep names that appear in both, \code{outer}
# keep names that appear in either, \code{left} keep names from \code{x},
# and \code{right} keep names from \code{y}.
# @seealso \code{\link{gtable_join}} to return the two gtables combined
# in to a single gtable.
# @return a list with elements \code{x} and \code{y} corresponding to the
# input gtables with extra rows/columns so that they now align.
gtable_align <- function(x, y, along = 1L, join = "left") {
join <- arg_match0(join, c("left", "right", "inner", "outer"))
names_x <- dimnames(x)[[along]]
names_y <- dimnames(y)[[along]]
if (is.null(names_x) || is.null(names_y)) {
cli::cli_abort("Both gtables must have names along dimension to be aligned")
}
idx <- switch(join,
left = names_x,
right = names_y,
inner = intersect(names_x, names_y),
outer = union(names_x, names_y)
)
list(
x = gtable_reindex(x, idx, along),
y = gtable_reindex(y, idx, along)
)
}
# Reindex a gtable.
#
# @keywords internal
# @examples
# gt <- gtable(heights = unit(rep(1, 3), "cm"), rownames = c("a", "b", "c"))
# rownames(gtable:::gtable_reindex(gt, c("a", "b", "c")))
# rownames(gtable:::gtable_reindex(gt, c("a", "b")))
# rownames(gtable:::gtable_reindex(gt, c("a")))
# rownames(gtable:::gtable_reindex(gt, c("a", "d", "e")))
gtable_reindex <- function(x, index, along = 1) {
check_character(index)
if (length(dim(x)) > 2L || along > 2L) {
cli::cli_abort("only 2d objects can be reindexed")
}
old_index <- switch(along, rownames(x), colnames(x))
if (is.null(old_index)) {
cli::cli_abort("{.arg index} is NULL in the given dimension")
}
if (identical(index, old_index)) {
return(x)
}
if (!(old_index %contains% index)) {
missing <- setdiff(index, old_index)
# Create and add dummy space rows
if (along == 1L) {
spacer <- gtable(
widths = unit(rep(0, length(x$widths)), "cm"),
heights = rep_along(unit(0, "cm"), missing),
rownames = missing
)
x <- rbind(x, spacer, size = "first")
} else if (along == 2L) {
spacer <- gtable(
heights = unit(rep(0, length(x$heights)), "cm"),
widths = rep_along(unit(0, "cm"), missing),
colnames = missing
)
x <- cbind(x, spacer, size = "first")
}
}
# Reorder & subset
switch(along,
x[index, ],
x[, index]
)
}
"%contains%" <- function(x, y) all(y %in% x)
rep_along <- function(x, y) {
if (length(y) == 0) return(NULL)
rep(x, length(y))
}
|
