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