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
|
#' @rdname Stat
#' @format NULL
#' @usage NULL
#' @export
StatAlign <- ggproto(
"StatAlign", Stat,
extra_params = c("na.rm", "orientation"),
required_aes = c("x", "y"),
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
params
},
compute_panel = function(self, data, scales, flipped_aes, ...) {
if (empty(data)) {
return(data_frame0())
}
if (is_unique(data$group)) {
return(data)
}
names <- flipped_names(flipped_aes)
x <- data[[names$x]]
y <- data[[names$y]]
# Find positions where 0 is crossed
pivot <- vec_unrep(data_frame0(group = data$group, y = y < 0))
group_ends <- cumsum(vec_unrep(pivot$key$group)$times)
pivot <- cumsum(pivot$times)[-group_ends]
cross <- -y[pivot] * (x[pivot + 1] - x[pivot]) /
(y[pivot + 1] - y[pivot]) + x[pivot]
unique_loc <- unique(sort(c(x, cross)))
adjust <- diff(range(unique_loc, na.rm = TRUE)) * 0.001
adjust <- min(adjust, min(diff(unique_loc)) / 3)
unique_loc <- unique(sort(c(
unique_loc - adjust, unique_loc, unique_loc + adjust
)))
ggproto_parent(Stat, self)$compute_panel(
data, scales, flipped_aes = flipped_aes, unique_loc = unique_loc,
adjust = adjust, ...
)
},
compute_group = function(data, scales, flipped_aes = NA, unique_loc = NULL, adjust = 0) {
data <- flip_data(data, flipped_aes)
if (is_unique(data$x)) {
# Not enough data to align
return(new_data_frame())
}
# Sort out multiple observations at the same x
if (anyDuplicated(data$x)) {
data <- dapply(data, "x", function(d) {
if (nrow(d) == 1) return(d)
d <- d[c(1, nrow(d)), ]
d$x[1] <- d$x[1] - adjust
d
})
}
y_val <- stats::approxfun(data$x, data$y)(unique_loc)
keep <- !is.na(y_val)
x_val <- unique_loc[keep]
y_val <- y_val[keep]
x_val <- c(min(x_val) - adjust, x_val, max(x_val) + adjust)
y_val <- c(0, y_val, 0)
data_aligned <- data_frame0(
x = x_val,
y = y_val,
data[1, setdiff(names(data), c("x", "y"))],
align_padding = c(TRUE, rep(FALSE, length(x_val) - 2), TRUE),
flipped_aes = flipped_aes
)
flip_data(data_aligned, flipped_aes)
},
finish_layer = function(data, params) {
# Silently remove out-of-bounds padding vertices
var <- flipped_names(params$flipped_aes %||% FALSE)$x
remove <- is.na(data[[var]]) & (data$align_padding %||% FALSE)
vec_slice(data, !remove)
}
)
#' @inheritParams layer
#' @inheritParams geom_point
#' @export
#' @rdname geom_ribbon
stat_align <- make_constructor(
StatAlign, geom = "area",
omit = c("unique_loc", "adjust")
)
|
