Skip to content

Commit 6aad4ee

Browse files
aphaloaphalo
committed
Add position_stacknudge_to() and position_fillnudge_to()
1 parent 00c930d commit 6aad4ee

14 files changed

+450
-11
lines changed

‎DESCRIPTION

+1
Original file line numberDiff line numberDiff line change
@@ -90,6 +90,7 @@ Collate:
9090
'position-nudge-center.R'
9191
'position-nudge-line.R'
9292
'position-stack-nudge.R'
93+
'position-stacknudge-to.R'
9394
'scale-continuous-npc.r'
9495
'stat-apply.R'
9596
'stat-dens1d-filter.r'

‎NAMESPACE

+4
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,10 @@ export(GeomYMarginPoint)
2828
export(PositionDodge2AndNudgeTo)
2929
export(PositionDodgeNudgeTo)
3030
export(PositionFillAndNudge)
31+
export(PositionFillNudgeTo)
3132
export(PositionNudgeCenter)
3233
export(PositionNudgeLine)
34+
export(PositionStackNudgeTo)
3335
export(StatApplyGroup)
3436
export(StatDens1dFilter)
3537
export(StatDens1dFilterG)
@@ -81,6 +83,7 @@ export(position_dodgenudge)
8183
export(position_dodgenudge_to)
8284
export(position_fill_keep)
8385
export(position_fillnudge)
86+
export(position_fillnudge_to)
8487
export(position_jitter_keep)
8588
export(position_jitternudge)
8689
export(position_nudge_center)
@@ -91,6 +94,7 @@ export(position_nudge_to)
9194
export(position_stack_keep)
9295
export(position_stack_minmax)
9396
export(position_stacknudge)
97+
export(position_stacknudge_to)
9498
export(scale_npcx_continuous)
9599
export(scale_npcy_continuous)
96100
export(stat_apply_group)

‎NEWS.md

+2
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,8 @@ editor_options:
1010

1111
- Add `position_dodgenudge_to()` and `position_dodge2nudge_to()` that allow the
1212
action of `position_nudge_to()` to be combined with dodging.
13+
- Add `position_stacknudge_to()` and `position_fillnudge_to()` that allow the
14+
action of `position_nudge_to()` to be combined with stacking.
1315

1416
# ggpp 0.5.8-1
1517

‎R/position-stacknudge-to.R

