1#' @export
2#' @rdname geom_text
3#' @param label.padding Amount of padding around label. Defaults to 0.25 lines.
4#' @param label.r Radius of rounded corners. Defaults to 0.15 lines.
5#' @param label.size Size of label border, in mm.
6geom_label <- function(mapping = NULL, data = NULL,
7                       stat = "identity", position = "identity",
8                       ...,
9                       parse = FALSE,
10                       nudge_x = 0,
11                       nudge_y = 0,
12                       label.padding = unit(0.25, "lines"),
13                       label.r = unit(0.15, "lines"),
14                       label.size = 0.25,
15                       na.rm = FALSE,
16                       show.legend = NA,
17                       inherit.aes = TRUE) {
18  if (!missing(nudge_x) || !missing(nudge_y)) {
19    if (!missing(position)) {
20      abort("You must specify either `position` or `nudge_x`/`nudge_y`.")
21    }
22
23    position <- position_nudge(nudge_x, nudge_y)
24  }
25
26  layer(
27    data = data,
28    mapping = mapping,
29    stat = stat,
30    geom = GeomLabel,
31    position = position,
32    show.legend = show.legend,
33    inherit.aes = inherit.aes,
34    params = list(
35      parse = parse,
36      label.padding = label.padding,
37      label.r = label.r,
38      label.size = label.size,
39      na.rm = na.rm,
40      ...
41    )
42  )
43}
44
45
46#' @rdname ggplot2-ggproto
47#' @format NULL
48#' @usage NULL
49#' @export
50GeomLabel <- ggproto("GeomLabel", Geom,
51  required_aes = c("x", "y", "label"),
52
53  default_aes = aes(
54    colour = "black", fill = "white", size = 3.88, angle = 0,
55    hjust = 0.5, vjust = 0.5, alpha = NA, family = "", fontface = 1,
56    lineheight = 1.2
57  ),
58
59  draw_panel = function(self, data, panel_params, coord, parse = FALSE,
60                        na.rm = FALSE,
61                        label.padding = unit(0.25, "lines"),
62                        label.r = unit(0.15, "lines"),
63                        label.size = 0.25) {
64    lab <- data$label
65    if (parse) {
66      lab <- parse_safe(as.character(lab))
67    }
68
69    data <- coord$transform(data, panel_params)
70    if (is.character(data$vjust)) {
71      data$vjust <- compute_just(data$vjust, data$y)
72    }
73    if (is.character(data$hjust)) {
74      data$hjust <- compute_just(data$hjust, data$x)
75    }
76
77    grobs <- lapply(1:nrow(data), function(i) {
78      row <- data[i, , drop = FALSE]
79      labelGrob(lab[i],
80        x = unit(row$x, "native"),
81        y = unit(row$y, "native"),
82        just = c(row$hjust, row$vjust),
83        padding = label.padding,
84        r = label.r,
85        text.gp = gpar(
86          col = row$colour,
87          fontsize = row$size * .pt,
88          fontfamily = row$family,
89          fontface = row$fontface,
90          lineheight = row$lineheight
91        ),
92        rect.gp = gpar(
93          col = if (isTRUE(all.equal(label.size, 0))) NA else row$colour,
94          fill = alpha(row$fill, row$alpha),
95          lwd = label.size * .pt
96        )
97      )
98    })
99    class(grobs) <- "gList"
100
101    ggname("geom_label", grobTree(children = grobs))
102  },
103
104  draw_key = draw_key_label
105)
106
107labelGrob <- function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"),
108                      just = "center", padding = unit(0.25, "lines"), r = unit(0.1, "snpc"),
109                      default.units = "npc", name = NULL,
110                      text.gp = gpar(), rect.gp = gpar(fill = "white"), vp = NULL) {
111
112  if (length(label) != 1) {
113    abort("label must be of length 1")
114  }
115
116  if (!is.unit(x))
117    x <- unit(x, default.units)
118  if (!is.unit(y))
119    y <- unit(y, default.units)
120
121  gTree(label = label, x = x, y = y, just = just, padding = padding, r = r,
122    name = name, text.gp = text.gp, rect.gp = rect.gp, vp = vp, cl = "labelgrob")
123}
124
125#' @export
126makeContent.labelgrob <- function(x) {
127  hj <- resolveHJust(x$just, NULL)
128  vj <- resolveVJust(x$just, NULL)
129
130  t <- textGrob(
131    x$label,
132    x$x + 2 * (0.5 - hj) * x$padding,
133    x$y + 2 * (0.5 - vj) * x$padding,
134    just = c(hj, vj),
135    gp = x$text.gp,
136    name = "text"
137  )
138
139  r <- roundrectGrob(x$x, x$y, default.units = "native",
140    width = grobWidth(t) + 2 * x$padding,
141    height = grobHeight(t) + 2 * x$padding,
142    just = c(hj, vj),
143    r = x$r,
144    gp = x$rect.gp,
145    name = "box"
146  )
147
148  setChildren(x, gList(r, t))
149}
150