1#' Add a single grob, possibly spanning multiple rows or columns.
2#'
3#' This only adds grobs into the table - it doesn't affect the table layout in
4#' any way.  In the gtable model, grobs always fill up the complete table
5#' cell.  If you want custom justification you might need to define the grob
6#' dimension in absolute units, or put it into another gtable that can then be
7#' added to the gtable instead of the grob.
8#'
9#' @param x a [gtable()] object
10#' @param grobs a single grob or a list of grobs
11#' @param t a numeric vector giving the top extent of the grobs
12#' @param l a numeric vector giving the left extent of the grobs
13#' @param b a numeric vector giving the bottom extent of the grobs
14#' @param r a numeric vector giving the right extent of the grobs
15#' @param z a numeric vector giving the order in which the grobs should be
16#'   plotted.  Use `Inf` (the default) to plot above or `-Inf`
17#'   below all existing grobs. By default positions are on the integers,
18#'  giving plenty of room to insert new grobs between existing grobs.
19#' @param clip should drawing be clipped to the specified cells
20#'   (`"on"`), the entire table (`"inherit"`), or not at all
21#'   (`"off"`)
22#' @param name name of the grob - used to modify the grob name before it's
23#'   plotted.
24#'
25#' @return A gtable object with the new grob(s) added
26#'
27#' @family gtable manipulation
28#'
29#' @export
30#'
31#' @examples
32#' library(grid)
33#'
34#' gt <- gtable(widths = unit(c(1, 1), 'null'), heights = unit(c(1, 1), 'null'))
35#' pts <- pointsGrob(x = runif(5), y = runif(5))
36#'
37#' # Add a grob to a single cell (top-right cell)
38#' gt <- gtable_add_grob(gt, pts, t = 1, l = 2)
39#'
40#' # Add a grob spanning multiple cells
41#' gt <- gtable_add_grob(gt, pts, t = 1, l = 1, b = 2)
42#'
43#' plot(gt)
44#'
45gtable_add_grob <- function(x, grobs, t, l, b = t, r = l, z = Inf, clip = "on", name = x$name) {
46  if (!is.gtable(x)) stop("x must be a gtable", call. = FALSE)
47  if (is.grob(grobs)) grobs <- list(grobs)
48  if (!is.list(grobs)) stop("grobs must either be a single grob or a list of grobs", call. = FALSE)
49  n_grobs <- length(grobs)
50
51  if (is.logical(clip)) {
52    clip <- ifelse(clip, "on", "off")
53  }
54
55  layout <- unclass(x$layout)
56
57  # Check that inputs have the right length
58  if (!all(vapply(
59    list(t, r, b, l, z, clip, name), len_same_or_1,
60    logical(1), n_grobs
61  ))) {
62    stop("Not all inputs have either length 1 or same length same as 'grobs'")
63  }
64
65  # If z is just one value, replicate to same length as grobs
66  z <- rep(z, length.out = n_grobs)
67
68  # Get the existing z values from x$layout, and new non-Inf z-values
69  zval <- c(layout$z, z[!is.infinite(z)])
70  if (length(zval) == 0) {
71    # If there are no existing finite z values, set these so that
72    # -Inf values get assigned ..., -2, -1, 0 and
73    # +Inf values get assigned 1, 2, 3, ...
74    zmin <- 1
75    zmax <- 0
76  } else {
77    zmin <- min(zval)
78    zmax <- max(zval)
79  }
80  z[z == -Inf] <- zmin - rev(seq_len(sum(z == -Inf)))
81  z[z == Inf] <- zmax + seq_len(sum(z == Inf))
82
83  x_row <- length(x$heights)
84  x_col <- length(x$widths)
85
86  t <- rep(neg_to_pos(t, x_row), length.out = n_grobs)
87  b <- rep(neg_to_pos(b, x_row), length.out = n_grobs)
88  l <- rep(neg_to_pos(l, x_col), length.out = n_grobs)
89  r <- rep(neg_to_pos(r, x_col), length.out = n_grobs)
90  clip <- rep(clip, length.out = n_grobs)
91  name <- rep(name, length.out = n_grobs)
92
93  x$grobs <- c(x$grobs, grobs)
94
95  x$layout <- new_data_frame(list(
96    t = c(layout$t, t),
97    l = c(layout$l, l),
98    b = c(layout$b, b),
99    r = c(layout$r, r),
100    z = c(layout$z, z),
101    clip = c(layout$clip, clip),
102    name = c(layout$name, name)
103  ))
104
105  x
106}
107