+316
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,316 @@
1+
#' Stack plus nudge labels to new positions
2+
#'
3+
#' \code{position_stacknudge_to()} is generally useful for aligning the position
4+
#' of labels or text so that the coordinates of the new position are given
5+
#' directly, rather than as a displacement from the original location. This
6+
#' nudging can be combined with stacking. As with other position functions in
7+
#' this package, the original positions are preserved to allow the text or
8+
#' labels to be linked back to their original position with a segment or arrow.
9+
#'
10+
#' @family position adjustments
11+
#'
12+
#' @param vjust Vertical adjustment for geoms that have a position (like points
13+
#' or lines), not a dimension (like bars or areas). Set to 0 to align with the
14+
#' bottom, 0.5 for the middle, and 1 (the default) for the top.
15+
#' @param reverse If TRUE, will reverse the default stacking order. This is
16+
#' useful if you're rotating both the plot and legend.
17+
#' @param x,y Coordinates of the destination position. A vector of mode
18+
#' \code{numeric}, that is extended if needed, to the same length as rows
19+
#' there are in \code{data}. The default, \code{NULL}, leaves the original
20+
#' coordinates unchanged after dodging.
21+
#' @param x.action,y.action character string, one of \code{"none"}, or
22+
#' \code{"spread"}. With \code{"spread"} distributing the positions
23+
#' within the range of argument \code{x} or \code{y}, if non-null, or the
24+
#' range the variable mapped to \emph{x} or \code{y}, otherwise.
25+
#' @param x.distance,y.distance character or numeric Currently only \code{"equal"} is
26+
#' implemented.
27+
#' @param x.expansion,y.expansion numeric vectors of length 1 or 2, as a
28+
#' fraction of width of the range.
29+
#' @param kept.origin One of \code{"original"}, \code{"stacked"} or
30+
#' \code{"none"}.
31+
#'
32+
#' @details The nudged to \code{x} and/or \code{y} values replace the original ones in
33+
#' \code{data}, while the original or the stacked coordinates are returned in \code{x_orig}
34+
#' and \code{y_orig}. Nudge values supported are those of \emph{mode} numeric,
35+
#' thus including dates and times when they match the mapped data.
36+
#'
37+
#' If the length of \code{x} and/or \code{y} is more than one but less than
38+
#' rows are present in the data, the vector is both recycled and reordered so
39+
#' that the nudges are applied sequentially based on the data values. If their
40+
#' length matches the number of rows in data, they are assumed to be already
41+
#' in data order.
42+
#'
43+
#' When applying stacking, the return of original positions instead of the stacked
44+
#' ones is achieved by passing \code{origin = "original"} instead of the default
45+
#' of \code{origin = "stacked"}.
46+
#'
47+
#' @note Irrespective of the action, the ordering of rows in \code{data} is
48+
#' preserved.
49+
#'
50+
#' @return A \code{"Position"} object.
51+
#'
52+
#' @seealso \code{\link{position_nudge_to}},
53+
#' \code{\link[ggplot2]{position_stack}}.
54+
#'
55+
#' @export
56+
#'
57+
position_stacknudge_to <-
58+
function(vjust = 1,
59+
reverse = FALSE,
60+
x = NULL,
61+
y = NULL,
62+
x.action = c("none", "spread"),
63+
y.action = c("none", "spread"),
64+
x.distance = "equal",
65+
y.distance = "equal",
66+
x.expansion = 0,
67+
y.expansion = 0,
68+
kept.origin = c("stakked", "original", "none")) {
69+
70+
stopifnot("'x' must be NULL or of mode numeric" = length(x) == 0 ||
71+
(!anyNA(x) && mode(x) == "numeric"))
72+
stopifnot("'y' must be NULL or of mode numeric" = length(y) == 0 ||
73+
(!anyNA(y) && mode(y) == "numeric"))
74+
75+
# this works as long as nudge and mapped variable are of the same class
76+
# ggplot2's behaviour has been in the past and seems to be again to expect
77+
# numeric seconds for POSIXct and numeric days for Date time shifts
78+
if (lubridate::is.instant(x)) {
79+
x <- as.numeric(x)
80+
}
81+
if (lubridate::is.instant(y)) {
82+
y <- as.numeric(y)
83+
}
84+
85+
ggplot2::ggproto(NULL, PositionStackNudgeTo,
86+
x = x,
87+
y = y,
88+
x.action = rlang::arg_match(x.action),
89+
y.action = rlang::arg_match(y.action),
90+
x.distance = x.distance,
91+
y.distance = y.distance,
92+
x.expansion = rep_len(x.expansion, 2),
93+
y.expansion = rep_len(y.expansion, 2),
94+
kept.origin = rlang::arg_match(kept.origin),
95+
vjust = vjust,
96+
reverse = reverse
97+
)
98+
}
99+
100+
#' @rdname ggpp-ggproto
101+
#' @format NULL
102+
#' @usage NULL
103+
#' @export
104+
PositionStackNudgeTo <-
105+
ggplot2::ggproto(
106+
"PositionStackNudgeTo",
107+
ggplot2::PositionStack,
108+
x = NULL,
109+
y = NULL,
110+
111+
setup_params = function(self, data) {
112+
c(list(x = self$x,
113+
y = self$y,
114+
x.action = self$x.action,
115+
y.action = self$y.action,
116+
x.distance = self$x.distance,
117+
y.distance = self$y.distance,
118+
x.expansion = self$x.expansion,
119+
y.expansion = self$y.expansion,
120+
x.reorder = !is.null(self$x) && length(self$x) > 1 && length(self$x) < nrow(data),
121+
y.reorder = !is.null(self$y) && length(self$y) > 1 && length(self$y) < nrow(data),
122+
kept.origin = self$kept.origin,
123+
vjust = self$vjust,
124+
reverse = self$reverse),
125+
ggplot2::ggproto_parent(ggplot2::PositionStack, self)$setup_params(data))
126+
},
127+
128+
setup_data = function(self, data, params) {
129+
data <- flip_data(data, params$flipped_aes)
130+
if (is.null(params$var)) {
131+
return(data)
132+
}
133+
134+
data$ymax <- switch(params$var,
135+
y = data$y,
136+
ymax = as.numeric(ifelse(data$ymax == 0, data$ymin, data$ymax))
137+
)
138+
139+
data <- remove_missing(
140+
data,
141+
vars = c("x", "xmin", "xmax", "y"),
142+
name = "position_stack"
143+
)
144+
flip_data(data, params$flipped_aes)
145+
},
146+
147+
compute_layer = function(self, data, params, layout) {
148+
x_orig <- data$x
149+
y_orig <- data$y
150+
151+
# operate on the stacked positions (updated in August 2020)
152+
data = ggplot2::ggproto_parent(ggplot2::PositionStack, self)$compute_layer(data, params, layout)
153+
x_stacked <- data$x
154+
y_stacked <- data$y
155+
156+
# compute/convert x nudges
157+
if (!length(params$x)) {
158+
# set default x
159+
if (params$x.action == "none") {
160+
params$x <- rep_len(0, nrow(data))
161+
} else if (params$x.action == "spread") {
162+
params$x <- range(x_stacked)
163+
}
164+
} else if (is.numeric(params$x)) {
165+
# check user supplied x
166+
if (length(params$x) > nrow(data)) {
167+
warning("Argument 'x' longer than data: some values dropped!")
168+
}
169+
if (params$x.action == "none") {
170+
# recycle or trim x as needed
171+
if (params$x.reorder) {
172+
params$x <- rep_len(params$x, nrow(data))[order(order(data$x))] - x_stacked
173+
} else {
174+
params$x <- rep_len(params$x, nrow(data)) - x_stacked
175+
}
176+
} else if (params$x.action == "spread") {
177+
params$x <- range(params$x)
178+
}
179+
}
180+
181+
if (params$x.action == "spread") {
182+
# apply x.expansion to x
183+
x.spread <- diff(params$x)
184+
params$x[1] <- params$x[1] - params$x.expansion[1] * x.spread
185+
params$x[2] <- params$x[2] + params$x.expansion[2] * x.spread
186+
if (params$x.distance == "equal") {
187+
# evenly spaced sequence of positions ordered as in data
188+
params$x <- seq(from = params$x[1],
189+
to = params$x[2],
190+
length.out = nrow(data))[order(order(data$x))] - x_stacked
191+
}
192+
# other strategies to distribute positions could be added here
193+
}
194+
195+
# compute/convert y nudges
196+
if (!length(params$y)) {
197+
# set default y
198+
if (params$y.action == "none") {
199+
params$y <- rep_len(0, nrow(data))
200+
} else if (params$y.action == "spread") {
201+
params$y <- range(y_stacked)
202+
}
203+
} else if (is.numeric(params$y)) {
204+
# check user supplied y
205+
if (length(params$y) > nrow(data)) {
206+
warning("Argument 'y' longer than data: some values dropped!")
207+
}
208+
if (params$y.action == "none") {
209+
# recycle or trim y as needed
210+
if (params$y.reorder) {
211+
params$y <- rep_len(params$y, nrow(data))[order(order(data$y))] - y_stacked
212+
} else {
213+
params$y <- rep_len(params$y, nrow(data)) - y_stacked
214+
}
215+
} else if (params$y.action == "spread") {
216+
params$y <- range(params$y)
217+
}
218+
}
219+
220+
if (params$y.action == "spread") {
221+
y.spread <- diff(params$y)
222+
params$y[1] <- params$y[1] - params$y.expansion[1] * y.spread
223+
params$y[2] <- params$y[2] + params$y.expansion[2] * y.spread
224+
if (params$y.distance == "equal") {
225+
# evenly spaced sequence ordered as in data
226+
params$y <- seq(from = params$y[1],
227+
to = params$y[2],
228+
length.out = nrow(data))[order(order(data$y))] - y_stacked
229+
}
230+
# other strategies could be added here
231+
}
232+
233+
# As in 'ggplot2' we apply the nudge to xmin, xmax, xend, ymin, ymax, and yend.
234+
# Transform the dimensions for which not all nudges are zero
235+
if (any(params$x != 0)) {
236+
if (any(params$y != 0)) {
237+
data <- transform_position(data, function(x) x + params$x, function(y) y + params$y)
238+
} else {
239+
data <- transform_position(data, function(x) x + params$x, NULL)
240+
}
241+
} else if (any(params$y != 0)) {
242+
data <- transform_position(data, NULL, function(y) y + params$y)
243+
}
244+
# add original position
245+
if (params$kept.origin == "stacked") {
246+
data$x_orig <- x_stacked
247+
data$y_orig <- y_stacked
248+
} else if (params$kept.origin == "original") {
249+
data$x_orig <- x_orig
250+
data$y_orig <- y_orig
251+
}
252+
253+
data
254+
},
255+
256+
compute_panel = function(self, data, params, scales) {
257+
ggplot2::ggproto_parent(PositionStack, self)$compute_panel(data, params, scales)
258+
}
259+
)
260+
261+
#' @rdname position_stacknudge_to
262+
#'
263+
#' @export
264+
#'
265+
position_fillnudge_to <-
266+
function(vjust = 1,
267+
reverse = FALSE,
268+
x = NULL,
269+
y = NULL,
270+
x.action = c("none", "spread"),
271+
y.action = c("none", "spread"),
272+
x.distance = "equal",
273+
y.distance = "equal",
274+
x.expansion = 0,
275+
y.expansion = 0,
276+
kept.origin = c("stakked", "original", "none")) {
277+
278+
stopifnot("'x' must be NULL or of mode numeric" = length(x) == 0 ||
279+
(!anyNA(x) && mode(x) == "numeric"))
280+
stopifnot("'y' must be NULL or of mode numeric" = length(y) == 0 ||
281+
(!anyNA(y) && mode(y) == "numeric"))
282+
283+
# this works as long as nudge and mapped variable are of the same class
284+
# ggplot2's behaviour has been in the past and seems to be again to expect
285+
# numeric seconds for POSIXct and numeric days for Date time shifts
286+
if (lubridate::is.instant(x)) {
287+
x <- as.numeric(x)
288+
}
289+
if (lubridate::is.instant(y)) {
290+
y <- as.numeric(y)
291+
}
292+
293+
ggplot2::ggproto(NULL, PositionFillNudgeTo,
294+
x = x,
295+
y = y,
296+
x.action = rlang::arg_match(x.action),
297+
y.action = rlang::arg_match(y.action),
298+
x.distance = x.distance,
299+
y.distance = y.distance,
300+
x.expansion = rep_len(x.expansion, 2),
301+
y.expansion = rep_len(y.expansion, 2),
302+
kept.origin = rlang::arg_match(kept.origin),
303+
vjust = vjust,
304+
reverse = reverse
305+
)
306+
}
307+
308+
#' @rdname ggpp-ggproto
309+
#' @format NULL
310+
#' @usage NULL
311+
#' @export
312+
PositionFillNudgeTo <-
313+
ggplot2::ggproto("PositionFillNudgeTo", PositionStackNudgeTo,
314+
fill = TRUE
315+
)
316+

‎man/ggpp-ggproto.Rd

+6-4
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/position_dodgenudge.Rd

+2-1
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)