another experiment
Evangeline Reynolds
2026-01-25
Intro Thoughts
Status Quo
library(tidyverse)
library(gapminder)
library(ggbraid)Braid new
gapminder |>
filter(country %in% c("Belgium", "Denmark")) |>
ggplot() +
aes(x = year, y = lifeExp, color = country) +
geom_line()
gapminder |>
filter(country %in% c("Belgium", "Denmark")) ->
df_long
df_wide <- pivot_wider(df_long |> select(country, year, lifeExp), names_from = country, values_from = lifeExp)
gapminder |>
filter(country %in% c("Belgium", "Denmark")) |>
ggplot() +
aes(x = year) +
geom_line(aes(y = lifeExp, color = country, x = year), inherit.aes = F) +
geom_braid(data = df_wide, alpha = 0.6,
aes(ymin = Belgium, ymax = Denmark,
fill = Belgium < Denmark)) ## `geom_braid()` using method = 'line'
# better than geom_ribbon (but not by much w/ group = 1)
gapminder |>
filter(country %in% c("Belgium", "Denmark")) |>
ggplot() +
aes(x = year) +
geom_line(aes(y = lifeExp, color = country, x = year), inherit.aes = F) +
geom_ribbon(data = df_wide, alpha = 0.6,
aes(ymin = Belgium, ymax = Denmark,
fill = Belgium < Denmark, group = 1)) 
StatBraidNew2
we had done interpolation between each point, but now a new approach
- divide x space up.
- cross for each group.
- delete original data
- go wide
- use with ribbon
interpolate
compute_panel_braid
interpolate <- function(data, n = 9){
x_minimum <- min(data$x, na.rm = T)
x_maximum <- max(data$x, na.rm = T)
x_divided <- seq(x_minimum, x_maximum, length.out = n)
df_x_seq <- data.frame(x = x_divided, original = F)
data |>
mutate(original = T) |>
full_join(df_x_seq, by = c("x", "original")) |>
arrange(x) |>
# mutate(x_seq = !is.na(x_seq)) |>
# mutate(original = !x_seq) |>
mutate(strech = cumsum(original)) |>
group_by(strech) |>
# mutate(row = 0:(n()-1)) >
mutate(prop_advance = (0:(n()-1))/n()) |>
ungroup() |>
mutate(yoriginal = y) |>
mutate(ystart = y) |>
fill(ystart, .direction = "down") |>
# fill(ystart, .direction = "up") |>
mutate(yending = y) |>
fill(yending, .direction = "up") |>
# fill(yending, .direction = "down") |>
mutate(ydiff = yending - ystart) |>
mutate(y = ystart + prop_advance * ydiff) |>
# fill(PANEL) |>
# fill(group) |>
filter(!original)
}
data.frame(x = 1:3, y = c(1,0,1)) |>
interpolate() |>
ggplot() +
aes(x, y) +
geom_point()## Warning: Removed 1 row containing missing values or values outside the scale range
## (`geom_point()`).
compute_panel_braid <- function(data = df_long, scales, n = 30){
# data$x = data$lifeExp
x_minimum <- min(data$x, na.rm = T)
x_maximum <- max(data$x, na.rm = T)
x_divided <- seq(x_minimum, x_maximum, length.out = n)
df_x_seq <- data.frame(x = x_divided, x_seq = T)
# data$strand <- data$country
# data$y <- data$lifeExp
# data$PANEL <- 1
# data$group <- 1
strands <- data |>
# arrange(x)
mutate(minmax = strand |> as.character() |> as.factor() |> as.numeric()) |>
pivot_wider(names_from = minmax, values_from = y, names_prefix = "strand_", id_cols = c(PANEL, group, x)) |>
mutate(ymin = strand_1,
ymax = strand_2)
strands |>
select(y = ymin, x, PANEL, group) |>
full_join(df_x_seq) |>
arrange(x) |>
mutate(x_seq = !is.na(x_seq)) |>
mutate(original = !x_seq) |>
mutate(strech = cumsum(original)) |>
group_by(strech) |>
mutate(prop_advance = 0:(n()-1)/n()) |>
ungroup() |>
mutate(ystart = y) |>
fill(ystart, .direction = "down") |>
# fill(ystart, .direction = "up") |>
mutate(yending = y) |>
fill(yending, .direction = "up") |>
# fill(yending, .direction = "down") |>
mutate(ydiff = yending - ystart) |>
mutate(y = ystart + prop_advance*ydiff) |>
fill(PANEL) |>
fill(group) |>
filter(x_seq) |>
select(x, ymin = y, PANEL, group) ->
strands_min
strands |>
select(y = ymax, x, PANEL, group) |>
full_join(df_x_seq) |>
arrange(x) |>
mutate(x_seq = !is.na(x_seq)) |>
mutate(original = !x_seq) |>
mutate(strech = cumsum(original)) |>
group_by(strech) |>
mutate(prop_advance = 0:(n()-1)/n()) |>
ungroup() |>
mutate(ystart = y) |>
fill(ystart, .direction = "down") |>
# fill(ystart, .direction = "up") |>
mutate(yending = y) |>
fill(yending, .direction = "up") |>
# fill(yending, .direction = "down") |>
mutate(ydiff = yending - ystart) |>
mutate(y = ystart + prop_advance*ydiff) |>
fill(PANEL) |>
fill(group) |>
filter(x_seq) |>
select(ymax = y) ->
strands_max
bind_cols(strands_min,
strands_max) |>
mutate(xend = x,
yend = ymax,
y = ymin) |>
mutate(row_number = row_number())
}gapminder |>
filter(country %in% c("Belgium", "Denmark")) |>
select(x = year, y = lifeExp, strand = country) |>
mutate(PANEL = 1, group = 1) |>
compute_panel_braid(n = 3) ## Joining with `by = join_by(x)`
## Joining with `by = join_by(x)`## # A tibble: 3 × 9
## x ymin PANEL group ymax xend yend y row_number
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <int>
## 1 1952 68 1 1 70.8 1952 70.8 68 1
## 2 1980. 73.4 1 1 74.7 1980. 74.7 73.4 2
## 3 2007 79.4 1 1 78.3 2007 78.3 79.4 3gapminder |>
filter(country %in% c("Belgium", "Denmark")) |>
select(x = year, y = lifeExp, strand = country) |>
mutate(PANEL = 1, group = 1) |>
compute_panel_braid(n = 300) |>
ggplot() +
aes(x = x, ymin = ymin,
ymax = ymax,
color = ymin > ymax,
fill = ymin > ymax, y = y, yend = yend,
xend = xend) +
geom_ribbon(alpha = .2) +
geom_segment() +
aes(label = row_number) +
geom_text()## Joining with `by = join_by(x)`
## Joining with `by = join_by(x)`
last_plot() +
geom_point(data = df_long, aes(x = year, y = lifeExp), inherit.aes = F)
StatBraid2
StatBraid2 <- ggproto("StatBraid2", Stat,
compute_panel = compute_panel_braid,
default_aes = aes(fill =
after_stat(ymin < ymax),
label = after_stat(row_number)
)
)
gapminder |>
filter(country %in% c("Belgium", "Denmark")) |>
ggplot() +
aes(x = year, y = lifeExp,
color = country,
strand = country) +
geom_line() +
geom_ribbon(stat = StatBraid2, alpha = .2, n = 300) #+ ## Joining with `by = join_by(x)`
## Joining with `by = join_by(x)`## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_ribbon()`).
# geom_text(stat = StatBraid2) +
# geom_segment(stat = StatBraid2)Sea and mountain
df <- gapminder |>
filter(country %in% c("Belgium"))
df |>
bind_rows(df |>
mutate(lifeExp = mean(df$lifeExp), country = "constant")) |>
ggplot() +
aes(x = year, y = lifeExp,
color = country,
strand = country) +
geom_line() +
geom_ribbon(stat = StatBraid2, alpha = .2, n = 300)## Joining with `by = join_by(x)`
## Joining with `by = join_by(x)`## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_ribbon()`).
mist
my_gradiant <- c("coral" |> alpha(.2), #<<
"transparent",
"transparent") |> #<<
grid::linearGradient(x1 = 0, x2 = 0,
y1 = 1, y2 = 0) #<<
df <- gapminder |>
filter(country %in% c("Belgium"))
continuous_ribbon_df <- df |>
bind_rows(df |>
mutate(lifeExp = lifeExp - 5, country = "below")) |>
rename(x = year,
y = lifeExp,
color = country,
strand = country) |>
mutate(PANEL = 1, group = 1) |>
compute_panel_braid(n = 300)## Joining with `by = join_by(x)`
## Joining with `by = join_by(x)`continuous_ribbon_df |>
mutate(row_number = lag(row_number)) |>
bind_rows(continuous_ribbon_df) |>
mutate(group = row_number) |>
ggplot() +
aes(x = x, y = y,
ymin = ymin, ymax = ymax,
# color = country,
# strand = country
) +
geom_line(color = "coral") +
geom_ribbon(#stat = StatBraid2,
, #n = 300,
fill = my_gradiant) +
aes(group = group)
# something unexpected...
last_plot() +
aes(alpha = .2 |> I())
"transparent" |> alpha(.2)## [1] "#FFFFFF33""#FFFFFF33"## [1] "#FFFFFF33"# cars |>
# rename(x = speed, y = dist) |>
# mutate(group = 1) |>
# ggforce:::interpolateDataFrame()
# gganimate::ease_aes()library(ggplot2)
my_gradiant <- c("pink", #<<
"lightblue") |> #<<
grid::linearGradient() #<<
cars |>
ggplot() +
aes(x = speed, y = dist) +
geom_point(
shape = "🎈", #<<
size = 7
) +
theme(panel.background =
element_rect(
fill = my_gradiant #<<
)
)
ggram::ggram("ggram:: Sky's the limit... ",
subtitle = "Changes to the grid package introduced in R 4.1.0 opens the door for gradient fill in ggplot2\nAnd setting up ggplot2 to work w/ {ragg} (agg -> anti-grain geometry), gives direct access to \nsystem font -- like emoji 🎈🚀📊!")## Error in error_interactive(): To run write_clip() in non-interactive mode, either call write_clip() with allow_non_interactive = TRUE, or set the environment variable CLIPR_ALLOW=TRUElayer_data(i = 2) |> head()## Error in ggplot_build(plot)@data[[i]]: subscript out of boundslast_plot() +
ggplyr::data_filter(year > 1970) +
ggplyr::data_filter(year < 1993)## Error in `dplyr::filter()`:
## ℹ In argument: `year > 1970`.
## Caused by error in `year > 1970`:
## ! comparison (>) is possible only for atomic and list typeslayer_data(i = 2) ## Error in ggplot_build(plot)@data[[i]]: subscript out of boundsGeomRibbon$setup_data## <ggproto method>
## <Wrapper function>
## function (...)
## setup_data(...)
##
## <Inner function (f)>
## function (data, params)
## {
## data$flipped_aes <- params$flipped_aes
## data <- flip_data(data, params$flipped_aes)
## if (is.null(data$ymin) && is.null(data$ymax)) {
## cli::cli_abort("Either {.field {flipped_names(params$flipped_aes)$ymin}} or {.field {flipped_names(params$flipped_aes)$ymax}} must be given as an aesthetic.")
## }
## data <- data[order(data$PANEL, data$group, data$x), , drop = FALSE]
## data$y <- data$ymin %||% data$ymax
## flip_data(data, params$flipped_aes)
## }GeomRibbon$setup_param## NULLdata.frame(x = 0:1 |> rep(2),
type = c("A", "A", "B", "B"),
y = c(0:1, 1:0)) |>
ggplot() +
aes(x = x,
y = y,
color = type,
strand = type) +
geom_line() +
geom_ribbon(stat = StatBraid2, alpha = .5, n = 500) +
geom_segment(stat = StatBraid2, n = 500)## Joining with `by = join_by(x)`
## Joining with `by = join_by(x)`
## Joining with `by = join_by(x)`
## Joining with `by = join_by(x)`## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_ribbon()`).## Warning: Removed 1 row containing missing values or values outside the scale range
## (`geom_segment()`).
## Removed 1 row containing missing values or values outside the scale range
## (`geom_segment()`).
knitr::knit_exit()