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
146
147
148
149
150
151
152
153
154
|
#' Create customizable legend key glyphs
#'
#' These functions create customizable legend key glyphs, such as filled rectangles or
#' circles.
#' @param colour,color Unquoted name of the aesthetic to use for the outline color,
#' usually `colour`, `color`, or `fill`. Can also be a color constant, e.g. `"red"`.
#' @param fill Unquoted name of the aesthetic to use for the fill color,
#' usually `colour`, `color`, or `fill`. Can also be a color constant, e.g. `"red"`.
#' @param alpha Unquoted name of the aesthetic to use for alpha,
#' usually `alpha`. Can also be a numerical constant, e.g. `0.5`.
#' @param size Unquoted name of the aesthetic to use for the line thickness of the
#' outline, usually `size`. Can also be a numerical constant, e.g. `0.5`.
#' @param linetype Unquoted name of the aesthetic to use for the line type of the
#' outline, usually `linetype`. Can also be a constant, e.g. `2`.
#' @param padding Unit vector with four elements specifying the top, right, bottom,
#' and left padding from the edges of the legend key to the edges of the key glyph.
#' @examples
#' library(ggplot2)
#'
#' set.seed(1233)
#' df <- data.frame(
#' x = sample(letters[1:2], 10, TRUE),
#' y = rnorm(10)
#' )
#'
#' ggplot(df, aes(x, y, color = x)) +
#' geom_boxplot(
#' key_glyph = rectangle_key_glyph(fill = color, padding = margin(3, 3, 3, 3))
#' )
#'
#' ggplot(df, aes(x, y, color = x)) +
#' geom_boxplot(
#' key_glyph = circle_key_glyph(
#' fill = color,
#' color = "black", linetype = 3, size = 0.3,
#' padding = margin(2, 2, 2, 2)
#' )
#' )
#' @export
rectangle_key_glyph <- function(colour = NA, fill = fill, alpha = alpha, size = size,
linetype = linetype, padding = unit(c(0, 0, 0, 0), "pt"),
color) {
colour_aes <- enquo(colour)
fill_aes <- enquo(fill)
alpha_aes <- enquo(alpha)
size_aes <- enquo(size)
linetype_aes <- enquo(linetype)
# enable US spelling
color <- enquo(color)
if (!quo_is_missing(color)) {
colour_aes <- color
}
function(data, params, size) {
if (is.null(data$size)) {
data$size <- 0.5
}
# enable US spelling
if (is.null(data$color)) {
data$color <- data$colour
}
lwd <- min(eval_tidy(size_aes, data), min(size) / 4)
col <- eval_default(colour_aes, data, NA)
fill <- eval_default(fill_aes, data, "grey20")
alpha <- eval_default(alpha_aes, data, NA)
lty <- eval_default(linetype_aes, data, 1)
rectGrob(
x = unit(0.5, "npc") + 0.5*(padding[4] - padding[2]),
y = unit(0.5, "npc") + 0.5*(padding[3] - padding[1]),
width = unit(1, "npc") - unit(lwd, "mm") - padding[2] - padding[4],
height = unit(1, "npc") - unit(lwd, "mm") - padding[1] - padding[3],
gp = gpar(
col = col,
fill = scales::alpha(fill, alpha),
lty = lty,
lwd = lwd * .pt,
linejoin = params$linejoin %||% "mitre",
# `lineend` is a workaround for Windows and intentionally kept unexposed
# as an argument. (c.f. https://github.com/tidyverse/ggplot2/issues/3037#issuecomment-457504667)
lineend = if (identical(params$linejoin, "round")) "round" else "square"
)
)
}
}
#' @rdname rectangle_key_glyph
#' @export
circle_key_glyph <- function(colour = NA, fill = fill, alpha = alpha, size = size,
linetype = linetype, padding = unit(c(0, 0, 0, 0), "pt"),
color) {
colour_aes <- enquo(colour)
fill_aes <- enquo(fill)
alpha_aes <- enquo(alpha)
size_aes <- enquo(size)
linetype_aes <- enquo(linetype)
# enable US spelling
color <- enquo(color)
if (!quo_is_missing(color)) {
colour_aes <- color
}
function(data, params, size) {
if (is.null(data$size)) {
data$size <- 0.5
}
# enable US spelling
if (is.null(data$color)) {
data$color <- data$colour
}
lwd <- min(eval_tidy(size_aes, data), min(size) / 4)
# use the minimum of width and height as the circle radius
radius <- min(
unit(1, "npc") - unit(lwd, "mm") - padding[2] - padding[4],
unit(1, "npc") - unit(lwd, "mm") - padding[1] - padding[3]
)
col <- eval_default(colour_aes, data, NA)
fill <- eval_default(fill_aes, data, "grey20")
alpha <- eval_default(alpha_aes, data, NA)
lty <- eval_default(linetype_aes, data, 1)
circleGrob(
x = unit(0.5, "npc") + 0.5*(padding[4] - padding[2]),
y = unit(0.5, "npc") + 0.5*(padding[3] - padding[1]),
r = 0.5*radius,
gp = gpar(
col = col,
fill = scales::alpha(fill, alpha),
lty = lty,
lwd = lwd * .pt
)
)
}
}
eval_default <- function(x, data, default) {
force(default)
suppressWarnings(
tryCatch(
error = function(e) default,
eval_tidy(x, data)
)
)
}
|
