Status Quo
library(tidyverse)
set.seed(123425)
tribble(~part_id, ~group, ~x0, ~y0, ~length, ~size,
1, 1, 0, .6, 0, 3,
2, 1, 0, 1, 0, 1,
3, 1, 0, 3, 0, 1,
2, 2, 0, 1, 0, NA,
4, 2, 0, 1, 1, 1,
5, 2, 0, 1, 1, 2,
2, 3, 0, 1, 0, NA,
6, 3, 0, 1, 1, 1,
7, 3, 0, 1, 1, 2,
3, 4, 0, 3, 0, NA,
8, 4, 0, 3, 1.3, 1,
9, 4, 0, 3, 1.3, 2.5,
3, 5, 0, 3, 0, NA,
10, 5, 0, 3, 1.3, 1,
11, 5, 0, 3, 1.3, 2.5
) %>%
mutate(angle = runif(15, 0, 2*pi)) %>%
mutate(xchange = length*cos(angle)) %>%
mutate(ychange = length*sin(angle)) %>%
group_by(group) %>%
mutate(xcumchange = cumsum(xchange)) %>%
mutate(ycumchange = cumsum(ychange)) %>%
mutate(x = x0 + xcumchange) %>%
mutate(y = y0 + ycumchange) %>%
ggplot() +
aes(x = x, y = y, group = group) +
geom_path(size = .2) +
geom_point() +
scale_y_reverse() +
coord_equal() +
aes(color = group %>% as.factor()) +
aes(size = size)
## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
## Warning: Removed 4 rows containing missing values or values outside the scale range
## (`geom_point()`).
Experiment
compute_panel_body <- function(data,scales){
tribble(~part_id, ~group_part, ~x0, ~y0, ~length, ~volume,
1, 1, 0, .5, 0, 3,
2, 1, 0, 1, 0, 1,
3, 1, 0, 3, 0, 1,
2, 2, 0, 1, 0, NA,
4, 2, 0, 1, 1, 1,
5, 2, 0, 1, 1, 2,
2, 3, 0, 1, 0, NA,
6, 3, 0, 1, 1, 1,
7, 3, 0, 1, 1, 2,
3, 4, 0, 3, 0, NA,
8, 4, 0, 3, 1.3, 1,
9, 4, 0, 3, 1.3, 2.5,
3, 5, 0, 3, 0, NA,
10, 5, 0, 3, 1.3, 1,
11, 5, 0, 3, 1.3, 2.5
) %>%
mutate(angle_part = runif(15, 0, 2*pi)) %>%
mutate(xchange = length*cos(angle_part)) %>%
mutate(ychange = length*sin(angle_part)) %>%
group_by(group_part) %>%
mutate(xcumchange = cumsum(xchange)) %>%
mutate(ycumchange = cumsum(ychange)) %>%
mutate(x = x0 + xcumchange) %>%
mutate(y = y0 + ycumchange) %>%
ungroup() %>%
mutate(y = -y) %>%
mutate(group_part = group_part %>% as.factor())
}
# compute_panel_body()
StatBody <- ggproto(`_class` = "StatBody",
`_inherit` = ggplot2::Stat,
compute_panel = compute_panel_body,
default_aes = aes(group = after_stat(group_part)))
StatHead <- ggproto(`_class` = "StatHead",
`_inherit` = ggplot2::Stat,
compute_panel = function(data, scales){compute_panel_body()[1,]},
default_aes = aes(group = after_stat(group_part)))
stat_body <- function(geom = ggplot2::GeomPath, data = mtcars,
mapping = NULL,
# data = NULL,
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE, ...) {
ggplot2::layer(
stat = StatBody, # proto object from step 2
geom = geom, # inherit other behavior
data = data,
mapping = mapping,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
stat_head <- function(geom = ggplot2::GeomPoint, data = mtcars,
mapping = NULL,
# data = NULL,
position = "identity",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE, ...) {
ggplot2::layer(
stat = StatHead, # proto object from step 2
geom = geom, # inherit other behavior
data = data,
mapping = mapping,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ...)
)
}
set.seed(1349824523)
tibble(x = 1:20) %>%
ggplot() +
stat_body() +
stat_head(size = 6) +
coord_equal() +
aes(color = after_stat(group_part))
ggwipe::last_plot_wipe_last() +
facet_wrap(~x) +
stat_head(size = 2)
# layer_data()
move <- function(n = 3){
tibble(x = 1:n) %>%
ggplot() +
stat_body() +
stat_head(size = 6) +
coord_equal() +
aes(color = after_stat(group_part)) +
facet_wrap(~x) +
stat_head(size = 2)
}
move(3)
