/
grob_textpath.R
225 lines (198 loc) · 7.76 KB
/
grob_textpath.R
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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
##---------------------------------------------------------------------------##
## ##
## grob_textpath.R ##
## Part of the geomtextpath R package ##
## ##
## Copyright (C) 2021 - 2022 by Allan Cameron & Teun van den Brand ##
## ##
## Licensed under the MIT license - see https://mit-license.org ##
## or the LICENSE file in the project root directory ##
## ##
##---------------------------------------------------------------------------##
# Grob -------------------------------------------------------------------------
#' Draw text on a path.
#'
#' This function creates (curved) text on a path.
#'
#' @param label A `character` vector.
#' @param x A `numeric` vector.
#' @param y A `numeric` vector.
#' @param id A `numeric` vector used to separate locations in `x` and `y` into
#' multiple lines. All locations with the same `id` belong to the same line.
#' @param gp_text,gp_path An object of class `"gpar"`, typically the output from
#' a call from the [`gpar()`][grid::gpar] function. These are basically lists
#' of graphical parameters for the text and path respectively.
#' @param vjust A `numeric` vector specifying justification orthogonal to the
#' direction of the text. Alternatively a [`unit()`][grid::unit()] object to
#' directly set the offset from the path.
#' @param angle a `numeric` vector either length 1 or the same length as `id`
#' describing the angle in degrees at which text should be rotated.
#' @param polar_params a list consisting of an x, y, and r component that
#' specifies the central point and radius of a circle around which
#' single-point labels will be wrapped.
#' @param arrow Arrow specification, as created by [`arrow()`][grid::arrow].
#' @param gp_box (Optional) an object of class `"gpar"`, typically the output
#' from a call to the [`gpar()`][grid::gpar] function. If this is an empty
#' list, no text box will be drawn.
#' @param label.padding Amount of padding around label. Defaults to 0.25 lines.
#' @param label.r Radius of rounded corners. Defaults to 0.15 lines.
#' @param as_label a `logical` TRUE or FALSE indicating whether the text should
#' be drawn inside a text box. If FALSE, the parameters `label.padding`,
#' `label.r` and `gp_box` will be ignored.
#' @inheritParams grid::textGrob
#' @inheritParams grid::polylineGrob
#' @inheritParams static_text_params
#'
#' @return An object of class `gTree`, containing grobs.
#' @export
#' @md
#'
#' @examples
#'require(grid)
#'
#' t <- seq(0, 2 * pi, length.out = 100)
#' grob <- textpathGrob(
#' label = c(
#' "Why I am making trigonometry jokes? Cos I can!",
#' "I was never any good at sine language."
#' ),
#' x = c(t, t) / (2 * pi),
#' y = c(cos(t), sin(t)) * 0.25 + 0.5,
#' id = rep(1:2, each = length(t)),
#' vjust = rep(0.5, 2 * length(t)),
#' gp_text = gpar(lineheight = c(1.2, 1.2), fontsize = c(10, 10)),
#' gp_path = gpar(lty = c(1, 2))
#' )
#'
#' grid.newpage(); grid.draw(grob)
textpathGrob <- function(
label,
x = 0.5,
y = 0.5,
id = 1L,
just = "centre",
hjust = NULL,
vjust = NULL,
halign = "left",
angle = 0,
straight = FALSE,
rich = FALSE,
gp_text = gpar(),
gp_path = gpar(),
gp_box = gpar(),
gap = NA,
upright = TRUE,
text_smoothing = 0,
polar_params = NULL,
padding = unit(0.05, "inch"),
label.padding = unit(0.25, "lines"),
label.r = unit(0.15, "lines"),
remove_long = FALSE,
arrow = NULL,
default.units = "npc",
name = NULL,
vp = NULL,
as_label = FALSE
) {
cl <- if (as_label) "labelpath" else "textpath"
if (missing(label)) return(gTree(name = name, vp = vp, cl = cl))
n_label <- length(label)
id <- discretise(id)
check_grob_input(x, y, id, n_label, angle)
# Match justification to labels length
hjust <- rep_len(resolveHJust(just, hjust), n_label)
vjust <- rep_len(resolveVJust(just, vjust), n_label)
halign <- rep_len(halign, n_label)
label <- measure_label(label, gp = gp_text, vjust = vjust,
halign = halign, straight = straight, rich = rich)
x <- as_unit(x, default.units)
y <- as_unit(y, default.units)
if (!is.null(polar_params)) {
polar_params$x <- unit(polar_params$x, default.units)
polar_params$y <- unit(polar_params$y, default.units)
}
path <- data_frame(x = x, y = y, id = id, line_x = x, line_y = y)
if (text_smoothing != 0) path <- path_smoother(path, text_smoothing)
gTree(
textpath = list(
data = path,
label = label,
gp_text = attr(label, "gp"),
gp_path = gp_path,
gp_box = gp_box,
arrow = arrow,
params = list(
upright = upright,
polar_params = polar_params,
angle = angle,
padding = padding,
label.padding = label.padding,
label.r = label.r,
hjust = hjust,
vjust = vjust,
halign = halign,
gap = gap,
remove_long = remove_long)
),
name = name,
vp = vp,
cl = cl
)
}
# makeContent ------------------------------------------------------------------
#' @export
makeContent.textpath <- function(x) {
if (is.null(x$textpath)) return(zeroGrob())
v <- x$textpath
x$textpath <- NULL
params <- v$params
path <- prepare_path(v$data, v$label, v$gp_path, params)
# Identify text that is too long for its path
if (params$remove_long) {
text_lens <- numapply(v$label, function(x) max(x$xmax))
path_lens <- numapply(path, function(d) {
max(arclength_from_xy(d$line_x, d$line_y))
})
too_long <- text_lens > path_lens
} else {
too_long <- rep(FALSE, length(v$label))
}
remove <- v$data$id %in% which(too_long)
if (any(too_long)) {
# Use simple polyline grobs for paths with text removed
x <- addGrob(x,
polylineGrob(
x = v$data$x[remove],
y = v$data$y[remove],
id = v$data$id[remove],
gp = gp_subset(v$gp_path, which(too_long))
))
}
if (!all(too_long)) {
# Get the actual text string positions and angles for each group
text <- Map(f = place_text,
path = path[!too_long],
label = v$label[!too_long],
hjust = params$hjust[!too_long],
halign = params$halign[!too_long],
upright = params$upright)
text <- rbind_dfs(text)
x <- add_path_grob(x, path[!too_long], text,
gp_subset(attr(path, "gp"), !too_long),
params, v$arrow)
x <- add_text_grob(x, text, gp_subset(v$gp_text, !too_long))
}
x
}
check_grob_input <- function(x, y, id, n_label, angle) {
stopifnot(
"`x` is not of the same length as `id`" =
length(x) == length(id),
"`y` is not the same length as `x`" =
length(x) == length(y),
"Cannot match labels to paths." =
n_label == max(id),
"`angle` must be length 1 or the same length as `x`." =
(length(x) == length(angle)) || length(angle) == 1
)
}