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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
#' Row and column binding for gtables.
#'
#' These functions are the parallels of the `matrix`/`data.frame` row and
#' column bindings. As such they work in the same way, except they have to take
#' care of additional attributes within the gtables. Most importantly it needs
#' to take care of the sizing of the final gtable, as the different gtables
#' going in may have different widths or heights. By default it tries to
#' calculate the maximum width/height among the supplied gtables, but other
#' options exists. Further, the relative layering of the grobs in each gtable
#' can be modified or left as-is.
#'
#' @param ... gtables to combine (`x` and `y`)
#' @param size How should the widths (for rbind) and the heights (for cbind)
#' be combined across the gtables: take values from `first`,
#' or `last` gtable, or compute the `min` or `max` values.
#' Defaults to `max`.
#' @param z A numeric vector indicating the relative z values of each gtable.
#' The z values of each object in the resulting gtable will be modified
#' to fit this order. If `NULL`, then the z values of obects within
#' each gtable will not be modified.
#'
#' @return A gtable object
#'
#' @name bind
#'
#' @examples
#' library(grid)
#' a <- rectGrob(gp = gpar(fill = "red"))
#' b <- circleGrob()
#' c <- linesGrob()
#'
#' row <- matrix(list(a, b), nrow = 1)
#' col <- matrix(list(a, b), ncol = 1)
#' mat <- matrix(list(a, b, c, nullGrob()), nrow = 2)
#'
#' row_gt <- gtable_matrix("demo", row, unit(c(1, 1), "null"), unit(1, "null"))
#' col_gt <- gtable_matrix("demo", col, unit(1, "null"), unit(c(1, 1), "null"))
#' mat_gt <- gtable_matrix("demo", mat, unit(c(1, 1), "null"), unit(c(1, 1), "null"))
#'
#' # cbind
#' c_binded <- cbind(mat_gt, col_gt, size = "first")
#' plot(c_binded)
#'
#' # rbind
#' r_binded <- rbind(mat_gt, row_gt, size = "last")
#' plot(r_binded)
#'
#' # Dimensions must match along bind direction
#' try(cbind(mat_gt, row_gt))
#'
NULL
#' @rdname bind
#' @method rbind gtable
#' @export
rbind.gtable <- function(..., size = "max", z = NULL) {
gtables <- list(...)
if (!is.null(z)) {
gtables <- z_arrange_gtables(gtables, z)
}
Reduce(function(x, y) rbind_gtable(x, y, size = size), gtables)
}
rbind_gtable <- function(x, y, size = "max") {
if (length(x$widths) != length(y$widths)) stop("x and y must have the same number of columns", call. = FALSE)
x_row <- length(x$heights)
y_row <- length(y$heights)
if (x_row == 0) return(y)
if (y_row == 0) return(x)
lay_x <- unclass(x$layout)
lay_y <- unclass(y$layout)
x$layout <- new_data_frame(list(
t = c(lay_x$t, lay_y$t + x_row),
l = c(lay_x$l, lay_y$l),
b = c(lay_x$b, lay_y$b + x_row),
r = c(lay_x$r, lay_y$r),
z = c(lay_x$z, lay_y$z),
clip = c(lay_x$clip, lay_y$clip),
name = c(lay_x$name, lay_y$name)
))
x$heights <- insert.unit(x$heights, y$heights)
x$rownames <- c(x$rownames, y$rownames)
size <- match.arg(size, c("first", "last", "max", "min"))
x$widths <- switch(size,
first = x$widths,
last = y$widths,
min = compare_unit(x$widths, y$widths, pmin),
max = compare_unit(x$widths, y$widths, pmax)
)
x$grobs <- append(x$grobs, y$grobs)
x
}
#' @rdname bind
#' @method cbind gtable
#' @export
cbind.gtable <- function(..., size = "max", z = NULL) {
gtables <- list(...)
if (!is.null(z)) {
gtables <- z_arrange_gtables(gtables, z)
}
Reduce(function(x, y) cbind_gtable(x, y, size = size), gtables)
}
cbind_gtable <- function(x, y, size = "max") {
if (length(x$heights) != length(y$heights)) stop("x and y must have the same number of rows", call. = FALSE)
x_col <- length(x$widths)
y_col <- length(y$widths)
if (x_col == 0) return(y)
if (y_col == 0) return(x)
lay_x <- unclass(x$layout)
lay_y <- unclass(y$layout)
x$layout <- new_data_frame(list(
t = c(lay_x$t, lay_y$t),
l = c(lay_x$l, lay_y$l + x_col),
b = c(lay_x$b, lay_y$b),
r = c(lay_x$r, lay_y$r + x_col),
z = c(lay_x$z, lay_y$z),
clip = c(lay_x$clip, lay_y$clip),
name = c(lay_x$name, lay_y$name)
))
x$widths <- insert.unit(x$widths, y$widths)
x$colnames <- c(x$colnames, y$colnames)
size <- match.arg(size, c("first", "last", "max", "min"))
x$heights <- switch(size,
first = x$heights,
last = y$heights,
min = compare_unit(x$heights, y$heights, pmin),
max = compare_unit(x$heights, y$heights, pmax)
)
x$grobs <- append(x$grobs, y$grobs)
x
}
|
